1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Types used in equivalence statements. */
32 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
36 /* Stack to push the current if we descend into a block during
37 resolution. See resolve_branch() and resolve_code(). */
39 typedef struct code_stack
41 struct gfc_code *head, *current;
42 struct code_stack *prev;
46 static code_stack *cs_base = NULL;
49 /* Nonzero if we're inside a FORALL block */
51 static int forall_flag;
53 /* Resolve types of formal argument lists. These have to be done early so that
54 the formal argument lists of module procedures can be copied to the
55 containing module before the individual procedures are resolved
56 individually. We also resolve argument lists of procedures in interface
57 blocks because they are self-contained scoping units.
59 Since a dummy argument cannot be a non-dummy procedure, the only
60 resort left for untyped names are the IMPLICIT types. */
63 resolve_formal_arglist (gfc_symbol * proc)
65 gfc_formal_arglist *f;
69 /* TODO: Procedures whose return character length parameter is not constant
70 or assumed must also have explicit interfaces. */
71 if (proc->result != NULL)
76 if (gfc_elemental (proc)
77 || sym->attr.pointer || sym->attr.allocatable
78 || (sym->as && sym->as->rank > 0))
79 proc->attr.always_explicit = 1;
81 for (f = proc->formal; f; f = f->next)
87 /* Alternate return placeholder. */
88 if (gfc_elemental (proc))
89 gfc_error ("Alternate return specifier in elemental subroutine "
90 "'%s' at %L is not allowed", proc->name,
92 if (proc->attr.function)
93 gfc_error ("Alternate return specifier in function "
94 "'%s' at %L is not allowed", proc->name,
99 if (sym->attr.if_source != IFSRC_UNKNOWN)
100 resolve_formal_arglist (sym);
102 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
104 if (gfc_pure (proc) && !gfc_pure (sym))
107 ("Dummy procedure '%s' of PURE procedure at %L must also "
108 "be PURE", sym->name, &sym->declared_at);
112 if (gfc_elemental (proc))
115 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
123 if (sym->ts.type == BT_UNKNOWN)
125 if (!sym->attr.function || sym->result == sym)
126 gfc_set_default_type (sym, 1, sym->ns);
129 /* Set the type of the RESULT, then copy. */
130 if (sym->result->ts.type == BT_UNKNOWN)
131 gfc_set_default_type (sym->result, 1, sym->result->ns);
133 sym->ts = sym->result->ts;
135 sym->as = gfc_copy_array_spec (sym->result->as);
139 gfc_resolve_array_spec (sym->as, 0);
141 /* We can't tell if an array with dimension (:) is assumed or deferred
142 shape until we know if it has the pointer or allocatable attributes.
144 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
145 && !(sym->attr.pointer || sym->attr.allocatable))
147 sym->as->type = AS_ASSUMED_SHAPE;
148 for (i = 0; i < sym->as->rank; i++)
149 sym->as->lower[i] = gfc_int_expr (1);
152 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
153 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
154 || sym->attr.optional)
155 proc->attr.always_explicit = 1;
157 /* If the flavor is unknown at this point, it has to be a variable.
158 A procedure specification would have already set the type. */
160 if (sym->attr.flavor == FL_UNKNOWN)
161 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
165 if (proc->attr.function && !sym->attr.pointer
166 && sym->attr.flavor != FL_PROCEDURE
167 && sym->attr.intent != INTENT_IN)
169 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
170 "INTENT(IN)", sym->name, proc->name,
173 if (proc->attr.subroutine && !sym->attr.pointer
174 && sym->attr.intent == INTENT_UNKNOWN)
177 ("Argument '%s' of pure subroutine '%s' at %L must have "
178 "its INTENT specified", sym->name, proc->name,
183 if (gfc_elemental (proc))
188 ("Argument '%s' of elemental procedure at %L must be scalar",
189 sym->name, &sym->declared_at);
193 if (sym->attr.pointer)
196 ("Argument '%s' of elemental procedure at %L cannot have "
197 "the POINTER attribute", sym->name, &sym->declared_at);
202 /* Each dummy shall be specified to be scalar. */
203 if (proc->attr.proc == PROC_ST_FUNCTION)
208 ("Argument '%s' of statement function at %L must be scalar",
209 sym->name, &sym->declared_at);
213 if (sym->ts.type == BT_CHARACTER)
215 gfc_charlen *cl = sym->ts.cl;
216 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
219 ("Character-valued argument '%s' of statement function at "
220 "%L must has constant length",
221 sym->name, &sym->declared_at);
230 /* Work function called when searching for symbols that have argument lists
231 associated with them. */
234 find_arglists (gfc_symbol * sym)
237 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
240 resolve_formal_arglist (sym);
244 /* Given a namespace, resolve all formal argument lists within the namespace.
248 resolve_formal_arglists (gfc_namespace * ns)
254 gfc_traverse_ns (ns, find_arglists);
259 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
263 /* If this namespace is not a function, ignore it. */
265 || !(sym->attr.function
266 || sym->attr.flavor == FL_VARIABLE))
269 /* Try to find out of what the return type is. */
270 if (sym->result != NULL)
273 if (sym->ts.type == BT_UNKNOWN)
275 t = gfc_set_default_type (sym, 0, ns);
277 if (t == FAILURE && !sym->attr.untyped)
279 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
280 sym->name, &sym->declared_at); /* FIXME */
281 sym->attr.untyped = 1;
287 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
288 introduce duplicates. */
291 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
293 gfc_formal_arglist *f, *new_arglist;
296 for (; new_args != NULL; new_args = new_args->next)
298 new_sym = new_args->sym;
299 /* See if ths arg is already in the formal argument list. */
300 for (f = proc->formal; f; f = f->next)
302 if (new_sym == f->sym)
309 /* Add a new argument. Argument order is not important. */
310 new_arglist = gfc_get_formal_arglist ();
311 new_arglist->sym = new_sym;
312 new_arglist->next = proc->formal;
313 proc->formal = new_arglist;
318 /* Resolve alternate entry points. If a symbol has multiple entry points we
319 create a new master symbol for the main routine, and turn the existing
320 symbol into an entry point. */
323 resolve_entries (gfc_namespace * ns)
325 gfc_namespace *old_ns;
329 char name[GFC_MAX_SYMBOL_LEN + 1];
330 static int master_count = 0;
332 if (ns->proc_name == NULL)
335 /* No need to do anything if this procedure doesn't have alternate entry
340 /* We may already have resolved alternate entry points. */
341 if (ns->proc_name->attr.entry_master)
344 /* If this isn't a procedure something has gone horribly wrong. */
345 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
347 /* Remember the current namespace. */
348 old_ns = gfc_current_ns;
352 /* Add the main entry point to the list of entry points. */
353 el = gfc_get_entry_list ();
354 el->sym = ns->proc_name;
356 el->next = ns->entries;
358 ns->proc_name->attr.entry = 1;
360 /* Add an entry statement for it. */
367 /* Create a new symbol for the master function. */
368 /* Give the internal function a unique name (within this file).
369 Also include the function name so the user has some hope of figuring
370 out what is going on. */
371 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
372 master_count++, ns->proc_name->name);
373 gfc_get_ha_symbol (name, &proc);
374 gcc_assert (proc != NULL);
376 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
377 if (ns->proc_name->attr.subroutine)
378 gfc_add_subroutine (&proc->attr, proc->name, NULL);
382 gfc_typespec *ts, *fts;
384 gfc_add_function (&proc->attr, proc->name, NULL);
386 fts = &ns->entries->sym->result->ts;
387 if (fts->type == BT_UNKNOWN)
388 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
389 for (el = ns->entries->next; el; el = el->next)
391 ts = &el->sym->result->ts;
392 if (ts->type == BT_UNKNOWN)
393 ts = gfc_get_default_type (el->sym->result, NULL);
394 if (! gfc_compare_types (ts, fts)
395 || (el->sym->result->attr.dimension
396 != ns->entries->sym->result->attr.dimension)
397 || (el->sym->result->attr.pointer
398 != ns->entries->sym->result->attr.pointer))
404 sym = ns->entries->sym->result;
405 /* All result types the same. */
407 if (sym->attr.dimension)
408 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
409 if (sym->attr.pointer)
410 gfc_add_pointer (&proc->attr, NULL);
414 /* Otherwise the result will be passed through a union by
416 proc->attr.mixed_entry_master = 1;
417 for (el = ns->entries; el; el = el->next)
419 sym = el->sym->result;
420 if (sym->attr.dimension)
422 if (el == ns->entries)
424 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
425 sym->name, ns->entries->sym->name, &sym->declared_at);
428 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
429 sym->name, ns->entries->sym->name, &sym->declared_at);
431 else if (sym->attr.pointer)
433 if (el == ns->entries)
435 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
436 sym->name, ns->entries->sym->name, &sym->declared_at);
439 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
440 sym->name, ns->entries->sym->name, &sym->declared_at);
445 if (ts->type == BT_UNKNOWN)
446 ts = gfc_get_default_type (sym, NULL);
450 if (ts->kind == gfc_default_integer_kind)
454 if (ts->kind == gfc_default_real_kind
455 || ts->kind == gfc_default_double_kind)
459 if (ts->kind == gfc_default_complex_kind)
463 if (ts->kind == gfc_default_logical_kind)
467 /* We will issue error elsewhere. */
475 if (el == ns->entries)
477 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
478 sym->name, gfc_typename (ts), ns->entries->sym->name,
482 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
483 sym->name, gfc_typename (ts), ns->entries->sym->name,
490 proc->attr.access = ACCESS_PRIVATE;
491 proc->attr.entry_master = 1;
493 /* Merge all the entry point arguments. */
494 for (el = ns->entries; el; el = el->next)
495 merge_argument_lists (proc, el->sym->formal);
497 /* Use the master function for the function body. */
498 ns->proc_name = proc;
500 /* Finalize the new symbols. */
501 gfc_commit_symbols ();
503 /* Restore the original namespace. */
504 gfc_current_ns = old_ns;
508 /* Resolve contained function types. Because contained functions can call one
509 another, they have to be worked out before any of the contained procedures
512 The good news is that if a function doesn't already have a type, the only
513 way it can get one is through an IMPLICIT type or a RESULT variable, because
514 by definition contained functions are contained namespace they're contained
515 in, not in a sibling or parent namespace. */
518 resolve_contained_functions (gfc_namespace * ns)
520 gfc_namespace *child;
523 resolve_formal_arglists (ns);
525 for (child = ns->contained; child; child = child->sibling)
527 /* Resolve alternate entry points first. */
528 resolve_entries (child);
530 /* Then check function return types. */
531 resolve_contained_fntype (child->proc_name, child);
532 for (el = child->entries; el; el = el->next)
533 resolve_contained_fntype (el->sym, child);
538 /* Resolve all of the elements of a structure constructor and make sure that
539 the types are correct. */
542 resolve_structure_cons (gfc_expr * expr)
544 gfc_constructor *cons;
549 cons = expr->value.constructor;
550 /* A constructor may have references if it is the result of substituting a
551 parameter variable. In this case we just pull out the component we
554 comp = expr->ref->u.c.sym->components;
556 comp = expr->ts.derived->components;
558 for (; comp; comp = comp->next, cons = cons->next)
566 if (gfc_resolve_expr (cons->expr) == FAILURE)
572 /* If we don't have the right type, try to convert it. */
574 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
575 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
584 /****************** Expression name resolution ******************/
586 /* Returns 0 if a symbol was not declared with a type or
587 attribute declaration statement, nonzero otherwise. */
590 was_declared (gfc_symbol * sym)
596 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
599 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
600 || a.optional || a.pointer || a.save || a.target
601 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
608 /* Determine if a symbol is generic or not. */
611 generic_sym (gfc_symbol * sym)
615 if (sym->attr.generic ||
616 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
619 if (was_declared (sym) || sym->ns->parent == NULL)
622 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
624 return (s == NULL) ? 0 : generic_sym (s);
628 /* Determine if a symbol is specific or not. */
631 specific_sym (gfc_symbol * sym)
635 if (sym->attr.if_source == IFSRC_IFBODY
636 || sym->attr.proc == PROC_MODULE
637 || sym->attr.proc == PROC_INTERNAL
638 || sym->attr.proc == PROC_ST_FUNCTION
639 || (sym->attr.intrinsic &&
640 gfc_specific_intrinsic (sym->name))
641 || sym->attr.external)
644 if (was_declared (sym) || sym->ns->parent == NULL)
647 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
649 return (s == NULL) ? 0 : specific_sym (s);
653 /* Figure out if the procedure is specific, generic or unknown. */
656 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
660 procedure_kind (gfc_symbol * sym)
663 if (generic_sym (sym))
664 return PTYPE_GENERIC;
666 if (specific_sym (sym))
667 return PTYPE_SPECIFIC;
669 return PTYPE_UNKNOWN;
673 /* Resolve an actual argument list. Most of the time, this is just
674 resolving the expressions in the list.
675 The exception is that we sometimes have to decide whether arguments
676 that look like procedure arguments are really simple variable
680 resolve_actual_arglist (gfc_actual_arglist * arg)
683 gfc_symtree *parent_st;
686 for (; arg; arg = arg->next)
692 /* Check the label is a valid branching target. */
695 if (arg->label->defined == ST_LABEL_UNKNOWN)
697 gfc_error ("Label %d referenced at %L is never defined",
698 arg->label->value, &arg->label->where);
705 if (e->ts.type != BT_PROCEDURE)
707 if (gfc_resolve_expr (e) != SUCCESS)
712 /* See if the expression node should really be a variable
715 sym = e->symtree->n.sym;
717 if (sym->attr.flavor == FL_PROCEDURE
718 || sym->attr.intrinsic
719 || sym->attr.external)
722 if (sym->attr.proc == PROC_ST_FUNCTION)
724 gfc_error ("Statement function '%s' at %L is not allowed as an "
725 "actual argument", sym->name, &e->where);
728 /* If the symbol is the function that names the current (or
729 parent) scope, then we really have a variable reference. */
731 if (sym->attr.function && sym->result == sym
732 && (sym->ns->proc_name == sym
733 || (sym->ns->parent != NULL
734 && sym->ns->parent->proc_name == sym)))
740 /* See if the name is a module procedure in a parent unit. */
742 if (was_declared (sym) || sym->ns->parent == NULL)
745 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
747 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
751 if (parent_st == NULL)
754 sym = parent_st->n.sym;
755 e->symtree = parent_st; /* Point to the right thing. */
757 if (sym->attr.flavor == FL_PROCEDURE
758 || sym->attr.intrinsic
759 || sym->attr.external)
765 e->expr_type = EXPR_VARIABLE;
769 e->rank = sym->as->rank;
770 e->ref = gfc_get_ref ();
771 e->ref->type = REF_ARRAY;
772 e->ref->u.ar.type = AR_FULL;
773 e->ref->u.ar.as = sym->as;
781 /************* Function resolution *************/
783 /* Resolve a function call known to be generic.
784 Section 14.1.2.4.1. */
787 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
791 if (sym->attr.generic)
794 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
797 expr->value.function.name = s->name;
798 expr->value.function.esym = s;
801 expr->rank = s->as->rank;
805 /* TODO: Need to search for elemental references in generic interface */
808 if (sym->attr.intrinsic)
809 return gfc_intrinsic_func_interface (expr, 0);
816 resolve_generic_f (gfc_expr * expr)
821 sym = expr->symtree->n.sym;
825 m = resolve_generic_f0 (expr, sym);
828 else if (m == MATCH_ERROR)
832 if (sym->ns->parent == NULL)
834 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
838 if (!generic_sym (sym))
842 /* Last ditch attempt. */
844 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
846 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
847 expr->symtree->n.sym->name, &expr->where);
851 m = gfc_intrinsic_func_interface (expr, 0);
856 ("Generic function '%s' at %L is not consistent with a specific "
857 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
863 /* Resolve a function call known to be specific. */
866 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
870 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
874 sym->attr.proc = PROC_DUMMY;
878 sym->attr.proc = PROC_EXTERNAL;
882 if (sym->attr.proc == PROC_MODULE
883 || sym->attr.proc == PROC_ST_FUNCTION
884 || sym->attr.proc == PROC_INTERNAL)
887 if (sym->attr.intrinsic)
889 m = gfc_intrinsic_func_interface (expr, 1);
894 ("Function '%s' at %L is INTRINSIC but is not compatible with "
895 "an intrinsic", sym->name, &expr->where);
903 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
906 expr->value.function.name = sym->name;
907 expr->value.function.esym = sym;
909 expr->rank = sym->as->rank;
916 resolve_specific_f (gfc_expr * expr)
921 sym = expr->symtree->n.sym;
925 m = resolve_specific_f0 (sym, expr);
928 if (m == MATCH_ERROR)
931 if (sym->ns->parent == NULL)
934 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
940 gfc_error ("Unable to resolve the specific function '%s' at %L",
941 expr->symtree->n.sym->name, &expr->where);
947 /* Resolve a procedure call not known to be generic nor specific. */
950 resolve_unknown_f (gfc_expr * expr)
955 sym = expr->symtree->n.sym;
959 sym->attr.proc = PROC_DUMMY;
960 expr->value.function.name = sym->name;
964 /* See if we have an intrinsic function reference. */
966 if (gfc_intrinsic_name (sym->name, 0))
968 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
973 /* The reference is to an external name. */
975 sym->attr.proc = PROC_EXTERNAL;
976 expr->value.function.name = sym->name;
977 expr->value.function.esym = expr->symtree->n.sym;
980 expr->rank = sym->as->rank;
982 /* Type of the expression is either the type of the symbol or the
983 default type of the symbol. */
986 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
988 if (sym->ts.type != BT_UNKNOWN)
992 ts = gfc_get_default_type (sym, sym->ns);
994 if (ts->type == BT_UNKNOWN)
996 gfc_error ("Function '%s' at %L has no IMPLICIT type",
997 sym->name, &expr->where);
1008 /* Figure out if a function reference is pure or not. Also set the name
1009 of the function for a potential error message. Return nonzero if the
1010 function is PURE, zero if not. */
1013 pure_function (gfc_expr * e, const char **name)
1017 if (e->value.function.esym)
1019 pure = gfc_pure (e->value.function.esym);
1020 *name = e->value.function.esym->name;
1022 else if (e->value.function.isym)
1024 pure = e->value.function.isym->pure
1025 || e->value.function.isym->elemental;
1026 *name = e->value.function.isym->name;
1030 /* Implicit functions are not pure. */
1032 *name = e->value.function.name;
1039 /* Resolve a function call, which means resolving the arguments, then figuring
1040 out which entity the name refers to. */
1041 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1042 to INTENT(OUT) or INTENT(INOUT). */
1045 resolve_function (gfc_expr * expr)
1047 gfc_actual_arglist *arg;
1051 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1054 /* See if function is already resolved. */
1056 if (expr->value.function.name != NULL)
1058 if (expr->ts.type == BT_UNKNOWN)
1059 expr->ts = expr->symtree->n.sym->ts;
1064 /* Apply the rules of section 14.1.2. */
1066 switch (procedure_kind (expr->symtree->n.sym))
1069 t = resolve_generic_f (expr);
1072 case PTYPE_SPECIFIC:
1073 t = resolve_specific_f (expr);
1077 t = resolve_unknown_f (expr);
1081 gfc_internal_error ("resolve_function(): bad function type");
1085 /* If the expression is still a function (it might have simplified),
1086 then we check to see if we are calling an elemental function. */
1088 if (expr->expr_type != EXPR_FUNCTION)
1091 if (expr->value.function.actual != NULL
1092 && ((expr->value.function.esym != NULL
1093 && expr->value.function.esym->attr.elemental)
1094 || (expr->value.function.isym != NULL
1095 && expr->value.function.isym->elemental)))
1098 /* The rank of an elemental is the rank of its array argument(s). */
1100 for (arg = expr->value.function.actual; arg; arg = arg->next)
1102 if (arg->expr != NULL && arg->expr->rank > 0)
1104 expr->rank = arg->expr->rank;
1110 if (!pure_function (expr, &name))
1115 ("Function reference to '%s' at %L is inside a FORALL block",
1116 name, &expr->where);
1119 else if (gfc_pure (NULL))
1121 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1122 "procedure within a PURE procedure", name, &expr->where);
1131 /************* Subroutine resolution *************/
1134 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1141 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1142 sym->name, &c->loc);
1143 else if (gfc_pure (NULL))
1144 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1150 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1154 if (sym->attr.generic)
1156 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1159 c->resolved_sym = s;
1160 pure_subroutine (c, s);
1164 /* TODO: Need to search for elemental references in generic interface. */
1167 if (sym->attr.intrinsic)
1168 return gfc_intrinsic_sub_interface (c, 0);
1175 resolve_generic_s (gfc_code * c)
1180 sym = c->symtree->n.sym;
1182 m = resolve_generic_s0 (c, sym);
1185 if (m == MATCH_ERROR)
1188 if (sym->ns->parent != NULL)
1190 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1193 m = resolve_generic_s0 (c, sym);
1196 if (m == MATCH_ERROR)
1201 /* Last ditch attempt. */
1203 if (!gfc_generic_intrinsic (sym->name))
1206 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1207 sym->name, &c->loc);
1211 m = gfc_intrinsic_sub_interface (c, 0);
1215 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1216 "intrinsic subroutine interface", sym->name, &c->loc);
1222 /* Resolve a subroutine call known to be specific. */
1225 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1229 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1231 if (sym->attr.dummy)
1233 sym->attr.proc = PROC_DUMMY;
1237 sym->attr.proc = PROC_EXTERNAL;
1241 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1244 if (sym->attr.intrinsic)
1246 m = gfc_intrinsic_sub_interface (c, 1);
1250 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1251 "with an intrinsic", sym->name, &c->loc);
1259 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1261 c->resolved_sym = sym;
1262 pure_subroutine (c, sym);
1269 resolve_specific_s (gfc_code * c)
1274 sym = c->symtree->n.sym;
1276 m = resolve_specific_s0 (c, sym);
1279 if (m == MATCH_ERROR)
1282 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1286 m = resolve_specific_s0 (c, sym);
1289 if (m == MATCH_ERROR)
1293 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1294 sym->name, &c->loc);
1300 /* Resolve a subroutine call not known to be generic nor specific. */
1303 resolve_unknown_s (gfc_code * c)
1307 sym = c->symtree->n.sym;
1309 if (sym->attr.dummy)
1311 sym->attr.proc = PROC_DUMMY;
1315 /* See if we have an intrinsic function reference. */
1317 if (gfc_intrinsic_name (sym->name, 1))
1319 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1324 /* The reference is to an external name. */
1327 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1329 c->resolved_sym = sym;
1331 pure_subroutine (c, sym);
1337 /* Resolve a subroutine call. Although it was tempting to use the same code
1338 for functions, subroutines and functions are stored differently and this
1339 makes things awkward. */
1342 resolve_call (gfc_code * c)
1346 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1349 if (c->resolved_sym != NULL)
1352 switch (procedure_kind (c->symtree->n.sym))
1355 t = resolve_generic_s (c);
1358 case PTYPE_SPECIFIC:
1359 t = resolve_specific_s (c);
1363 t = resolve_unknown_s (c);
1367 gfc_internal_error ("resolve_subroutine(): bad function type");
1373 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1374 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1375 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1376 if their shapes do not match. If either op1->shape or op2->shape is
1377 NULL, return SUCCESS. */
1380 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1387 if (op1->shape != NULL && op2->shape != NULL)
1389 for (i = 0; i < op1->rank; i++)
1391 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1393 gfc_error ("Shapes for operands at %L and %L are not conformable",
1394 &op1->where, &op2->where);
1404 /* Resolve an operator expression node. This can involve replacing the
1405 operation with a user defined function call. */
1408 resolve_operator (gfc_expr * e)
1410 gfc_expr *op1, *op2;
1414 /* Resolve all subnodes-- give them types. */
1416 switch (e->value.op.operator)
1419 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1422 /* Fall through... */
1425 case INTRINSIC_UPLUS:
1426 case INTRINSIC_UMINUS:
1427 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1432 /* Typecheck the new node. */
1434 op1 = e->value.op.op1;
1435 op2 = e->value.op.op2;
1437 switch (e->value.op.operator)
1439 case INTRINSIC_UPLUS:
1440 case INTRINSIC_UMINUS:
1441 if (op1->ts.type == BT_INTEGER
1442 || op1->ts.type == BT_REAL
1443 || op1->ts.type == BT_COMPLEX)
1449 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1450 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1453 case INTRINSIC_PLUS:
1454 case INTRINSIC_MINUS:
1455 case INTRINSIC_TIMES:
1456 case INTRINSIC_DIVIDE:
1457 case INTRINSIC_POWER:
1458 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1460 gfc_type_convert_binary (e);
1465 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1466 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1467 gfc_typename (&op2->ts));
1470 case INTRINSIC_CONCAT:
1471 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1473 e->ts.type = BT_CHARACTER;
1474 e->ts.kind = op1->ts.kind;
1479 _("Operands of string concatenation operator at %%L are %s/%s"),
1480 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1486 case INTRINSIC_NEQV:
1487 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1489 e->ts.type = BT_LOGICAL;
1490 e->ts.kind = gfc_kind_max (op1, op2);
1491 if (op1->ts.kind < e->ts.kind)
1492 gfc_convert_type (op1, &e->ts, 2);
1493 else if (op2->ts.kind < e->ts.kind)
1494 gfc_convert_type (op2, &e->ts, 2);
1498 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1499 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1500 gfc_typename (&op2->ts));
1505 if (op1->ts.type == BT_LOGICAL)
1507 e->ts.type = BT_LOGICAL;
1508 e->ts.kind = op1->ts.kind;
1512 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1513 gfc_typename (&op1->ts));
1520 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1522 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1526 /* Fall through... */
1530 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1532 e->ts.type = BT_LOGICAL;
1533 e->ts.kind = gfc_default_logical_kind;
1537 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1539 gfc_type_convert_binary (e);
1541 e->ts.type = BT_LOGICAL;
1542 e->ts.kind = gfc_default_logical_kind;
1546 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1548 _("Logicals at %%L must be compared with %s instead of %s"),
1549 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1550 gfc_op2string (e->value.op.operator));
1553 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1554 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1555 gfc_typename (&op2->ts));
1559 case INTRINSIC_USER:
1561 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1562 e->value.op.uop->name, gfc_typename (&op1->ts));
1564 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1565 e->value.op.uop->name, gfc_typename (&op1->ts),
1566 gfc_typename (&op2->ts));
1571 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1574 /* Deal with arrayness of an operand through an operator. */
1578 switch (e->value.op.operator)
1580 case INTRINSIC_PLUS:
1581 case INTRINSIC_MINUS:
1582 case INTRINSIC_TIMES:
1583 case INTRINSIC_DIVIDE:
1584 case INTRINSIC_POWER:
1585 case INTRINSIC_CONCAT:
1589 case INTRINSIC_NEQV:
1597 if (op1->rank == 0 && op2->rank == 0)
1600 if (op1->rank == 0 && op2->rank != 0)
1602 e->rank = op2->rank;
1604 if (e->shape == NULL)
1605 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1608 if (op1->rank != 0 && op2->rank == 0)
1610 e->rank = op1->rank;
1612 if (e->shape == NULL)
1613 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1616 if (op1->rank != 0 && op2->rank != 0)
1618 if (op1->rank == op2->rank)
1620 e->rank = op1->rank;
1621 if (e->shape == NULL)
1623 t = compare_shapes(op1, op2);
1627 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1632 gfc_error ("Inconsistent ranks for operator at %L and %L",
1633 &op1->where, &op2->where);
1636 /* Allow higher level expressions to work. */
1644 case INTRINSIC_UPLUS:
1645 case INTRINSIC_UMINUS:
1646 e->rank = op1->rank;
1648 if (e->shape == NULL)
1649 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1651 /* Simply copy arrayness attribute */
1658 /* Attempt to simplify the expression. */
1660 t = gfc_simplify_expr (e, 0);
1665 if (gfc_extend_expr (e) == SUCCESS)
1668 gfc_error (msg, &e->where);
1674 /************** Array resolution subroutines **************/
1678 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1681 /* Compare two integer expressions. */
1684 compare_bound (gfc_expr * a, gfc_expr * b)
1688 if (a == NULL || a->expr_type != EXPR_CONSTANT
1689 || b == NULL || b->expr_type != EXPR_CONSTANT)
1692 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1693 gfc_internal_error ("compare_bound(): Bad expression");
1695 i = mpz_cmp (a->value.integer, b->value.integer);
1705 /* Compare an integer expression with an integer. */
1708 compare_bound_int (gfc_expr * a, int b)
1712 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1715 if (a->ts.type != BT_INTEGER)
1716 gfc_internal_error ("compare_bound_int(): Bad expression");
1718 i = mpz_cmp_si (a->value.integer, b);
1728 /* Compare a single dimension of an array reference to the array
1732 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1735 /* Given start, end and stride values, calculate the minimum and
1736 maximum referenced indexes. */
1744 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1746 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1752 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1754 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1758 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1760 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1763 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1764 it is legal (see 6.2.2.3.1). */
1769 gfc_internal_error ("check_dimension(): Bad array reference");
1775 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1780 /* Compare an array reference with an array specification. */
1783 compare_spec_to_ref (gfc_array_ref * ar)
1790 /* TODO: Full array sections are only allowed as actual parameters. */
1791 if (as->type == AS_ASSUMED_SIZE
1792 && (/*ar->type == AR_FULL
1793 ||*/ (ar->type == AR_SECTION
1794 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1796 gfc_error ("Rightmost upper bound of assumed size array section"
1797 " not specified at %L", &ar->where);
1801 if (ar->type == AR_FULL)
1804 if (as->rank != ar->dimen)
1806 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1807 &ar->where, ar->dimen, as->rank);
1811 for (i = 0; i < as->rank; i++)
1812 if (check_dimension (i, ar, as) == FAILURE)
1819 /* Resolve one part of an array index. */
1822 gfc_resolve_index (gfc_expr * index, int check_scalar)
1829 if (gfc_resolve_expr (index) == FAILURE)
1832 if (check_scalar && index->rank != 0)
1834 gfc_error ("Array index at %L must be scalar", &index->where);
1838 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1840 gfc_error ("Array index at %L must be of INTEGER type",
1845 if (index->ts.type == BT_REAL)
1846 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1847 &index->where) == FAILURE)
1850 if (index->ts.kind != gfc_index_integer_kind
1851 || index->ts.type != BT_INTEGER)
1853 ts.type = BT_INTEGER;
1854 ts.kind = gfc_index_integer_kind;
1856 gfc_convert_type_warn (index, &ts, 2, 0);
1862 /* Resolve a dim argument to an intrinsic function. */
1865 gfc_resolve_dim_arg (gfc_expr *dim)
1870 if (gfc_resolve_expr (dim) == FAILURE)
1875 gfc_error ("Argument dim at %L must be scalar", &dim->where);
1879 if (dim->ts.type != BT_INTEGER)
1881 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1884 if (dim->ts.kind != gfc_index_integer_kind)
1888 ts.type = BT_INTEGER;
1889 ts.kind = gfc_index_integer_kind;
1891 gfc_convert_type_warn (dim, &ts, 2, 0);
1897 /* Given an expression that contains array references, update those array
1898 references to point to the right array specifications. While this is
1899 filled in during matching, this information is difficult to save and load
1900 in a module, so we take care of it here.
1902 The idea here is that the original array reference comes from the
1903 base symbol. We traverse the list of reference structures, setting
1904 the stored reference to references. Component references can
1905 provide an additional array specification. */
1908 find_array_spec (gfc_expr * e)
1914 as = e->symtree->n.sym->as;
1915 c = e->symtree->n.sym->components;
1917 for (ref = e->ref; ref; ref = ref->next)
1922 gfc_internal_error ("find_array_spec(): Missing spec");
1929 for (; c; c = c->next)
1930 if (c == ref->u.c.component)
1934 gfc_internal_error ("find_array_spec(): Component not found");
1939 gfc_internal_error ("find_array_spec(): unused as(1)");
1943 c = c->ts.derived->components;
1951 gfc_internal_error ("find_array_spec(): unused as(2)");
1955 /* Resolve an array reference. */
1958 resolve_array_ref (gfc_array_ref * ar)
1960 int i, check_scalar;
1962 for (i = 0; i < ar->dimen; i++)
1964 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1966 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1968 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1970 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1973 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1974 switch (ar->start[i]->rank)
1977 ar->dimen_type[i] = DIMEN_ELEMENT;
1981 ar->dimen_type[i] = DIMEN_VECTOR;
1985 gfc_error ("Array index at %L is an array of rank %d",
1986 &ar->c_where[i], ar->start[i]->rank);
1991 /* If the reference type is unknown, figure out what kind it is. */
1993 if (ar->type == AR_UNKNOWN)
1995 ar->type = AR_ELEMENT;
1996 for (i = 0; i < ar->dimen; i++)
1997 if (ar->dimen_type[i] == DIMEN_RANGE
1998 || ar->dimen_type[i] == DIMEN_VECTOR)
2000 ar->type = AR_SECTION;
2005 if (compare_spec_to_ref (ar) == FAILURE)
2013 resolve_substring (gfc_ref * ref)
2016 if (ref->u.ss.start != NULL)
2018 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2021 if (ref->u.ss.start->ts.type != BT_INTEGER)
2023 gfc_error ("Substring start index at %L must be of type INTEGER",
2024 &ref->u.ss.start->where);
2028 if (ref->u.ss.start->rank != 0)
2030 gfc_error ("Substring start index at %L must be scalar",
2031 &ref->u.ss.start->where);
2035 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2037 gfc_error ("Substring start index at %L is less than one",
2038 &ref->u.ss.start->where);
2043 if (ref->u.ss.end != NULL)
2045 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2048 if (ref->u.ss.end->ts.type != BT_INTEGER)
2050 gfc_error ("Substring end index at %L must be of type INTEGER",
2051 &ref->u.ss.end->where);
2055 if (ref->u.ss.end->rank != 0)
2057 gfc_error ("Substring end index at %L must be scalar",
2058 &ref->u.ss.end->where);
2062 if (ref->u.ss.length != NULL
2063 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2065 gfc_error ("Substring end index at %L is out of bounds",
2066 &ref->u.ss.start->where);
2075 /* Resolve subtype references. */
2078 resolve_ref (gfc_expr * expr)
2080 int current_part_dimension, n_components, seen_part_dimension;
2083 for (ref = expr->ref; ref; ref = ref->next)
2084 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2086 find_array_spec (expr);
2090 for (ref = expr->ref; ref; ref = ref->next)
2094 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2102 resolve_substring (ref);
2106 /* Check constraints on part references. */
2108 current_part_dimension = 0;
2109 seen_part_dimension = 0;
2112 for (ref = expr->ref; ref; ref = ref->next)
2117 switch (ref->u.ar.type)
2121 current_part_dimension = 1;
2125 current_part_dimension = 0;
2129 gfc_internal_error ("resolve_ref(): Bad array reference");
2135 if ((current_part_dimension || seen_part_dimension)
2136 && ref->u.c.component->pointer)
2139 ("Component to the right of a part reference with nonzero "
2140 "rank must not have the POINTER attribute at %L",
2152 if (((ref->type == REF_COMPONENT && n_components > 1)
2153 || ref->next == NULL)
2154 && current_part_dimension
2155 && seen_part_dimension)
2158 gfc_error ("Two or more part references with nonzero rank must "
2159 "not be specified at %L", &expr->where);
2163 if (ref->type == REF_COMPONENT)
2165 if (current_part_dimension)
2166 seen_part_dimension = 1;
2168 /* reset to make sure */
2169 current_part_dimension = 0;
2177 /* Given an expression, determine its shape. This is easier than it sounds.
2178 Leaves the shape array NULL if it is not possible to determine the shape. */
2181 expression_shape (gfc_expr * e)
2183 mpz_t array[GFC_MAX_DIMENSIONS];
2186 if (e->rank == 0 || e->shape != NULL)
2189 for (i = 0; i < e->rank; i++)
2190 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2193 e->shape = gfc_get_shape (e->rank);
2195 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2200 for (i--; i >= 0; i--)
2201 mpz_clear (array[i]);
2205 /* Given a variable expression node, compute the rank of the expression by
2206 examining the base symbol and any reference structures it may have. */
2209 expression_rank (gfc_expr * e)
2216 if (e->expr_type == EXPR_ARRAY)
2218 /* Constructors can have a rank different from one via RESHAPE(). */
2220 if (e->symtree == NULL)
2226 e->rank = (e->symtree->n.sym->as == NULL)
2227 ? 0 : e->symtree->n.sym->as->rank;
2233 for (ref = e->ref; ref; ref = ref->next)
2235 if (ref->type != REF_ARRAY)
2238 if (ref->u.ar.type == AR_FULL)
2240 rank = ref->u.ar.as->rank;
2244 if (ref->u.ar.type == AR_SECTION)
2246 /* Figure out the rank of the section. */
2248 gfc_internal_error ("expression_rank(): Two array specs");
2250 for (i = 0; i < ref->u.ar.dimen; i++)
2251 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2252 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2262 expression_shape (e);
2266 /* Resolve a variable expression. */
2269 resolve_variable (gfc_expr * e)
2273 if (e->ref && resolve_ref (e) == FAILURE)
2276 if (e->symtree == NULL)
2279 sym = e->symtree->n.sym;
2280 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2282 e->ts.type = BT_PROCEDURE;
2286 if (sym->ts.type != BT_UNKNOWN)
2287 gfc_variable_attr (e, &e->ts);
2290 /* Must be a simple variable reference. */
2291 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2300 /* Resolve an expression. That is, make sure that types of operands agree
2301 with their operators, intrinsic operators are converted to function calls
2302 for overloaded types and unresolved function references are resolved. */
2305 gfc_resolve_expr (gfc_expr * e)
2312 switch (e->expr_type)
2315 t = resolve_operator (e);
2319 t = resolve_function (e);
2323 t = resolve_variable (e);
2325 expression_rank (e);
2328 case EXPR_SUBSTRING:
2329 t = resolve_ref (e);
2339 if (resolve_ref (e) == FAILURE)
2342 t = gfc_resolve_array_constructor (e);
2343 /* Also try to expand a constructor. */
2346 expression_rank (e);
2347 gfc_expand_constructor (e);
2352 case EXPR_STRUCTURE:
2353 t = resolve_ref (e);
2357 t = resolve_structure_cons (e);
2361 t = gfc_simplify_expr (e, 0);
2365 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2372 /* Resolve an expression from an iterator. They must be scalar and have
2373 INTEGER or (optionally) REAL type. */
2376 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2377 const char * name_msgid)
2379 if (gfc_resolve_expr (expr) == FAILURE)
2382 if (expr->rank != 0)
2384 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2388 if (!(expr->ts.type == BT_INTEGER
2389 || (expr->ts.type == BT_REAL && real_ok)))
2392 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2395 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2402 /* Resolve the expressions in an iterator structure. If REAL_OK is
2403 false allow only INTEGER type iterators, otherwise allow REAL types. */
2406 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2409 if (iter->var->ts.type == BT_REAL)
2410 gfc_notify_std (GFC_STD_F95_DEL,
2411 "Obsolete: REAL DO loop iterator at %L",
2414 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2418 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2420 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2425 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2426 "Start expression in DO loop") == FAILURE)
2429 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2430 "End expression in DO loop") == FAILURE)
2433 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2434 "Step expression in DO loop") == FAILURE)
2437 if (iter->step->expr_type == EXPR_CONSTANT)
2439 if ((iter->step->ts.type == BT_INTEGER
2440 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2441 || (iter->step->ts.type == BT_REAL
2442 && mpfr_sgn (iter->step->value.real) == 0))
2444 gfc_error ("Step expression in DO loop at %L cannot be zero",
2445 &iter->step->where);
2450 /* Convert start, end, and step to the same type as var. */
2451 if (iter->start->ts.kind != iter->var->ts.kind
2452 || iter->start->ts.type != iter->var->ts.type)
2453 gfc_convert_type (iter->start, &iter->var->ts, 2);
2455 if (iter->end->ts.kind != iter->var->ts.kind
2456 || iter->end->ts.type != iter->var->ts.type)
2457 gfc_convert_type (iter->end, &iter->var->ts, 2);
2459 if (iter->step->ts.kind != iter->var->ts.kind
2460 || iter->step->ts.type != iter->var->ts.type)
2461 gfc_convert_type (iter->step, &iter->var->ts, 2);
2467 /* Resolve a list of FORALL iterators. */
2470 resolve_forall_iterators (gfc_forall_iterator * iter)
2475 if (gfc_resolve_expr (iter->var) == SUCCESS
2476 && iter->var->ts.type != BT_INTEGER)
2477 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2480 if (gfc_resolve_expr (iter->start) == SUCCESS
2481 && iter->start->ts.type != BT_INTEGER)
2482 gfc_error ("FORALL start expression at %L must be INTEGER",
2483 &iter->start->where);
2484 if (iter->var->ts.kind != iter->start->ts.kind)
2485 gfc_convert_type (iter->start, &iter->var->ts, 2);
2487 if (gfc_resolve_expr (iter->end) == SUCCESS
2488 && iter->end->ts.type != BT_INTEGER)
2489 gfc_error ("FORALL end expression at %L must be INTEGER",
2491 if (iter->var->ts.kind != iter->end->ts.kind)
2492 gfc_convert_type (iter->end, &iter->var->ts, 2);
2494 if (gfc_resolve_expr (iter->stride) == SUCCESS
2495 && iter->stride->ts.type != BT_INTEGER)
2496 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2497 &iter->stride->where);
2498 if (iter->var->ts.kind != iter->stride->ts.kind)
2499 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2506 /* Given a pointer to a symbol that is a derived type, see if any components
2507 have the POINTER attribute. The search is recursive if necessary.
2508 Returns zero if no pointer components are found, nonzero otherwise. */
2511 derived_pointer (gfc_symbol * sym)
2515 for (c = sym->components; c; c = c->next)
2520 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2528 /* Given a pointer to a symbol that is a derived type, see if it's
2529 inaccessible, i.e. if it's defined in another module and the components are
2530 PRIVATE. The search is recursive if necessary. Returns zero if no
2531 inaccessible components are found, nonzero otherwise. */
2534 derived_inaccessible (gfc_symbol *sym)
2538 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2541 for (c = sym->components; c; c = c->next)
2543 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2551 /* Resolve the argument of a deallocate expression. The expression must be
2552 a pointer or a full array. */
2555 resolve_deallocate_expr (gfc_expr * e)
2557 symbol_attribute attr;
2561 if (gfc_resolve_expr (e) == FAILURE)
2564 attr = gfc_expr_attr (e);
2568 if (e->expr_type != EXPR_VARIABLE)
2571 allocatable = e->symtree->n.sym->attr.allocatable;
2572 for (ref = e->ref; ref; ref = ref->next)
2576 if (ref->u.ar.type != AR_FULL)
2581 allocatable = (ref->u.c.component->as != NULL
2582 && ref->u.c.component->as->type == AS_DEFERRED);
2590 if (allocatable == 0)
2593 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2594 "ALLOCATABLE or a POINTER", &e->where);
2601 /* Resolve the expression in an ALLOCATE statement, doing the additional
2602 checks to see whether the expression is OK or not. The expression must
2603 have a trailing array reference that gives the size of the array. */
2606 resolve_allocate_expr (gfc_expr * e)
2608 int i, pointer, allocatable, dimension;
2609 symbol_attribute attr;
2610 gfc_ref *ref, *ref2;
2613 if (gfc_resolve_expr (e) == FAILURE)
2616 /* Make sure the expression is allocatable or a pointer. If it is
2617 pointer, the next-to-last reference must be a pointer. */
2621 if (e->expr_type != EXPR_VARIABLE)
2625 attr = gfc_expr_attr (e);
2626 pointer = attr.pointer;
2627 dimension = attr.dimension;
2632 allocatable = e->symtree->n.sym->attr.allocatable;
2633 pointer = e->symtree->n.sym->attr.pointer;
2634 dimension = e->symtree->n.sym->attr.dimension;
2636 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2640 if (ref->next != NULL)
2645 allocatable = (ref->u.c.component->as != NULL
2646 && ref->u.c.component->as->type == AS_DEFERRED);
2648 pointer = ref->u.c.component->pointer;
2649 dimension = ref->u.c.component->dimension;
2659 if (allocatable == 0 && pointer == 0)
2661 gfc_error ("Expression in ALLOCATE statement at %L must be "
2662 "ALLOCATABLE or a POINTER", &e->where);
2666 if (pointer && dimension == 0)
2669 /* Make sure the next-to-last reference node is an array specification. */
2671 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2673 gfc_error ("Array specification required in ALLOCATE statement "
2674 "at %L", &e->where);
2678 if (ref2->u.ar.type == AR_ELEMENT)
2681 /* Make sure that the array section reference makes sense in the
2682 context of an ALLOCATE specification. */
2686 for (i = 0; i < ar->dimen; i++)
2687 switch (ar->dimen_type[i])
2693 if (ar->start[i] != NULL
2694 && ar->end[i] != NULL
2695 && ar->stride[i] == NULL)
2698 /* Fall Through... */
2702 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2711 /************ SELECT CASE resolution subroutines ************/
2713 /* Callback function for our mergesort variant. Determines interval
2714 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2715 op1 > op2. Assumes we're not dealing with the default case.
2716 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2717 There are nine situations to check. */
2720 compare_cases (const gfc_case * op1, const gfc_case * op2)
2724 if (op1->low == NULL) /* op1 = (:L) */
2726 /* op2 = (:N), so overlap. */
2728 /* op2 = (M:) or (M:N), L < M */
2729 if (op2->low != NULL
2730 && gfc_compare_expr (op1->high, op2->low) < 0)
2733 else if (op1->high == NULL) /* op1 = (K:) */
2735 /* op2 = (M:), so overlap. */
2737 /* op2 = (:N) or (M:N), K > N */
2738 if (op2->high != NULL
2739 && gfc_compare_expr (op1->low, op2->high) > 0)
2742 else /* op1 = (K:L) */
2744 if (op2->low == NULL) /* op2 = (:N), K > N */
2745 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2746 else if (op2->high == NULL) /* op2 = (M:), L < M */
2747 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2748 else /* op2 = (M:N) */
2752 if (gfc_compare_expr (op1->high, op2->low) < 0)
2755 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2764 /* Merge-sort a double linked case list, detecting overlap in the
2765 process. LIST is the head of the double linked case list before it
2766 is sorted. Returns the head of the sorted list if we don't see any
2767 overlap, or NULL otherwise. */
2770 check_case_overlap (gfc_case * list)
2772 gfc_case *p, *q, *e, *tail;
2773 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2775 /* If the passed list was empty, return immediately. */
2782 /* Loop unconditionally. The only exit from this loop is a return
2783 statement, when we've finished sorting the case list. */
2790 /* Count the number of merges we do in this pass. */
2793 /* Loop while there exists a merge to be done. */
2798 /* Count this merge. */
2801 /* Cut the list in two pieces by stepping INSIZE places
2802 forward in the list, starting from P. */
2805 for (i = 0; i < insize; i++)
2814 /* Now we have two lists. Merge them! */
2815 while (psize > 0 || (qsize > 0 && q != NULL))
2818 /* See from which the next case to merge comes from. */
2821 /* P is empty so the next case must come from Q. */
2826 else if (qsize == 0 || q == NULL)
2835 cmp = compare_cases (p, q);
2838 /* The whole case range for P is less than the
2846 /* The whole case range for Q is greater than
2847 the case range for P. */
2854 /* The cases overlap, or they are the same
2855 element in the list. Either way, we must
2856 issue an error and get the next case from P. */
2857 /* FIXME: Sort P and Q by line number. */
2858 gfc_error ("CASE label at %L overlaps with CASE "
2859 "label at %L", &p->where, &q->where);
2867 /* Add the next element to the merged list. */
2876 /* P has now stepped INSIZE places along, and so has Q. So
2877 they're the same. */
2882 /* If we have done only one merge or none at all, we've
2883 finished sorting the cases. */
2892 /* Otherwise repeat, merging lists twice the size. */
2898 /* Check to see if an expression is suitable for use in a CASE statement.
2899 Makes sure that all case expressions are scalar constants of the same
2900 type. Return FAILURE if anything is wrong. */
2903 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2905 if (e == NULL) return SUCCESS;
2907 if (e->ts.type != case_expr->ts.type)
2909 gfc_error ("Expression in CASE statement at %L must be of type %s",
2910 &e->where, gfc_basic_typename (case_expr->ts.type));
2914 /* C805 (R808) For a given case-construct, each case-value shall be of
2915 the same type as case-expr. For character type, length differences
2916 are allowed, but the kind type parameters shall be the same. */
2918 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2920 gfc_error("Expression in CASE statement at %L must be kind %d",
2921 &e->where, case_expr->ts.kind);
2925 /* Convert the case value kind to that of case expression kind, if needed.
2926 FIXME: Should a warning be issued? */
2927 if (e->ts.kind != case_expr->ts.kind)
2928 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2932 gfc_error ("Expression in CASE statement at %L must be scalar",
2941 /* Given a completely parsed select statement, we:
2943 - Validate all expressions and code within the SELECT.
2944 - Make sure that the selection expression is not of the wrong type.
2945 - Make sure that no case ranges overlap.
2946 - Eliminate unreachable cases and unreachable code resulting from
2947 removing case labels.
2949 The standard does allow unreachable cases, e.g. CASE (5:3). But
2950 they are a hassle for code generation, and to prevent that, we just
2951 cut them out here. This is not necessary for overlapping cases
2952 because they are illegal and we never even try to generate code.
2954 We have the additional caveat that a SELECT construct could have
2955 been a computed GOTO in the source code. Fortunately we can fairly
2956 easily work around that here: The case_expr for a "real" SELECT CASE
2957 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2958 we have to do is make sure that the case_expr is a scalar integer
2962 resolve_select (gfc_code * code)
2965 gfc_expr *case_expr;
2966 gfc_case *cp, *default_case, *tail, *head;
2967 int seen_unreachable;
2972 if (code->expr == NULL)
2974 /* This was actually a computed GOTO statement. */
2975 case_expr = code->expr2;
2976 if (case_expr->ts.type != BT_INTEGER
2977 || case_expr->rank != 0)
2978 gfc_error ("Selection expression in computed GOTO statement "
2979 "at %L must be a scalar integer expression",
2982 /* Further checking is not necessary because this SELECT was built
2983 by the compiler, so it should always be OK. Just move the
2984 case_expr from expr2 to expr so that we can handle computed
2985 GOTOs as normal SELECTs from here on. */
2986 code->expr = code->expr2;
2991 case_expr = code->expr;
2993 type = case_expr->ts.type;
2994 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2996 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2997 &case_expr->where, gfc_typename (&case_expr->ts));
2999 /* Punt. Going on here just produce more garbage error messages. */
3003 if (case_expr->rank != 0)
3005 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3006 "expression", &case_expr->where);
3012 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3013 of the SELECT CASE expression and its CASE values. Walk the lists
3014 of case values, and if we find a mismatch, promote case_expr to
3015 the appropriate kind. */
3017 if (type == BT_LOGICAL || type == BT_INTEGER)
3019 for (body = code->block; body; body = body->block)
3021 /* Walk the case label list. */
3022 for (cp = body->ext.case_list; cp; cp = cp->next)
3024 /* Intercept the DEFAULT case. It does not have a kind. */
3025 if (cp->low == NULL && cp->high == NULL)
3028 /* Unreachable case ranges are discarded, so ignore. */
3029 if (cp->low != NULL && cp->high != NULL
3030 && cp->low != cp->high
3031 && gfc_compare_expr (cp->low, cp->high) > 0)
3034 /* FIXME: Should a warning be issued? */
3036 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3037 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3039 if (cp->high != NULL
3040 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3041 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3046 /* Assume there is no DEFAULT case. */
3047 default_case = NULL;
3051 for (body = code->block; body; body = body->block)
3053 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3055 seen_unreachable = 0;
3057 /* Walk the case label list, making sure that all case labels
3059 for (cp = body->ext.case_list; cp; cp = cp->next)
3061 /* Count the number of cases in the whole construct. */
3064 /* Intercept the DEFAULT case. */
3065 if (cp->low == NULL && cp->high == NULL)
3067 if (default_case != NULL)
3069 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3070 "by a second DEFAULT CASE at %L",
3071 &default_case->where, &cp->where);
3082 /* Deal with single value cases and case ranges. Errors are
3083 issued from the validation function. */
3084 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3085 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3091 if (type == BT_LOGICAL
3092 && ((cp->low == NULL || cp->high == NULL)
3093 || cp->low != cp->high))
3096 ("Logical range in CASE statement at %L is not allowed",
3102 if (cp->low != NULL && cp->high != NULL
3103 && cp->low != cp->high
3104 && gfc_compare_expr (cp->low, cp->high) > 0)
3106 if (gfc_option.warn_surprising)
3107 gfc_warning ("Range specification at %L can never "
3108 "be matched", &cp->where);
3110 cp->unreachable = 1;
3111 seen_unreachable = 1;
3115 /* If the case range can be matched, it can also overlap with
3116 other cases. To make sure it does not, we put it in a
3117 double linked list here. We sort that with a merge sort
3118 later on to detect any overlapping cases. */
3122 head->right = head->left = NULL;
3127 tail->right->left = tail;
3134 /* It there was a failure in the previous case label, give up
3135 for this case label list. Continue with the next block. */
3139 /* See if any case labels that are unreachable have been seen.
3140 If so, we eliminate them. This is a bit of a kludge because
3141 the case lists for a single case statement (label) is a
3142 single forward linked lists. */
3143 if (seen_unreachable)
3145 /* Advance until the first case in the list is reachable. */
3146 while (body->ext.case_list != NULL
3147 && body->ext.case_list->unreachable)
3149 gfc_case *n = body->ext.case_list;
3150 body->ext.case_list = body->ext.case_list->next;
3152 gfc_free_case_list (n);
3155 /* Strip all other unreachable cases. */
3156 if (body->ext.case_list)
3158 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3160 if (cp->next->unreachable)
3162 gfc_case *n = cp->next;
3163 cp->next = cp->next->next;
3165 gfc_free_case_list (n);
3172 /* See if there were overlapping cases. If the check returns NULL,
3173 there was overlap. In that case we don't do anything. If head
3174 is non-NULL, we prepend the DEFAULT case. The sorted list can
3175 then used during code generation for SELECT CASE constructs with
3176 a case expression of a CHARACTER type. */
3179 head = check_case_overlap (head);
3181 /* Prepend the default_case if it is there. */
3182 if (head != NULL && default_case)
3184 default_case->left = NULL;
3185 default_case->right = head;
3186 head->left = default_case;
3190 /* Eliminate dead blocks that may be the result if we've seen
3191 unreachable case labels for a block. */
3192 for (body = code; body && body->block; body = body->block)
3194 if (body->block->ext.case_list == NULL)
3196 /* Cut the unreachable block from the code chain. */
3197 gfc_code *c = body->block;
3198 body->block = c->block;
3200 /* Kill the dead block, but not the blocks below it. */
3202 gfc_free_statements (c);
3206 /* More than two cases is legal but insane for logical selects.
3207 Issue a warning for it. */
3208 if (gfc_option.warn_surprising && type == BT_LOGICAL
3210 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3215 /* Resolve a transfer statement. This is making sure that:
3216 -- a derived type being transferred has only non-pointer components
3217 -- a derived type being transferred doesn't have private components, unless
3218 it's being transferred from the module where the type was defined
3219 -- we're not trying to transfer a whole assumed size array. */
3222 resolve_transfer (gfc_code * code)
3231 if (exp->expr_type != EXPR_VARIABLE)
3234 sym = exp->symtree->n.sym;
3237 /* Go to actual component transferred. */
3238 for (ref = code->expr->ref; ref; ref = ref->next)
3239 if (ref->type == REF_COMPONENT)
3240 ts = &ref->u.c.component->ts;
3242 if (ts->type == BT_DERIVED)
3244 /* Check that transferred derived type doesn't contain POINTER
3246 if (derived_pointer (ts->derived))
3248 gfc_error ("Data transfer element at %L cannot have "
3249 "POINTER components", &code->loc);
3253 if (derived_inaccessible (ts->derived))
3255 gfc_error ("Data transfer element at %L cannot have "
3256 "PRIVATE components",&code->loc);
3261 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3262 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3264 gfc_error ("Data transfer element at %L cannot be a full reference to "
3265 "an assumed-size array", &code->loc);
3271 /*********** Toplevel code resolution subroutines ***********/
3273 /* Given a branch to a label and a namespace, if the branch is conforming.
3274 The code node described where the branch is located. */
3277 resolve_branch (gfc_st_label * label, gfc_code * code)
3279 gfc_code *block, *found;
3287 /* Step one: is this a valid branching target? */
3289 if (lp->defined == ST_LABEL_UNKNOWN)
3291 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3296 if (lp->defined != ST_LABEL_TARGET)
3298 gfc_error ("Statement at %L is not a valid branch target statement "
3299 "for the branch statement at %L", &lp->where, &code->loc);
3303 /* Step two: make sure this branch is not a branch to itself ;-) */
3305 if (code->here == label)
3307 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3311 /* Step three: Try to find the label in the parse tree. To do this,
3312 we traverse the tree block-by-block: first the block that
3313 contains this GOTO, then the block that it is nested in, etc. We
3314 can ignore other blocks because branching into another block is
3319 for (stack = cs_base; stack; stack = stack->prev)
3321 for (block = stack->head; block; block = block->next)
3323 if (block->here == label)
3336 /* still nothing, so illegal. */
3337 gfc_error_now ("Label at %L is not in the same block as the "
3338 "GOTO statement at %L", &lp->where, &code->loc);
3342 /* Step four: Make sure that the branching target is legal if
3343 the statement is an END {SELECT,DO,IF}. */
3345 if (found->op == EXEC_NOP)
3347 for (stack = cs_base; stack; stack = stack->prev)
3348 if (stack->current->next == found)
3352 gfc_notify_std (GFC_STD_F95_DEL,
3353 "Obsolete: GOTO at %L jumps to END of construct at %L",
3354 &code->loc, &found->loc);
3359 /* Check whether EXPR1 has the same shape as EXPR2. */
3362 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3364 mpz_t shape[GFC_MAX_DIMENSIONS];
3365 mpz_t shape2[GFC_MAX_DIMENSIONS];
3366 try result = FAILURE;
3369 /* Compare the rank. */
3370 if (expr1->rank != expr2->rank)
3373 /* Compare the size of each dimension. */
3374 for (i=0; i<expr1->rank; i++)
3376 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3379 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3382 if (mpz_cmp (shape[i], shape2[i]))
3386 /* When either of the two expression is an assumed size array, we
3387 ignore the comparison of dimension sizes. */
3392 for (i--; i>=0; i--)
3394 mpz_clear (shape[i]);
3395 mpz_clear (shape2[i]);
3401 /* Check whether a WHERE assignment target or a WHERE mask expression
3402 has the same shape as the outmost WHERE mask expression. */
3405 resolve_where (gfc_code *code, gfc_expr *mask)
3411 cblock = code->block;
3413 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3414 In case of nested WHERE, only the outmost one is stored. */
3415 if (mask == NULL) /* outmost WHERE */
3417 else /* inner WHERE */
3424 /* Check if the mask-expr has a consistent shape with the
3425 outmost WHERE mask-expr. */
3426 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3427 gfc_error ("WHERE mask at %L has inconsistent shape",
3428 &cblock->expr->where);
3431 /* the assignment statement of a WHERE statement, or the first
3432 statement in where-body-construct of a WHERE construct */
3433 cnext = cblock->next;
3438 /* WHERE assignment statement */
3441 /* Check shape consistent for WHERE assignment target. */
3442 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3443 gfc_error ("WHERE assignment target at %L has "
3444 "inconsistent shape", &cnext->expr->where);
3447 /* WHERE or WHERE construct is part of a where-body-construct */
3449 resolve_where (cnext, e);
3453 gfc_error ("Unsupported statement inside WHERE at %L",
3456 /* the next statement within the same where-body-construct */
3457 cnext = cnext->next;
3459 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3460 cblock = cblock->block;
3465 /* Check whether the FORALL index appears in the expression or not. */
3468 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3472 gfc_actual_arglist *args;
3475 switch (expr->expr_type)
3478 gcc_assert (expr->symtree->n.sym);
3480 /* A scalar assignment */
3483 if (expr->symtree->n.sym == symbol)
3489 /* the expr is array ref, substring or struct component. */
3496 /* Check if the symbol appears in the array subscript. */
3498 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3501 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3505 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3509 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3515 if (expr->symtree->n.sym == symbol)
3518 /* Check if the symbol appears in the substring section. */
3519 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3521 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3529 gfc_error("expresion reference type error at %L", &expr->where);
3535 /* If the expression is a function call, then check if the symbol
3536 appears in the actual arglist of the function. */
3538 for (args = expr->value.function.actual; args; args = args->next)
3540 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3545 /* It seems not to happen. */
3546 case EXPR_SUBSTRING:
3550 gcc_assert (expr->ref->type == REF_SUBSTRING);
3551 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3553 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3558 /* It seems not to happen. */
3559 case EXPR_STRUCTURE:
3561 gfc_error ("Unsupported statement while finding forall index in "
3566 /* Find the FORALL index in the first operand. */
3567 if (expr->value.op.op1)
3569 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3573 /* Find the FORALL index in the second operand. */
3574 if (expr->value.op.op2)
3576 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3589 /* Resolve assignment in FORALL construct.
3590 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3591 FORALL index variables. */
3594 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3598 for (n = 0; n < nvar; n++)
3600 gfc_symbol *forall_index;
3602 forall_index = var_expr[n]->symtree->n.sym;
3604 /* Check whether the assignment target is one of the FORALL index
3606 if ((code->expr->expr_type == EXPR_VARIABLE)
3607 && (code->expr->symtree->n.sym == forall_index))
3608 gfc_error ("Assignment to a FORALL index variable at %L",
3609 &code->expr->where);
3612 /* If one of the FORALL index variables doesn't appear in the
3613 assignment target, then there will be a many-to-one
3615 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3616 gfc_error ("The FORALL with index '%s' cause more than one "
3617 "assignment to this object at %L",
3618 var_expr[n]->symtree->name, &code->expr->where);
3624 /* Resolve WHERE statement in FORALL construct. */
3627 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3631 cblock = code->block;
3634 /* the assignment statement of a WHERE statement, or the first
3635 statement in where-body-construct of a WHERE construct */
3636 cnext = cblock->next;
3641 /* WHERE assignment statement */
3643 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3646 /* WHERE or WHERE construct is part of a where-body-construct */
3648 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3652 gfc_error ("Unsupported statement inside WHERE at %L",
3655 /* the next statement within the same where-body-construct */
3656 cnext = cnext->next;
3658 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3659 cblock = cblock->block;
3664 /* Traverse the FORALL body to check whether the following errors exist:
3665 1. For assignment, check if a many-to-one assignment happens.
3666 2. For WHERE statement, check the WHERE body to see if there is any
3667 many-to-one assignment. */
3670 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3674 c = code->block->next;
3680 case EXEC_POINTER_ASSIGN:
3681 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3684 /* Because the resolve_blocks() will handle the nested FORALL,
3685 there is no need to handle it here. */
3689 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3694 /* The next statement in the FORALL body. */
3700 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3701 gfc_resolve_forall_body to resolve the FORALL body. */
3703 static void resolve_blocks (gfc_code *, gfc_namespace *);
3706 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3708 static gfc_expr **var_expr;
3709 static int total_var = 0;
3710 static int nvar = 0;
3711 gfc_forall_iterator *fa;
3712 gfc_symbol *forall_index;
3716 /* Start to resolve a FORALL construct */
3717 if (forall_save == 0)
3719 /* Count the total number of FORALL index in the nested FORALL
3720 construct in order to allocate the VAR_EXPR with proper size. */
3722 while ((next != NULL) && (next->op == EXEC_FORALL))
3724 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3726 next = next->block->next;
3729 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3730 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3733 /* The information about FORALL iterator, including FORALL index start, end
3734 and stride. The FORALL index can not appear in start, end or stride. */
3735 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3737 /* Check if any outer FORALL index name is the same as the current
3739 for (i = 0; i < nvar; i++)
3741 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3743 gfc_error ("An outer FORALL construct already has an index "
3744 "with this name %L", &fa->var->where);
3748 /* Record the current FORALL index. */
3749 var_expr[nvar] = gfc_copy_expr (fa->var);
3751 forall_index = fa->var->symtree->n.sym;
3753 /* Check if the FORALL index appears in start, end or stride. */
3754 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3755 gfc_error ("A FORALL index must not appear in a limit or stride "
3756 "expression in the same FORALL at %L", &fa->start->where);
3757 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3758 gfc_error ("A FORALL index must not appear in a limit or stride "
3759 "expression in the same FORALL at %L", &fa->end->where);
3760 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3761 gfc_error ("A FORALL index must not appear in a limit or stride "
3762 "expression in the same FORALL at %L", &fa->stride->where);
3766 /* Resolve the FORALL body. */
3767 gfc_resolve_forall_body (code, nvar, var_expr);
3769 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3770 resolve_blocks (code->block, ns);
3772 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3773 for (i = 0; i < total_var; i++)
3774 gfc_free_expr (var_expr[i]);
3776 /* Reset the counters. */
3782 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3785 static void resolve_code (gfc_code *, gfc_namespace *);
3788 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3792 for (; b; b = b->block)
3794 t = gfc_resolve_expr (b->expr);
3795 if (gfc_resolve_expr (b->expr2) == FAILURE)
3801 if (t == SUCCESS && b->expr != NULL
3802 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3804 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3811 && (b->expr->ts.type != BT_LOGICAL
3812 || b->expr->rank == 0))
3814 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3819 resolve_branch (b->label, b);
3829 gfc_internal_error ("resolve_block(): Bad block type");
3832 resolve_code (b->next, ns);
3837 /* Given a block of code, recursively resolve everything pointed to by this
3841 resolve_code (gfc_code * code, gfc_namespace * ns)
3843 int forall_save = 0;
3848 frame.prev = cs_base;
3852 for (; code; code = code->next)
3854 frame.current = code;
3856 if (code->op == EXEC_FORALL)
3858 forall_save = forall_flag;
3860 gfc_resolve_forall (code, ns, forall_save);
3863 resolve_blocks (code->block, ns);
3865 if (code->op == EXEC_FORALL)
3866 forall_flag = forall_save;
3868 t = gfc_resolve_expr (code->expr);
3869 if (gfc_resolve_expr (code->expr2) == FAILURE)
3885 resolve_where (code, NULL);
3889 if (code->expr != NULL)
3891 if (code->expr->ts.type != BT_INTEGER)
3892 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3893 "variable", &code->expr->where);
3894 else if (code->expr->symtree->n.sym->attr.assign != 1)
3895 gfc_error ("Variable '%s' has not been assigned a target label "
3896 "at %L", code->expr->symtree->n.sym->name,
3897 &code->expr->where);
3900 resolve_branch (code->label, code);
3904 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3905 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3906 "return specifier", &code->expr->where);
3913 if (gfc_extend_assign (code, ns) == SUCCESS)
3916 if (gfc_pure (NULL))
3918 if (gfc_impure_variable (code->expr->symtree->n.sym))
3921 ("Cannot assign to variable '%s' in PURE procedure at %L",
3922 code->expr->symtree->n.sym->name, &code->expr->where);
3926 if (code->expr2->ts.type == BT_DERIVED
3927 && derived_pointer (code->expr2->ts.derived))
3930 ("Right side of assignment at %L is a derived type "
3931 "containing a POINTER in a PURE procedure",
3932 &code->expr2->where);
3937 gfc_check_assign (code->expr, code->expr2, 1);
3940 case EXEC_LABEL_ASSIGN:
3941 if (code->label->defined == ST_LABEL_UNKNOWN)
3942 gfc_error ("Label %d referenced at %L is never defined",
3943 code->label->value, &code->label->where);
3945 && (code->expr->expr_type != EXPR_VARIABLE
3946 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
3947 || code->expr->symtree->n.sym->ts.kind
3948 != gfc_default_integer_kind
3949 || code->expr->symtree->n.sym->as != NULL))
3950 gfc_error ("ASSIGN statement at %L requires a scalar "
3951 "default INTEGER variable", &code->expr->where);
3954 case EXEC_POINTER_ASSIGN:
3958 gfc_check_pointer_assign (code->expr, code->expr2);
3961 case EXEC_ARITHMETIC_IF:
3963 && code->expr->ts.type != BT_INTEGER
3964 && code->expr->ts.type != BT_REAL)
3965 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3966 "expression", &code->expr->where);
3968 resolve_branch (code->label, code);
3969 resolve_branch (code->label2, code);
3970 resolve_branch (code->label3, code);
3974 if (t == SUCCESS && code->expr != NULL
3975 && (code->expr->ts.type != BT_LOGICAL
3976 || code->expr->rank != 0))
3977 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3978 &code->expr->where);
3983 resolve_call (code);
3987 /* Select is complicated. Also, a SELECT construct could be
3988 a transformed computed GOTO. */
3989 resolve_select (code);
3993 if (code->ext.iterator != NULL)
3994 gfc_resolve_iterator (code->ext.iterator, true);
3998 if (code->expr == NULL)
3999 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4001 && (code->expr->rank != 0
4002 || code->expr->ts.type != BT_LOGICAL))
4003 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4004 "a scalar LOGICAL expression", &code->expr->where);
4008 if (t == SUCCESS && code->expr != NULL
4009 && code->expr->ts.type != BT_INTEGER)
4010 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4011 "of type INTEGER", &code->expr->where);
4013 for (a = code->ext.alloc_list; a; a = a->next)
4014 resolve_allocate_expr (a->expr);
4018 case EXEC_DEALLOCATE:
4019 if (t == SUCCESS && code->expr != NULL
4020 && code->expr->ts.type != BT_INTEGER)
4022 ("STAT tag in DEALLOCATE statement at %L must be of type "
4023 "INTEGER", &code->expr->where);
4025 for (a = code->ext.alloc_list; a; a = a->next)
4026 resolve_deallocate_expr (a->expr);
4031 if (gfc_resolve_open (code->ext.open) == FAILURE)
4034 resolve_branch (code->ext.open->err, code);
4038 if (gfc_resolve_close (code->ext.close) == FAILURE)
4041 resolve_branch (code->ext.close->err, code);
4044 case EXEC_BACKSPACE:
4048 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4051 resolve_branch (code->ext.filepos->err, code);
4055 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4058 resolve_branch (code->ext.inquire->err, code);
4062 gcc_assert (code->ext.inquire != NULL);
4063 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4066 resolve_branch (code->ext.inquire->err, code);
4071 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4074 resolve_branch (code->ext.dt->err, code);
4075 resolve_branch (code->ext.dt->end, code);
4076 resolve_branch (code->ext.dt->eor, code);
4080 resolve_transfer (code);
4084 resolve_forall_iterators (code->ext.forall_iterator);
4086 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4088 ("FORALL mask clause at %L requires a LOGICAL expression",
4089 &code->expr->where);
4093 gfc_internal_error ("resolve_code(): Bad statement code");
4097 cs_base = frame.prev;
4101 /* Resolve initial values and make sure they are compatible with
4105 resolve_values (gfc_symbol * sym)
4108 if (sym->value == NULL)
4111 if (gfc_resolve_expr (sym->value) == FAILURE)
4114 gfc_check_assign_symbol (sym, sym->value);
4118 /* Do anything necessary to resolve a symbol. Right now, we just
4119 assume that an otherwise unknown symbol is a variable. This sort
4120 of thing commonly happens for symbols in module. */
4123 resolve_symbol (gfc_symbol * sym)
4125 /* Zero if we are checking a formal namespace. */
4126 static int formal_ns_flag = 1;
4127 int formal_ns_save, check_constant, mp_flag;
4131 gfc_symtree * symtree;
4132 gfc_symtree * this_symtree;
4135 gfc_formal_arglist * arg;
4137 if (sym->attr.flavor == FL_UNKNOWN)
4140 /* If we find that a flavorless symbol is an interface in one of the
4141 parent namespaces, find its symtree in this namespace, free the
4142 symbol and set the symtree to point to the interface symbol. */
4143 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4145 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4146 if (symtree && symtree->n.sym->generic)
4148 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4152 gfc_free_symbol (sym);
4153 symtree->n.sym->refs++;
4154 this_symtree->n.sym = symtree->n.sym;
4159 /* Otherwise give it a flavor according to such attributes as
4161 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4162 sym->attr.flavor = FL_VARIABLE;
4165 sym->attr.flavor = FL_PROCEDURE;
4166 if (sym->attr.dimension)
4167 sym->attr.function = 1;
4171 /* Symbols that are module procedures with results (functions) have
4172 the types and array specification copied for type checking in
4173 procedures that call them, as well as for saving to a module
4174 file. These symbols can't stand the scrutiny that their results
4176 mp_flag = (sym->result != NULL && sym->result != sym);
4178 /* Assign default type to symbols that need one and don't have one. */
4179 if (sym->ts.type == BT_UNKNOWN)
4181 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4182 gfc_set_default_type (sym, 1, NULL);
4184 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4187 gfc_set_default_type (sym, 0, NULL);
4190 /* Result may be in another namespace. */
4191 resolve_symbol (sym->result);
4193 sym->ts = sym->result->ts;
4194 sym->as = gfc_copy_array_spec (sym->result->as);
4195 sym->attr.dimension = sym->result->attr.dimension;
4196 sym->attr.pointer = sym->result->attr.pointer;
4201 /* Assumed size arrays and assumed shape arrays must be dummy
4205 && (sym->as->type == AS_ASSUMED_SIZE
4206 || sym->as->type == AS_ASSUMED_SHAPE)
4207 && sym->attr.dummy == 0)
4209 if (sym->as->type == AS_ASSUMED_SIZE)
4210 gfc_error ("Assumed size array at %L must be a dummy argument",
4213 gfc_error ("Assumed shape array at %L must be a dummy argument",
4218 /* A parameter array's shape needs to be constant. */
4220 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4221 && !gfc_is_compile_time_shape (sym->as))
4223 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4224 "or assumed shape", sym->name, &sym->declared_at);
4228 /* Make sure that character string variables with assumed length are
4231 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4232 && sym->ts.type == BT_CHARACTER
4233 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4235 gfc_error ("Entity with assumed character length at %L must be a "
4236 "dummy argument or a PARAMETER", &sym->declared_at);
4240 /* Make sure a parameter that has been implicitly typed still
4241 matches the implicit type, since PARAMETER statements can precede
4242 IMPLICIT statements. */
4244 if (sym->attr.flavor == FL_PARAMETER
4245 && sym->attr.implicit_type
4246 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4247 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4248 "later IMPLICIT type", sym->name, &sym->declared_at);
4250 /* Make sure the types of derived parameters are consistent. This
4251 type checking is deferred until resolution because the type may
4252 refer to a derived type from the host. */
4254 if (sym->attr.flavor == FL_PARAMETER
4255 && sym->ts.type == BT_DERIVED
4256 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4257 gfc_error ("Incompatible derived type in PARAMETER at %L",
4258 &sym->value->where);
4260 /* Make sure symbols with known intent or optional are really dummy
4261 variable. Because of ENTRY statement, this has to be deferred
4262 until resolution time. */
4264 if (! sym->attr.dummy
4265 && (sym->attr.optional
4266 || sym->attr.intent != INTENT_UNKNOWN))
4268 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4272 if (sym->attr.proc == PROC_ST_FUNCTION)
4274 if (sym->ts.type == BT_CHARACTER)
4276 gfc_charlen *cl = sym->ts.cl;
4277 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4279 gfc_error ("Character-valued statement function '%s' at %L must "
4280 "have constant length", sym->name, &sym->declared_at);
4286 /* Ensure that derived type components of a public derived type
4287 are not of a private type. */
4288 if (sym->attr.flavor == FL_DERIVED
4289 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4291 for (c = sym->components; c; c = c->next)
4293 if (c->ts.type == BT_DERIVED
4294 && !c->ts.derived->attr.use_assoc
4295 && !gfc_check_access(c->ts.derived->attr.access,
4296 c->ts.derived->ns->default_access))
4298 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4299 "a component of '%s', which is PUBLIC at %L",
4300 c->name, sym->name, &sym->declared_at);
4306 /* Ensure that derived type formal arguments of a public procedure
4307 are not of a private type. */
4308 if (sym->attr.flavor == FL_PROCEDURE
4309 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4311 for (arg = sym->formal; arg; arg = arg->next)
4314 && arg->sym->ts.type == BT_DERIVED
4315 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4316 arg->sym->ts.derived->ns->default_access))
4318 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4319 "a dummy argument of '%s', which is PUBLIC at %L",
4320 arg->sym->name, sym->name, &sym->declared_at);
4321 /* Stop this message from recurring. */
4322 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4328 /* Constraints on deferred shape variable. */
4329 if (sym->attr.flavor == FL_VARIABLE
4330 || (sym->attr.flavor == FL_PROCEDURE
4331 && sym->attr.function))
4333 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4335 if (sym->attr.allocatable)
4337 if (sym->attr.dimension)
4338 gfc_error ("Allocatable array at %L must have a deferred shape",
4341 gfc_error ("Object at %L may not be ALLOCATABLE",
4346 if (sym->attr.pointer && sym->attr.dimension)
4348 gfc_error ("Pointer to array at %L must have a deferred shape",
4356 if (!mp_flag && !sym->attr.allocatable
4357 && !sym->attr.pointer && !sym->attr.dummy)
4359 gfc_error ("Array at %L cannot have a deferred shape",
4366 switch (sym->attr.flavor)
4369 /* Can the sybol have an initializer? */
4371 if (sym->attr.allocatable)
4372 whynot = _("Allocatable");
4373 else if (sym->attr.external)
4374 whynot = _("External");
4375 else if (sym->attr.dummy)
4376 whynot = _("Dummy");
4377 else if (sym->attr.intrinsic)
4378 whynot = _("Intrinsic");
4379 else if (sym->attr.result)
4380 whynot = _("Function Result");
4381 else if (sym->attr.dimension && !sym->attr.pointer)
4383 /* Don't allow initialization of automatic arrays. */
4384 for (i = 0; i < sym->as->rank; i++)
4386 if (sym->as->lower[i] == NULL
4387 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4388 || sym->as->upper[i] == NULL
4389 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4391 whynot = _("Automatic array");
4397 /* Reject illegal initializers. */
4398 if (sym->value && whynot)
4400 gfc_error ("%s '%s' at %L cannot have an initializer",
4401 whynot, sym->name, &sym->declared_at);
4405 /* Assign default initializer. */
4406 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot)
4407 && !sym->attr.pointer)
4408 sym->value = gfc_default_initializer (&sym->ts);
4412 /* Reject PRIVATE objects in a PUBLIC namelist. */
4413 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4415 for (nl = sym->namelist; nl; nl = nl->next)
4417 if (!gfc_check_access(nl->sym->attr.access,
4418 nl->sym->ns->default_access))
4419 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4420 "PUBLIC namelist at %L", nl->sym->name,
4431 /* Make sure that intrinsic exist */
4432 if (sym->attr.intrinsic
4433 && ! gfc_intrinsic_name(sym->name, 0)
4434 && ! gfc_intrinsic_name(sym->name, 1))
4435 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4437 /* Resolve array specifier. Check as well some constraints
4438 on COMMON blocks. */
4440 check_constant = sym->attr.in_common && !sym->attr.pointer;
4441 gfc_resolve_array_spec (sym->as, check_constant);
4443 /* Resolve formal namespaces. */
4445 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4447 formal_ns_save = formal_ns_flag;
4449 gfc_resolve (sym->formal_ns);
4450 formal_ns_flag = formal_ns_save;
4456 /************* Resolve DATA statements *************/
4460 gfc_data_value *vnode;
4466 /* Advance the values structure to point to the next value in the data list. */
4469 next_data_value (void)
4471 while (values.left == 0)
4473 if (values.vnode->next == NULL)
4476 values.vnode = values.vnode->next;
4477 values.left = values.vnode->repeat;
4485 check_data_variable (gfc_data_variable * var, locus * where)
4491 ar_type mark = AR_UNKNOWN;
4493 mpz_t section_index[GFC_MAX_DIMENSIONS];
4497 if (gfc_resolve_expr (var->expr) == FAILURE)
4501 mpz_init_set_si (offset, 0);
4504 if (e->expr_type != EXPR_VARIABLE)
4505 gfc_internal_error ("check_data_variable(): Bad expression");
4509 mpz_init_set_ui (size, 1);
4516 /* Find the array section reference. */
4517 for (ref = e->ref; ref; ref = ref->next)
4519 if (ref->type != REF_ARRAY)
4521 if (ref->u.ar.type == AR_ELEMENT)
4527 /* Set marks according to the reference pattern. */
4528 switch (ref->u.ar.type)
4536 /* Get the start position of array section. */
4537 gfc_get_section_index (ar, section_index, &offset);
4545 if (gfc_array_size (e, &size) == FAILURE)
4547 gfc_error ("Nonconstant array section at %L in DATA statement",
4556 while (mpz_cmp_ui (size, 0) > 0)
4558 if (next_data_value () == FAILURE)
4560 gfc_error ("DATA statement at %L has more variables than values",
4566 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4570 /* If we have more than one element left in the repeat count,
4571 and we have more than one element left in the target variable,
4572 then create a range assignment. */
4573 /* ??? Only done for full arrays for now, since array sections
4575 if (mark == AR_FULL && ref && ref->next == NULL
4576 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4580 if (mpz_cmp_ui (size, values.left) >= 0)
4582 mpz_init_set_ui (range, values.left);
4583 mpz_sub_ui (size, size, values.left);
4588 mpz_init_set (range, size);
4589 values.left -= mpz_get_ui (size);
4590 mpz_set_ui (size, 0);
4593 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4596 mpz_add (offset, offset, range);
4600 /* Assign initial value to symbol. */
4604 mpz_sub_ui (size, size, 1);
4606 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4608 if (mark == AR_FULL)
4609 mpz_add_ui (offset, offset, 1);
4611 /* Modify the array section indexes and recalculate the offset
4612 for next element. */
4613 else if (mark == AR_SECTION)
4614 gfc_advance_section (section_index, ar, &offset);
4618 if (mark == AR_SECTION)
4620 for (i = 0; i < ar->dimen; i++)
4621 mpz_clear (section_index[i]);
4631 static try traverse_data_var (gfc_data_variable *, locus *);
4633 /* Iterate over a list of elements in a DATA statement. */
4636 traverse_data_list (gfc_data_variable * var, locus * where)
4639 iterator_stack frame;
4642 mpz_init (frame.value);
4644 mpz_init_set (trip, var->iter.end->value.integer);
4645 mpz_sub (trip, trip, var->iter.start->value.integer);
4646 mpz_add (trip, trip, var->iter.step->value.integer);
4648 mpz_div (trip, trip, var->iter.step->value.integer);
4650 mpz_set (frame.value, var->iter.start->value.integer);
4652 frame.prev = iter_stack;
4653 frame.variable = var->iter.var->symtree;
4654 iter_stack = &frame;
4656 while (mpz_cmp_ui (trip, 0) > 0)
4658 if (traverse_data_var (var->list, where) == FAILURE)
4664 e = gfc_copy_expr (var->expr);
4665 if (gfc_simplify_expr (e, 1) == FAILURE)
4671 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4673 mpz_sub_ui (trip, trip, 1);
4677 mpz_clear (frame.value);
4679 iter_stack = frame.prev;
4684 /* Type resolve variables in the variable list of a DATA statement. */
4687 traverse_data_var (gfc_data_variable * var, locus * where)
4691 for (; var; var = var->next)
4693 if (var->expr == NULL)
4694 t = traverse_data_list (var, where);
4696 t = check_data_variable (var, where);
4706 /* Resolve the expressions and iterators associated with a data statement.
4707 This is separate from the assignment checking because data lists should
4708 only be resolved once. */
4711 resolve_data_variables (gfc_data_variable * d)
4713 for (; d; d = d->next)
4715 if (d->list == NULL)
4717 if (gfc_resolve_expr (d->expr) == FAILURE)
4722 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
4725 if (d->iter.start->expr_type != EXPR_CONSTANT
4726 || d->iter.end->expr_type != EXPR_CONSTANT
4727 || d->iter.step->expr_type != EXPR_CONSTANT)
4728 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4730 if (resolve_data_variables (d->list) == FAILURE)
4739 /* Resolve a single DATA statement. We implement this by storing a pointer to
4740 the value list into static variables, and then recursively traversing the
4741 variables list, expanding iterators and such. */
4744 resolve_data (gfc_data * d)
4746 if (resolve_data_variables (d->var) == FAILURE)
4749 values.vnode = d->value;
4750 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4752 if (traverse_data_var (d->var, &d->where) == FAILURE)
4755 /* At this point, we better not have any values left. */
4757 if (next_data_value () == SUCCESS)
4758 gfc_error ("DATA statement at %L has more values than variables",
4763 /* Determines if a variable is not 'pure', ie not assignable within a pure
4764 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4768 gfc_impure_variable (gfc_symbol * sym)
4770 if (sym->attr.use_assoc || sym->attr.in_common)
4773 if (sym->ns != gfc_current_ns)
4774 return !sym->attr.function;
4776 /* TODO: Check storage association through EQUIVALENCE statements */
4782 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4783 symbol of the current procedure. */
4786 gfc_pure (gfc_symbol * sym)
4788 symbol_attribute attr;
4791 sym = gfc_current_ns->proc_name;
4797 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4801 /* Test whether the current procedure is elemental or not. */
4804 gfc_elemental (gfc_symbol * sym)
4806 symbol_attribute attr;
4809 sym = gfc_current_ns->proc_name;
4814 return attr.flavor == FL_PROCEDURE && attr.elemental;
4818 /* Warn about unused labels. */
4821 warn_unused_label (gfc_namespace * ns)
4832 for (; l; l = l->prev)
4834 if (l->defined == ST_LABEL_UNKNOWN)
4837 switch (l->referenced)
4839 case ST_LABEL_UNKNOWN:
4840 gfc_warning ("Label %d at %L defined but not used", l->value,
4844 case ST_LABEL_BAD_TARGET:
4845 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4856 /* Returns the sequence type of a symbol or sequence. */
4859 sequence_type (gfc_typespec ts)
4868 if (ts.derived->components == NULL)
4869 return SEQ_NONDEFAULT;
4871 result = sequence_type (ts.derived->components->ts);
4872 for (c = ts.derived->components->next; c; c = c->next)
4873 if (sequence_type (c->ts) != result)
4879 if (ts.kind != gfc_default_character_kind)
4880 return SEQ_NONDEFAULT;
4882 return SEQ_CHARACTER;
4885 if (ts.kind != gfc_default_integer_kind)
4886 return SEQ_NONDEFAULT;
4891 if (!(ts.kind == gfc_default_real_kind
4892 || ts.kind == gfc_default_double_kind))
4893 return SEQ_NONDEFAULT;
4898 if (ts.kind != gfc_default_complex_kind)
4899 return SEQ_NONDEFAULT;
4904 if (ts.kind != gfc_default_logical_kind)
4905 return SEQ_NONDEFAULT;
4910 return SEQ_NONDEFAULT;
4915 /* Resolve derived type EQUIVALENCE object. */
4918 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4921 gfc_component *c = derived->components;
4926 /* Shall not be an object of nonsequence derived type. */
4927 if (!derived->attr.sequence)
4929 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4930 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4934 for (; c ; c = c->next)
4937 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4940 /* Shall not be an object of sequence derived type containing a pointer
4941 in the structure. */
4944 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
4945 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4951 gfc_error ("Derived type variable '%s' at %L with default initializer "
4952 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4960 /* Resolve equivalence object.
4961 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
4962 an allocatable array, an object of nonsequence derived type, an object of
4963 sequence derived type containing a pointer at any level of component
4964 selection, an automatic object, a function name, an entry name, a result
4965 name, a named constant, a structure component, or a subobject of any of
4966 the preceding objects. A substring shall not have length zero. A
4967 derived type shall not have components with default initialization nor
4968 shall two objects of an equivalence group be initialized.
4969 The simple constraints are done in symbol.c(check_conflict) and the rest
4970 are implemented here. */
4973 resolve_equivalence (gfc_equiv *eq)
4976 gfc_symbol *derived;
4977 gfc_symbol *first_sym;
4980 locus *last_where = NULL;
4981 seq_type eq_type, last_eq_type;
4982 gfc_typespec *last_ts;
4984 const char *value_name;
4988 last_ts = &eq->expr->symtree->n.sym->ts;
4990 first_sym = eq->expr->symtree->n.sym;
4992 for (object = 1; eq; eq = eq->eq, object++)
4996 e->ts = e->symtree->n.sym->ts;
4997 /* match_varspec might not know yet if it is seeing
4998 array reference or substring reference, as it doesn't
5000 if (e->ref && e->ref->type == REF_ARRAY)
5002 gfc_ref *ref = e->ref;
5003 sym = e->symtree->n.sym;
5005 if (sym->attr.dimension)
5007 ref->u.ar.as = sym->as;
5011 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5012 if (e->ts.type == BT_CHARACTER
5014 && ref->type == REF_ARRAY
5015 && ref->u.ar.dimen == 1
5016 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5017 && ref->u.ar.stride[0] == NULL)
5019 gfc_expr *start = ref->u.ar.start[0];
5020 gfc_expr *end = ref->u.ar.end[0];
5023 /* Optimize away the (:) reference. */
5024 if (start == NULL && end == NULL)
5029 e->ref->next = ref->next;
5034 ref->type = REF_SUBSTRING;
5036 start = gfc_int_expr (1);
5037 ref->u.ss.start = start;
5038 if (end == NULL && e->ts.cl)
5039 end = gfc_copy_expr (e->ts.cl->length);
5040 ref->u.ss.end = end;
5041 ref->u.ss.length = e->ts.cl;
5048 /* Any further ref is an error. */
5051 gcc_assert (ref->type == REF_ARRAY);
5052 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5058 if (gfc_resolve_expr (e) == FAILURE)
5061 sym = e->symtree->n.sym;
5063 /* An equivalence statement cannot have more than one initialized
5067 if (value_name != NULL)
5069 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5070 "be in the EQUIVALENCE statement at %L",
5071 value_name, sym->name, &e->where);
5075 value_name = sym->name;
5078 /* Shall not equivalence common block variables in a PURE procedure. */
5079 if (sym->ns->proc_name
5080 && sym->ns->proc_name->attr.pure
5081 && sym->attr.in_common)
5083 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5084 "object in the pure procedure '%s'",
5085 sym->name, &e->where, sym->ns->proc_name->name);
5089 /* Shall not be a named constant. */
5090 if (e->expr_type == EXPR_CONSTANT)
5092 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5093 "object", sym->name, &e->where);
5097 derived = e->ts.derived;
5098 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5101 /* Check that the types correspond correctly:
5103 A numeric sequence structure may be equivalenced to another sequence
5104 structure, an object of default integer type, default real type, double
5105 precision real type, default logical type such that components of the
5106 structure ultimately only become associated to objects of the same
5107 kind. A character sequence structure may be equivalenced to an object
5108 of default character kind or another character sequence structure.
5109 Other objects may be equivalenced only to objects of the same type and
5112 /* Identical types are unconditionally OK. */
5113 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5114 goto identical_types;
5116 last_eq_type = sequence_type (*last_ts);
5117 eq_type = sequence_type (sym->ts);
5119 /* Since the pair of objects is not of the same type, mixed or
5120 non-default sequences can be rejected. */
5122 msg = "Sequence %s with mixed components in EQUIVALENCE "
5123 "statement at %L with different type objects";
5125 && last_eq_type == SEQ_MIXED
5126 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5127 last_where) == FAILURE)
5128 || (eq_type == SEQ_MIXED
5129 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5130 &e->where) == FAILURE))
5133 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5134 "statement at %L with objects of different type";
5136 && last_eq_type == SEQ_NONDEFAULT
5137 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5138 last_where) == FAILURE)
5139 || (eq_type == SEQ_NONDEFAULT
5140 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5141 &e->where) == FAILURE))
5144 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5145 "EQUIVALENCE statement at %L";
5146 if (last_eq_type == SEQ_CHARACTER
5147 && eq_type != SEQ_CHARACTER
5148 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5149 &e->where) == FAILURE)
5152 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5153 "EQUIVALENCE statement at %L";
5154 if (last_eq_type == SEQ_NUMERIC
5155 && eq_type != SEQ_NUMERIC
5156 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5157 &e->where) == FAILURE)
5162 last_where = &e->where;
5167 /* Shall not be an automatic array. */
5168 if (e->ref->type == REF_ARRAY
5169 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5171 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5172 "an EQUIVALENCE object", sym->name, &e->where);
5179 /* Shall not be a structure component. */
5180 if (r->type == REF_COMPONENT)
5182 gfc_error ("Structure component '%s' at %L cannot be an "
5183 "EQUIVALENCE object",
5184 r->u.c.component->name, &e->where);
5188 /* A substring shall not have length zero. */
5189 if (r->type == REF_SUBSTRING)
5191 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5193 gfc_error ("Substring at %L has length zero",
5194 &r->u.ss.start->where);
5204 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5207 resolve_fntype (gfc_namespace * ns)
5212 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5215 /* If there are any entries, ns->proc_name is the entry master
5216 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5218 sym = ns->entries->sym;
5220 sym = ns->proc_name;
5221 if (sym->result == sym
5222 && sym->ts.type == BT_UNKNOWN
5223 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5224 && !sym->attr.untyped)
5226 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5227 sym->name, &sym->declared_at);
5228 sym->attr.untyped = 1;
5232 for (el = ns->entries->next; el; el = el->next)
5234 if (el->sym->result == el->sym
5235 && el->sym->ts.type == BT_UNKNOWN
5236 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5237 && !el->sym->attr.untyped)
5239 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5240 el->sym->name, &el->sym->declared_at);
5241 el->sym->attr.untyped = 1;
5247 /* This function is called after a complete program unit has been compiled.
5248 Its purpose is to examine all of the expressions associated with a program
5249 unit, assign types to all intermediate expressions, make sure that all
5250 assignments are to compatible types and figure out which names refer to
5251 which functions or subroutines. */
5254 gfc_resolve (gfc_namespace * ns)
5256 gfc_namespace *old_ns, *n;
5261 old_ns = gfc_current_ns;
5262 gfc_current_ns = ns;
5264 resolve_entries (ns);
5266 resolve_contained_functions (ns);
5268 gfc_traverse_ns (ns, resolve_symbol);
5270 resolve_fntype (ns);
5272 for (n = ns->contained; n; n = n->sibling)
5274 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5275 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5276 "also be PURE", n->proc_name->name,
5277 &n->proc_name->declared_at);
5283 gfc_check_interfaces (ns);
5285 for (cl = ns->cl_list; cl; cl = cl->next)
5287 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
5290 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
5293 if (gfc_specification_expr (cl->length) == FAILURE)
5297 gfc_traverse_ns (ns, resolve_values);
5303 for (d = ns->data; d; d = d->next)
5307 gfc_traverse_ns (ns, gfc_formalize_init_value);
5309 for (eq = ns->equiv; eq; eq = eq->next)
5310 resolve_equivalence (eq);
5313 resolve_code (ns->code, ns);
5315 /* Warn about unused labels. */
5316 if (gfc_option.warn_unused_labels)
5317 warn_unused_label (ns);
5319 gfc_current_ns = old_ns;