1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code *head, *current;
44 struct code_stack *prev;
48 static code_stack *cs_base = NULL;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag = 0;
64 gfc_is_formal_arg (void)
66 return formal_arg_flag;
69 /* Resolve types of formal argument lists. These have to be done early so that
70 the formal argument lists of module procedures can be copied to the
71 containing module before the individual procedures are resolved
72 individually. We also resolve argument lists of procedures in interface
73 blocks because they are self-contained scoping units.
75 Since a dummy argument cannot be a non-dummy procedure, the only
76 resort left for untyped names are the IMPLICIT types. */
79 resolve_formal_arglist (gfc_symbol * proc)
81 gfc_formal_arglist *f;
85 /* TODO: Procedures whose return character length parameter is not constant
86 or assumed must also have explicit interfaces. */
87 if (proc->result != NULL)
92 if (gfc_elemental (proc)
93 || sym->attr.pointer || sym->attr.allocatable
94 || (sym->as && sym->as->rank > 0))
95 proc->attr.always_explicit = 1;
99 for (f = proc->formal; f; f = f->next)
105 /* Alternate return placeholder. */
106 if (gfc_elemental (proc))
107 gfc_error ("Alternate return specifier in elemental subroutine "
108 "'%s' at %L is not allowed", proc->name,
110 if (proc->attr.function)
111 gfc_error ("Alternate return specifier in function "
112 "'%s' at %L is not allowed", proc->name,
117 if (sym->attr.if_source != IFSRC_UNKNOWN)
118 resolve_formal_arglist (sym);
120 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
122 if (gfc_pure (proc) && !gfc_pure (sym))
125 ("Dummy procedure '%s' of PURE procedure at %L must also "
126 "be PURE", sym->name, &sym->declared_at);
130 if (gfc_elemental (proc))
133 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
141 if (sym->ts.type == BT_UNKNOWN)
143 if (!sym->attr.function || sym->result == sym)
144 gfc_set_default_type (sym, 1, sym->ns);
147 gfc_resolve_array_spec (sym->as, 0);
149 /* We can't tell if an array with dimension (:) is assumed or deferred
150 shape until we know if it has the pointer or allocatable attributes.
152 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
153 && !(sym->attr.pointer || sym->attr.allocatable))
155 sym->as->type = AS_ASSUMED_SHAPE;
156 for (i = 0; i < sym->as->rank; i++)
157 sym->as->lower[i] = gfc_int_expr (1);
160 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
161 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
162 || sym->attr.optional)
163 proc->attr.always_explicit = 1;
165 /* If the flavor is unknown at this point, it has to be a variable.
166 A procedure specification would have already set the type. */
168 if (sym->attr.flavor == FL_UNKNOWN)
169 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
173 if (proc->attr.function && !sym->attr.pointer
174 && sym->attr.flavor != FL_PROCEDURE
175 && sym->attr.intent != INTENT_IN)
177 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
178 "INTENT(IN)", sym->name, proc->name,
181 if (proc->attr.subroutine && !sym->attr.pointer
182 && sym->attr.intent == INTENT_UNKNOWN)
185 ("Argument '%s' of pure subroutine '%s' at %L must have "
186 "its INTENT specified", sym->name, proc->name,
191 if (gfc_elemental (proc))
196 ("Argument '%s' of elemental procedure at %L must be scalar",
197 sym->name, &sym->declared_at);
201 if (sym->attr.pointer)
204 ("Argument '%s' of elemental procedure at %L cannot have "
205 "the POINTER attribute", sym->name, &sym->declared_at);
210 /* Each dummy shall be specified to be scalar. */
211 if (proc->attr.proc == PROC_ST_FUNCTION)
216 ("Argument '%s' of statement function at %L must be scalar",
217 sym->name, &sym->declared_at);
221 if (sym->ts.type == BT_CHARACTER)
223 gfc_charlen *cl = sym->ts.cl;
224 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
227 ("Character-valued argument '%s' of statement function at "
228 "%L must has constant length",
229 sym->name, &sym->declared_at);
239 /* Work function called when searching for symbols that have argument lists
240 associated with them. */
243 find_arglists (gfc_symbol * sym)
246 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
249 resolve_formal_arglist (sym);
253 /* Given a namespace, resolve all formal argument lists within the namespace.
257 resolve_formal_arglists (gfc_namespace * ns)
263 gfc_traverse_ns (ns, find_arglists);
268 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
272 /* If this namespace is not a function, ignore it. */
274 || !(sym->attr.function
275 || sym->attr.flavor == FL_VARIABLE))
278 /* Try to find out of what the return type is. */
279 if (sym->result != NULL)
282 if (sym->ts.type == BT_UNKNOWN)
284 t = gfc_set_default_type (sym, 0, ns);
286 if (t == FAILURE && !sym->attr.untyped)
288 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
289 sym->name, &sym->declared_at); /* FIXME */
290 sym->attr.untyped = 1;
294 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
295 lists the only ways a character length value of * can be used: dummy arguments
296 of procedures, named constants, and function results in external functions.
297 Internal function results are not on that list; ergo, not permitted. */
299 if (sym->ts.type == BT_CHARACTER)
301 gfc_charlen *cl = sym->ts.cl;
302 if (!cl || !cl->length)
303 gfc_error ("Character-valued internal function '%s' at %L must "
304 "not be assumed length", sym->name, &sym->declared_at);
309 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
310 introduce duplicates. */
313 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
315 gfc_formal_arglist *f, *new_arglist;
318 for (; new_args != NULL; new_args = new_args->next)
320 new_sym = new_args->sym;
321 /* See if ths arg is already in the formal argument list. */
322 for (f = proc->formal; f; f = f->next)
324 if (new_sym == f->sym)
331 /* Add a new argument. Argument order is not important. */
332 new_arglist = gfc_get_formal_arglist ();
333 new_arglist->sym = new_sym;
334 new_arglist->next = proc->formal;
335 proc->formal = new_arglist;
340 /* Resolve alternate entry points. If a symbol has multiple entry points we
341 create a new master symbol for the main routine, and turn the existing
342 symbol into an entry point. */
345 resolve_entries (gfc_namespace * ns)
347 gfc_namespace *old_ns;
351 char name[GFC_MAX_SYMBOL_LEN + 1];
352 static int master_count = 0;
354 if (ns->proc_name == NULL)
357 /* No need to do anything if this procedure doesn't have alternate entry
362 /* We may already have resolved alternate entry points. */
363 if (ns->proc_name->attr.entry_master)
366 /* If this isn't a procedure something has gone horribly wrong. */
367 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
369 /* Remember the current namespace. */
370 old_ns = gfc_current_ns;
374 /* Add the main entry point to the list of entry points. */
375 el = gfc_get_entry_list ();
376 el->sym = ns->proc_name;
378 el->next = ns->entries;
380 ns->proc_name->attr.entry = 1;
382 /* Add an entry statement for it. */
389 /* Create a new symbol for the master function. */
390 /* Give the internal function a unique name (within this file).
391 Also include the function name so the user has some hope of figuring
392 out what is going on. */
393 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
394 master_count++, ns->proc_name->name);
395 gfc_get_ha_symbol (name, &proc);
396 gcc_assert (proc != NULL);
398 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
399 if (ns->proc_name->attr.subroutine)
400 gfc_add_subroutine (&proc->attr, proc->name, NULL);
404 gfc_typespec *ts, *fts;
406 gfc_add_function (&proc->attr, proc->name, NULL);
408 fts = &ns->entries->sym->result->ts;
409 if (fts->type == BT_UNKNOWN)
410 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
411 for (el = ns->entries->next; el; el = el->next)
413 ts = &el->sym->result->ts;
414 if (ts->type == BT_UNKNOWN)
415 ts = gfc_get_default_type (el->sym->result, NULL);
416 if (! gfc_compare_types (ts, fts)
417 || (el->sym->result->attr.dimension
418 != ns->entries->sym->result->attr.dimension)
419 || (el->sym->result->attr.pointer
420 != ns->entries->sym->result->attr.pointer))
426 sym = ns->entries->sym->result;
427 /* All result types the same. */
429 if (sym->attr.dimension)
430 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
431 if (sym->attr.pointer)
432 gfc_add_pointer (&proc->attr, NULL);
436 /* Otherwise the result will be passed through a union by
438 proc->attr.mixed_entry_master = 1;
439 for (el = ns->entries; el; el = el->next)
441 sym = el->sym->result;
442 if (sym->attr.dimension)
444 if (el == ns->entries)
446 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
447 sym->name, ns->entries->sym->name, &sym->declared_at);
450 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
451 sym->name, ns->entries->sym->name, &sym->declared_at);
453 else if (sym->attr.pointer)
455 if (el == ns->entries)
457 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
458 sym->name, ns->entries->sym->name, &sym->declared_at);
461 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
462 sym->name, ns->entries->sym->name, &sym->declared_at);
467 if (ts->type == BT_UNKNOWN)
468 ts = gfc_get_default_type (sym, NULL);
472 if (ts->kind == gfc_default_integer_kind)
476 if (ts->kind == gfc_default_real_kind
477 || ts->kind == gfc_default_double_kind)
481 if (ts->kind == gfc_default_complex_kind)
485 if (ts->kind == gfc_default_logical_kind)
489 /* We will issue error elsewhere. */
497 if (el == ns->entries)
499 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
500 sym->name, gfc_typename (ts), ns->entries->sym->name,
504 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
505 sym->name, gfc_typename (ts), ns->entries->sym->name,
512 proc->attr.access = ACCESS_PRIVATE;
513 proc->attr.entry_master = 1;
515 /* Merge all the entry point arguments. */
516 for (el = ns->entries; el; el = el->next)
517 merge_argument_lists (proc, el->sym->formal);
519 /* Use the master function for the function body. */
520 ns->proc_name = proc;
522 /* Finalize the new symbols. */
523 gfc_commit_symbols ();
525 /* Restore the original namespace. */
526 gfc_current_ns = old_ns;
530 /* Resolve contained function types. Because contained functions can call one
531 another, they have to be worked out before any of the contained procedures
534 The good news is that if a function doesn't already have a type, the only
535 way it can get one is through an IMPLICIT type or a RESULT variable, because
536 by definition contained functions are contained namespace they're contained
537 in, not in a sibling or parent namespace. */
540 resolve_contained_functions (gfc_namespace * ns)
542 gfc_namespace *child;
545 resolve_formal_arglists (ns);
547 for (child = ns->contained; child; child = child->sibling)
549 /* Resolve alternate entry points first. */
550 resolve_entries (child);
552 /* Then check function return types. */
553 resolve_contained_fntype (child->proc_name, child);
554 for (el = child->entries; el; el = el->next)
555 resolve_contained_fntype (el->sym, child);
560 /* Resolve all of the elements of a structure constructor and make sure that
561 the types are correct. */
564 resolve_structure_cons (gfc_expr * expr)
566 gfc_constructor *cons;
571 cons = expr->value.constructor;
572 /* A constructor may have references if it is the result of substituting a
573 parameter variable. In this case we just pull out the component we
576 comp = expr->ref->u.c.sym->components;
578 comp = expr->ts.derived->components;
580 for (; comp; comp = comp->next, cons = cons->next)
588 if (gfc_resolve_expr (cons->expr) == FAILURE)
594 /* If we don't have the right type, try to convert it. */
596 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
599 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
600 gfc_error ("The element in the derived type constructor at %L, "
601 "for pointer component '%s', is %s but should be %s",
602 &cons->expr->where, comp->name,
603 gfc_basic_typename (cons->expr->ts.type),
604 gfc_basic_typename (comp->ts.type));
606 t = gfc_convert_type (cons->expr, &comp->ts, 1);
615 /****************** Expression name resolution ******************/
617 /* Returns 0 if a symbol was not declared with a type or
618 attribute declaration statement, nonzero otherwise. */
621 was_declared (gfc_symbol * sym)
627 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
630 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
631 || a.optional || a.pointer || a.save || a.target
632 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
639 /* Determine if a symbol is generic or not. */
642 generic_sym (gfc_symbol * sym)
646 if (sym->attr.generic ||
647 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
650 if (was_declared (sym) || sym->ns->parent == NULL)
653 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
655 return (s == NULL) ? 0 : generic_sym (s);
659 /* Determine if a symbol is specific or not. */
662 specific_sym (gfc_symbol * sym)
666 if (sym->attr.if_source == IFSRC_IFBODY
667 || sym->attr.proc == PROC_MODULE
668 || sym->attr.proc == PROC_INTERNAL
669 || sym->attr.proc == PROC_ST_FUNCTION
670 || (sym->attr.intrinsic &&
671 gfc_specific_intrinsic (sym->name))
672 || sym->attr.external)
675 if (was_declared (sym) || sym->ns->parent == NULL)
678 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
680 return (s == NULL) ? 0 : specific_sym (s);
684 /* Figure out if the procedure is specific, generic or unknown. */
687 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
691 procedure_kind (gfc_symbol * sym)
694 if (generic_sym (sym))
695 return PTYPE_GENERIC;
697 if (specific_sym (sym))
698 return PTYPE_SPECIFIC;
700 return PTYPE_UNKNOWN;
703 /* Check references to assumed size arrays. The flag need_full_assumed_size
704 is nonzero when matching actual arguments. */
706 static int need_full_assumed_size = 0;
709 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
715 if (need_full_assumed_size
716 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
719 for (ref = e->ref; ref; ref = ref->next)
720 if (ref->type == REF_ARRAY)
721 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
722 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
726 gfc_error ("The upper bound in the last dimension must "
727 "appear in the reference to the assumed size "
728 "array '%s' at %L.", sym->name, &e->where);
735 /* Look for bad assumed size array references in argument expressions
736 of elemental and array valued intrinsic procedures. Since this is
737 called from procedure resolution functions, it only recurses at
741 resolve_assumed_size_actual (gfc_expr *e)
746 switch (e->expr_type)
750 && check_assumed_size_reference (e->symtree->n.sym, e))
755 if (resolve_assumed_size_actual (e->value.op.op1)
756 || resolve_assumed_size_actual (e->value.op.op2))
767 /* Resolve an actual argument list. Most of the time, this is just
768 resolving the expressions in the list.
769 The exception is that we sometimes have to decide whether arguments
770 that look like procedure arguments are really simple variable
774 resolve_actual_arglist (gfc_actual_arglist * arg)
777 gfc_symtree *parent_st;
780 for (; arg; arg = arg->next)
786 /* Check the label is a valid branching target. */
789 if (arg->label->defined == ST_LABEL_UNKNOWN)
791 gfc_error ("Label %d referenced at %L is never defined",
792 arg->label->value, &arg->label->where);
799 if (e->ts.type != BT_PROCEDURE)
801 if (gfc_resolve_expr (e) != SUCCESS)
806 /* See if the expression node should really be a variable
809 sym = e->symtree->n.sym;
811 if (sym->attr.flavor == FL_PROCEDURE
812 || sym->attr.intrinsic
813 || sym->attr.external)
816 if (sym->attr.proc == PROC_ST_FUNCTION)
818 gfc_error ("Statement function '%s' at %L is not allowed as an "
819 "actual argument", sym->name, &e->where);
822 if (sym->attr.contained && !sym->attr.use_assoc
823 && sym->ns->proc_name->attr.flavor != FL_MODULE)
825 gfc_error ("Internal procedure '%s' is not allowed as an "
826 "actual argument at %L", sym->name, &e->where);
829 if (sym->attr.elemental && !sym->attr.intrinsic)
831 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
832 "allowed as an actual argument at %L", sym->name,
836 /* If the symbol is the function that names the current (or
837 parent) scope, then we really have a variable reference. */
839 if (sym->attr.function && sym->result == sym
840 && (sym->ns->proc_name == sym
841 || (sym->ns->parent != NULL
842 && sym->ns->parent->proc_name == sym)))
848 /* See if the name is a module procedure in a parent unit. */
850 if (was_declared (sym) || sym->ns->parent == NULL)
853 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
855 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
859 if (parent_st == NULL)
862 sym = parent_st->n.sym;
863 e->symtree = parent_st; /* Point to the right thing. */
865 if (sym->attr.flavor == FL_PROCEDURE
866 || sym->attr.intrinsic
867 || sym->attr.external)
873 e->expr_type = EXPR_VARIABLE;
877 e->rank = sym->as->rank;
878 e->ref = gfc_get_ref ();
879 e->ref->type = REF_ARRAY;
880 e->ref->u.ar.type = AR_FULL;
881 e->ref->u.ar.as = sym->as;
889 /* Go through each actual argument in ACTUAL and see if it can be
890 implemented as an inlined, non-copying intrinsic. FNSYM is the
891 function being called, or NULL if not known. */
894 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
896 gfc_actual_arglist *ap;
899 for (ap = actual; ap; ap = ap->next)
901 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
902 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
903 ap->expr->inline_noncopying_intrinsic = 1;
906 /* This function does the checking of references to global procedures
907 as defined in sections 18.1 and 14.1, respectively, of the Fortran
908 77 and 95 standards. It checks for a gsymbol for the name, making
909 one if it does not already exist. If it already exists, then the
910 reference being resolved must correspond to the type of gsymbol.
911 Otherwise, the new symbol is equipped with the attributes of the
912 reference. The corresponding code that is called in creating
913 global entities is parse.c. */
916 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
921 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
923 gsym = gfc_get_gsymbol (sym->name);
925 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
926 global_used (gsym, where);
928 if (gsym->type == GSYM_UNKNOWN)
931 gsym->where = *where;
937 /************* Function resolution *************/
939 /* Resolve a function call known to be generic.
940 Section 14.1.2.4.1. */
943 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
947 if (sym->attr.generic)
950 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
953 expr->value.function.name = s->name;
954 expr->value.function.esym = s;
956 if (s->ts.type != BT_UNKNOWN)
958 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
959 expr->ts = s->result->ts;
962 expr->rank = s->as->rank;
963 else if (s->result != NULL && s->result->as != NULL)
964 expr->rank = s->result->as->rank;
969 /* TODO: Need to search for elemental references in generic interface */
972 if (sym->attr.intrinsic)
973 return gfc_intrinsic_func_interface (expr, 0);
980 resolve_generic_f (gfc_expr * expr)
985 sym = expr->symtree->n.sym;
989 m = resolve_generic_f0 (expr, sym);
992 else if (m == MATCH_ERROR)
996 if (sym->ns->parent == NULL)
998 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1002 if (!generic_sym (sym))
1006 /* Last ditch attempt. */
1008 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1010 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1011 expr->symtree->n.sym->name, &expr->where);
1015 m = gfc_intrinsic_func_interface (expr, 0);
1020 ("Generic function '%s' at %L is not consistent with a specific "
1021 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1027 /* Resolve a function call known to be specific. */
1030 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1034 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1036 if (sym->attr.dummy)
1038 sym->attr.proc = PROC_DUMMY;
1042 sym->attr.proc = PROC_EXTERNAL;
1046 if (sym->attr.proc == PROC_MODULE
1047 || sym->attr.proc == PROC_ST_FUNCTION
1048 || sym->attr.proc == PROC_INTERNAL)
1051 if (sym->attr.intrinsic)
1053 m = gfc_intrinsic_func_interface (expr, 1);
1058 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1059 "an intrinsic", sym->name, &expr->where);
1067 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1070 expr->value.function.name = sym->name;
1071 expr->value.function.esym = sym;
1072 if (sym->as != NULL)
1073 expr->rank = sym->as->rank;
1080 resolve_specific_f (gfc_expr * expr)
1085 sym = expr->symtree->n.sym;
1089 m = resolve_specific_f0 (sym, expr);
1092 if (m == MATCH_ERROR)
1095 if (sym->ns->parent == NULL)
1098 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1104 gfc_error ("Unable to resolve the specific function '%s' at %L",
1105 expr->symtree->n.sym->name, &expr->where);
1111 /* Resolve a procedure call not known to be generic nor specific. */
1114 resolve_unknown_f (gfc_expr * expr)
1119 sym = expr->symtree->n.sym;
1121 if (sym->attr.dummy)
1123 sym->attr.proc = PROC_DUMMY;
1124 expr->value.function.name = sym->name;
1128 /* See if we have an intrinsic function reference. */
1130 if (gfc_intrinsic_name (sym->name, 0))
1132 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1137 /* The reference is to an external name. */
1139 sym->attr.proc = PROC_EXTERNAL;
1140 expr->value.function.name = sym->name;
1141 expr->value.function.esym = expr->symtree->n.sym;
1143 if (sym->as != NULL)
1144 expr->rank = sym->as->rank;
1146 /* Type of the expression is either the type of the symbol or the
1147 default type of the symbol. */
1150 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1152 if (sym->ts.type != BT_UNKNOWN)
1156 ts = gfc_get_default_type (sym, sym->ns);
1158 if (ts->type == BT_UNKNOWN)
1160 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1161 sym->name, &expr->where);
1172 /* Figure out if a function reference is pure or not. Also set the name
1173 of the function for a potential error message. Return nonzero if the
1174 function is PURE, zero if not. */
1177 pure_function (gfc_expr * e, const char **name)
1181 if (e->value.function.esym)
1183 pure = gfc_pure (e->value.function.esym);
1184 *name = e->value.function.esym->name;
1186 else if (e->value.function.isym)
1188 pure = e->value.function.isym->pure
1189 || e->value.function.isym->elemental;
1190 *name = e->value.function.isym->name;
1194 /* Implicit functions are not pure. */
1196 *name = e->value.function.name;
1203 /* Resolve a function call, which means resolving the arguments, then figuring
1204 out which entity the name refers to. */
1205 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1206 to INTENT(OUT) or INTENT(INOUT). */
1209 resolve_function (gfc_expr * expr)
1211 gfc_actual_arglist *arg;
1220 sym = expr->symtree->n.sym;
1222 /* If the procedure is not internal, a statement function or a module
1223 procedure,it must be external and should be checked for usage. */
1224 if (sym && !sym->attr.dummy && !sym->attr.contained
1225 && sym->attr.proc != PROC_ST_FUNCTION
1226 && !sym->attr.use_assoc)
1227 resolve_global_procedure (sym, &expr->where, 0);
1229 /* Switch off assumed size checking and do this again for certain kinds
1230 of procedure, once the procedure itself is resolved. */
1231 need_full_assumed_size++;
1233 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1236 /* Resume assumed_size checking. */
1237 need_full_assumed_size--;
1239 if (sym && sym->ts.type == BT_CHARACTER
1241 && sym->ts.cl->length == NULL
1243 && !sym->attr.contained)
1245 /* Internal procedures are taken care of in resolve_contained_fntype. */
1246 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1247 "be used at %L since it is not a dummy argument",
1248 sym->name, &expr->where);
1252 /* See if function is already resolved. */
1254 if (expr->value.function.name != NULL)
1256 if (expr->ts.type == BT_UNKNOWN)
1262 /* Apply the rules of section 14.1.2. */
1264 switch (procedure_kind (sym))
1267 t = resolve_generic_f (expr);
1270 case PTYPE_SPECIFIC:
1271 t = resolve_specific_f (expr);
1275 t = resolve_unknown_f (expr);
1279 gfc_internal_error ("resolve_function(): bad function type");
1283 /* If the expression is still a function (it might have simplified),
1284 then we check to see if we are calling an elemental function. */
1286 if (expr->expr_type != EXPR_FUNCTION)
1289 temp = need_full_assumed_size;
1290 need_full_assumed_size = 0;
1292 if (expr->value.function.actual != NULL
1293 && ((expr->value.function.esym != NULL
1294 && expr->value.function.esym->attr.elemental)
1295 || (expr->value.function.isym != NULL
1296 && expr->value.function.isym->elemental)))
1298 /* The rank of an elemental is the rank of its array argument(s). */
1299 for (arg = expr->value.function.actual; arg; arg = arg->next)
1301 if (arg->expr != NULL && arg->expr->rank > 0)
1303 expr->rank = arg->expr->rank;
1304 if (!expr->shape && arg->expr->shape)
1306 expr->shape = gfc_get_shape (expr->rank);
1307 for (i = 0; i < expr->rank; i++)
1308 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1314 /* Being elemental, the last upper bound of an assumed size array
1315 argument must be present. */
1316 for (arg = expr->value.function.actual; arg; arg = arg->next)
1318 if (arg->expr != NULL
1319 && arg->expr->rank > 0
1320 && resolve_assumed_size_actual (arg->expr))
1324 if (omp_workshare_flag
1325 && expr->value.function.esym
1326 && ! gfc_elemental (expr->value.function.esym))
1328 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1329 " in WORKSHARE construct", expr->value.function.esym->name,
1334 else if (expr->value.function.actual != NULL
1335 && expr->value.function.isym != NULL
1336 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1337 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1338 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1340 /* Array instrinsics must also have the last upper bound of an
1341 assumed size array argument. UBOUND and SIZE have to be
1342 excluded from the check if the second argument is anything
1345 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1346 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1348 for (arg = expr->value.function.actual; arg; arg = arg->next)
1350 if (inquiry && arg->next != NULL && arg->next->expr
1351 && arg->next->expr->expr_type != EXPR_CONSTANT)
1354 if (arg->expr != NULL
1355 && arg->expr->rank > 0
1356 && resolve_assumed_size_actual (arg->expr))
1361 need_full_assumed_size = temp;
1363 if (!pure_function (expr, &name) && name)
1368 ("Function reference to '%s' at %L is inside a FORALL block",
1369 name, &expr->where);
1372 else if (gfc_pure (NULL))
1374 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1375 "procedure within a PURE procedure", name, &expr->where);
1380 /* Character lengths of use associated functions may contains references to
1381 symbols not referenced from the current program unit otherwise. Make sure
1382 those symbols are marked as referenced. */
1384 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1385 && expr->value.function.esym->attr.use_assoc)
1387 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1391 find_noncopying_intrinsics (expr->value.function.esym,
1392 expr->value.function.actual);
1397 /************* Subroutine resolution *************/
1400 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1407 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1408 sym->name, &c->loc);
1409 else if (gfc_pure (NULL))
1410 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1416 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1420 if (sym->attr.generic)
1422 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1425 c->resolved_sym = s;
1426 pure_subroutine (c, s);
1430 /* TODO: Need to search for elemental references in generic interface. */
1433 if (sym->attr.intrinsic)
1434 return gfc_intrinsic_sub_interface (c, 0);
1441 resolve_generic_s (gfc_code * c)
1446 sym = c->symtree->n.sym;
1448 m = resolve_generic_s0 (c, sym);
1451 if (m == MATCH_ERROR)
1454 if (sym->ns->parent != NULL)
1456 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1459 m = resolve_generic_s0 (c, sym);
1462 if (m == MATCH_ERROR)
1467 /* Last ditch attempt. */
1469 if (!gfc_generic_intrinsic (sym->name))
1472 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1473 sym->name, &c->loc);
1477 m = gfc_intrinsic_sub_interface (c, 0);
1481 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1482 "intrinsic subroutine interface", sym->name, &c->loc);
1488 /* Resolve a subroutine call known to be specific. */
1491 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1495 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1497 if (sym->attr.dummy)
1499 sym->attr.proc = PROC_DUMMY;
1503 sym->attr.proc = PROC_EXTERNAL;
1507 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1510 if (sym->attr.intrinsic)
1512 m = gfc_intrinsic_sub_interface (c, 1);
1516 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1517 "with an intrinsic", sym->name, &c->loc);
1525 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1527 c->resolved_sym = sym;
1528 pure_subroutine (c, sym);
1535 resolve_specific_s (gfc_code * c)
1540 sym = c->symtree->n.sym;
1542 m = resolve_specific_s0 (c, sym);
1545 if (m == MATCH_ERROR)
1548 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1552 m = resolve_specific_s0 (c, sym);
1555 if (m == MATCH_ERROR)
1559 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1560 sym->name, &c->loc);
1566 /* Resolve a subroutine call not known to be generic nor specific. */
1569 resolve_unknown_s (gfc_code * c)
1573 sym = c->symtree->n.sym;
1575 if (sym->attr.dummy)
1577 sym->attr.proc = PROC_DUMMY;
1581 /* See if we have an intrinsic function reference. */
1583 if (gfc_intrinsic_name (sym->name, 1))
1585 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1590 /* The reference is to an external name. */
1593 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1595 c->resolved_sym = sym;
1597 pure_subroutine (c, sym);
1603 /* Resolve a subroutine call. Although it was tempting to use the same code
1604 for functions, subroutines and functions are stored differently and this
1605 makes things awkward. */
1608 resolve_call (gfc_code * c)
1612 if (c->symtree && c->symtree->n.sym
1613 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1615 gfc_error ("'%s' at %L has a type, which is not consistent with "
1616 "the CALL at %L", c->symtree->n.sym->name,
1617 &c->symtree->n.sym->declared_at, &c->loc);
1621 /* If the procedure is not internal or module, it must be external and
1622 should be checked for usage. */
1623 if (c->symtree && c->symtree->n.sym
1624 && !c->symtree->n.sym->attr.dummy
1625 && !c->symtree->n.sym->attr.contained
1626 && !c->symtree->n.sym->attr.use_assoc)
1627 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1629 /* Switch off assumed size checking and do this again for certain kinds
1630 of procedure, once the procedure itself is resolved. */
1631 need_full_assumed_size++;
1633 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1636 /* Resume assumed_size checking. */
1637 need_full_assumed_size--;
1641 if (c->resolved_sym == NULL)
1642 switch (procedure_kind (c->symtree->n.sym))
1645 t = resolve_generic_s (c);
1648 case PTYPE_SPECIFIC:
1649 t = resolve_specific_s (c);
1653 t = resolve_unknown_s (c);
1657 gfc_internal_error ("resolve_subroutine(): bad function type");
1660 /* Some checks of elemental subroutines. */
1661 if (c->ext.actual != NULL
1662 && c->symtree->n.sym->attr.elemental)
1664 gfc_actual_arglist * a;
1668 for (a = c->ext.actual; a; a = a->next)
1670 if (a->expr == NULL || a->expr->rank == 0)
1673 /* The last upper bound of an assumed size array argument must
1675 if (resolve_assumed_size_actual (a->expr))
1678 /* Array actual arguments must conform. */
1681 if (gfc_check_conformance ("elemental subroutine", a->expr, e)
1691 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1695 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1696 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1697 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1698 if their shapes do not match. If either op1->shape or op2->shape is
1699 NULL, return SUCCESS. */
1702 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1709 if (op1->shape != NULL && op2->shape != NULL)
1711 for (i = 0; i < op1->rank; i++)
1713 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1715 gfc_error ("Shapes for operands at %L and %L are not conformable",
1716 &op1->where, &op2->where);
1726 /* Resolve an operator expression node. This can involve replacing the
1727 operation with a user defined function call. */
1730 resolve_operator (gfc_expr * e)
1732 gfc_expr *op1, *op2;
1736 /* Resolve all subnodes-- give them types. */
1738 switch (e->value.op.operator)
1741 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1744 /* Fall through... */
1747 case INTRINSIC_UPLUS:
1748 case INTRINSIC_UMINUS:
1749 case INTRINSIC_PARENTHESES:
1750 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1755 /* Typecheck the new node. */
1757 op1 = e->value.op.op1;
1758 op2 = e->value.op.op2;
1760 switch (e->value.op.operator)
1762 case INTRINSIC_UPLUS:
1763 case INTRINSIC_UMINUS:
1764 if (op1->ts.type == BT_INTEGER
1765 || op1->ts.type == BT_REAL
1766 || op1->ts.type == BT_COMPLEX)
1772 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1773 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1776 case INTRINSIC_PLUS:
1777 case INTRINSIC_MINUS:
1778 case INTRINSIC_TIMES:
1779 case INTRINSIC_DIVIDE:
1780 case INTRINSIC_POWER:
1781 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1783 gfc_type_convert_binary (e);
1788 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1789 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1790 gfc_typename (&op2->ts));
1793 case INTRINSIC_CONCAT:
1794 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1796 e->ts.type = BT_CHARACTER;
1797 e->ts.kind = op1->ts.kind;
1802 _("Operands of string concatenation operator at %%L are %s/%s"),
1803 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1809 case INTRINSIC_NEQV:
1810 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1812 e->ts.type = BT_LOGICAL;
1813 e->ts.kind = gfc_kind_max (op1, op2);
1814 if (op1->ts.kind < e->ts.kind)
1815 gfc_convert_type (op1, &e->ts, 2);
1816 else if (op2->ts.kind < e->ts.kind)
1817 gfc_convert_type (op2, &e->ts, 2);
1821 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1822 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1823 gfc_typename (&op2->ts));
1828 if (op1->ts.type == BT_LOGICAL)
1830 e->ts.type = BT_LOGICAL;
1831 e->ts.kind = op1->ts.kind;
1835 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1836 gfc_typename (&op1->ts));
1843 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1845 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1849 /* Fall through... */
1853 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1855 e->ts.type = BT_LOGICAL;
1856 e->ts.kind = gfc_default_logical_kind;
1860 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1862 gfc_type_convert_binary (e);
1864 e->ts.type = BT_LOGICAL;
1865 e->ts.kind = gfc_default_logical_kind;
1869 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1871 _("Logicals at %%L must be compared with %s instead of %s"),
1872 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1873 gfc_op2string (e->value.op.operator));
1876 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1877 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1878 gfc_typename (&op2->ts));
1882 case INTRINSIC_USER:
1884 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1885 e->value.op.uop->name, gfc_typename (&op1->ts));
1887 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1888 e->value.op.uop->name, gfc_typename (&op1->ts),
1889 gfc_typename (&op2->ts));
1893 case INTRINSIC_PARENTHESES:
1897 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1900 /* Deal with arrayness of an operand through an operator. */
1904 switch (e->value.op.operator)
1906 case INTRINSIC_PLUS:
1907 case INTRINSIC_MINUS:
1908 case INTRINSIC_TIMES:
1909 case INTRINSIC_DIVIDE:
1910 case INTRINSIC_POWER:
1911 case INTRINSIC_CONCAT:
1915 case INTRINSIC_NEQV:
1923 if (op1->rank == 0 && op2->rank == 0)
1926 if (op1->rank == 0 && op2->rank != 0)
1928 e->rank = op2->rank;
1930 if (e->shape == NULL)
1931 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1934 if (op1->rank != 0 && op2->rank == 0)
1936 e->rank = op1->rank;
1938 if (e->shape == NULL)
1939 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1942 if (op1->rank != 0 && op2->rank != 0)
1944 if (op1->rank == op2->rank)
1946 e->rank = op1->rank;
1947 if (e->shape == NULL)
1949 t = compare_shapes(op1, op2);
1953 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1958 gfc_error ("Inconsistent ranks for operator at %L and %L",
1959 &op1->where, &op2->where);
1962 /* Allow higher level expressions to work. */
1970 case INTRINSIC_UPLUS:
1971 case INTRINSIC_UMINUS:
1972 case INTRINSIC_PARENTHESES:
1973 e->rank = op1->rank;
1975 if (e->shape == NULL)
1976 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1978 /* Simply copy arrayness attribute */
1985 /* Attempt to simplify the expression. */
1987 t = gfc_simplify_expr (e, 0);
1992 if (gfc_extend_expr (e) == SUCCESS)
1995 gfc_error (msg, &e->where);
2001 /************** Array resolution subroutines **************/
2005 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2008 /* Compare two integer expressions. */
2011 compare_bound (gfc_expr * a, gfc_expr * b)
2015 if (a == NULL || a->expr_type != EXPR_CONSTANT
2016 || b == NULL || b->expr_type != EXPR_CONSTANT)
2019 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2020 gfc_internal_error ("compare_bound(): Bad expression");
2022 i = mpz_cmp (a->value.integer, b->value.integer);
2032 /* Compare an integer expression with an integer. */
2035 compare_bound_int (gfc_expr * a, int b)
2039 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2042 if (a->ts.type != BT_INTEGER)
2043 gfc_internal_error ("compare_bound_int(): Bad expression");
2045 i = mpz_cmp_si (a->value.integer, b);
2055 /* Compare a single dimension of an array reference to the array
2059 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2062 /* Given start, end and stride values, calculate the minimum and
2063 maximum referenced indexes. */
2071 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2073 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2079 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2081 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2085 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2087 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2090 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2091 it is legal (see 6.2.2.3.1). */
2096 gfc_internal_error ("check_dimension(): Bad array reference");
2102 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2107 /* Compare an array reference with an array specification. */
2110 compare_spec_to_ref (gfc_array_ref * ar)
2117 /* TODO: Full array sections are only allowed as actual parameters. */
2118 if (as->type == AS_ASSUMED_SIZE
2119 && (/*ar->type == AR_FULL
2120 ||*/ (ar->type == AR_SECTION
2121 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2123 gfc_error ("Rightmost upper bound of assumed size array section"
2124 " not specified at %L", &ar->where);
2128 if (ar->type == AR_FULL)
2131 if (as->rank != ar->dimen)
2133 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2134 &ar->where, ar->dimen, as->rank);
2138 for (i = 0; i < as->rank; i++)
2139 if (check_dimension (i, ar, as) == FAILURE)
2146 /* Resolve one part of an array index. */
2149 gfc_resolve_index (gfc_expr * index, int check_scalar)
2156 if (gfc_resolve_expr (index) == FAILURE)
2159 if (check_scalar && index->rank != 0)
2161 gfc_error ("Array index at %L must be scalar", &index->where);
2165 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2167 gfc_error ("Array index at %L must be of INTEGER type",
2172 if (index->ts.type == BT_REAL)
2173 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
2174 &index->where) == FAILURE)
2177 if (index->ts.kind != gfc_index_integer_kind
2178 || index->ts.type != BT_INTEGER)
2181 ts.type = BT_INTEGER;
2182 ts.kind = gfc_index_integer_kind;
2184 gfc_convert_type_warn (index, &ts, 2, 0);
2190 /* Resolve a dim argument to an intrinsic function. */
2193 gfc_resolve_dim_arg (gfc_expr *dim)
2198 if (gfc_resolve_expr (dim) == FAILURE)
2203 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2207 if (dim->ts.type != BT_INTEGER)
2209 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2212 if (dim->ts.kind != gfc_index_integer_kind)
2216 ts.type = BT_INTEGER;
2217 ts.kind = gfc_index_integer_kind;
2219 gfc_convert_type_warn (dim, &ts, 2, 0);
2225 /* Given an expression that contains array references, update those array
2226 references to point to the right array specifications. While this is
2227 filled in during matching, this information is difficult to save and load
2228 in a module, so we take care of it here.
2230 The idea here is that the original array reference comes from the
2231 base symbol. We traverse the list of reference structures, setting
2232 the stored reference to references. Component references can
2233 provide an additional array specification. */
2236 find_array_spec (gfc_expr * e)
2242 as = e->symtree->n.sym->as;
2244 for (ref = e->ref; ref; ref = ref->next)
2249 gfc_internal_error ("find_array_spec(): Missing spec");
2256 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
2257 if (c == ref->u.c.component)
2261 gfc_internal_error ("find_array_spec(): Component not found");
2266 gfc_internal_error ("find_array_spec(): unused as(1)");
2277 gfc_internal_error ("find_array_spec(): unused as(2)");
2281 /* Resolve an array reference. */
2284 resolve_array_ref (gfc_array_ref * ar)
2286 int i, check_scalar;
2288 for (i = 0; i < ar->dimen; i++)
2290 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2292 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2294 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2296 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2299 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2300 switch (ar->start[i]->rank)
2303 ar->dimen_type[i] = DIMEN_ELEMENT;
2307 ar->dimen_type[i] = DIMEN_VECTOR;
2311 gfc_error ("Array index at %L is an array of rank %d",
2312 &ar->c_where[i], ar->start[i]->rank);
2317 /* If the reference type is unknown, figure out what kind it is. */
2319 if (ar->type == AR_UNKNOWN)
2321 ar->type = AR_ELEMENT;
2322 for (i = 0; i < ar->dimen; i++)
2323 if (ar->dimen_type[i] == DIMEN_RANGE
2324 || ar->dimen_type[i] == DIMEN_VECTOR)
2326 ar->type = AR_SECTION;
2331 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2339 resolve_substring (gfc_ref * ref)
2342 if (ref->u.ss.start != NULL)
2344 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2347 if (ref->u.ss.start->ts.type != BT_INTEGER)
2349 gfc_error ("Substring start index at %L must be of type INTEGER",
2350 &ref->u.ss.start->where);
2354 if (ref->u.ss.start->rank != 0)
2356 gfc_error ("Substring start index at %L must be scalar",
2357 &ref->u.ss.start->where);
2361 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2363 gfc_error ("Substring start index at %L is less than one",
2364 &ref->u.ss.start->where);
2369 if (ref->u.ss.end != NULL)
2371 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2374 if (ref->u.ss.end->ts.type != BT_INTEGER)
2376 gfc_error ("Substring end index at %L must be of type INTEGER",
2377 &ref->u.ss.end->where);
2381 if (ref->u.ss.end->rank != 0)
2383 gfc_error ("Substring end index at %L must be scalar",
2384 &ref->u.ss.end->where);
2388 if (ref->u.ss.length != NULL
2389 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2391 gfc_error ("Substring end index at %L is out of bounds",
2392 &ref->u.ss.start->where);
2401 /* Resolve subtype references. */
2404 resolve_ref (gfc_expr * expr)
2406 int current_part_dimension, n_components, seen_part_dimension;
2409 for (ref = expr->ref; ref; ref = ref->next)
2410 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2412 find_array_spec (expr);
2416 for (ref = expr->ref; ref; ref = ref->next)
2420 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2428 resolve_substring (ref);
2432 /* Check constraints on part references. */
2434 current_part_dimension = 0;
2435 seen_part_dimension = 0;
2438 for (ref = expr->ref; ref; ref = ref->next)
2443 switch (ref->u.ar.type)
2447 current_part_dimension = 1;
2451 current_part_dimension = 0;
2455 gfc_internal_error ("resolve_ref(): Bad array reference");
2461 if ((current_part_dimension || seen_part_dimension)
2462 && ref->u.c.component->pointer)
2465 ("Component to the right of a part reference with nonzero "
2466 "rank must not have the POINTER attribute at %L",
2478 if (((ref->type == REF_COMPONENT && n_components > 1)
2479 || ref->next == NULL)
2480 && current_part_dimension
2481 && seen_part_dimension)
2484 gfc_error ("Two or more part references with nonzero rank must "
2485 "not be specified at %L", &expr->where);
2489 if (ref->type == REF_COMPONENT)
2491 if (current_part_dimension)
2492 seen_part_dimension = 1;
2494 /* reset to make sure */
2495 current_part_dimension = 0;
2503 /* Given an expression, determine its shape. This is easier than it sounds.
2504 Leaves the shape array NULL if it is not possible to determine the shape. */
2507 expression_shape (gfc_expr * e)
2509 mpz_t array[GFC_MAX_DIMENSIONS];
2512 if (e->rank == 0 || e->shape != NULL)
2515 for (i = 0; i < e->rank; i++)
2516 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2519 e->shape = gfc_get_shape (e->rank);
2521 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2526 for (i--; i >= 0; i--)
2527 mpz_clear (array[i]);
2531 /* Given a variable expression node, compute the rank of the expression by
2532 examining the base symbol and any reference structures it may have. */
2535 expression_rank (gfc_expr * e)
2542 if (e->expr_type == EXPR_ARRAY)
2544 /* Constructors can have a rank different from one via RESHAPE(). */
2546 if (e->symtree == NULL)
2552 e->rank = (e->symtree->n.sym->as == NULL)
2553 ? 0 : e->symtree->n.sym->as->rank;
2559 for (ref = e->ref; ref; ref = ref->next)
2561 if (ref->type != REF_ARRAY)
2564 if (ref->u.ar.type == AR_FULL)
2566 rank = ref->u.ar.as->rank;
2570 if (ref->u.ar.type == AR_SECTION)
2572 /* Figure out the rank of the section. */
2574 gfc_internal_error ("expression_rank(): Two array specs");
2576 for (i = 0; i < ref->u.ar.dimen; i++)
2577 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2578 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2588 expression_shape (e);
2592 /* Resolve a variable expression. */
2595 resolve_variable (gfc_expr * e)
2599 if (e->ref && resolve_ref (e) == FAILURE)
2602 if (e->symtree == NULL)
2605 sym = e->symtree->n.sym;
2606 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2608 e->ts.type = BT_PROCEDURE;
2612 if (sym->ts.type != BT_UNKNOWN)
2613 gfc_variable_attr (e, &e->ts);
2616 /* Must be a simple variable reference. */
2617 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2622 if (check_assumed_size_reference (sym, e))
2629 /* Resolve an expression. That is, make sure that types of operands agree
2630 with their operators, intrinsic operators are converted to function calls
2631 for overloaded types and unresolved function references are resolved. */
2634 gfc_resolve_expr (gfc_expr * e)
2641 switch (e->expr_type)
2644 t = resolve_operator (e);
2648 t = resolve_function (e);
2652 t = resolve_variable (e);
2654 expression_rank (e);
2657 case EXPR_SUBSTRING:
2658 t = resolve_ref (e);
2668 if (resolve_ref (e) == FAILURE)
2671 t = gfc_resolve_array_constructor (e);
2672 /* Also try to expand a constructor. */
2675 expression_rank (e);
2676 gfc_expand_constructor (e);
2681 case EXPR_STRUCTURE:
2682 t = resolve_ref (e);
2686 t = resolve_structure_cons (e);
2690 t = gfc_simplify_expr (e, 0);
2694 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2701 /* Resolve an expression from an iterator. They must be scalar and have
2702 INTEGER or (optionally) REAL type. */
2705 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2706 const char * name_msgid)
2708 if (gfc_resolve_expr (expr) == FAILURE)
2711 if (expr->rank != 0)
2713 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2717 if (!(expr->ts.type == BT_INTEGER
2718 || (expr->ts.type == BT_REAL && real_ok)))
2721 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2724 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2731 /* Resolve the expressions in an iterator structure. If REAL_OK is
2732 false allow only INTEGER type iterators, otherwise allow REAL types. */
2735 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2738 if (iter->var->ts.type == BT_REAL)
2739 gfc_notify_std (GFC_STD_F95_DEL,
2740 "Obsolete: REAL DO loop iterator at %L",
2743 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2747 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2749 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2754 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2755 "Start expression in DO loop") == FAILURE)
2758 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2759 "End expression in DO loop") == FAILURE)
2762 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2763 "Step expression in DO loop") == FAILURE)
2766 if (iter->step->expr_type == EXPR_CONSTANT)
2768 if ((iter->step->ts.type == BT_INTEGER
2769 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2770 || (iter->step->ts.type == BT_REAL
2771 && mpfr_sgn (iter->step->value.real) == 0))
2773 gfc_error ("Step expression in DO loop at %L cannot be zero",
2774 &iter->step->where);
2779 /* Convert start, end, and step to the same type as var. */
2780 if (iter->start->ts.kind != iter->var->ts.kind
2781 || iter->start->ts.type != iter->var->ts.type)
2782 gfc_convert_type (iter->start, &iter->var->ts, 2);
2784 if (iter->end->ts.kind != iter->var->ts.kind
2785 || iter->end->ts.type != iter->var->ts.type)
2786 gfc_convert_type (iter->end, &iter->var->ts, 2);
2788 if (iter->step->ts.kind != iter->var->ts.kind
2789 || iter->step->ts.type != iter->var->ts.type)
2790 gfc_convert_type (iter->step, &iter->var->ts, 2);
2796 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2797 to be a scalar INTEGER variable. The subscripts and stride are scalar
2798 INTEGERs, and if stride is a constant it must be nonzero. */
2801 resolve_forall_iterators (gfc_forall_iterator * iter)
2806 if (gfc_resolve_expr (iter->var) == SUCCESS
2807 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2808 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2811 if (gfc_resolve_expr (iter->start) == SUCCESS
2812 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2813 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2814 &iter->start->where);
2815 if (iter->var->ts.kind != iter->start->ts.kind)
2816 gfc_convert_type (iter->start, &iter->var->ts, 2);
2818 if (gfc_resolve_expr (iter->end) == SUCCESS
2819 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2820 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2822 if (iter->var->ts.kind != iter->end->ts.kind)
2823 gfc_convert_type (iter->end, &iter->var->ts, 2);
2825 if (gfc_resolve_expr (iter->stride) == SUCCESS)
2827 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2828 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2829 &iter->stride->where, "INTEGER");
2831 if (iter->stride->expr_type == EXPR_CONSTANT
2832 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2833 gfc_error ("FORALL stride expression at %L cannot be zero",
2834 &iter->stride->where);
2836 if (iter->var->ts.kind != iter->stride->ts.kind)
2837 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2844 /* Given a pointer to a symbol that is a derived type, see if any components
2845 have the POINTER attribute. The search is recursive if necessary.
2846 Returns zero if no pointer components are found, nonzero otherwise. */
2849 derived_pointer (gfc_symbol * sym)
2853 for (c = sym->components; c; c = c->next)
2858 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2866 /* Given a pointer to a symbol that is a derived type, see if it's
2867 inaccessible, i.e. if it's defined in another module and the components are
2868 PRIVATE. The search is recursive if necessary. Returns zero if no
2869 inaccessible components are found, nonzero otherwise. */
2872 derived_inaccessible (gfc_symbol *sym)
2876 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2879 for (c = sym->components; c; c = c->next)
2881 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2889 /* Resolve the argument of a deallocate expression. The expression must be
2890 a pointer or a full array. */
2893 resolve_deallocate_expr (gfc_expr * e)
2895 symbol_attribute attr;
2899 if (gfc_resolve_expr (e) == FAILURE)
2902 attr = gfc_expr_attr (e);
2906 if (e->expr_type != EXPR_VARIABLE)
2909 allocatable = e->symtree->n.sym->attr.allocatable;
2910 for (ref = e->ref; ref; ref = ref->next)
2914 if (ref->u.ar.type != AR_FULL)
2919 allocatable = (ref->u.c.component->as != NULL
2920 && ref->u.c.component->as->type == AS_DEFERRED);
2928 if (allocatable == 0)
2931 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2932 "ALLOCATABLE or a POINTER", &e->where);
2935 if (e->symtree->n.sym->attr.intent == INTENT_IN)
2937 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
2938 e->symtree->n.sym->name, &e->where);
2946 /* Given the expression node e for an allocatable/pointer of derived type to be
2947 allocated, get the expression node to be initialized afterwards (needed for
2948 derived types with default initializers). */
2951 expr_to_initialize (gfc_expr * e)
2957 result = gfc_copy_expr (e);
2959 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2960 for (ref = result->ref; ref; ref = ref->next)
2961 if (ref->type == REF_ARRAY && ref->next == NULL)
2963 ref->u.ar.type = AR_FULL;
2965 for (i = 0; i < ref->u.ar.dimen; i++)
2966 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2968 result->rank = ref->u.ar.dimen;
2976 /* Resolve the expression in an ALLOCATE statement, doing the additional
2977 checks to see whether the expression is OK or not. The expression must
2978 have a trailing array reference that gives the size of the array. */
2981 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2983 int i, pointer, allocatable, dimension;
2984 symbol_attribute attr;
2985 gfc_ref *ref, *ref2;
2990 if (gfc_resolve_expr (e) == FAILURE)
2993 /* Make sure the expression is allocatable or a pointer. If it is
2994 pointer, the next-to-last reference must be a pointer. */
2998 if (e->expr_type != EXPR_VARIABLE)
3002 attr = gfc_expr_attr (e);
3003 pointer = attr.pointer;
3004 dimension = attr.dimension;
3009 allocatable = e->symtree->n.sym->attr.allocatable;
3010 pointer = e->symtree->n.sym->attr.pointer;
3011 dimension = e->symtree->n.sym->attr.dimension;
3013 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3017 if (ref->next != NULL)
3022 allocatable = (ref->u.c.component->as != NULL
3023 && ref->u.c.component->as->type == AS_DEFERRED);
3025 pointer = ref->u.c.component->pointer;
3026 dimension = ref->u.c.component->dimension;
3036 if (allocatable == 0 && pointer == 0)
3038 gfc_error ("Expression in ALLOCATE statement at %L must be "
3039 "ALLOCATABLE or a POINTER", &e->where);
3043 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3045 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3046 e->symtree->n.sym->name, &e->where);
3050 /* Add default initializer for those derived types that need them. */
3051 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3053 init_st = gfc_get_code ();
3054 init_st->loc = code->loc;
3055 init_st->op = EXEC_ASSIGN;
3056 init_st->expr = expr_to_initialize (e);
3057 init_st->expr2 = init_e;
3059 init_st->next = code->next;
3060 code->next = init_st;
3063 if (pointer && dimension == 0)
3066 /* Make sure the next-to-last reference node is an array specification. */
3068 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3070 gfc_error ("Array specification required in ALLOCATE statement "
3071 "at %L", &e->where);
3075 if (ref2->u.ar.type == AR_ELEMENT)
3078 /* Make sure that the array section reference makes sense in the
3079 context of an ALLOCATE specification. */
3083 for (i = 0; i < ar->dimen; i++)
3084 switch (ar->dimen_type[i])
3090 if (ar->start[i] != NULL
3091 && ar->end[i] != NULL
3092 && ar->stride[i] == NULL)
3095 /* Fall Through... */
3099 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3108 /************ SELECT CASE resolution subroutines ************/
3110 /* Callback function for our mergesort variant. Determines interval
3111 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3112 op1 > op2. Assumes we're not dealing with the default case.
3113 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3114 There are nine situations to check. */
3117 compare_cases (const gfc_case * op1, const gfc_case * op2)
3121 if (op1->low == NULL) /* op1 = (:L) */
3123 /* op2 = (:N), so overlap. */
3125 /* op2 = (M:) or (M:N), L < M */
3126 if (op2->low != NULL
3127 && gfc_compare_expr (op1->high, op2->low) < 0)
3130 else if (op1->high == NULL) /* op1 = (K:) */
3132 /* op2 = (M:), so overlap. */
3134 /* op2 = (:N) or (M:N), K > N */
3135 if (op2->high != NULL
3136 && gfc_compare_expr (op1->low, op2->high) > 0)
3139 else /* op1 = (K:L) */
3141 if (op2->low == NULL) /* op2 = (:N), K > N */
3142 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3143 else if (op2->high == NULL) /* op2 = (M:), L < M */
3144 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3145 else /* op2 = (M:N) */
3149 if (gfc_compare_expr (op1->high, op2->low) < 0)
3152 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3161 /* Merge-sort a double linked case list, detecting overlap in the
3162 process. LIST is the head of the double linked case list before it
3163 is sorted. Returns the head of the sorted list if we don't see any
3164 overlap, or NULL otherwise. */
3167 check_case_overlap (gfc_case * list)
3169 gfc_case *p, *q, *e, *tail;
3170 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3172 /* If the passed list was empty, return immediately. */
3179 /* Loop unconditionally. The only exit from this loop is a return
3180 statement, when we've finished sorting the case list. */
3187 /* Count the number of merges we do in this pass. */
3190 /* Loop while there exists a merge to be done. */
3195 /* Count this merge. */
3198 /* Cut the list in two pieces by stepping INSIZE places
3199 forward in the list, starting from P. */
3202 for (i = 0; i < insize; i++)
3211 /* Now we have two lists. Merge them! */
3212 while (psize > 0 || (qsize > 0 && q != NULL))
3215 /* See from which the next case to merge comes from. */
3218 /* P is empty so the next case must come from Q. */
3223 else if (qsize == 0 || q == NULL)
3232 cmp = compare_cases (p, q);
3235 /* The whole case range for P is less than the
3243 /* The whole case range for Q is greater than
3244 the case range for P. */
3251 /* The cases overlap, or they are the same
3252 element in the list. Either way, we must
3253 issue an error and get the next case from P. */
3254 /* FIXME: Sort P and Q by line number. */
3255 gfc_error ("CASE label at %L overlaps with CASE "
3256 "label at %L", &p->where, &q->where);
3264 /* Add the next element to the merged list. */
3273 /* P has now stepped INSIZE places along, and so has Q. So
3274 they're the same. */
3279 /* If we have done only one merge or none at all, we've
3280 finished sorting the cases. */
3289 /* Otherwise repeat, merging lists twice the size. */
3295 /* Check to see if an expression is suitable for use in a CASE statement.
3296 Makes sure that all case expressions are scalar constants of the same
3297 type. Return FAILURE if anything is wrong. */
3300 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3302 if (e == NULL) return SUCCESS;
3304 if (e->ts.type != case_expr->ts.type)
3306 gfc_error ("Expression in CASE statement at %L must be of type %s",
3307 &e->where, gfc_basic_typename (case_expr->ts.type));
3311 /* C805 (R808) For a given case-construct, each case-value shall be of
3312 the same type as case-expr. For character type, length differences
3313 are allowed, but the kind type parameters shall be the same. */
3315 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3317 gfc_error("Expression in CASE statement at %L must be kind %d",
3318 &e->where, case_expr->ts.kind);
3322 /* Convert the case value kind to that of case expression kind, if needed.
3323 FIXME: Should a warning be issued? */
3324 if (e->ts.kind != case_expr->ts.kind)
3325 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3329 gfc_error ("Expression in CASE statement at %L must be scalar",
3338 /* Given a completely parsed select statement, we:
3340 - Validate all expressions and code within the SELECT.
3341 - Make sure that the selection expression is not of the wrong type.
3342 - Make sure that no case ranges overlap.
3343 - Eliminate unreachable cases and unreachable code resulting from
3344 removing case labels.
3346 The standard does allow unreachable cases, e.g. CASE (5:3). But
3347 they are a hassle for code generation, and to prevent that, we just
3348 cut them out here. This is not necessary for overlapping cases
3349 because they are illegal and we never even try to generate code.
3351 We have the additional caveat that a SELECT construct could have
3352 been a computed GOTO in the source code. Fortunately we can fairly
3353 easily work around that here: The case_expr for a "real" SELECT CASE
3354 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3355 we have to do is make sure that the case_expr is a scalar integer
3359 resolve_select (gfc_code * code)
3362 gfc_expr *case_expr;
3363 gfc_case *cp, *default_case, *tail, *head;
3364 int seen_unreachable;
3369 if (code->expr == NULL)
3371 /* This was actually a computed GOTO statement. */
3372 case_expr = code->expr2;
3373 if (case_expr->ts.type != BT_INTEGER
3374 || case_expr->rank != 0)
3375 gfc_error ("Selection expression in computed GOTO statement "
3376 "at %L must be a scalar integer expression",
3379 /* Further checking is not necessary because this SELECT was built
3380 by the compiler, so it should always be OK. Just move the
3381 case_expr from expr2 to expr so that we can handle computed
3382 GOTOs as normal SELECTs from here on. */
3383 code->expr = code->expr2;
3388 case_expr = code->expr;
3390 type = case_expr->ts.type;
3391 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3393 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3394 &case_expr->where, gfc_typename (&case_expr->ts));
3396 /* Punt. Going on here just produce more garbage error messages. */
3400 if (case_expr->rank != 0)
3402 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3403 "expression", &case_expr->where);
3409 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3410 of the SELECT CASE expression and its CASE values. Walk the lists
3411 of case values, and if we find a mismatch, promote case_expr to
3412 the appropriate kind. */
3414 if (type == BT_LOGICAL || type == BT_INTEGER)
3416 for (body = code->block; body; body = body->block)
3418 /* Walk the case label list. */
3419 for (cp = body->ext.case_list; cp; cp = cp->next)
3421 /* Intercept the DEFAULT case. It does not have a kind. */
3422 if (cp->low == NULL && cp->high == NULL)
3425 /* Unreachable case ranges are discarded, so ignore. */
3426 if (cp->low != NULL && cp->high != NULL
3427 && cp->low != cp->high
3428 && gfc_compare_expr (cp->low, cp->high) > 0)
3431 /* FIXME: Should a warning be issued? */
3433 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3434 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3436 if (cp->high != NULL
3437 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3438 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3443 /* Assume there is no DEFAULT case. */
3444 default_case = NULL;
3448 for (body = code->block; body; body = body->block)
3450 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3452 seen_unreachable = 0;
3454 /* Walk the case label list, making sure that all case labels
3456 for (cp = body->ext.case_list; cp; cp = cp->next)
3458 /* Count the number of cases in the whole construct. */
3461 /* Intercept the DEFAULT case. */
3462 if (cp->low == NULL && cp->high == NULL)
3464 if (default_case != NULL)
3466 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3467 "by a second DEFAULT CASE at %L",
3468 &default_case->where, &cp->where);
3479 /* Deal with single value cases and case ranges. Errors are
3480 issued from the validation function. */
3481 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3482 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3488 if (type == BT_LOGICAL
3489 && ((cp->low == NULL || cp->high == NULL)
3490 || cp->low != cp->high))
3493 ("Logical range in CASE statement at %L is not allowed",
3499 if (cp->low != NULL && cp->high != NULL
3500 && cp->low != cp->high
3501 && gfc_compare_expr (cp->low, cp->high) > 0)
3503 if (gfc_option.warn_surprising)
3504 gfc_warning ("Range specification at %L can never "
3505 "be matched", &cp->where);
3507 cp->unreachable = 1;
3508 seen_unreachable = 1;
3512 /* If the case range can be matched, it can also overlap with
3513 other cases. To make sure it does not, we put it in a
3514 double linked list here. We sort that with a merge sort
3515 later on to detect any overlapping cases. */
3519 head->right = head->left = NULL;
3524 tail->right->left = tail;
3531 /* It there was a failure in the previous case label, give up
3532 for this case label list. Continue with the next block. */
3536 /* See if any case labels that are unreachable have been seen.
3537 If so, we eliminate them. This is a bit of a kludge because
3538 the case lists for a single case statement (label) is a
3539 single forward linked lists. */
3540 if (seen_unreachable)
3542 /* Advance until the first case in the list is reachable. */
3543 while (body->ext.case_list != NULL
3544 && body->ext.case_list->unreachable)
3546 gfc_case *n = body->ext.case_list;
3547 body->ext.case_list = body->ext.case_list->next;
3549 gfc_free_case_list (n);
3552 /* Strip all other unreachable cases. */
3553 if (body->ext.case_list)
3555 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3557 if (cp->next->unreachable)
3559 gfc_case *n = cp->next;
3560 cp->next = cp->next->next;
3562 gfc_free_case_list (n);
3569 /* See if there were overlapping cases. If the check returns NULL,
3570 there was overlap. In that case we don't do anything. If head
3571 is non-NULL, we prepend the DEFAULT case. The sorted list can
3572 then used during code generation for SELECT CASE constructs with
3573 a case expression of a CHARACTER type. */
3576 head = check_case_overlap (head);
3578 /* Prepend the default_case if it is there. */
3579 if (head != NULL && default_case)
3581 default_case->left = NULL;
3582 default_case->right = head;
3583 head->left = default_case;
3587 /* Eliminate dead blocks that may be the result if we've seen
3588 unreachable case labels for a block. */
3589 for (body = code; body && body->block; body = body->block)
3591 if (body->block->ext.case_list == NULL)
3593 /* Cut the unreachable block from the code chain. */
3594 gfc_code *c = body->block;
3595 body->block = c->block;
3597 /* Kill the dead block, but not the blocks below it. */
3599 gfc_free_statements (c);
3603 /* More than two cases is legal but insane for logical selects.
3604 Issue a warning for it. */
3605 if (gfc_option.warn_surprising && type == BT_LOGICAL
3607 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3612 /* Resolve a transfer statement. This is making sure that:
3613 -- a derived type being transferred has only non-pointer components
3614 -- a derived type being transferred doesn't have private components, unless
3615 it's being transferred from the module where the type was defined
3616 -- we're not trying to transfer a whole assumed size array. */
3619 resolve_transfer (gfc_code * code)
3628 if (exp->expr_type != EXPR_VARIABLE)
3631 sym = exp->symtree->n.sym;
3634 /* Go to actual component transferred. */
3635 for (ref = code->expr->ref; ref; ref = ref->next)
3636 if (ref->type == REF_COMPONENT)
3637 ts = &ref->u.c.component->ts;
3639 if (ts->type == BT_DERIVED)
3641 /* Check that transferred derived type doesn't contain POINTER
3643 if (derived_pointer (ts->derived))
3645 gfc_error ("Data transfer element at %L cannot have "
3646 "POINTER components", &code->loc);
3650 if (derived_inaccessible (ts->derived))
3652 gfc_error ("Data transfer element at %L cannot have "
3653 "PRIVATE components",&code->loc);
3658 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3659 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3661 gfc_error ("Data transfer element at %L cannot be a full reference to "
3662 "an assumed-size array", &code->loc);
3668 /*********** Toplevel code resolution subroutines ***********/
3670 /* Given a branch to a label and a namespace, if the branch is conforming.
3671 The code node described where the branch is located. */
3674 resolve_branch (gfc_st_label * label, gfc_code * code)
3676 gfc_code *block, *found;
3684 /* Step one: is this a valid branching target? */
3686 if (lp->defined == ST_LABEL_UNKNOWN)
3688 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3693 if (lp->defined != ST_LABEL_TARGET)
3695 gfc_error ("Statement at %L is not a valid branch target statement "
3696 "for the branch statement at %L", &lp->where, &code->loc);
3700 /* Step two: make sure this branch is not a branch to itself ;-) */
3702 if (code->here == label)
3704 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3708 /* Step three: Try to find the label in the parse tree. To do this,
3709 we traverse the tree block-by-block: first the block that
3710 contains this GOTO, then the block that it is nested in, etc. We
3711 can ignore other blocks because branching into another block is
3716 for (stack = cs_base; stack; stack = stack->prev)
3718 for (block = stack->head; block; block = block->next)
3720 if (block->here == label)
3733 /* The label is not in an enclosing block, so illegal. This was
3734 allowed in Fortran 66, so we allow it as extension. We also
3735 forego further checks if we run into this. */
3736 gfc_notify_std (GFC_STD_LEGACY,
3737 "Label at %L is not in the same block as the "
3738 "GOTO statement at %L", &lp->where, &code->loc);
3742 /* Step four: Make sure that the branching target is legal if
3743 the statement is an END {SELECT,DO,IF}. */
3745 if (found->op == EXEC_NOP)
3747 for (stack = cs_base; stack; stack = stack->prev)
3748 if (stack->current->next == found)
3752 gfc_notify_std (GFC_STD_F95_DEL,
3753 "Obsolete: GOTO at %L jumps to END of construct at %L",
3754 &code->loc, &found->loc);
3759 /* Check whether EXPR1 has the same shape as EXPR2. */
3762 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3764 mpz_t shape[GFC_MAX_DIMENSIONS];
3765 mpz_t shape2[GFC_MAX_DIMENSIONS];
3766 try result = FAILURE;
3769 /* Compare the rank. */
3770 if (expr1->rank != expr2->rank)
3773 /* Compare the size of each dimension. */
3774 for (i=0; i<expr1->rank; i++)
3776 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3779 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3782 if (mpz_cmp (shape[i], shape2[i]))
3786 /* When either of the two expression is an assumed size array, we
3787 ignore the comparison of dimension sizes. */
3792 for (i--; i>=0; i--)
3794 mpz_clear (shape[i]);
3795 mpz_clear (shape2[i]);
3801 /* Check whether a WHERE assignment target or a WHERE mask expression
3802 has the same shape as the outmost WHERE mask expression. */
3805 resolve_where (gfc_code *code, gfc_expr *mask)
3811 cblock = code->block;
3813 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3814 In case of nested WHERE, only the outmost one is stored. */
3815 if (mask == NULL) /* outmost WHERE */
3817 else /* inner WHERE */
3824 /* Check if the mask-expr has a consistent shape with the
3825 outmost WHERE mask-expr. */
3826 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3827 gfc_error ("WHERE mask at %L has inconsistent shape",
3828 &cblock->expr->where);
3831 /* the assignment statement of a WHERE statement, or the first
3832 statement in where-body-construct of a WHERE construct */
3833 cnext = cblock->next;
3838 /* WHERE assignment statement */
3841 /* Check shape consistent for WHERE assignment target. */
3842 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3843 gfc_error ("WHERE assignment target at %L has "
3844 "inconsistent shape", &cnext->expr->where);
3847 /* WHERE or WHERE construct is part of a where-body-construct */
3849 resolve_where (cnext, e);
3853 gfc_error ("Unsupported statement inside WHERE at %L",
3856 /* the next statement within the same where-body-construct */
3857 cnext = cnext->next;
3859 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3860 cblock = cblock->block;
3865 /* Check whether the FORALL index appears in the expression or not. */
3868 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3872 gfc_actual_arglist *args;
3875 switch (expr->expr_type)
3878 gcc_assert (expr->symtree->n.sym);
3880 /* A scalar assignment */
3883 if (expr->symtree->n.sym == symbol)
3889 /* the expr is array ref, substring or struct component. */
3896 /* Check if the symbol appears in the array subscript. */
3898 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3901 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3905 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3909 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3915 if (expr->symtree->n.sym == symbol)
3918 /* Check if the symbol appears in the substring section. */
3919 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3921 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3929 gfc_error("expresion reference type error at %L", &expr->where);
3935 /* If the expression is a function call, then check if the symbol
3936 appears in the actual arglist of the function. */
3938 for (args = expr->value.function.actual; args; args = args->next)
3940 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3945 /* It seems not to happen. */
3946 case EXPR_SUBSTRING:
3950 gcc_assert (expr->ref->type == REF_SUBSTRING);
3951 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3953 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3958 /* It seems not to happen. */
3959 case EXPR_STRUCTURE:
3961 gfc_error ("Unsupported statement while finding forall index in "
3966 /* Find the FORALL index in the first operand. */
3967 if (expr->value.op.op1)
3969 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3973 /* Find the FORALL index in the second operand. */
3974 if (expr->value.op.op2)
3976 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3989 /* Resolve assignment in FORALL construct.
3990 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3991 FORALL index variables. */
3994 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3998 for (n = 0; n < nvar; n++)
4000 gfc_symbol *forall_index;
4002 forall_index = var_expr[n]->symtree->n.sym;
4004 /* Check whether the assignment target is one of the FORALL index
4006 if ((code->expr->expr_type == EXPR_VARIABLE)
4007 && (code->expr->symtree->n.sym == forall_index))
4008 gfc_error ("Assignment to a FORALL index variable at %L",
4009 &code->expr->where);
4012 /* If one of the FORALL index variables doesn't appear in the
4013 assignment target, then there will be a many-to-one
4015 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4016 gfc_error ("The FORALL with index '%s' cause more than one "
4017 "assignment to this object at %L",
4018 var_expr[n]->symtree->name, &code->expr->where);
4024 /* Resolve WHERE statement in FORALL construct. */
4027 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4031 cblock = code->block;
4034 /* the assignment statement of a WHERE statement, or the first
4035 statement in where-body-construct of a WHERE construct */
4036 cnext = cblock->next;
4041 /* WHERE assignment statement */
4043 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4046 /* WHERE or WHERE construct is part of a where-body-construct */
4048 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4052 gfc_error ("Unsupported statement inside WHERE at %L",
4055 /* the next statement within the same where-body-construct */
4056 cnext = cnext->next;
4058 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4059 cblock = cblock->block;
4064 /* Traverse the FORALL body to check whether the following errors exist:
4065 1. For assignment, check if a many-to-one assignment happens.
4066 2. For WHERE statement, check the WHERE body to see if there is any
4067 many-to-one assignment. */
4070 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4074 c = code->block->next;
4080 case EXEC_POINTER_ASSIGN:
4081 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4084 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4085 there is no need to handle it here. */
4089 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4094 /* The next statement in the FORALL body. */
4100 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4101 gfc_resolve_forall_body to resolve the FORALL body. */
4104 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4106 static gfc_expr **var_expr;
4107 static int total_var = 0;
4108 static int nvar = 0;
4109 gfc_forall_iterator *fa;
4110 gfc_symbol *forall_index;
4114 /* Start to resolve a FORALL construct */
4115 if (forall_save == 0)
4117 /* Count the total number of FORALL index in the nested FORALL
4118 construct in order to allocate the VAR_EXPR with proper size. */
4120 while ((next != NULL) && (next->op == EXEC_FORALL))
4122 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4124 next = next->block->next;
4127 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4128 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4131 /* The information about FORALL iterator, including FORALL index start, end
4132 and stride. The FORALL index can not appear in start, end or stride. */
4133 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4135 /* Check if any outer FORALL index name is the same as the current
4137 for (i = 0; i < nvar; i++)
4139 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4141 gfc_error ("An outer FORALL construct already has an index "
4142 "with this name %L", &fa->var->where);
4146 /* Record the current FORALL index. */
4147 var_expr[nvar] = gfc_copy_expr (fa->var);
4149 forall_index = fa->var->symtree->n.sym;
4151 /* Check if the FORALL index appears in start, end or stride. */
4152 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4153 gfc_error ("A FORALL index must not appear in a limit or stride "
4154 "expression in the same FORALL at %L", &fa->start->where);
4155 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4156 gfc_error ("A FORALL index must not appear in a limit or stride "
4157 "expression in the same FORALL at %L", &fa->end->where);
4158 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4159 gfc_error ("A FORALL index must not appear in a limit or stride "
4160 "expression in the same FORALL at %L", &fa->stride->where);
4164 /* Resolve the FORALL body. */
4165 gfc_resolve_forall_body (code, nvar, var_expr);
4167 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4168 gfc_resolve_blocks (code->block, ns);
4170 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4171 for (i = 0; i < total_var; i++)
4172 gfc_free_expr (var_expr[i]);
4174 /* Reset the counters. */
4180 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4183 static void resolve_code (gfc_code *, gfc_namespace *);
4186 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4190 for (; b; b = b->block)
4192 t = gfc_resolve_expr (b->expr);
4193 if (gfc_resolve_expr (b->expr2) == FAILURE)
4199 if (t == SUCCESS && b->expr != NULL
4200 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4202 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4209 && (b->expr->ts.type != BT_LOGICAL
4210 || b->expr->rank == 0))
4212 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4217 resolve_branch (b->label, b);
4229 case EXEC_OMP_ATOMIC:
4230 case EXEC_OMP_CRITICAL:
4232 case EXEC_OMP_MASTER:
4233 case EXEC_OMP_ORDERED:
4234 case EXEC_OMP_PARALLEL:
4235 case EXEC_OMP_PARALLEL_DO:
4236 case EXEC_OMP_PARALLEL_SECTIONS:
4237 case EXEC_OMP_PARALLEL_WORKSHARE:
4238 case EXEC_OMP_SECTIONS:
4239 case EXEC_OMP_SINGLE:
4240 case EXEC_OMP_WORKSHARE:
4244 gfc_internal_error ("resolve_block(): Bad block type");
4247 resolve_code (b->next, ns);
4252 /* Given a block of code, recursively resolve everything pointed to by this
4256 resolve_code (gfc_code * code, gfc_namespace * ns)
4258 int omp_workshare_save;
4263 frame.prev = cs_base;
4267 for (; code; code = code->next)
4269 frame.current = code;
4271 if (code->op == EXEC_FORALL)
4273 int forall_save = forall_flag;
4276 gfc_resolve_forall (code, ns, forall_save);
4277 forall_flag = forall_save;
4279 else if (code->block)
4281 omp_workshare_save = -1;
4284 case EXEC_OMP_PARALLEL_WORKSHARE:
4285 omp_workshare_save = omp_workshare_flag;
4286 omp_workshare_flag = 1;
4287 gfc_resolve_omp_parallel_blocks (code, ns);
4289 case EXEC_OMP_PARALLEL:
4290 case EXEC_OMP_PARALLEL_DO:
4291 case EXEC_OMP_PARALLEL_SECTIONS:
4292 omp_workshare_save = omp_workshare_flag;
4293 omp_workshare_flag = 0;
4294 gfc_resolve_omp_parallel_blocks (code, ns);
4297 gfc_resolve_omp_do_blocks (code, ns);
4299 case EXEC_OMP_WORKSHARE:
4300 omp_workshare_save = omp_workshare_flag;
4301 omp_workshare_flag = 1;
4304 gfc_resolve_blocks (code->block, ns);
4308 if (omp_workshare_save != -1)
4309 omp_workshare_flag = omp_workshare_save;
4312 t = gfc_resolve_expr (code->expr);
4313 if (gfc_resolve_expr (code->expr2) == FAILURE)
4329 resolve_where (code, NULL);
4333 if (code->expr != NULL)
4335 if (code->expr->ts.type != BT_INTEGER)
4336 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4337 "variable", &code->expr->where);
4338 else if (code->expr->symtree->n.sym->attr.assign != 1)
4339 gfc_error ("Variable '%s' has not been assigned a target label "
4340 "at %L", code->expr->symtree->n.sym->name,
4341 &code->expr->where);
4344 resolve_branch (code->label, code);
4348 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4349 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4350 "return specifier", &code->expr->where);
4357 if (gfc_extend_assign (code, ns) == SUCCESS)
4359 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4361 gfc_error ("Subroutine '%s' called instead of assignment at "
4362 "%L must be PURE", code->symtree->n.sym->name,
4369 if (gfc_pure (NULL))
4371 if (gfc_impure_variable (code->expr->symtree->n.sym))
4374 ("Cannot assign to variable '%s' in PURE procedure at %L",
4375 code->expr->symtree->n.sym->name, &code->expr->where);
4379 if (code->expr2->ts.type == BT_DERIVED
4380 && derived_pointer (code->expr2->ts.derived))
4383 ("Right side of assignment at %L is a derived type "
4384 "containing a POINTER in a PURE procedure",
4385 &code->expr2->where);
4390 gfc_check_assign (code->expr, code->expr2, 1);
4393 case EXEC_LABEL_ASSIGN:
4394 if (code->label->defined == ST_LABEL_UNKNOWN)
4395 gfc_error ("Label %d referenced at %L is never defined",
4396 code->label->value, &code->label->where);
4398 && (code->expr->expr_type != EXPR_VARIABLE
4399 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4400 || code->expr->symtree->n.sym->ts.kind
4401 != gfc_default_integer_kind
4402 || code->expr->symtree->n.sym->as != NULL))
4403 gfc_error ("ASSIGN statement at %L requires a scalar "
4404 "default INTEGER variable", &code->expr->where);
4407 case EXEC_POINTER_ASSIGN:
4411 gfc_check_pointer_assign (code->expr, code->expr2);
4414 case EXEC_ARITHMETIC_IF:
4416 && code->expr->ts.type != BT_INTEGER
4417 && code->expr->ts.type != BT_REAL)
4418 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4419 "expression", &code->expr->where);
4421 resolve_branch (code->label, code);
4422 resolve_branch (code->label2, code);
4423 resolve_branch (code->label3, code);
4427 if (t == SUCCESS && code->expr != NULL
4428 && (code->expr->ts.type != BT_LOGICAL
4429 || code->expr->rank != 0))
4430 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4431 &code->expr->where);
4436 resolve_call (code);
4440 /* Select is complicated. Also, a SELECT construct could be
4441 a transformed computed GOTO. */
4442 resolve_select (code);
4446 if (code->ext.iterator != NULL)
4448 gfc_iterator *iter = code->ext.iterator;
4449 if (gfc_resolve_iterator (iter, true) != FAILURE)
4450 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4455 if (code->expr == NULL)
4456 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4458 && (code->expr->rank != 0
4459 || code->expr->ts.type != BT_LOGICAL))
4460 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4461 "a scalar LOGICAL expression", &code->expr->where);
4465 if (t == SUCCESS && code->expr != NULL
4466 && code->expr->ts.type != BT_INTEGER)
4467 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4468 "of type INTEGER", &code->expr->where);
4470 for (a = code->ext.alloc_list; a; a = a->next)
4471 resolve_allocate_expr (a->expr, code);
4475 case EXEC_DEALLOCATE:
4476 if (t == SUCCESS && code->expr != NULL
4477 && code->expr->ts.type != BT_INTEGER)
4479 ("STAT tag in DEALLOCATE statement at %L must be of type "
4480 "INTEGER", &code->expr->where);
4482 for (a = code->ext.alloc_list; a; a = a->next)
4483 resolve_deallocate_expr (a->expr);
4488 if (gfc_resolve_open (code->ext.open) == FAILURE)
4491 resolve_branch (code->ext.open->err, code);
4495 if (gfc_resolve_close (code->ext.close) == FAILURE)
4498 resolve_branch (code->ext.close->err, code);
4501 case EXEC_BACKSPACE:
4505 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4508 resolve_branch (code->ext.filepos->err, code);
4512 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4515 resolve_branch (code->ext.inquire->err, code);
4519 gcc_assert (code->ext.inquire != NULL);
4520 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4523 resolve_branch (code->ext.inquire->err, code);
4528 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4531 resolve_branch (code->ext.dt->err, code);
4532 resolve_branch (code->ext.dt->end, code);
4533 resolve_branch (code->ext.dt->eor, code);
4537 resolve_transfer (code);
4541 resolve_forall_iterators (code->ext.forall_iterator);
4543 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4545 ("FORALL mask clause at %L requires a LOGICAL expression",
4546 &code->expr->where);
4549 case EXEC_OMP_ATOMIC:
4550 case EXEC_OMP_BARRIER:
4551 case EXEC_OMP_CRITICAL:
4552 case EXEC_OMP_FLUSH:
4554 case EXEC_OMP_MASTER:
4555 case EXEC_OMP_ORDERED:
4556 case EXEC_OMP_SECTIONS:
4557 case EXEC_OMP_SINGLE:
4558 case EXEC_OMP_WORKSHARE:
4559 gfc_resolve_omp_directive (code, ns);
4562 case EXEC_OMP_PARALLEL:
4563 case EXEC_OMP_PARALLEL_DO:
4564 case EXEC_OMP_PARALLEL_SECTIONS:
4565 case EXEC_OMP_PARALLEL_WORKSHARE:
4566 omp_workshare_save = omp_workshare_flag;
4567 omp_workshare_flag = 0;
4568 gfc_resolve_omp_directive (code, ns);
4569 omp_workshare_flag = omp_workshare_save;
4573 gfc_internal_error ("resolve_code(): Bad statement code");
4577 cs_base = frame.prev;
4581 /* Resolve initial values and make sure they are compatible with
4585 resolve_values (gfc_symbol * sym)
4588 if (sym->value == NULL)
4591 if (gfc_resolve_expr (sym->value) == FAILURE)
4594 gfc_check_assign_symbol (sym, sym->value);
4598 /* Resolve an index expression. */
4601 resolve_index_expr (gfc_expr * e)
4604 if (gfc_resolve_expr (e) == FAILURE)
4607 if (gfc_simplify_expr (e, 0) == FAILURE)
4610 if (gfc_specification_expr (e) == FAILURE)
4616 /* Resolve a charlen structure. */
4619 resolve_charlen (gfc_charlen *cl)
4626 if (resolve_index_expr (cl->length) == FAILURE)
4633 /* Test for non-constant shape arrays. */
4636 is_non_constant_shape_array (gfc_symbol *sym)
4641 if (sym->as != NULL)
4643 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
4644 has not been simplified; parameter array references. Do the
4645 simplification now. */
4646 for (i = 0; i < sym->as->rank; i++)
4648 e = sym->as->lower[i];
4649 if (e && (resolve_index_expr (e) == FAILURE
4650 || !gfc_is_constant_expr (e)))
4653 e = sym->as->upper[i];
4654 if (e && (resolve_index_expr (e) == FAILURE
4655 || !gfc_is_constant_expr (e)))
4662 /* Resolution of common features of flavors variable and procedure. */
4665 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
4667 /* Constraints on deferred shape variable. */
4668 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4670 if (sym->attr.allocatable)
4672 if (sym->attr.dimension)
4673 gfc_error ("Allocatable array '%s' at %L must have "
4674 "a deferred shape", sym->name, &sym->declared_at);
4676 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4677 sym->name, &sym->declared_at);
4681 if (sym->attr.pointer && sym->attr.dimension)
4683 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4684 sym->name, &sym->declared_at);
4691 if (!mp_flag && !sym->attr.allocatable
4692 && !sym->attr.pointer && !sym->attr.dummy)
4694 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4695 sym->name, &sym->declared_at);
4702 /* Resolve symbols with flavor variable. */
4705 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
4710 gfc_expr *constructor_expr;
4712 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4715 /* The shape of a main program or module array needs to be constant. */
4716 if (sym->ns->proc_name
4717 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4718 || sym->ns->proc_name->attr.is_main_program)
4719 && !sym->attr.use_assoc
4720 && !sym->attr.allocatable
4721 && !sym->attr.pointer
4722 && is_non_constant_shape_array (sym))
4724 gfc_error ("The module or main program array '%s' at %L must "
4725 "have constant shape", sym->name, &sym->declared_at);
4729 if (sym->ts.type == BT_CHARACTER)
4731 /* Make sure that character string variables with assumed length are
4733 e = sym->ts.cl->length;
4734 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
4736 gfc_error ("Entity with assumed character length at %L must be a "
4737 "dummy argument or a PARAMETER", &sym->declared_at);
4741 if (!gfc_is_constant_expr (e)
4742 && !(e->expr_type == EXPR_VARIABLE
4743 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
4744 && sym->ns->proc_name
4745 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4746 || sym->ns->proc_name->attr.is_main_program)
4747 && !sym->attr.use_assoc)
4749 gfc_error ("'%s' at %L must have constant character length "
4750 "in this context", sym->name, &sym->declared_at);
4755 /* Can the symbol have an initializer? */
4757 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4758 || sym->attr.intrinsic || sym->attr.result)
4760 else if (sym->attr.dimension && !sym->attr.pointer)
4762 /* Don't allow initialization of automatic arrays. */
4763 for (i = 0; i < sym->as->rank; i++)
4765 if (sym->as->lower[i] == NULL
4766 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4767 || sym->as->upper[i] == NULL
4768 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4776 /* Reject illegal initializers. */
4777 if (sym->value && flag)
4779 if (sym->attr.allocatable)
4780 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4781 sym->name, &sym->declared_at);
4782 else if (sym->attr.external)
4783 gfc_error ("External '%s' at %L cannot have an initializer",
4784 sym->name, &sym->declared_at);
4785 else if (sym->attr.dummy)
4786 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4787 sym->name, &sym->declared_at);
4788 else if (sym->attr.intrinsic)
4789 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4790 sym->name, &sym->declared_at);
4791 else if (sym->attr.result)
4792 gfc_error ("Function result '%s' at %L cannot have an initializer",
4793 sym->name, &sym->declared_at);
4795 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4796 sym->name, &sym->declared_at);
4800 /* 4th constraint in section 11.3: "If an object of a type for which
4801 component-initialization is specified (R429) appears in the
4802 specification-part of a module and does not have the ALLOCATABLE
4803 or POINTER attribute, the object shall have the SAVE attribute." */
4805 constructor_expr = NULL;
4806 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
4807 constructor_expr = gfc_default_initializer (&sym->ts);
4809 if (sym->ns->proc_name
4810 && sym->ns->proc_name->attr.flavor == FL_MODULE
4812 && !sym->ns->save_all && !sym->attr.save
4813 && !sym->attr.pointer && !sym->attr.allocatable)
4815 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4816 sym->name, &sym->declared_at,
4817 "for default initialization of a component");
4821 /* Assign default initializer. */
4822 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4823 && !sym->attr.pointer)
4824 sym->value = gfc_default_initializer (&sym->ts);
4830 /* Resolve a procedure. */
4833 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
4835 gfc_formal_arglist *arg;
4837 if (sym->attr.function
4838 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4841 if (sym->attr.proc == PROC_ST_FUNCTION)
4843 if (sym->ts.type == BT_CHARACTER)
4845 gfc_charlen *cl = sym->ts.cl;
4846 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4848 gfc_error ("Character-valued statement function '%s' at %L must "
4849 "have constant length", sym->name, &sym->declared_at);
4855 /* Ensure that derived type for are not of a private type. Internal
4856 module procedures are excluded by 2.2.3.3 - ie. they are not
4857 externally accessible and can access all the objects accessible in
4859 if (!(sym->ns->parent
4860 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
4861 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4863 for (arg = sym->formal; arg; arg = arg->next)
4866 && arg->sym->ts.type == BT_DERIVED
4867 && !arg->sym->ts.derived->attr.use_assoc
4868 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4869 arg->sym->ts.derived->ns->default_access))
4871 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
4872 "a dummy argument of '%s', which is "
4873 "PUBLIC at %L", arg->sym->name, sym->name,
4875 /* Stop this message from recurring. */
4876 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4882 /* An external symbol may not have an intializer because it is taken to be
4884 if (sym->attr.external && sym->value)
4886 gfc_error ("External object '%s' at %L may not have an initializer",
4887 sym->name, &sym->declared_at);
4891 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4892 char-len-param shall not be array-valued, pointer-valued, recursive
4893 or pure. ....snip... A character value of * may only be used in the
4894 following ways: (i) Dummy arg of procedure - dummy associates with
4895 actual length; (ii) To declare a named constant; or (iii) External
4896 function - but length must be declared in calling scoping unit. */
4897 if (sym->attr.function
4898 && sym->ts.type == BT_CHARACTER
4899 && sym->ts.cl && sym->ts.cl->length == NULL)
4901 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
4902 || (sym->attr.recursive) || (sym->attr.pure))
4904 if (sym->as && sym->as->rank)
4905 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4906 "array-valued", sym->name, &sym->declared_at);
4908 if (sym->attr.pointer)
4909 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4910 "pointer-valued", sym->name, &sym->declared_at);
4913 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4914 "pure", sym->name, &sym->declared_at);
4916 if (sym->attr.recursive)
4917 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4918 "recursive", sym->name, &sym->declared_at);
4923 /* Appendix B.2 of the standard. Contained functions give an
4924 error anyway. Fixed-form is likely to be F77/legacy. */
4925 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
4926 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
4927 "'%s' at %L is obsolescent in fortran 95",
4928 sym->name, &sym->declared_at);
4934 /* Resolve the components of a derived type. */
4937 resolve_fl_derived (gfc_symbol *sym)
4940 gfc_dt_list * dt_list;
4943 for (c = sym->components; c != NULL; c = c->next)
4945 if (c->ts.type == BT_CHARACTER)
4947 if (c->ts.cl->length == NULL
4948 || (resolve_charlen (c->ts.cl) == FAILURE)
4949 || !gfc_is_constant_expr (c->ts.cl->length))
4951 gfc_error ("Character length of component '%s' needs to "
4952 "be a constant specification expression at %L.",
4954 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
4959 if (c->ts.type == BT_DERIVED
4960 && sym->component_access != ACCESS_PRIVATE
4961 && gfc_check_access(sym->attr.access, sym->ns->default_access)
4962 && !c->ts.derived->attr.use_assoc
4963 && !gfc_check_access(c->ts.derived->attr.access,
4964 c->ts.derived->ns->default_access))
4966 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4967 "a component of '%s', which is PUBLIC at %L",
4968 c->name, sym->name, &sym->declared_at);
4972 if (c->pointer || c->as == NULL)
4975 for (i = 0; i < c->as->rank; i++)
4977 if (c->as->lower[i] == NULL
4978 || !gfc_is_constant_expr (c->as->lower[i])
4979 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
4980 || c->as->upper[i] == NULL
4981 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
4982 || !gfc_is_constant_expr (c->as->upper[i]))
4984 gfc_error ("Component '%s' of '%s' at %L must have "
4985 "constant array bounds.",
4986 c->name, sym->name, &c->loc);
4992 /* Add derived type to the derived type list. */
4993 dt_list = gfc_get_dt_list ();
4994 dt_list->next = sym->ns->derived_types;
4995 dt_list->derived = sym;
4996 sym->ns->derived_types = dt_list;
5003 resolve_fl_namelist (gfc_symbol *sym)
5008 /* Reject PRIVATE objects in a PUBLIC namelist. */
5009 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5011 for (nl = sym->namelist; nl; nl = nl->next)
5013 if (!nl->sym->attr.use_assoc
5014 && !(sym->ns->parent == nl->sym->ns)
5015 && !gfc_check_access(nl->sym->attr.access,
5016 nl->sym->ns->default_access))
5018 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5019 "PUBLIC namelist at %L", nl->sym->name,
5026 /* Reject namelist arrays that are not constant shape. */
5027 for (nl = sym->namelist; nl; nl = nl->next)
5029 if (is_non_constant_shape_array (nl->sym))
5031 gfc_error ("The array '%s' must have constant shape to be "
5032 "a NAMELIST object at %L", nl->sym->name,
5038 /* 14.1.2 A module or internal procedure represent local entities
5039 of the same type as a namelist member and so are not allowed.
5040 Note that this is sometimes caught by check_conflict so the
5041 same message has been used. */
5042 for (nl = sym->namelist; nl; nl = nl->next)
5045 if (sym->ns->parent && nl->sym && nl->sym->name)
5046 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5047 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5049 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5050 "attribute in '%s' at %L", nlsym->name,
5061 resolve_fl_parameter (gfc_symbol *sym)
5063 /* A parameter array's shape needs to be constant. */
5064 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5066 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5067 "or assumed shape", sym->name, &sym->declared_at);
5071 /* Make sure a parameter that has been implicitly typed still
5072 matches the implicit type, since PARAMETER statements can precede
5073 IMPLICIT statements. */
5074 if (sym->attr.implicit_type
5075 && !gfc_compare_types (&sym->ts,
5076 gfc_get_default_type (sym, sym->ns)))
5078 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5079 "later IMPLICIT type", sym->name, &sym->declared_at);
5083 /* Make sure the types of derived parameters are consistent. This
5084 type checking is deferred until resolution because the type may
5085 refer to a derived type from the host. */
5086 if (sym->ts.type == BT_DERIVED
5087 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5089 gfc_error ("Incompatible derived type in PARAMETER at %L",
5090 &sym->value->where);
5097 /* Do anything necessary to resolve a symbol. Right now, we just
5098 assume that an otherwise unknown symbol is a variable. This sort
5099 of thing commonly happens for symbols in module. */
5102 resolve_symbol (gfc_symbol * sym)
5104 /* Zero if we are checking a formal namespace. */
5105 static int formal_ns_flag = 1;
5106 int formal_ns_save, check_constant, mp_flag;
5107 gfc_symtree *symtree;
5108 gfc_symtree *this_symtree;
5112 if (sym->attr.flavor == FL_UNKNOWN)
5115 /* If we find that a flavorless symbol is an interface in one of the
5116 parent namespaces, find its symtree in this namespace, free the
5117 symbol and set the symtree to point to the interface symbol. */
5118 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5120 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5121 if (symtree && symtree->n.sym->generic)
5123 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5127 gfc_free_symbol (sym);
5128 symtree->n.sym->refs++;
5129 this_symtree->n.sym = symtree->n.sym;
5134 /* Otherwise give it a flavor according to such attributes as
5136 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5137 sym->attr.flavor = FL_VARIABLE;
5140 sym->attr.flavor = FL_PROCEDURE;
5141 if (sym->attr.dimension)
5142 sym->attr.function = 1;
5146 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5149 /* Symbols that are module procedures with results (functions) have
5150 the types and array specification copied for type checking in
5151 procedures that call them, as well as for saving to a module
5152 file. These symbols can't stand the scrutiny that their results
5154 mp_flag = (sym->result != NULL && sym->result != sym);
5156 /* Assign default type to symbols that need one and don't have one. */
5157 if (sym->ts.type == BT_UNKNOWN)
5159 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5160 gfc_set_default_type (sym, 1, NULL);
5162 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5164 /* The specific case of an external procedure should emit an error
5165 in the case that there is no implicit type. */
5167 gfc_set_default_type (sym, sym->attr.external, NULL);
5170 /* Result may be in another namespace. */
5171 resolve_symbol (sym->result);
5173 sym->ts = sym->result->ts;
5174 sym->as = gfc_copy_array_spec (sym->result->as);
5175 sym->attr.dimension = sym->result->attr.dimension;
5176 sym->attr.pointer = sym->result->attr.pointer;
5177 sym->attr.allocatable = sym->result->attr.allocatable;
5182 /* Assumed size arrays and assumed shape arrays must be dummy
5186 && (sym->as->type == AS_ASSUMED_SIZE
5187 || sym->as->type == AS_ASSUMED_SHAPE)
5188 && sym->attr.dummy == 0)
5190 if (sym->as->type == AS_ASSUMED_SIZE)
5191 gfc_error ("Assumed size array at %L must be a dummy argument",
5194 gfc_error ("Assumed shape array at %L must be a dummy argument",
5199 /* Make sure symbols with known intent or optional are really dummy
5200 variable. Because of ENTRY statement, this has to be deferred
5201 until resolution time. */
5203 if (!sym->attr.dummy
5204 && (sym->attr.optional
5205 || sym->attr.intent != INTENT_UNKNOWN))
5207 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5211 /* If a derived type symbol has reached this point, without its
5212 type being declared, we have an error. Notice that most
5213 conditions that produce undefined derived types have already
5214 been dealt with. However, the likes of:
5215 implicit type(t) (t) ..... call foo (t) will get us here if
5216 the type is not declared in the scope of the implicit
5217 statement. Change the type to BT_UNKNOWN, both because it is so
5218 and to prevent an ICE. */
5219 if (sym->ts.type == BT_DERIVED
5220 && sym->ts.derived->components == NULL)
5222 gfc_error ("The derived type '%s' at %L is of type '%s', "
5223 "which has not been defined.", sym->name,
5224 &sym->declared_at, sym->ts.derived->name);
5225 sym->ts.type = BT_UNKNOWN;
5229 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5230 default initialization is defined (5.1.2.4.4). */
5231 if (sym->ts.type == BT_DERIVED
5233 && sym->attr.intent == INTENT_OUT
5235 && sym->as->type == AS_ASSUMED_SIZE)
5237 for (c = sym->ts.derived->components; c; c = c->next)
5241 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5242 "ASSUMED SIZE and so cannot have a default initializer",
5243 sym->name, &sym->declared_at);
5249 switch (sym->attr.flavor)
5252 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5257 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5262 if (resolve_fl_namelist (sym) == FAILURE)
5267 if (resolve_fl_parameter (sym) == FAILURE)
5277 /* Make sure that intrinsic exist */
5278 if (sym->attr.intrinsic
5279 && ! gfc_intrinsic_name(sym->name, 0)
5280 && ! gfc_intrinsic_name(sym->name, 1))
5281 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5283 /* Resolve array specifier. Check as well some constraints
5284 on COMMON blocks. */
5286 check_constant = sym->attr.in_common && !sym->attr.pointer;
5287 gfc_resolve_array_spec (sym->as, check_constant);
5289 /* Resolve formal namespaces. */
5291 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5293 formal_ns_save = formal_ns_flag;
5295 gfc_resolve (sym->formal_ns);
5296 formal_ns_flag = formal_ns_save;
5299 /* Check threadprivate restrictions. */
5300 if (sym->attr.threadprivate && !sym->attr.save
5301 && (!sym->attr.in_common
5302 && sym->module == NULL
5303 && (sym->ns->proc_name == NULL
5304 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5305 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5310 /************* Resolve DATA statements *************/
5314 gfc_data_value *vnode;
5320 /* Advance the values structure to point to the next value in the data list. */
5323 next_data_value (void)
5325 while (values.left == 0)
5327 if (values.vnode->next == NULL)
5330 values.vnode = values.vnode->next;
5331 values.left = values.vnode->repeat;
5339 check_data_variable (gfc_data_variable * var, locus * where)
5345 ar_type mark = AR_UNKNOWN;
5347 mpz_t section_index[GFC_MAX_DIMENSIONS];
5351 if (gfc_resolve_expr (var->expr) == FAILURE)
5355 mpz_init_set_si (offset, 0);
5358 if (e->expr_type != EXPR_VARIABLE)
5359 gfc_internal_error ("check_data_variable(): Bad expression");
5361 if (e->symtree->n.sym->ns->is_block_data
5362 && !e->symtree->n.sym->attr.in_common)
5364 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5365 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5370 mpz_init_set_ui (size, 1);
5377 /* Find the array section reference. */
5378 for (ref = e->ref; ref; ref = ref->next)
5380 if (ref->type != REF_ARRAY)
5382 if (ref->u.ar.type == AR_ELEMENT)
5388 /* Set marks according to the reference pattern. */
5389 switch (ref->u.ar.type)
5397 /* Get the start position of array section. */
5398 gfc_get_section_index (ar, section_index, &offset);
5406 if (gfc_array_size (e, &size) == FAILURE)
5408 gfc_error ("Nonconstant array section at %L in DATA statement",
5417 while (mpz_cmp_ui (size, 0) > 0)
5419 if (next_data_value () == FAILURE)
5421 gfc_error ("DATA statement at %L has more variables than values",
5427 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5431 /* If we have more than one element left in the repeat count,
5432 and we have more than one element left in the target variable,
5433 then create a range assignment. */
5434 /* ??? Only done for full arrays for now, since array sections
5436 if (mark == AR_FULL && ref && ref->next == NULL
5437 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5441 if (mpz_cmp_ui (size, values.left) >= 0)
5443 mpz_init_set_ui (range, values.left);
5444 mpz_sub_ui (size, size, values.left);
5449 mpz_init_set (range, size);
5450 values.left -= mpz_get_ui (size);
5451 mpz_set_ui (size, 0);
5454 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5457 mpz_add (offset, offset, range);
5461 /* Assign initial value to symbol. */
5465 mpz_sub_ui (size, size, 1);
5467 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5469 if (mark == AR_FULL)
5470 mpz_add_ui (offset, offset, 1);
5472 /* Modify the array section indexes and recalculate the offset
5473 for next element. */
5474 else if (mark == AR_SECTION)
5475 gfc_advance_section (section_index, ar, &offset);
5479 if (mark == AR_SECTION)
5481 for (i = 0; i < ar->dimen; i++)
5482 mpz_clear (section_index[i]);
5492 static try traverse_data_var (gfc_data_variable *, locus *);
5494 /* Iterate over a list of elements in a DATA statement. */
5497 traverse_data_list (gfc_data_variable * var, locus * where)
5500 iterator_stack frame;
5503 mpz_init (frame.value);
5505 mpz_init_set (trip, var->iter.end->value.integer);
5506 mpz_sub (trip, trip, var->iter.start->value.integer);
5507 mpz_add (trip, trip, var->iter.step->value.integer);
5509 mpz_div (trip, trip, var->iter.step->value.integer);
5511 mpz_set (frame.value, var->iter.start->value.integer);
5513 frame.prev = iter_stack;
5514 frame.variable = var->iter.var->symtree;
5515 iter_stack = &frame;
5517 while (mpz_cmp_ui (trip, 0) > 0)
5519 if (traverse_data_var (var->list, where) == FAILURE)
5525 e = gfc_copy_expr (var->expr);
5526 if (gfc_simplify_expr (e, 1) == FAILURE)
5532 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5534 mpz_sub_ui (trip, trip, 1);
5538 mpz_clear (frame.value);
5540 iter_stack = frame.prev;
5545 /* Type resolve variables in the variable list of a DATA statement. */
5548 traverse_data_var (gfc_data_variable * var, locus * where)
5552 for (; var; var = var->next)
5554 if (var->expr == NULL)
5555 t = traverse_data_list (var, where);
5557 t = check_data_variable (var, where);
5567 /* Resolve the expressions and iterators associated with a data statement.
5568 This is separate from the assignment checking because data lists should
5569 only be resolved once. */
5572 resolve_data_variables (gfc_data_variable * d)
5574 for (; d; d = d->next)
5576 if (d->list == NULL)
5578 if (gfc_resolve_expr (d->expr) == FAILURE)
5583 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5586 if (d->iter.start->expr_type != EXPR_CONSTANT
5587 || d->iter.end->expr_type != EXPR_CONSTANT
5588 || d->iter.step->expr_type != EXPR_CONSTANT)
5589 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5591 if (resolve_data_variables (d->list) == FAILURE)
5600 /* Resolve a single DATA statement. We implement this by storing a pointer to
5601 the value list into static variables, and then recursively traversing the
5602 variables list, expanding iterators and such. */
5605 resolve_data (gfc_data * d)
5607 if (resolve_data_variables (d->var) == FAILURE)
5610 values.vnode = d->value;
5611 values.left = (d->value == NULL) ? 0 : d->value->repeat;
5613 if (traverse_data_var (d->var, &d->where) == FAILURE)
5616 /* At this point, we better not have any values left. */
5618 if (next_data_value () == SUCCESS)
5619 gfc_error ("DATA statement at %L has more values than variables",
5624 /* Determines if a variable is not 'pure', ie not assignable within a pure
5625 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5629 gfc_impure_variable (gfc_symbol * sym)
5631 if (sym->attr.use_assoc || sym->attr.in_common)
5634 if (sym->ns != gfc_current_ns)
5635 return !sym->attr.function;
5637 /* TODO: Check storage association through EQUIVALENCE statements */
5643 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5644 symbol of the current procedure. */
5647 gfc_pure (gfc_symbol * sym)
5649 symbol_attribute attr;
5652 sym = gfc_current_ns->proc_name;
5658 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5662 /* Test whether the current procedure is elemental or not. */
5665 gfc_elemental (gfc_symbol * sym)
5667 symbol_attribute attr;
5670 sym = gfc_current_ns->proc_name;
5675 return attr.flavor == FL_PROCEDURE && attr.elemental;
5679 /* Warn about unused labels. */
5682 warn_unused_label (gfc_st_label * label)
5687 warn_unused_label (label->left);
5689 if (label->defined == ST_LABEL_UNKNOWN)
5692 switch (label->referenced)
5694 case ST_LABEL_UNKNOWN:
5695 gfc_warning ("Label %d at %L defined but not used", label->value,
5699 case ST_LABEL_BAD_TARGET:
5700 gfc_warning ("Label %d at %L defined but cannot be used",
5701 label->value, &label->where);
5708 warn_unused_label (label->right);
5712 /* Returns the sequence type of a symbol or sequence. */
5715 sequence_type (gfc_typespec ts)
5724 if (ts.derived->components == NULL)
5725 return SEQ_NONDEFAULT;
5727 result = sequence_type (ts.derived->components->ts);
5728 for (c = ts.derived->components->next; c; c = c->next)
5729 if (sequence_type (c->ts) != result)
5735 if (ts.kind != gfc_default_character_kind)
5736 return SEQ_NONDEFAULT;
5738 return SEQ_CHARACTER;
5741 if (ts.kind != gfc_default_integer_kind)
5742 return SEQ_NONDEFAULT;
5747 if (!(ts.kind == gfc_default_real_kind
5748 || ts.kind == gfc_default_double_kind))
5749 return SEQ_NONDEFAULT;
5754 if (ts.kind != gfc_default_complex_kind)
5755 return SEQ_NONDEFAULT;
5760 if (ts.kind != gfc_default_logical_kind)
5761 return SEQ_NONDEFAULT;
5766 return SEQ_NONDEFAULT;
5771 /* Resolve derived type EQUIVALENCE object. */
5774 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5777 gfc_component *c = derived->components;
5782 /* Shall not be an object of nonsequence derived type. */
5783 if (!derived->attr.sequence)
5785 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5786 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5790 for (; c ; c = c->next)
5793 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5796 /* Shall not be an object of sequence derived type containing a pointer
5797 in the structure. */
5800 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5801 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5807 gfc_error ("Derived type variable '%s' at %L with default initializer "
5808 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5816 /* Resolve equivalence object.
5817 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5818 an allocatable array, an object of nonsequence derived type, an object of
5819 sequence derived type containing a pointer at any level of component
5820 selection, an automatic object, a function name, an entry name, a result
5821 name, a named constant, a structure component, or a subobject of any of
5822 the preceding objects. A substring shall not have length zero. A
5823 derived type shall not have components with default initialization nor
5824 shall two objects of an equivalence group be initialized.
5825 The simple constraints are done in symbol.c(check_conflict) and the rest
5826 are implemented here. */
5829 resolve_equivalence (gfc_equiv *eq)
5832 gfc_symbol *derived;
5833 gfc_symbol *first_sym;
5836 locus *last_where = NULL;
5837 seq_type eq_type, last_eq_type;
5838 gfc_typespec *last_ts;
5840 const char *value_name;
5844 last_ts = &eq->expr->symtree->n.sym->ts;
5846 first_sym = eq->expr->symtree->n.sym;
5848 for (object = 1; eq; eq = eq->eq, object++)
5852 e->ts = e->symtree->n.sym->ts;
5853 /* match_varspec might not know yet if it is seeing
5854 array reference or substring reference, as it doesn't
5856 if (e->ref && e->ref->type == REF_ARRAY)
5858 gfc_ref *ref = e->ref;
5859 sym = e->symtree->n.sym;
5861 if (sym->attr.dimension)
5863 ref->u.ar.as = sym->as;
5867 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5868 if (e->ts.type == BT_CHARACTER
5870 && ref->type == REF_ARRAY
5871 && ref->u.ar.dimen == 1
5872 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5873 && ref->u.ar.stride[0] == NULL)
5875 gfc_expr *start = ref->u.ar.start[0];
5876 gfc_expr *end = ref->u.ar.end[0];
5879 /* Optimize away the (:) reference. */
5880 if (start == NULL && end == NULL)
5885 e->ref->next = ref->next;
5890 ref->type = REF_SUBSTRING;
5892 start = gfc_int_expr (1);
5893 ref->u.ss.start = start;
5894 if (end == NULL && e->ts.cl)
5895 end = gfc_copy_expr (e->ts.cl->length);
5896 ref->u.ss.end = end;
5897 ref->u.ss.length = e->ts.cl;
5904 /* Any further ref is an error. */
5907 gcc_assert (ref->type == REF_ARRAY);
5908 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5914 if (gfc_resolve_expr (e) == FAILURE)
5917 sym = e->symtree->n.sym;
5919 /* An equivalence statement cannot have more than one initialized
5923 if (value_name != NULL)
5925 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5926 "be in the EQUIVALENCE statement at %L",
5927 value_name, sym->name, &e->where);
5931 value_name = sym->name;
5934 /* Shall not equivalence common block variables in a PURE procedure. */
5935 if (sym->ns->proc_name
5936 && sym->ns->proc_name->attr.pure
5937 && sym->attr.in_common)
5939 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5940 "object in the pure procedure '%s'",
5941 sym->name, &e->where, sym->ns->proc_name->name);
5945 /* Shall not be a named constant. */
5946 if (e->expr_type == EXPR_CONSTANT)
5948 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5949 "object", sym->name, &e->where);
5953 derived = e->ts.derived;
5954 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5957 /* Check that the types correspond correctly:
5959 A numeric sequence structure may be equivalenced to another sequence
5960 structure, an object of default integer type, default real type, double
5961 precision real type, default logical type such that components of the
5962 structure ultimately only become associated to objects of the same
5963 kind. A character sequence structure may be equivalenced to an object
5964 of default character kind or another character sequence structure.
5965 Other objects may be equivalenced only to objects of the same type and
5968 /* Identical types are unconditionally OK. */
5969 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5970 goto identical_types;
5972 last_eq_type = sequence_type (*last_ts);
5973 eq_type = sequence_type (sym->ts);
5975 /* Since the pair of objects is not of the same type, mixed or
5976 non-default sequences can be rejected. */
5978 msg = "Sequence %s with mixed components in EQUIVALENCE "
5979 "statement at %L with different type objects";
5981 && last_eq_type == SEQ_MIXED
5982 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5983 last_where) == FAILURE)
5984 || (eq_type == SEQ_MIXED
5985 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5986 &e->where) == FAILURE))
5989 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5990 "statement at %L with objects of different type";
5992 && last_eq_type == SEQ_NONDEFAULT
5993 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5994 last_where) == FAILURE)
5995 || (eq_type == SEQ_NONDEFAULT
5996 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5997 &e->where) == FAILURE))
6000 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6001 "EQUIVALENCE statement at %L";
6002 if (last_eq_type == SEQ_CHARACTER
6003 && eq_type != SEQ_CHARACTER
6004 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6005 &e->where) == FAILURE)
6008 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6009 "EQUIVALENCE statement at %L";
6010 if (last_eq_type == SEQ_NUMERIC
6011 && eq_type != SEQ_NUMERIC
6012 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6013 &e->where) == FAILURE)
6018 last_where = &e->where;
6023 /* Shall not be an automatic array. */
6024 if (e->ref->type == REF_ARRAY
6025 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6027 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6028 "an EQUIVALENCE object", sym->name, &e->where);
6035 /* Shall not be a structure component. */
6036 if (r->type == REF_COMPONENT)
6038 gfc_error ("Structure component '%s' at %L cannot be an "
6039 "EQUIVALENCE object",
6040 r->u.c.component->name, &e->where);
6044 /* A substring shall not have length zero. */
6045 if (r->type == REF_SUBSTRING)
6047 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6049 gfc_error ("Substring at %L has length zero",
6050 &r->u.ss.start->where);
6060 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6063 resolve_fntype (gfc_namespace * ns)
6068 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6071 /* If there are any entries, ns->proc_name is the entry master
6072 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6074 sym = ns->entries->sym;
6076 sym = ns->proc_name;
6077 if (sym->result == sym
6078 && sym->ts.type == BT_UNKNOWN
6079 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6080 && !sym->attr.untyped)
6082 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6083 sym->name, &sym->declared_at);
6084 sym->attr.untyped = 1;
6087 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6088 && !gfc_check_access (sym->ts.derived->attr.access,
6089 sym->ts.derived->ns->default_access)
6090 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6092 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6093 sym->name, &sym->declared_at, sym->ts.derived->name);
6097 for (el = ns->entries->next; el; el = el->next)
6099 if (el->sym->result == el->sym
6100 && el->sym->ts.type == BT_UNKNOWN
6101 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6102 && !el->sym->attr.untyped)
6104 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6105 el->sym->name, &el->sym->declared_at);
6106 el->sym->attr.untyped = 1;
6111 /* 12.3.2.1.1 Defined operators. */
6114 gfc_resolve_uops(gfc_symtree *symtree)
6118 gfc_formal_arglist *formal;
6120 if (symtree == NULL)
6123 gfc_resolve_uops (symtree->left);
6124 gfc_resolve_uops (symtree->right);
6126 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6129 if (!sym->attr.function)
6130 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6131 sym->name, &sym->declared_at);
6133 if (sym->ts.type == BT_CHARACTER
6134 && !(sym->ts.cl && sym->ts.cl->length)
6135 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6136 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6137 "length", sym->name, &sym->declared_at);
6139 formal = sym->formal;
6140 if (!formal || !formal->sym)
6142 gfc_error("User operator procedure '%s' at %L must have at least "
6143 "one argument", sym->name, &sym->declared_at);
6147 if (formal->sym->attr.intent != INTENT_IN)
6148 gfc_error ("First argument of operator interface at %L must be "
6149 "INTENT(IN)", &sym->declared_at);
6151 if (formal->sym->attr.optional)
6152 gfc_error ("First argument of operator interface at %L cannot be "
6153 "optional", &sym->declared_at);
6155 formal = formal->next;
6156 if (!formal || !formal->sym)
6159 if (formal->sym->attr.intent != INTENT_IN)
6160 gfc_error ("Second argument of operator interface at %L must be "
6161 "INTENT(IN)", &sym->declared_at);
6163 if (formal->sym->attr.optional)
6164 gfc_error ("Second argument of operator interface at %L cannot be "
6165 "optional", &sym->declared_at);
6168 gfc_error ("Operator interface at %L must have, at most, two "
6169 "arguments", &sym->declared_at);
6174 /* Examine all of the expressions associated with a program unit,
6175 assign types to all intermediate expressions, make sure that all
6176 assignments are to compatible types and figure out which names
6177 refer to which functions or subroutines. It doesn't check code
6178 block, which is handled by resolve_code. */
6181 resolve_types (gfc_namespace * ns)
6188 gfc_current_ns = ns;
6190 resolve_entries (ns);
6192 resolve_contained_functions (ns);
6194 gfc_traverse_ns (ns, resolve_symbol);
6196 resolve_fntype (ns);
6198 for (n = ns->contained; n; n = n->sibling)
6200 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6201 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6202 "also be PURE", n->proc_name->name,
6203 &n->proc_name->declared_at);
6209 gfc_check_interfaces (ns);
6211 for (cl = ns->cl_list; cl; cl = cl->next)
6212 resolve_charlen (cl);
6214 gfc_traverse_ns (ns, resolve_values);
6220 for (d = ns->data; d; d = d->next)
6224 gfc_traverse_ns (ns, gfc_formalize_init_value);
6226 for (eq = ns->equiv; eq; eq = eq->next)
6227 resolve_equivalence (eq);
6229 /* Warn about unused labels. */
6230 if (gfc_option.warn_unused_labels)
6231 warn_unused_label (ns->st_labels);
6233 gfc_resolve_uops (ns->uop_root);
6238 /* Call resolve_code recursively. */
6241 resolve_codes (gfc_namespace * ns)
6245 for (n = ns->contained; n; n = n->sibling)
6248 gfc_current_ns = ns;
6250 resolve_code (ns->code, ns);
6254 /* This function is called after a complete program unit has been compiled.
6255 Its purpose is to examine all of the expressions associated with a program
6256 unit, assign types to all intermediate expressions, make sure that all
6257 assignments are to compatible types and figure out which names refer to
6258 which functions or subroutines. */
6261 gfc_resolve (gfc_namespace * ns)
6263 gfc_namespace *old_ns;
6265 old_ns = gfc_current_ns;
6270 gfc_current_ns = old_ns;