1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Types used in equivalence statements. */
32 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
36 /* Stack to push the current if we descend into a block during
37 resolution. See resolve_branch() and resolve_code(). */
39 typedef struct code_stack
41 struct gfc_code *head, *current;
42 struct code_stack *prev;
46 static code_stack *cs_base = NULL;
49 /* Nonzero if we're inside a FORALL block */
51 static int forall_flag;
53 /* Nonzero if we are processing a formal arglist. The corresponding function
54 resets the flag each time that it is read. */
55 static int formal_arg_flag = 0;
58 gfc_is_formal_arg (void)
60 return formal_arg_flag;
63 /* Resolve types of formal argument lists. These have to be done early so that
64 the formal argument lists of module procedures can be copied to the
65 containing module before the individual procedures are resolved
66 individually. We also resolve argument lists of procedures in interface
67 blocks because they are self-contained scoping units.
69 Since a dummy argument cannot be a non-dummy procedure, the only
70 resort left for untyped names are the IMPLICIT types. */
73 resolve_formal_arglist (gfc_symbol * proc)
75 gfc_formal_arglist *f;
79 /* TODO: Procedures whose return character length parameter is not constant
80 or assumed must also have explicit interfaces. */
81 if (proc->result != NULL)
86 if (gfc_elemental (proc)
87 || sym->attr.pointer || sym->attr.allocatable
88 || (sym->as && sym->as->rank > 0))
89 proc->attr.always_explicit = 1;
93 for (f = proc->formal; f; f = f->next)
99 /* Alternate return placeholder. */
100 if (gfc_elemental (proc))
101 gfc_error ("Alternate return specifier in elemental subroutine "
102 "'%s' at %L is not allowed", proc->name,
104 if (proc->attr.function)
105 gfc_error ("Alternate return specifier in function "
106 "'%s' at %L is not allowed", proc->name,
111 if (sym->attr.if_source != IFSRC_UNKNOWN)
112 resolve_formal_arglist (sym);
114 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
116 if (gfc_pure (proc) && !gfc_pure (sym))
119 ("Dummy procedure '%s' of PURE procedure at %L must also "
120 "be PURE", sym->name, &sym->declared_at);
124 if (gfc_elemental (proc))
127 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
135 if (sym->ts.type == BT_UNKNOWN)
137 if (!sym->attr.function || sym->result == sym)
138 gfc_set_default_type (sym, 1, sym->ns);
141 /* Set the type of the RESULT, then copy. */
142 if (sym->result->ts.type == BT_UNKNOWN)
143 gfc_set_default_type (sym->result, 1, sym->result->ns);
145 sym->ts = sym->result->ts;
147 sym->as = gfc_copy_array_spec (sym->result->as);
151 gfc_resolve_array_spec (sym->as, 0);
153 /* We can't tell if an array with dimension (:) is assumed or deferred
154 shape until we know if it has the pointer or allocatable attributes.
156 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
157 && !(sym->attr.pointer || sym->attr.allocatable))
159 sym->as->type = AS_ASSUMED_SHAPE;
160 for (i = 0; i < sym->as->rank; i++)
161 sym->as->lower[i] = gfc_int_expr (1);
164 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
165 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
166 || sym->attr.optional)
167 proc->attr.always_explicit = 1;
169 /* If the flavor is unknown at this point, it has to be a variable.
170 A procedure specification would have already set the type. */
172 if (sym->attr.flavor == FL_UNKNOWN)
173 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
177 if (proc->attr.function && !sym->attr.pointer
178 && sym->attr.flavor != FL_PROCEDURE
179 && sym->attr.intent != INTENT_IN)
181 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
182 "INTENT(IN)", sym->name, proc->name,
185 if (proc->attr.subroutine && !sym->attr.pointer
186 && sym->attr.intent == INTENT_UNKNOWN)
189 ("Argument '%s' of pure subroutine '%s' at %L must have "
190 "its INTENT specified", sym->name, proc->name,
195 if (gfc_elemental (proc))
200 ("Argument '%s' of elemental procedure at %L must be scalar",
201 sym->name, &sym->declared_at);
205 if (sym->attr.pointer)
208 ("Argument '%s' of elemental procedure at %L cannot have "
209 "the POINTER attribute", sym->name, &sym->declared_at);
214 /* Each dummy shall be specified to be scalar. */
215 if (proc->attr.proc == PROC_ST_FUNCTION)
220 ("Argument '%s' of statement function at %L must be scalar",
221 sym->name, &sym->declared_at);
225 if (sym->ts.type == BT_CHARACTER)
227 gfc_charlen *cl = sym->ts.cl;
228 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
231 ("Character-valued argument '%s' of statement function at "
232 "%L must has constant length",
233 sym->name, &sym->declared_at);
243 /* Work function called when searching for symbols that have argument lists
244 associated with them. */
247 find_arglists (gfc_symbol * sym)
250 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
253 resolve_formal_arglist (sym);
257 /* Given a namespace, resolve all formal argument lists within the namespace.
261 resolve_formal_arglists (gfc_namespace * ns)
267 gfc_traverse_ns (ns, find_arglists);
272 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
276 /* If this namespace is not a function, ignore it. */
278 || !(sym->attr.function
279 || sym->attr.flavor == FL_VARIABLE))
282 /* Try to find out of what the return type is. */
283 if (sym->result != NULL)
286 if (sym->ts.type == BT_UNKNOWN)
288 t = gfc_set_default_type (sym, 0, ns);
290 if (t == FAILURE && !sym->attr.untyped)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym->name, &sym->declared_at); /* FIXME */
294 sym->attr.untyped = 1;
298 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
299 lists the only ways a character length value of * can be used: dummy arguments
300 of proceedures, named constants, and function results in external functions.
301 Internal function results are not on that list; ergo, not permitted. */
303 if (sym->ts.type == BT_CHARACTER)
305 gfc_charlen *cl = sym->ts.cl;
306 if (!cl || !cl->length)
307 gfc_error ("Character-valued internal function '%s' at %L must "
308 "not be assumed length", sym->name, &sym->declared_at);
313 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
314 introduce duplicates. */
317 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
319 gfc_formal_arglist *f, *new_arglist;
322 for (; new_args != NULL; new_args = new_args->next)
324 new_sym = new_args->sym;
325 /* See if ths arg is already in the formal argument list. */
326 for (f = proc->formal; f; f = f->next)
328 if (new_sym == f->sym)
335 /* Add a new argument. Argument order is not important. */
336 new_arglist = gfc_get_formal_arglist ();
337 new_arglist->sym = new_sym;
338 new_arglist->next = proc->formal;
339 proc->formal = new_arglist;
344 /* Resolve alternate entry points. If a symbol has multiple entry points we
345 create a new master symbol for the main routine, and turn the existing
346 symbol into an entry point. */
349 resolve_entries (gfc_namespace * ns)
351 gfc_namespace *old_ns;
355 char name[GFC_MAX_SYMBOL_LEN + 1];
356 static int master_count = 0;
358 if (ns->proc_name == NULL)
361 /* No need to do anything if this procedure doesn't have alternate entry
366 /* We may already have resolved alternate entry points. */
367 if (ns->proc_name->attr.entry_master)
370 /* If this isn't a procedure something has gone horribly wrong. */
371 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
373 /* Remember the current namespace. */
374 old_ns = gfc_current_ns;
378 /* Add the main entry point to the list of entry points. */
379 el = gfc_get_entry_list ();
380 el->sym = ns->proc_name;
382 el->next = ns->entries;
384 ns->proc_name->attr.entry = 1;
386 /* Add an entry statement for it. */
393 /* Create a new symbol for the master function. */
394 /* Give the internal function a unique name (within this file).
395 Also include the function name so the user has some hope of figuring
396 out what is going on. */
397 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
398 master_count++, ns->proc_name->name);
399 gfc_get_ha_symbol (name, &proc);
400 gcc_assert (proc != NULL);
402 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
403 if (ns->proc_name->attr.subroutine)
404 gfc_add_subroutine (&proc->attr, proc->name, NULL);
408 gfc_typespec *ts, *fts;
410 gfc_add_function (&proc->attr, proc->name, NULL);
412 fts = &ns->entries->sym->result->ts;
413 if (fts->type == BT_UNKNOWN)
414 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
415 for (el = ns->entries->next; el; el = el->next)
417 ts = &el->sym->result->ts;
418 if (ts->type == BT_UNKNOWN)
419 ts = gfc_get_default_type (el->sym->result, NULL);
420 if (! gfc_compare_types (ts, fts)
421 || (el->sym->result->attr.dimension
422 != ns->entries->sym->result->attr.dimension)
423 || (el->sym->result->attr.pointer
424 != ns->entries->sym->result->attr.pointer))
430 sym = ns->entries->sym->result;
431 /* All result types the same. */
433 if (sym->attr.dimension)
434 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
435 if (sym->attr.pointer)
436 gfc_add_pointer (&proc->attr, NULL);
440 /* Otherwise the result will be passed through a union by
442 proc->attr.mixed_entry_master = 1;
443 for (el = ns->entries; el; el = el->next)
445 sym = el->sym->result;
446 if (sym->attr.dimension)
448 if (el == ns->entries)
450 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
451 sym->name, ns->entries->sym->name, &sym->declared_at);
454 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
455 sym->name, ns->entries->sym->name, &sym->declared_at);
457 else if (sym->attr.pointer)
459 if (el == ns->entries)
461 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
462 sym->name, ns->entries->sym->name, &sym->declared_at);
465 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
466 sym->name, ns->entries->sym->name, &sym->declared_at);
471 if (ts->type == BT_UNKNOWN)
472 ts = gfc_get_default_type (sym, NULL);
476 if (ts->kind == gfc_default_integer_kind)
480 if (ts->kind == gfc_default_real_kind
481 || ts->kind == gfc_default_double_kind)
485 if (ts->kind == gfc_default_complex_kind)
489 if (ts->kind == gfc_default_logical_kind)
493 /* We will issue error elsewhere. */
501 if (el == ns->entries)
503 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
504 sym->name, gfc_typename (ts), ns->entries->sym->name,
508 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
509 sym->name, gfc_typename (ts), ns->entries->sym->name,
516 proc->attr.access = ACCESS_PRIVATE;
517 proc->attr.entry_master = 1;
519 /* Merge all the entry point arguments. */
520 for (el = ns->entries; el; el = el->next)
521 merge_argument_lists (proc, el->sym->formal);
523 /* Use the master function for the function body. */
524 ns->proc_name = proc;
526 /* Finalize the new symbols. */
527 gfc_commit_symbols ();
529 /* Restore the original namespace. */
530 gfc_current_ns = old_ns;
534 /* Resolve contained function types. Because contained functions can call one
535 another, they have to be worked out before any of the contained procedures
538 The good news is that if a function doesn't already have a type, the only
539 way it can get one is through an IMPLICIT type or a RESULT variable, because
540 by definition contained functions are contained namespace they're contained
541 in, not in a sibling or parent namespace. */
544 resolve_contained_functions (gfc_namespace * ns)
546 gfc_namespace *child;
549 resolve_formal_arglists (ns);
551 for (child = ns->contained; child; child = child->sibling)
553 /* Resolve alternate entry points first. */
554 resolve_entries (child);
556 /* Then check function return types. */
557 resolve_contained_fntype (child->proc_name, child);
558 for (el = child->entries; el; el = el->next)
559 resolve_contained_fntype (el->sym, child);
564 /* Resolve all of the elements of a structure constructor and make sure that
565 the types are correct. */
568 resolve_structure_cons (gfc_expr * expr)
570 gfc_constructor *cons;
575 cons = expr->value.constructor;
576 /* A constructor may have references if it is the result of substituting a
577 parameter variable. In this case we just pull out the component we
580 comp = expr->ref->u.c.sym->components;
582 comp = expr->ts.derived->components;
584 for (; comp; comp = comp->next, cons = cons->next)
592 if (gfc_resolve_expr (cons->expr) == FAILURE)
598 /* If we don't have the right type, try to convert it. */
600 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
601 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
610 /****************** Expression name resolution ******************/
612 /* Returns 0 if a symbol was not declared with a type or
613 attribute declaration statement, nonzero otherwise. */
616 was_declared (gfc_symbol * sym)
622 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
625 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
626 || a.optional || a.pointer || a.save || a.target
627 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
634 /* Determine if a symbol is generic or not. */
637 generic_sym (gfc_symbol * sym)
641 if (sym->attr.generic ||
642 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
645 if (was_declared (sym) || sym->ns->parent == NULL)
648 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
650 return (s == NULL) ? 0 : generic_sym (s);
654 /* Determine if a symbol is specific or not. */
657 specific_sym (gfc_symbol * sym)
661 if (sym->attr.if_source == IFSRC_IFBODY
662 || sym->attr.proc == PROC_MODULE
663 || sym->attr.proc == PROC_INTERNAL
664 || sym->attr.proc == PROC_ST_FUNCTION
665 || (sym->attr.intrinsic &&
666 gfc_specific_intrinsic (sym->name))
667 || sym->attr.external)
670 if (was_declared (sym) || sym->ns->parent == NULL)
673 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
675 return (s == NULL) ? 0 : specific_sym (s);
679 /* Figure out if the procedure is specific, generic or unknown. */
682 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
686 procedure_kind (gfc_symbol * sym)
689 if (generic_sym (sym))
690 return PTYPE_GENERIC;
692 if (specific_sym (sym))
693 return PTYPE_SPECIFIC;
695 return PTYPE_UNKNOWN;
699 /* Resolve an actual argument list. Most of the time, this is just
700 resolving the expressions in the list.
701 The exception is that we sometimes have to decide whether arguments
702 that look like procedure arguments are really simple variable
706 resolve_actual_arglist (gfc_actual_arglist * arg)
709 gfc_symtree *parent_st;
712 for (; arg; arg = arg->next)
718 /* Check the label is a valid branching target. */
721 if (arg->label->defined == ST_LABEL_UNKNOWN)
723 gfc_error ("Label %d referenced at %L is never defined",
724 arg->label->value, &arg->label->where);
731 if (e->ts.type != BT_PROCEDURE)
733 if (gfc_resolve_expr (e) != SUCCESS)
738 /* See if the expression node should really be a variable
741 sym = e->symtree->n.sym;
743 if (sym->attr.flavor == FL_PROCEDURE
744 || sym->attr.intrinsic
745 || sym->attr.external)
748 if (sym->attr.proc == PROC_ST_FUNCTION)
750 gfc_error ("Statement function '%s' at %L is not allowed as an "
751 "actual argument", sym->name, &e->where);
754 /* If the symbol is the function that names the current (or
755 parent) scope, then we really have a variable reference. */
757 if (sym->attr.function && sym->result == sym
758 && (sym->ns->proc_name == sym
759 || (sym->ns->parent != NULL
760 && sym->ns->parent->proc_name == sym)))
766 /* See if the name is a module procedure in a parent unit. */
768 if (was_declared (sym) || sym->ns->parent == NULL)
771 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
773 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
777 if (parent_st == NULL)
780 sym = parent_st->n.sym;
781 e->symtree = parent_st; /* Point to the right thing. */
783 if (sym->attr.flavor == FL_PROCEDURE
784 || sym->attr.intrinsic
785 || sym->attr.external)
791 e->expr_type = EXPR_VARIABLE;
795 e->rank = sym->as->rank;
796 e->ref = gfc_get_ref ();
797 e->ref->type = REF_ARRAY;
798 e->ref->u.ar.type = AR_FULL;
799 e->ref->u.ar.as = sym->as;
807 /************* Function resolution *************/
809 /* Resolve a function call known to be generic.
810 Section 14.1.2.4.1. */
813 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
817 if (sym->attr.generic)
820 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
823 expr->value.function.name = s->name;
824 expr->value.function.esym = s;
827 expr->rank = s->as->rank;
831 /* TODO: Need to search for elemental references in generic interface */
834 if (sym->attr.intrinsic)
835 return gfc_intrinsic_func_interface (expr, 0);
842 resolve_generic_f (gfc_expr * expr)
847 sym = expr->symtree->n.sym;
851 m = resolve_generic_f0 (expr, sym);
854 else if (m == MATCH_ERROR)
858 if (sym->ns->parent == NULL)
860 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
864 if (!generic_sym (sym))
868 /* Last ditch attempt. */
870 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
872 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
873 expr->symtree->n.sym->name, &expr->where);
877 m = gfc_intrinsic_func_interface (expr, 0);
882 ("Generic function '%s' at %L is not consistent with a specific "
883 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
889 /* Resolve a function call known to be specific. */
892 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
896 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
900 sym->attr.proc = PROC_DUMMY;
904 sym->attr.proc = PROC_EXTERNAL;
908 if (sym->attr.proc == PROC_MODULE
909 || sym->attr.proc == PROC_ST_FUNCTION
910 || sym->attr.proc == PROC_INTERNAL)
913 if (sym->attr.intrinsic)
915 m = gfc_intrinsic_func_interface (expr, 1);
920 ("Function '%s' at %L is INTRINSIC but is not compatible with "
921 "an intrinsic", sym->name, &expr->where);
929 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
932 expr->value.function.name = sym->name;
933 expr->value.function.esym = sym;
935 expr->rank = sym->as->rank;
942 resolve_specific_f (gfc_expr * expr)
947 sym = expr->symtree->n.sym;
951 m = resolve_specific_f0 (sym, expr);
954 if (m == MATCH_ERROR)
957 if (sym->ns->parent == NULL)
960 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
966 gfc_error ("Unable to resolve the specific function '%s' at %L",
967 expr->symtree->n.sym->name, &expr->where);
973 /* Resolve a procedure call not known to be generic nor specific. */
976 resolve_unknown_f (gfc_expr * expr)
981 sym = expr->symtree->n.sym;
985 sym->attr.proc = PROC_DUMMY;
986 expr->value.function.name = sym->name;
990 /* See if we have an intrinsic function reference. */
992 if (gfc_intrinsic_name (sym->name, 0))
994 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
999 /* The reference is to an external name. */
1001 sym->attr.proc = PROC_EXTERNAL;
1002 expr->value.function.name = sym->name;
1003 expr->value.function.esym = expr->symtree->n.sym;
1005 if (sym->as != NULL)
1006 expr->rank = sym->as->rank;
1008 /* Type of the expression is either the type of the symbol or the
1009 default type of the symbol. */
1012 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1014 if (sym->ts.type != BT_UNKNOWN)
1018 ts = gfc_get_default_type (sym, sym->ns);
1020 if (ts->type == BT_UNKNOWN)
1022 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1023 sym->name, &expr->where);
1034 /* Figure out if a function reference is pure or not. Also set the name
1035 of the function for a potential error message. Return nonzero if the
1036 function is PURE, zero if not. */
1039 pure_function (gfc_expr * e, const char **name)
1043 if (e->value.function.esym)
1045 pure = gfc_pure (e->value.function.esym);
1046 *name = e->value.function.esym->name;
1048 else if (e->value.function.isym)
1050 pure = e->value.function.isym->pure
1051 || e->value.function.isym->elemental;
1052 *name = e->value.function.isym->name;
1056 /* Implicit functions are not pure. */
1058 *name = e->value.function.name;
1065 /* Resolve a function call, which means resolving the arguments, then figuring
1066 out which entity the name refers to. */
1067 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1068 to INTENT(OUT) or INTENT(INOUT). */
1071 resolve_function (gfc_expr * expr)
1073 gfc_actual_arglist *arg;
1077 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1080 /* See if function is already resolved. */
1082 if (expr->value.function.name != NULL)
1084 if (expr->ts.type == BT_UNKNOWN)
1085 expr->ts = expr->symtree->n.sym->ts;
1090 /* Apply the rules of section 14.1.2. */
1092 switch (procedure_kind (expr->symtree->n.sym))
1095 t = resolve_generic_f (expr);
1098 case PTYPE_SPECIFIC:
1099 t = resolve_specific_f (expr);
1103 t = resolve_unknown_f (expr);
1107 gfc_internal_error ("resolve_function(): bad function type");
1111 /* If the expression is still a function (it might have simplified),
1112 then we check to see if we are calling an elemental function. */
1114 if (expr->expr_type != EXPR_FUNCTION)
1117 if (expr->value.function.actual != NULL
1118 && ((expr->value.function.esym != NULL
1119 && expr->value.function.esym->attr.elemental)
1120 || (expr->value.function.isym != NULL
1121 && expr->value.function.isym->elemental)))
1124 /* The rank of an elemental is the rank of its array argument(s). */
1126 for (arg = expr->value.function.actual; arg; arg = arg->next)
1128 if (arg->expr != NULL && arg->expr->rank > 0)
1130 expr->rank = arg->expr->rank;
1136 if (!pure_function (expr, &name))
1141 ("Function reference to '%s' at %L is inside a FORALL block",
1142 name, &expr->where);
1145 else if (gfc_pure (NULL))
1147 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1148 "procedure within a PURE procedure", name, &expr->where);
1157 /************* Subroutine resolution *************/
1160 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1167 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1168 sym->name, &c->loc);
1169 else if (gfc_pure (NULL))
1170 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1176 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1180 if (sym->attr.generic)
1182 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1185 c->resolved_sym = s;
1186 pure_subroutine (c, s);
1190 /* TODO: Need to search for elemental references in generic interface. */
1193 if (sym->attr.intrinsic)
1194 return gfc_intrinsic_sub_interface (c, 0);
1201 resolve_generic_s (gfc_code * c)
1206 sym = c->symtree->n.sym;
1208 m = resolve_generic_s0 (c, sym);
1211 if (m == MATCH_ERROR)
1214 if (sym->ns->parent != NULL)
1216 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1219 m = resolve_generic_s0 (c, sym);
1222 if (m == MATCH_ERROR)
1227 /* Last ditch attempt. */
1229 if (!gfc_generic_intrinsic (sym->name))
1232 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1233 sym->name, &c->loc);
1237 m = gfc_intrinsic_sub_interface (c, 0);
1241 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1242 "intrinsic subroutine interface", sym->name, &c->loc);
1248 /* Resolve a subroutine call known to be specific. */
1251 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1255 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1257 if (sym->attr.dummy)
1259 sym->attr.proc = PROC_DUMMY;
1263 sym->attr.proc = PROC_EXTERNAL;
1267 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1270 if (sym->attr.intrinsic)
1272 m = gfc_intrinsic_sub_interface (c, 1);
1276 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1277 "with an intrinsic", sym->name, &c->loc);
1285 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1287 c->resolved_sym = sym;
1288 pure_subroutine (c, sym);
1295 resolve_specific_s (gfc_code * c)
1300 sym = c->symtree->n.sym;
1302 m = resolve_specific_s0 (c, sym);
1305 if (m == MATCH_ERROR)
1308 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1312 m = resolve_specific_s0 (c, sym);
1315 if (m == MATCH_ERROR)
1319 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1320 sym->name, &c->loc);
1326 /* Resolve a subroutine call not known to be generic nor specific. */
1329 resolve_unknown_s (gfc_code * c)
1333 sym = c->symtree->n.sym;
1335 if (sym->attr.dummy)
1337 sym->attr.proc = PROC_DUMMY;
1341 /* See if we have an intrinsic function reference. */
1343 if (gfc_intrinsic_name (sym->name, 1))
1345 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1350 /* The reference is to an external name. */
1353 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1355 c->resolved_sym = sym;
1357 pure_subroutine (c, sym);
1363 /* Resolve a subroutine call. Although it was tempting to use the same code
1364 for functions, subroutines and functions are stored differently and this
1365 makes things awkward. */
1368 resolve_call (gfc_code * c)
1372 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1375 if (c->resolved_sym != NULL)
1378 switch (procedure_kind (c->symtree->n.sym))
1381 t = resolve_generic_s (c);
1384 case PTYPE_SPECIFIC:
1385 t = resolve_specific_s (c);
1389 t = resolve_unknown_s (c);
1393 gfc_internal_error ("resolve_subroutine(): bad function type");
1399 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1400 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1401 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1402 if their shapes do not match. If either op1->shape or op2->shape is
1403 NULL, return SUCCESS. */
1406 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1413 if (op1->shape != NULL && op2->shape != NULL)
1415 for (i = 0; i < op1->rank; i++)
1417 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1419 gfc_error ("Shapes for operands at %L and %L are not conformable",
1420 &op1->where, &op2->where);
1430 /* Resolve an operator expression node. This can involve replacing the
1431 operation with a user defined function call. */
1434 resolve_operator (gfc_expr * e)
1436 gfc_expr *op1, *op2;
1440 /* Resolve all subnodes-- give them types. */
1442 switch (e->value.op.operator)
1445 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1448 /* Fall through... */
1451 case INTRINSIC_UPLUS:
1452 case INTRINSIC_UMINUS:
1453 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1458 /* Typecheck the new node. */
1460 op1 = e->value.op.op1;
1461 op2 = e->value.op.op2;
1463 switch (e->value.op.operator)
1465 case INTRINSIC_UPLUS:
1466 case INTRINSIC_UMINUS:
1467 if (op1->ts.type == BT_INTEGER
1468 || op1->ts.type == BT_REAL
1469 || op1->ts.type == BT_COMPLEX)
1475 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1476 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1479 case INTRINSIC_PLUS:
1480 case INTRINSIC_MINUS:
1481 case INTRINSIC_TIMES:
1482 case INTRINSIC_DIVIDE:
1483 case INTRINSIC_POWER:
1484 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1486 gfc_type_convert_binary (e);
1491 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1492 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1493 gfc_typename (&op2->ts));
1496 case INTRINSIC_CONCAT:
1497 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1499 e->ts.type = BT_CHARACTER;
1500 e->ts.kind = op1->ts.kind;
1505 _("Operands of string concatenation operator at %%L are %s/%s"),
1506 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1512 case INTRINSIC_NEQV:
1513 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1515 e->ts.type = BT_LOGICAL;
1516 e->ts.kind = gfc_kind_max (op1, op2);
1517 if (op1->ts.kind < e->ts.kind)
1518 gfc_convert_type (op1, &e->ts, 2);
1519 else if (op2->ts.kind < e->ts.kind)
1520 gfc_convert_type (op2, &e->ts, 2);
1524 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1525 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1526 gfc_typename (&op2->ts));
1531 if (op1->ts.type == BT_LOGICAL)
1533 e->ts.type = BT_LOGICAL;
1534 e->ts.kind = op1->ts.kind;
1538 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1539 gfc_typename (&op1->ts));
1546 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1548 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1552 /* Fall through... */
1556 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1558 e->ts.type = BT_LOGICAL;
1559 e->ts.kind = gfc_default_logical_kind;
1563 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1565 gfc_type_convert_binary (e);
1567 e->ts.type = BT_LOGICAL;
1568 e->ts.kind = gfc_default_logical_kind;
1572 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1574 _("Logicals at %%L must be compared with %s instead of %s"),
1575 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1576 gfc_op2string (e->value.op.operator));
1579 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1580 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1581 gfc_typename (&op2->ts));
1585 case INTRINSIC_USER:
1587 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1588 e->value.op.uop->name, gfc_typename (&op1->ts));
1590 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1591 e->value.op.uop->name, gfc_typename (&op1->ts),
1592 gfc_typename (&op2->ts));
1597 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1600 /* Deal with arrayness of an operand through an operator. */
1604 switch (e->value.op.operator)
1606 case INTRINSIC_PLUS:
1607 case INTRINSIC_MINUS:
1608 case INTRINSIC_TIMES:
1609 case INTRINSIC_DIVIDE:
1610 case INTRINSIC_POWER:
1611 case INTRINSIC_CONCAT:
1615 case INTRINSIC_NEQV:
1623 if (op1->rank == 0 && op2->rank == 0)
1626 if (op1->rank == 0 && op2->rank != 0)
1628 e->rank = op2->rank;
1630 if (e->shape == NULL)
1631 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1634 if (op1->rank != 0 && op2->rank == 0)
1636 e->rank = op1->rank;
1638 if (e->shape == NULL)
1639 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1642 if (op1->rank != 0 && op2->rank != 0)
1644 if (op1->rank == op2->rank)
1646 e->rank = op1->rank;
1647 if (e->shape == NULL)
1649 t = compare_shapes(op1, op2);
1653 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1658 gfc_error ("Inconsistent ranks for operator at %L and %L",
1659 &op1->where, &op2->where);
1662 /* Allow higher level expressions to work. */
1670 case INTRINSIC_UPLUS:
1671 case INTRINSIC_UMINUS:
1672 e->rank = op1->rank;
1674 if (e->shape == NULL)
1675 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1677 /* Simply copy arrayness attribute */
1684 /* Attempt to simplify the expression. */
1686 t = gfc_simplify_expr (e, 0);
1691 if (gfc_extend_expr (e) == SUCCESS)
1694 gfc_error (msg, &e->where);
1700 /************** Array resolution subroutines **************/
1704 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1707 /* Compare two integer expressions. */
1710 compare_bound (gfc_expr * a, gfc_expr * b)
1714 if (a == NULL || a->expr_type != EXPR_CONSTANT
1715 || b == NULL || b->expr_type != EXPR_CONSTANT)
1718 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1719 gfc_internal_error ("compare_bound(): Bad expression");
1721 i = mpz_cmp (a->value.integer, b->value.integer);
1731 /* Compare an integer expression with an integer. */
1734 compare_bound_int (gfc_expr * a, int b)
1738 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1741 if (a->ts.type != BT_INTEGER)
1742 gfc_internal_error ("compare_bound_int(): Bad expression");
1744 i = mpz_cmp_si (a->value.integer, b);
1754 /* Compare a single dimension of an array reference to the array
1758 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1761 /* Given start, end and stride values, calculate the minimum and
1762 maximum referenced indexes. */
1770 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1772 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1778 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1780 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1784 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1786 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1789 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1790 it is legal (see 6.2.2.3.1). */
1795 gfc_internal_error ("check_dimension(): Bad array reference");
1801 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1806 /* Compare an array reference with an array specification. */
1809 compare_spec_to_ref (gfc_array_ref * ar)
1816 /* TODO: Full array sections are only allowed as actual parameters. */
1817 if (as->type == AS_ASSUMED_SIZE
1818 && (/*ar->type == AR_FULL
1819 ||*/ (ar->type == AR_SECTION
1820 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1822 gfc_error ("Rightmost upper bound of assumed size array section"
1823 " not specified at %L", &ar->where);
1827 if (ar->type == AR_FULL)
1830 if (as->rank != ar->dimen)
1832 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1833 &ar->where, ar->dimen, as->rank);
1837 for (i = 0; i < as->rank; i++)
1838 if (check_dimension (i, ar, as) == FAILURE)
1845 /* Resolve one part of an array index. */
1848 gfc_resolve_index (gfc_expr * index, int check_scalar)
1855 if (gfc_resolve_expr (index) == FAILURE)
1858 if (check_scalar && index->rank != 0)
1860 gfc_error ("Array index at %L must be scalar", &index->where);
1864 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1866 gfc_error ("Array index at %L must be of INTEGER type",
1871 if (index->ts.type == BT_REAL)
1872 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1873 &index->where) == FAILURE)
1876 if (index->ts.kind != gfc_index_integer_kind
1877 || index->ts.type != BT_INTEGER)
1879 ts.type = BT_INTEGER;
1880 ts.kind = gfc_index_integer_kind;
1882 gfc_convert_type_warn (index, &ts, 2, 0);
1888 /* Resolve a dim argument to an intrinsic function. */
1891 gfc_resolve_dim_arg (gfc_expr *dim)
1896 if (gfc_resolve_expr (dim) == FAILURE)
1901 gfc_error ("Argument dim at %L must be scalar", &dim->where);
1905 if (dim->ts.type != BT_INTEGER)
1907 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1910 if (dim->ts.kind != gfc_index_integer_kind)
1914 ts.type = BT_INTEGER;
1915 ts.kind = gfc_index_integer_kind;
1917 gfc_convert_type_warn (dim, &ts, 2, 0);
1923 /* Given an expression that contains array references, update those array
1924 references to point to the right array specifications. While this is
1925 filled in during matching, this information is difficult to save and load
1926 in a module, so we take care of it here.
1928 The idea here is that the original array reference comes from the
1929 base symbol. We traverse the list of reference structures, setting
1930 the stored reference to references. Component references can
1931 provide an additional array specification. */
1934 find_array_spec (gfc_expr * e)
1940 as = e->symtree->n.sym->as;
1942 for (ref = e->ref; ref; ref = ref->next)
1947 gfc_internal_error ("find_array_spec(): Missing spec");
1954 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
1955 if (c == ref->u.c.component)
1959 gfc_internal_error ("find_array_spec(): Component not found");
1964 gfc_internal_error ("find_array_spec(): unused as(1)");
1975 gfc_internal_error ("find_array_spec(): unused as(2)");
1979 /* Resolve an array reference. */
1982 resolve_array_ref (gfc_array_ref * ar)
1984 int i, check_scalar;
1986 for (i = 0; i < ar->dimen; i++)
1988 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1990 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1992 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1994 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1997 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1998 switch (ar->start[i]->rank)
2001 ar->dimen_type[i] = DIMEN_ELEMENT;
2005 ar->dimen_type[i] = DIMEN_VECTOR;
2009 gfc_error ("Array index at %L is an array of rank %d",
2010 &ar->c_where[i], ar->start[i]->rank);
2015 /* If the reference type is unknown, figure out what kind it is. */
2017 if (ar->type == AR_UNKNOWN)
2019 ar->type = AR_ELEMENT;
2020 for (i = 0; i < ar->dimen; i++)
2021 if (ar->dimen_type[i] == DIMEN_RANGE
2022 || ar->dimen_type[i] == DIMEN_VECTOR)
2024 ar->type = AR_SECTION;
2029 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2037 resolve_substring (gfc_ref * ref)
2040 if (ref->u.ss.start != NULL)
2042 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2045 if (ref->u.ss.start->ts.type != BT_INTEGER)
2047 gfc_error ("Substring start index at %L must be of type INTEGER",
2048 &ref->u.ss.start->where);
2052 if (ref->u.ss.start->rank != 0)
2054 gfc_error ("Substring start index at %L must be scalar",
2055 &ref->u.ss.start->where);
2059 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2061 gfc_error ("Substring start index at %L is less than one",
2062 &ref->u.ss.start->where);
2067 if (ref->u.ss.end != NULL)
2069 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2072 if (ref->u.ss.end->ts.type != BT_INTEGER)
2074 gfc_error ("Substring end index at %L must be of type INTEGER",
2075 &ref->u.ss.end->where);
2079 if (ref->u.ss.end->rank != 0)
2081 gfc_error ("Substring end index at %L must be scalar",
2082 &ref->u.ss.end->where);
2086 if (ref->u.ss.length != NULL
2087 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2089 gfc_error ("Substring end index at %L is out of bounds",
2090 &ref->u.ss.start->where);
2099 /* Resolve subtype references. */
2102 resolve_ref (gfc_expr * expr)
2104 int current_part_dimension, n_components, seen_part_dimension;
2107 for (ref = expr->ref; ref; ref = ref->next)
2108 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2110 find_array_spec (expr);
2114 for (ref = expr->ref; ref; ref = ref->next)
2118 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2126 resolve_substring (ref);
2130 /* Check constraints on part references. */
2132 current_part_dimension = 0;
2133 seen_part_dimension = 0;
2136 for (ref = expr->ref; ref; ref = ref->next)
2141 switch (ref->u.ar.type)
2145 current_part_dimension = 1;
2149 current_part_dimension = 0;
2153 gfc_internal_error ("resolve_ref(): Bad array reference");
2159 if ((current_part_dimension || seen_part_dimension)
2160 && ref->u.c.component->pointer)
2163 ("Component to the right of a part reference with nonzero "
2164 "rank must not have the POINTER attribute at %L",
2176 if (((ref->type == REF_COMPONENT && n_components > 1)
2177 || ref->next == NULL)
2178 && current_part_dimension
2179 && seen_part_dimension)
2182 gfc_error ("Two or more part references with nonzero rank must "
2183 "not be specified at %L", &expr->where);
2187 if (ref->type == REF_COMPONENT)
2189 if (current_part_dimension)
2190 seen_part_dimension = 1;
2192 /* reset to make sure */
2193 current_part_dimension = 0;
2201 /* Given an expression, determine its shape. This is easier than it sounds.
2202 Leaves the shape array NULL if it is not possible to determine the shape. */
2205 expression_shape (gfc_expr * e)
2207 mpz_t array[GFC_MAX_DIMENSIONS];
2210 if (e->rank == 0 || e->shape != NULL)
2213 for (i = 0; i < e->rank; i++)
2214 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2217 e->shape = gfc_get_shape (e->rank);
2219 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2224 for (i--; i >= 0; i--)
2225 mpz_clear (array[i]);
2229 /* Given a variable expression node, compute the rank of the expression by
2230 examining the base symbol and any reference structures it may have. */
2233 expression_rank (gfc_expr * e)
2240 if (e->expr_type == EXPR_ARRAY)
2242 /* Constructors can have a rank different from one via RESHAPE(). */
2244 if (e->symtree == NULL)
2250 e->rank = (e->symtree->n.sym->as == NULL)
2251 ? 0 : e->symtree->n.sym->as->rank;
2257 for (ref = e->ref; ref; ref = ref->next)
2259 if (ref->type != REF_ARRAY)
2262 if (ref->u.ar.type == AR_FULL)
2264 rank = ref->u.ar.as->rank;
2268 if (ref->u.ar.type == AR_SECTION)
2270 /* Figure out the rank of the section. */
2272 gfc_internal_error ("expression_rank(): Two array specs");
2274 for (i = 0; i < ref->u.ar.dimen; i++)
2275 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2276 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2286 expression_shape (e);
2290 /* Resolve a variable expression. */
2293 resolve_variable (gfc_expr * e)
2297 if (e->ref && resolve_ref (e) == FAILURE)
2300 if (e->symtree == NULL)
2303 sym = e->symtree->n.sym;
2304 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2306 e->ts.type = BT_PROCEDURE;
2310 if (sym->ts.type != BT_UNKNOWN)
2311 gfc_variable_attr (e, &e->ts);
2314 /* Must be a simple variable reference. */
2315 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2324 /* Resolve an expression. That is, make sure that types of operands agree
2325 with their operators, intrinsic operators are converted to function calls
2326 for overloaded types and unresolved function references are resolved. */
2329 gfc_resolve_expr (gfc_expr * e)
2336 switch (e->expr_type)
2339 t = resolve_operator (e);
2343 t = resolve_function (e);
2347 t = resolve_variable (e);
2349 expression_rank (e);
2352 case EXPR_SUBSTRING:
2353 t = resolve_ref (e);
2363 if (resolve_ref (e) == FAILURE)
2366 t = gfc_resolve_array_constructor (e);
2367 /* Also try to expand a constructor. */
2370 expression_rank (e);
2371 gfc_expand_constructor (e);
2376 case EXPR_STRUCTURE:
2377 t = resolve_ref (e);
2381 t = resolve_structure_cons (e);
2385 t = gfc_simplify_expr (e, 0);
2389 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2396 /* Resolve an expression from an iterator. They must be scalar and have
2397 INTEGER or (optionally) REAL type. */
2400 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2401 const char * name_msgid)
2403 if (gfc_resolve_expr (expr) == FAILURE)
2406 if (expr->rank != 0)
2408 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2412 if (!(expr->ts.type == BT_INTEGER
2413 || (expr->ts.type == BT_REAL && real_ok)))
2416 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2419 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2426 /* Resolve the expressions in an iterator structure. If REAL_OK is
2427 false allow only INTEGER type iterators, otherwise allow REAL types. */
2430 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2433 if (iter->var->ts.type == BT_REAL)
2434 gfc_notify_std (GFC_STD_F95_DEL,
2435 "Obsolete: REAL DO loop iterator at %L",
2438 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2442 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2444 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2449 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2450 "Start expression in DO loop") == FAILURE)
2453 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2454 "End expression in DO loop") == FAILURE)
2457 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2458 "Step expression in DO loop") == FAILURE)
2461 if (iter->step->expr_type == EXPR_CONSTANT)
2463 if ((iter->step->ts.type == BT_INTEGER
2464 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2465 || (iter->step->ts.type == BT_REAL
2466 && mpfr_sgn (iter->step->value.real) == 0))
2468 gfc_error ("Step expression in DO loop at %L cannot be zero",
2469 &iter->step->where);
2474 /* Convert start, end, and step to the same type as var. */
2475 if (iter->start->ts.kind != iter->var->ts.kind
2476 || iter->start->ts.type != iter->var->ts.type)
2477 gfc_convert_type (iter->start, &iter->var->ts, 2);
2479 if (iter->end->ts.kind != iter->var->ts.kind
2480 || iter->end->ts.type != iter->var->ts.type)
2481 gfc_convert_type (iter->end, &iter->var->ts, 2);
2483 if (iter->step->ts.kind != iter->var->ts.kind
2484 || iter->step->ts.type != iter->var->ts.type)
2485 gfc_convert_type (iter->step, &iter->var->ts, 2);
2491 /* Resolve a list of FORALL iterators. */
2494 resolve_forall_iterators (gfc_forall_iterator * iter)
2499 if (gfc_resolve_expr (iter->var) == SUCCESS
2500 && iter->var->ts.type != BT_INTEGER)
2501 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2504 if (gfc_resolve_expr (iter->start) == SUCCESS
2505 && iter->start->ts.type != BT_INTEGER)
2506 gfc_error ("FORALL start expression at %L must be INTEGER",
2507 &iter->start->where);
2508 if (iter->var->ts.kind != iter->start->ts.kind)
2509 gfc_convert_type (iter->start, &iter->var->ts, 2);
2511 if (gfc_resolve_expr (iter->end) == SUCCESS
2512 && iter->end->ts.type != BT_INTEGER)
2513 gfc_error ("FORALL end expression at %L must be INTEGER",
2515 if (iter->var->ts.kind != iter->end->ts.kind)
2516 gfc_convert_type (iter->end, &iter->var->ts, 2);
2518 if (gfc_resolve_expr (iter->stride) == SUCCESS
2519 && iter->stride->ts.type != BT_INTEGER)
2520 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2521 &iter->stride->where);
2522 if (iter->var->ts.kind != iter->stride->ts.kind)
2523 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2530 /* Given a pointer to a symbol that is a derived type, see if any components
2531 have the POINTER attribute. The search is recursive if necessary.
2532 Returns zero if no pointer components are found, nonzero otherwise. */
2535 derived_pointer (gfc_symbol * sym)
2539 for (c = sym->components; c; c = c->next)
2544 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2552 /* Given a pointer to a symbol that is a derived type, see if it's
2553 inaccessible, i.e. if it's defined in another module and the components are
2554 PRIVATE. The search is recursive if necessary. Returns zero if no
2555 inaccessible components are found, nonzero otherwise. */
2558 derived_inaccessible (gfc_symbol *sym)
2562 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2565 for (c = sym->components; c; c = c->next)
2567 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2575 /* Resolve the argument of a deallocate expression. The expression must be
2576 a pointer or a full array. */
2579 resolve_deallocate_expr (gfc_expr * e)
2581 symbol_attribute attr;
2585 if (gfc_resolve_expr (e) == FAILURE)
2588 attr = gfc_expr_attr (e);
2592 if (e->expr_type != EXPR_VARIABLE)
2595 allocatable = e->symtree->n.sym->attr.allocatable;
2596 for (ref = e->ref; ref; ref = ref->next)
2600 if (ref->u.ar.type != AR_FULL)
2605 allocatable = (ref->u.c.component->as != NULL
2606 && ref->u.c.component->as->type == AS_DEFERRED);
2614 if (allocatable == 0)
2617 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2618 "ALLOCATABLE or a POINTER", &e->where);
2625 /* Given the expression node e for an allocatable/pointer of derived type to be
2626 allocated, get the expression node to be initialized afterwards (needed for
2627 derived types with default initializers). */
2630 expr_to_initialize (gfc_expr * e)
2636 result = gfc_copy_expr (e);
2638 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2639 for (ref = result->ref; ref; ref = ref->next)
2640 if (ref->type == REF_ARRAY && ref->next == NULL)
2642 ref->u.ar.type = AR_FULL;
2644 for (i = 0; i < ref->u.ar.dimen; i++)
2645 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2647 result->rank = ref->u.ar.dimen;
2655 /* Resolve the expression in an ALLOCATE statement, doing the additional
2656 checks to see whether the expression is OK or not. The expression must
2657 have a trailing array reference that gives the size of the array. */
2660 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2662 int i, pointer, allocatable, dimension;
2663 symbol_attribute attr;
2664 gfc_ref *ref, *ref2;
2669 if (gfc_resolve_expr (e) == FAILURE)
2672 /* Make sure the expression is allocatable or a pointer. If it is
2673 pointer, the next-to-last reference must be a pointer. */
2677 if (e->expr_type != EXPR_VARIABLE)
2681 attr = gfc_expr_attr (e);
2682 pointer = attr.pointer;
2683 dimension = attr.dimension;
2688 allocatable = e->symtree->n.sym->attr.allocatable;
2689 pointer = e->symtree->n.sym->attr.pointer;
2690 dimension = e->symtree->n.sym->attr.dimension;
2692 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2696 if (ref->next != NULL)
2701 allocatable = (ref->u.c.component->as != NULL
2702 && ref->u.c.component->as->type == AS_DEFERRED);
2704 pointer = ref->u.c.component->pointer;
2705 dimension = ref->u.c.component->dimension;
2715 if (allocatable == 0 && pointer == 0)
2717 gfc_error ("Expression in ALLOCATE statement at %L must be "
2718 "ALLOCATABLE or a POINTER", &e->where);
2722 /* Add default initializer for those derived types that need them. */
2723 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2725 init_st = gfc_get_code ();
2726 init_st->loc = code->loc;
2727 init_st->op = EXEC_ASSIGN;
2728 init_st->expr = expr_to_initialize (e);
2729 init_st->expr2 = init_e;
2731 init_st->next = code->next;
2732 code->next = init_st;
2735 if (pointer && dimension == 0)
2738 /* Make sure the next-to-last reference node is an array specification. */
2740 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2742 gfc_error ("Array specification required in ALLOCATE statement "
2743 "at %L", &e->where);
2747 if (ref2->u.ar.type == AR_ELEMENT)
2750 /* Make sure that the array section reference makes sense in the
2751 context of an ALLOCATE specification. */
2755 for (i = 0; i < ar->dimen; i++)
2756 switch (ar->dimen_type[i])
2762 if (ar->start[i] != NULL
2763 && ar->end[i] != NULL
2764 && ar->stride[i] == NULL)
2767 /* Fall Through... */
2771 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2780 /************ SELECT CASE resolution subroutines ************/
2782 /* Callback function for our mergesort variant. Determines interval
2783 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2784 op1 > op2. Assumes we're not dealing with the default case.
2785 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2786 There are nine situations to check. */
2789 compare_cases (const gfc_case * op1, const gfc_case * op2)
2793 if (op1->low == NULL) /* op1 = (:L) */
2795 /* op2 = (:N), so overlap. */
2797 /* op2 = (M:) or (M:N), L < M */
2798 if (op2->low != NULL
2799 && gfc_compare_expr (op1->high, op2->low) < 0)
2802 else if (op1->high == NULL) /* op1 = (K:) */
2804 /* op2 = (M:), so overlap. */
2806 /* op2 = (:N) or (M:N), K > N */
2807 if (op2->high != NULL
2808 && gfc_compare_expr (op1->low, op2->high) > 0)
2811 else /* op1 = (K:L) */
2813 if (op2->low == NULL) /* op2 = (:N), K > N */
2814 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2815 else if (op2->high == NULL) /* op2 = (M:), L < M */
2816 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2817 else /* op2 = (M:N) */
2821 if (gfc_compare_expr (op1->high, op2->low) < 0)
2824 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2833 /* Merge-sort a double linked case list, detecting overlap in the
2834 process. LIST is the head of the double linked case list before it
2835 is sorted. Returns the head of the sorted list if we don't see any
2836 overlap, or NULL otherwise. */
2839 check_case_overlap (gfc_case * list)
2841 gfc_case *p, *q, *e, *tail;
2842 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2844 /* If the passed list was empty, return immediately. */
2851 /* Loop unconditionally. The only exit from this loop is a return
2852 statement, when we've finished sorting the case list. */
2859 /* Count the number of merges we do in this pass. */
2862 /* Loop while there exists a merge to be done. */
2867 /* Count this merge. */
2870 /* Cut the list in two pieces by stepping INSIZE places
2871 forward in the list, starting from P. */
2874 for (i = 0; i < insize; i++)
2883 /* Now we have two lists. Merge them! */
2884 while (psize > 0 || (qsize > 0 && q != NULL))
2887 /* See from which the next case to merge comes from. */
2890 /* P is empty so the next case must come from Q. */
2895 else if (qsize == 0 || q == NULL)
2904 cmp = compare_cases (p, q);
2907 /* The whole case range for P is less than the
2915 /* The whole case range for Q is greater than
2916 the case range for P. */
2923 /* The cases overlap, or they are the same
2924 element in the list. Either way, we must
2925 issue an error and get the next case from P. */
2926 /* FIXME: Sort P and Q by line number. */
2927 gfc_error ("CASE label at %L overlaps with CASE "
2928 "label at %L", &p->where, &q->where);
2936 /* Add the next element to the merged list. */
2945 /* P has now stepped INSIZE places along, and so has Q. So
2946 they're the same. */
2951 /* If we have done only one merge or none at all, we've
2952 finished sorting the cases. */
2961 /* Otherwise repeat, merging lists twice the size. */
2967 /* Check to see if an expression is suitable for use in a CASE statement.
2968 Makes sure that all case expressions are scalar constants of the same
2969 type. Return FAILURE if anything is wrong. */
2972 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2974 if (e == NULL) return SUCCESS;
2976 if (e->ts.type != case_expr->ts.type)
2978 gfc_error ("Expression in CASE statement at %L must be of type %s",
2979 &e->where, gfc_basic_typename (case_expr->ts.type));
2983 /* C805 (R808) For a given case-construct, each case-value shall be of
2984 the same type as case-expr. For character type, length differences
2985 are allowed, but the kind type parameters shall be the same. */
2987 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2989 gfc_error("Expression in CASE statement at %L must be kind %d",
2990 &e->where, case_expr->ts.kind);
2994 /* Convert the case value kind to that of case expression kind, if needed.
2995 FIXME: Should a warning be issued? */
2996 if (e->ts.kind != case_expr->ts.kind)
2997 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3001 gfc_error ("Expression in CASE statement at %L must be scalar",
3010 /* Given a completely parsed select statement, we:
3012 - Validate all expressions and code within the SELECT.
3013 - Make sure that the selection expression is not of the wrong type.
3014 - Make sure that no case ranges overlap.
3015 - Eliminate unreachable cases and unreachable code resulting from
3016 removing case labels.
3018 The standard does allow unreachable cases, e.g. CASE (5:3). But
3019 they are a hassle for code generation, and to prevent that, we just
3020 cut them out here. This is not necessary for overlapping cases
3021 because they are illegal and we never even try to generate code.
3023 We have the additional caveat that a SELECT construct could have
3024 been a computed GOTO in the source code. Fortunately we can fairly
3025 easily work around that here: The case_expr for a "real" SELECT CASE
3026 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3027 we have to do is make sure that the case_expr is a scalar integer
3031 resolve_select (gfc_code * code)
3034 gfc_expr *case_expr;
3035 gfc_case *cp, *default_case, *tail, *head;
3036 int seen_unreachable;
3041 if (code->expr == NULL)
3043 /* This was actually a computed GOTO statement. */
3044 case_expr = code->expr2;
3045 if (case_expr->ts.type != BT_INTEGER
3046 || case_expr->rank != 0)
3047 gfc_error ("Selection expression in computed GOTO statement "
3048 "at %L must be a scalar integer expression",
3051 /* Further checking is not necessary because this SELECT was built
3052 by the compiler, so it should always be OK. Just move the
3053 case_expr from expr2 to expr so that we can handle computed
3054 GOTOs as normal SELECTs from here on. */
3055 code->expr = code->expr2;
3060 case_expr = code->expr;
3062 type = case_expr->ts.type;
3063 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3065 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3066 &case_expr->where, gfc_typename (&case_expr->ts));
3068 /* Punt. Going on here just produce more garbage error messages. */
3072 if (case_expr->rank != 0)
3074 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3075 "expression", &case_expr->where);
3081 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3082 of the SELECT CASE expression and its CASE values. Walk the lists
3083 of case values, and if we find a mismatch, promote case_expr to
3084 the appropriate kind. */
3086 if (type == BT_LOGICAL || type == BT_INTEGER)
3088 for (body = code->block; body; body = body->block)
3090 /* Walk the case label list. */
3091 for (cp = body->ext.case_list; cp; cp = cp->next)
3093 /* Intercept the DEFAULT case. It does not have a kind. */
3094 if (cp->low == NULL && cp->high == NULL)
3097 /* Unreachable case ranges are discarded, so ignore. */
3098 if (cp->low != NULL && cp->high != NULL
3099 && cp->low != cp->high
3100 && gfc_compare_expr (cp->low, cp->high) > 0)
3103 /* FIXME: Should a warning be issued? */
3105 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3106 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3108 if (cp->high != NULL
3109 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3110 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3115 /* Assume there is no DEFAULT case. */
3116 default_case = NULL;
3120 for (body = code->block; body; body = body->block)
3122 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3124 seen_unreachable = 0;
3126 /* Walk the case label list, making sure that all case labels
3128 for (cp = body->ext.case_list; cp; cp = cp->next)
3130 /* Count the number of cases in the whole construct. */
3133 /* Intercept the DEFAULT case. */
3134 if (cp->low == NULL && cp->high == NULL)
3136 if (default_case != NULL)
3138 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3139 "by a second DEFAULT CASE at %L",
3140 &default_case->where, &cp->where);
3151 /* Deal with single value cases and case ranges. Errors are
3152 issued from the validation function. */
3153 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3154 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3160 if (type == BT_LOGICAL
3161 && ((cp->low == NULL || cp->high == NULL)
3162 || cp->low != cp->high))
3165 ("Logical range in CASE statement at %L is not allowed",
3171 if (cp->low != NULL && cp->high != NULL
3172 && cp->low != cp->high
3173 && gfc_compare_expr (cp->low, cp->high) > 0)
3175 if (gfc_option.warn_surprising)
3176 gfc_warning ("Range specification at %L can never "
3177 "be matched", &cp->where);
3179 cp->unreachable = 1;
3180 seen_unreachable = 1;
3184 /* If the case range can be matched, it can also overlap with
3185 other cases. To make sure it does not, we put it in a
3186 double linked list here. We sort that with a merge sort
3187 later on to detect any overlapping cases. */
3191 head->right = head->left = NULL;
3196 tail->right->left = tail;
3203 /* It there was a failure in the previous case label, give up
3204 for this case label list. Continue with the next block. */
3208 /* See if any case labels that are unreachable have been seen.
3209 If so, we eliminate them. This is a bit of a kludge because
3210 the case lists for a single case statement (label) is a
3211 single forward linked lists. */
3212 if (seen_unreachable)
3214 /* Advance until the first case in the list is reachable. */
3215 while (body->ext.case_list != NULL
3216 && body->ext.case_list->unreachable)
3218 gfc_case *n = body->ext.case_list;
3219 body->ext.case_list = body->ext.case_list->next;
3221 gfc_free_case_list (n);
3224 /* Strip all other unreachable cases. */
3225 if (body->ext.case_list)
3227 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3229 if (cp->next->unreachable)
3231 gfc_case *n = cp->next;
3232 cp->next = cp->next->next;
3234 gfc_free_case_list (n);
3241 /* See if there were overlapping cases. If the check returns NULL,
3242 there was overlap. In that case we don't do anything. If head
3243 is non-NULL, we prepend the DEFAULT case. The sorted list can
3244 then used during code generation for SELECT CASE constructs with
3245 a case expression of a CHARACTER type. */
3248 head = check_case_overlap (head);
3250 /* Prepend the default_case if it is there. */
3251 if (head != NULL && default_case)
3253 default_case->left = NULL;
3254 default_case->right = head;
3255 head->left = default_case;
3259 /* Eliminate dead blocks that may be the result if we've seen
3260 unreachable case labels for a block. */
3261 for (body = code; body && body->block; body = body->block)
3263 if (body->block->ext.case_list == NULL)
3265 /* Cut the unreachable block from the code chain. */
3266 gfc_code *c = body->block;
3267 body->block = c->block;
3269 /* Kill the dead block, but not the blocks below it. */
3271 gfc_free_statements (c);
3275 /* More than two cases is legal but insane for logical selects.
3276 Issue a warning for it. */
3277 if (gfc_option.warn_surprising && type == BT_LOGICAL
3279 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3284 /* Resolve a transfer statement. This is making sure that:
3285 -- a derived type being transferred has only non-pointer components
3286 -- a derived type being transferred doesn't have private components, unless
3287 it's being transferred from the module where the type was defined
3288 -- we're not trying to transfer a whole assumed size array. */
3291 resolve_transfer (gfc_code * code)
3300 if (exp->expr_type != EXPR_VARIABLE)
3303 sym = exp->symtree->n.sym;
3306 /* Go to actual component transferred. */
3307 for (ref = code->expr->ref; ref; ref = ref->next)
3308 if (ref->type == REF_COMPONENT)
3309 ts = &ref->u.c.component->ts;
3311 if (ts->type == BT_DERIVED)
3313 /* Check that transferred derived type doesn't contain POINTER
3315 if (derived_pointer (ts->derived))
3317 gfc_error ("Data transfer element at %L cannot have "
3318 "POINTER components", &code->loc);
3322 if (derived_inaccessible (ts->derived))
3324 gfc_error ("Data transfer element at %L cannot have "
3325 "PRIVATE components",&code->loc);
3330 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3331 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3333 gfc_error ("Data transfer element at %L cannot be a full reference to "
3334 "an assumed-size array", &code->loc);
3340 /*********** Toplevel code resolution subroutines ***********/
3342 /* Given a branch to a label and a namespace, if the branch is conforming.
3343 The code node described where the branch is located. */
3346 resolve_branch (gfc_st_label * label, gfc_code * code)
3348 gfc_code *block, *found;
3356 /* Step one: is this a valid branching target? */
3358 if (lp->defined == ST_LABEL_UNKNOWN)
3360 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3365 if (lp->defined != ST_LABEL_TARGET)
3367 gfc_error ("Statement at %L is not a valid branch target statement "
3368 "for the branch statement at %L", &lp->where, &code->loc);
3372 /* Step two: make sure this branch is not a branch to itself ;-) */
3374 if (code->here == label)
3376 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3380 /* Step three: Try to find the label in the parse tree. To do this,
3381 we traverse the tree block-by-block: first the block that
3382 contains this GOTO, then the block that it is nested in, etc. We
3383 can ignore other blocks because branching into another block is
3388 for (stack = cs_base; stack; stack = stack->prev)
3390 for (block = stack->head; block; block = block->next)
3392 if (block->here == label)
3405 /* still nothing, so illegal. */
3406 gfc_error_now ("Label at %L is not in the same block as the "
3407 "GOTO statement at %L", &lp->where, &code->loc);
3411 /* Step four: Make sure that the branching target is legal if
3412 the statement is an END {SELECT,DO,IF}. */
3414 if (found->op == EXEC_NOP)
3416 for (stack = cs_base; stack; stack = stack->prev)
3417 if (stack->current->next == found)
3421 gfc_notify_std (GFC_STD_F95_DEL,
3422 "Obsolete: GOTO at %L jumps to END of construct at %L",
3423 &code->loc, &found->loc);
3428 /* Check whether EXPR1 has the same shape as EXPR2. */
3431 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3433 mpz_t shape[GFC_MAX_DIMENSIONS];
3434 mpz_t shape2[GFC_MAX_DIMENSIONS];
3435 try result = FAILURE;
3438 /* Compare the rank. */
3439 if (expr1->rank != expr2->rank)
3442 /* Compare the size of each dimension. */
3443 for (i=0; i<expr1->rank; i++)
3445 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3448 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3451 if (mpz_cmp (shape[i], shape2[i]))
3455 /* When either of the two expression is an assumed size array, we
3456 ignore the comparison of dimension sizes. */
3461 for (i--; i>=0; i--)
3463 mpz_clear (shape[i]);
3464 mpz_clear (shape2[i]);
3470 /* Check whether a WHERE assignment target or a WHERE mask expression
3471 has the same shape as the outmost WHERE mask expression. */
3474 resolve_where (gfc_code *code, gfc_expr *mask)
3480 cblock = code->block;
3482 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3483 In case of nested WHERE, only the outmost one is stored. */
3484 if (mask == NULL) /* outmost WHERE */
3486 else /* inner WHERE */
3493 /* Check if the mask-expr has a consistent shape with the
3494 outmost WHERE mask-expr. */
3495 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3496 gfc_error ("WHERE mask at %L has inconsistent shape",
3497 &cblock->expr->where);
3500 /* the assignment statement of a WHERE statement, or the first
3501 statement in where-body-construct of a WHERE construct */
3502 cnext = cblock->next;
3507 /* WHERE assignment statement */
3510 /* Check shape consistent for WHERE assignment target. */
3511 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3512 gfc_error ("WHERE assignment target at %L has "
3513 "inconsistent shape", &cnext->expr->where);
3516 /* WHERE or WHERE construct is part of a where-body-construct */
3518 resolve_where (cnext, e);
3522 gfc_error ("Unsupported statement inside WHERE at %L",
3525 /* the next statement within the same where-body-construct */
3526 cnext = cnext->next;
3528 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3529 cblock = cblock->block;
3534 /* Check whether the FORALL index appears in the expression or not. */
3537 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3541 gfc_actual_arglist *args;
3544 switch (expr->expr_type)
3547 gcc_assert (expr->symtree->n.sym);
3549 /* A scalar assignment */
3552 if (expr->symtree->n.sym == symbol)
3558 /* the expr is array ref, substring or struct component. */
3565 /* Check if the symbol appears in the array subscript. */
3567 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3570 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3574 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3578 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3584 if (expr->symtree->n.sym == symbol)
3587 /* Check if the symbol appears in the substring section. */
3588 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3590 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3598 gfc_error("expresion reference type error at %L", &expr->where);
3604 /* If the expression is a function call, then check if the symbol
3605 appears in the actual arglist of the function. */
3607 for (args = expr->value.function.actual; args; args = args->next)
3609 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3614 /* It seems not to happen. */
3615 case EXPR_SUBSTRING:
3619 gcc_assert (expr->ref->type == REF_SUBSTRING);
3620 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3622 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3627 /* It seems not to happen. */
3628 case EXPR_STRUCTURE:
3630 gfc_error ("Unsupported statement while finding forall index in "
3635 /* Find the FORALL index in the first operand. */
3636 if (expr->value.op.op1)
3638 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3642 /* Find the FORALL index in the second operand. */
3643 if (expr->value.op.op2)
3645 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3658 /* Resolve assignment in FORALL construct.
3659 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3660 FORALL index variables. */
3663 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3667 for (n = 0; n < nvar; n++)
3669 gfc_symbol *forall_index;
3671 forall_index = var_expr[n]->symtree->n.sym;
3673 /* Check whether the assignment target is one of the FORALL index
3675 if ((code->expr->expr_type == EXPR_VARIABLE)
3676 && (code->expr->symtree->n.sym == forall_index))
3677 gfc_error ("Assignment to a FORALL index variable at %L",
3678 &code->expr->where);
3681 /* If one of the FORALL index variables doesn't appear in the
3682 assignment target, then there will be a many-to-one
3684 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3685 gfc_error ("The FORALL with index '%s' cause more than one "
3686 "assignment to this object at %L",
3687 var_expr[n]->symtree->name, &code->expr->where);
3693 /* Resolve WHERE statement in FORALL construct. */
3696 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3700 cblock = code->block;
3703 /* the assignment statement of a WHERE statement, or the first
3704 statement in where-body-construct of a WHERE construct */
3705 cnext = cblock->next;
3710 /* WHERE assignment statement */
3712 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3715 /* WHERE or WHERE construct is part of a where-body-construct */
3717 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3721 gfc_error ("Unsupported statement inside WHERE at %L",
3724 /* the next statement within the same where-body-construct */
3725 cnext = cnext->next;
3727 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3728 cblock = cblock->block;
3733 /* Traverse the FORALL body to check whether the following errors exist:
3734 1. For assignment, check if a many-to-one assignment happens.
3735 2. For WHERE statement, check the WHERE body to see if there is any
3736 many-to-one assignment. */
3739 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3743 c = code->block->next;
3749 case EXEC_POINTER_ASSIGN:
3750 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3753 /* Because the resolve_blocks() will handle the nested FORALL,
3754 there is no need to handle it here. */
3758 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3763 /* The next statement in the FORALL body. */
3769 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3770 gfc_resolve_forall_body to resolve the FORALL body. */
3772 static void resolve_blocks (gfc_code *, gfc_namespace *);
3775 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3777 static gfc_expr **var_expr;
3778 static int total_var = 0;
3779 static int nvar = 0;
3780 gfc_forall_iterator *fa;
3781 gfc_symbol *forall_index;
3785 /* Start to resolve a FORALL construct */
3786 if (forall_save == 0)
3788 /* Count the total number of FORALL index in the nested FORALL
3789 construct in order to allocate the VAR_EXPR with proper size. */
3791 while ((next != NULL) && (next->op == EXEC_FORALL))
3793 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3795 next = next->block->next;
3798 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3799 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3802 /* The information about FORALL iterator, including FORALL index start, end
3803 and stride. The FORALL index can not appear in start, end or stride. */
3804 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3806 /* Check if any outer FORALL index name is the same as the current
3808 for (i = 0; i < nvar; i++)
3810 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3812 gfc_error ("An outer FORALL construct already has an index "
3813 "with this name %L", &fa->var->where);
3817 /* Record the current FORALL index. */
3818 var_expr[nvar] = gfc_copy_expr (fa->var);
3820 forall_index = fa->var->symtree->n.sym;
3822 /* Check if the FORALL index appears in start, end or stride. */
3823 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3824 gfc_error ("A FORALL index must not appear in a limit or stride "
3825 "expression in the same FORALL at %L", &fa->start->where);
3826 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3827 gfc_error ("A FORALL index must not appear in a limit or stride "
3828 "expression in the same FORALL at %L", &fa->end->where);
3829 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3830 gfc_error ("A FORALL index must not appear in a limit or stride "
3831 "expression in the same FORALL at %L", &fa->stride->where);
3835 /* Resolve the FORALL body. */
3836 gfc_resolve_forall_body (code, nvar, var_expr);
3838 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3839 resolve_blocks (code->block, ns);
3841 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3842 for (i = 0; i < total_var; i++)
3843 gfc_free_expr (var_expr[i]);
3845 /* Reset the counters. */
3851 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3854 static void resolve_code (gfc_code *, gfc_namespace *);
3857 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3861 for (; b; b = b->block)
3863 t = gfc_resolve_expr (b->expr);
3864 if (gfc_resolve_expr (b->expr2) == FAILURE)
3870 if (t == SUCCESS && b->expr != NULL
3871 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3873 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3880 && (b->expr->ts.type != BT_LOGICAL
3881 || b->expr->rank == 0))
3883 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3888 resolve_branch (b->label, b);
3901 gfc_internal_error ("resolve_block(): Bad block type");
3904 resolve_code (b->next, ns);
3909 /* Given a block of code, recursively resolve everything pointed to by this
3913 resolve_code (gfc_code * code, gfc_namespace * ns)
3915 int forall_save = 0;
3920 frame.prev = cs_base;
3924 for (; code; code = code->next)
3926 frame.current = code;
3928 if (code->op == EXEC_FORALL)
3930 forall_save = forall_flag;
3932 gfc_resolve_forall (code, ns, forall_save);
3935 resolve_blocks (code->block, ns);
3937 if (code->op == EXEC_FORALL)
3938 forall_flag = forall_save;
3940 t = gfc_resolve_expr (code->expr);
3941 if (gfc_resolve_expr (code->expr2) == FAILURE)
3957 resolve_where (code, NULL);
3961 if (code->expr != NULL)
3963 if (code->expr->ts.type != BT_INTEGER)
3964 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3965 "variable", &code->expr->where);
3966 else if (code->expr->symtree->n.sym->attr.assign != 1)
3967 gfc_error ("Variable '%s' has not been assigned a target label "
3968 "at %L", code->expr->symtree->n.sym->name,
3969 &code->expr->where);
3972 resolve_branch (code->label, code);
3976 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3977 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3978 "return specifier", &code->expr->where);
3985 if (gfc_extend_assign (code, ns) == SUCCESS)
3988 if (gfc_pure (NULL))
3990 if (gfc_impure_variable (code->expr->symtree->n.sym))
3993 ("Cannot assign to variable '%s' in PURE procedure at %L",
3994 code->expr->symtree->n.sym->name, &code->expr->where);
3998 if (code->expr2->ts.type == BT_DERIVED
3999 && derived_pointer (code->expr2->ts.derived))
4002 ("Right side of assignment at %L is a derived type "
4003 "containing a POINTER in a PURE procedure",
4004 &code->expr2->where);
4009 gfc_check_assign (code->expr, code->expr2, 1);
4012 case EXEC_LABEL_ASSIGN:
4013 if (code->label->defined == ST_LABEL_UNKNOWN)
4014 gfc_error ("Label %d referenced at %L is never defined",
4015 code->label->value, &code->label->where);
4017 && (code->expr->expr_type != EXPR_VARIABLE
4018 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4019 || code->expr->symtree->n.sym->ts.kind
4020 != gfc_default_integer_kind
4021 || code->expr->symtree->n.sym->as != NULL))
4022 gfc_error ("ASSIGN statement at %L requires a scalar "
4023 "default INTEGER variable", &code->expr->where);
4026 case EXEC_POINTER_ASSIGN:
4030 gfc_check_pointer_assign (code->expr, code->expr2);
4033 case EXEC_ARITHMETIC_IF:
4035 && code->expr->ts.type != BT_INTEGER
4036 && code->expr->ts.type != BT_REAL)
4037 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4038 "expression", &code->expr->where);
4040 resolve_branch (code->label, code);
4041 resolve_branch (code->label2, code);
4042 resolve_branch (code->label3, code);
4046 if (t == SUCCESS && code->expr != NULL
4047 && (code->expr->ts.type != BT_LOGICAL
4048 || code->expr->rank != 0))
4049 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4050 &code->expr->where);
4055 resolve_call (code);
4059 /* Select is complicated. Also, a SELECT construct could be
4060 a transformed computed GOTO. */
4061 resolve_select (code);
4065 if (code->ext.iterator != NULL)
4066 gfc_resolve_iterator (code->ext.iterator, true);
4070 if (code->expr == NULL)
4071 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4073 && (code->expr->rank != 0
4074 || code->expr->ts.type != BT_LOGICAL))
4075 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4076 "a scalar LOGICAL expression", &code->expr->where);
4080 if (t == SUCCESS && code->expr != NULL
4081 && code->expr->ts.type != BT_INTEGER)
4082 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4083 "of type INTEGER", &code->expr->where);
4085 for (a = code->ext.alloc_list; a; a = a->next)
4086 resolve_allocate_expr (a->expr, code);
4090 case EXEC_DEALLOCATE:
4091 if (t == SUCCESS && code->expr != NULL
4092 && code->expr->ts.type != BT_INTEGER)
4094 ("STAT tag in DEALLOCATE statement at %L must be of type "
4095 "INTEGER", &code->expr->where);
4097 for (a = code->ext.alloc_list; a; a = a->next)
4098 resolve_deallocate_expr (a->expr);
4103 if (gfc_resolve_open (code->ext.open) == FAILURE)
4106 resolve_branch (code->ext.open->err, code);
4110 if (gfc_resolve_close (code->ext.close) == FAILURE)
4113 resolve_branch (code->ext.close->err, code);
4116 case EXEC_BACKSPACE:
4120 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4123 resolve_branch (code->ext.filepos->err, code);
4127 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4130 resolve_branch (code->ext.inquire->err, code);
4134 gcc_assert (code->ext.inquire != NULL);
4135 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4138 resolve_branch (code->ext.inquire->err, code);
4143 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4146 resolve_branch (code->ext.dt->err, code);
4147 resolve_branch (code->ext.dt->end, code);
4148 resolve_branch (code->ext.dt->eor, code);
4152 resolve_transfer (code);
4156 resolve_forall_iterators (code->ext.forall_iterator);
4158 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4160 ("FORALL mask clause at %L requires a LOGICAL expression",
4161 &code->expr->where);
4165 gfc_internal_error ("resolve_code(): Bad statement code");
4169 cs_base = frame.prev;
4173 /* Resolve initial values and make sure they are compatible with
4177 resolve_values (gfc_symbol * sym)
4180 if (sym->value == NULL)
4183 if (gfc_resolve_expr (sym->value) == FAILURE)
4186 gfc_check_assign_symbol (sym, sym->value);
4190 /* Do anything necessary to resolve a symbol. Right now, we just
4191 assume that an otherwise unknown symbol is a variable. This sort
4192 of thing commonly happens for symbols in module. */
4195 resolve_symbol (gfc_symbol * sym)
4197 /* Zero if we are checking a formal namespace. */
4198 static int formal_ns_flag = 1;
4199 int formal_ns_save, check_constant, mp_flag;
4202 gfc_symtree * symtree;
4203 gfc_symtree * this_symtree;
4206 gfc_formal_arglist * arg;
4208 if (sym->attr.flavor == FL_UNKNOWN)
4211 /* If we find that a flavorless symbol is an interface in one of the
4212 parent namespaces, find its symtree in this namespace, free the
4213 symbol and set the symtree to point to the interface symbol. */
4214 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4216 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4217 if (symtree && symtree->n.sym->generic)
4219 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4223 gfc_free_symbol (sym);
4224 symtree->n.sym->refs++;
4225 this_symtree->n.sym = symtree->n.sym;
4230 /* Otherwise give it a flavor according to such attributes as
4232 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4233 sym->attr.flavor = FL_VARIABLE;
4236 sym->attr.flavor = FL_PROCEDURE;
4237 if (sym->attr.dimension)
4238 sym->attr.function = 1;
4242 /* Symbols that are module procedures with results (functions) have
4243 the types and array specification copied for type checking in
4244 procedures that call them, as well as for saving to a module
4245 file. These symbols can't stand the scrutiny that their results
4247 mp_flag = (sym->result != NULL && sym->result != sym);
4249 /* Assign default type to symbols that need one and don't have one. */
4250 if (sym->ts.type == BT_UNKNOWN)
4252 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4253 gfc_set_default_type (sym, 1, NULL);
4255 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4257 /* The specific case of an external procedure should emit an error
4258 in the case that there is no implicit type. */
4260 gfc_set_default_type (sym, sym->attr.external, NULL);
4263 /* Result may be in another namespace. */
4264 resolve_symbol (sym->result);
4266 sym->ts = sym->result->ts;
4267 sym->as = gfc_copy_array_spec (sym->result->as);
4268 sym->attr.dimension = sym->result->attr.dimension;
4269 sym->attr.pointer = sym->result->attr.pointer;
4274 /* Assumed size arrays and assumed shape arrays must be dummy
4278 && (sym->as->type == AS_ASSUMED_SIZE
4279 || sym->as->type == AS_ASSUMED_SHAPE)
4280 && sym->attr.dummy == 0)
4282 if (sym->as->type == AS_ASSUMED_SIZE)
4283 gfc_error ("Assumed size array at %L must be a dummy argument",
4286 gfc_error ("Assumed shape array at %L must be a dummy argument",
4291 /* A parameter array's shape needs to be constant. */
4293 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4294 && !gfc_is_compile_time_shape (sym->as))
4296 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4297 "or assumed shape", sym->name, &sym->declared_at);
4301 /* A module array's shape needs to be constant. */
4303 if (sym->ns->proc_name
4304 && sym->attr.flavor == FL_VARIABLE
4305 && sym->ns->proc_name->attr.flavor == FL_MODULE
4306 && !sym->attr.use_assoc
4307 && !sym->attr.allocatable
4308 && !sym->attr.pointer
4310 && !gfc_is_compile_time_shape (sym->as))
4312 gfc_error ("Module array '%s' at %L cannot be automatic "
4313 "or assumed shape", sym->name, &sym->declared_at);
4317 /* Make sure that character string variables with assumed length are
4320 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4321 && sym->ts.type == BT_CHARACTER
4322 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4324 gfc_error ("Entity with assumed character length at %L must be a "
4325 "dummy argument or a PARAMETER", &sym->declared_at);
4329 /* Make sure a parameter that has been implicitly typed still
4330 matches the implicit type, since PARAMETER statements can precede
4331 IMPLICIT statements. */
4333 if (sym->attr.flavor == FL_PARAMETER
4334 && sym->attr.implicit_type
4335 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4336 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4337 "later IMPLICIT type", sym->name, &sym->declared_at);
4339 /* Make sure the types of derived parameters are consistent. This
4340 type checking is deferred until resolution because the type may
4341 refer to a derived type from the host. */
4343 if (sym->attr.flavor == FL_PARAMETER
4344 && sym->ts.type == BT_DERIVED
4345 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4346 gfc_error ("Incompatible derived type in PARAMETER at %L",
4347 &sym->value->where);
4349 /* Make sure symbols with known intent or optional are really dummy
4350 variable. Because of ENTRY statement, this has to be deferred
4351 until resolution time. */
4353 if (! sym->attr.dummy
4354 && (sym->attr.optional
4355 || sym->attr.intent != INTENT_UNKNOWN))
4357 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4361 if (sym->attr.proc == PROC_ST_FUNCTION)
4363 if (sym->ts.type == BT_CHARACTER)
4365 gfc_charlen *cl = sym->ts.cl;
4366 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4368 gfc_error ("Character-valued statement function '%s' at %L must "
4369 "have constant length", sym->name, &sym->declared_at);
4375 /* If a derived type symbol has reached this point, without its
4376 type being declared, we have an error. Notice that most
4377 conditions that produce undefined derived types have already
4378 been dealt with. However, the likes of:
4379 implicit type(t) (t) ..... call foo (t) will get us here if
4380 the type is not declared in the scope of the implicit
4381 statement. Change the type to BT_UNKNOWN, both because it is so
4382 and to prevent an ICE. */
4383 if (sym->ts.type == BT_DERIVED
4384 && sym->ts.derived->components == NULL)
4386 gfc_error ("The derived type '%s' at %L is of type '%s', "
4387 "which has not been defined.", sym->name,
4388 &sym->declared_at, sym->ts.derived->name);
4389 sym->ts.type = BT_UNKNOWN;
4393 /* If a component of a derived type is of a type declared to be private,
4394 either the derived type definition must contain the PRIVATE statement,
4395 or the derived type must be private. (4.4.1 just after R427) */
4396 if (sym->attr.flavor == FL_DERIVED
4397 && sym->component_access != ACCESS_PRIVATE
4398 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4400 for (c = sym->components; c; c = c->next)
4402 if (c->ts.type == BT_DERIVED
4403 && !c->ts.derived->attr.use_assoc
4404 && !gfc_check_access(c->ts.derived->attr.access,
4405 c->ts.derived->ns->default_access))
4407 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4408 "a component of '%s', which is PUBLIC at %L",
4409 c->name, sym->name, &sym->declared_at);
4415 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4416 default initialization is defined (5.1.2.4.4). */
4417 if (sym->ts.type == BT_DERIVED
4419 && sym->attr.intent == INTENT_OUT
4421 && sym->as->type == AS_ASSUMED_SIZE)
4423 for (c = sym->ts.derived->components; c; c = c->next)
4427 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4428 "ASSUMED SIZE and so cannot have a default initializer",
4429 sym->name, &sym->declared_at);
4436 /* Ensure that derived type formal arguments of a public procedure
4437 are not of a private type. */
4438 if (sym->attr.flavor == FL_PROCEDURE
4439 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4441 for (arg = sym->formal; arg; arg = arg->next)
4444 && arg->sym->ts.type == BT_DERIVED
4445 && !arg->sym->ts.derived->attr.use_assoc
4446 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4447 arg->sym->ts.derived->ns->default_access))
4449 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4450 "a dummy argument of '%s', which is PUBLIC at %L",
4451 arg->sym->name, sym->name, &sym->declared_at);
4452 /* Stop this message from recurring. */
4453 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4459 /* Constraints on deferred shape variable. */
4460 if (sym->attr.flavor == FL_VARIABLE
4461 || (sym->attr.flavor == FL_PROCEDURE
4462 && sym->attr.function))
4464 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4466 if (sym->attr.allocatable)
4468 if (sym->attr.dimension)
4469 gfc_error ("Allocatable array '%s' at %L must have "
4470 "a deferred shape", sym->name, &sym->declared_at);
4472 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4473 sym->name, &sym->declared_at);
4477 if (sym->attr.pointer && sym->attr.dimension)
4479 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4480 sym->name, &sym->declared_at);
4487 if (!mp_flag && !sym->attr.allocatable
4488 && !sym->attr.pointer && !sym->attr.dummy)
4490 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4491 sym->name, &sym->declared_at);
4497 switch (sym->attr.flavor)
4500 /* Can the symbol have an initializer? */
4502 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4503 || sym->attr.intrinsic || sym->attr.result)
4505 else if (sym->attr.dimension && !sym->attr.pointer)
4507 /* Don't allow initialization of automatic arrays. */
4508 for (i = 0; i < sym->as->rank; i++)
4510 if (sym->as->lower[i] == NULL
4511 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4512 || sym->as->upper[i] == NULL
4513 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4521 /* Reject illegal initializers. */
4522 if (sym->value && flag)
4524 if (sym->attr.allocatable)
4525 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4526 sym->name, &sym->declared_at);
4527 else if (sym->attr.external)
4528 gfc_error ("External '%s' at %L cannot have an initializer",
4529 sym->name, &sym->declared_at);
4530 else if (sym->attr.dummy)
4531 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4532 sym->name, &sym->declared_at);
4533 else if (sym->attr.intrinsic)
4534 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4535 sym->name, &sym->declared_at);
4536 else if (sym->attr.result)
4537 gfc_error ("Function result '%s' at %L cannot have an initializer",
4538 sym->name, &sym->declared_at);
4540 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4541 sym->name, &sym->declared_at);
4545 /* Assign default initializer. */
4546 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4547 && !sym->attr.pointer)
4548 sym->value = gfc_default_initializer (&sym->ts);
4552 /* Reject PRIVATE objects in a PUBLIC namelist. */
4553 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4555 for (nl = sym->namelist; nl; nl = nl->next)
4557 if (!nl->sym->attr.use_assoc
4559 !(sym->ns->parent == nl->sym->ns)
4561 !gfc_check_access(nl->sym->attr.access,
4562 nl->sym->ns->default_access))
4563 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4564 "PUBLIC namelist at %L", nl->sym->name,
4572 /* An external symbol falls through to here if it is not referenced. */
4573 if (sym->attr.external && sym->value)
4575 gfc_error ("External object '%s' at %L may not have an initializer",
4576 sym->name, &sym->declared_at);
4584 /* Make sure that intrinsic exist */
4585 if (sym->attr.intrinsic
4586 && ! gfc_intrinsic_name(sym->name, 0)
4587 && ! gfc_intrinsic_name(sym->name, 1))
4588 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4590 /* Resolve array specifier. Check as well some constraints
4591 on COMMON blocks. */
4593 check_constant = sym->attr.in_common && !sym->attr.pointer;
4594 gfc_resolve_array_spec (sym->as, check_constant);
4596 /* Resolve formal namespaces. */
4598 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4600 formal_ns_save = formal_ns_flag;
4602 gfc_resolve (sym->formal_ns);
4603 formal_ns_flag = formal_ns_save;
4609 /************* Resolve DATA statements *************/
4613 gfc_data_value *vnode;
4619 /* Advance the values structure to point to the next value in the data list. */
4622 next_data_value (void)
4624 while (values.left == 0)
4626 if (values.vnode->next == NULL)
4629 values.vnode = values.vnode->next;
4630 values.left = values.vnode->repeat;
4638 check_data_variable (gfc_data_variable * var, locus * where)
4644 ar_type mark = AR_UNKNOWN;
4646 mpz_t section_index[GFC_MAX_DIMENSIONS];
4650 if (gfc_resolve_expr (var->expr) == FAILURE)
4654 mpz_init_set_si (offset, 0);
4657 if (e->expr_type != EXPR_VARIABLE)
4658 gfc_internal_error ("check_data_variable(): Bad expression");
4662 mpz_init_set_ui (size, 1);
4669 /* Find the array section reference. */
4670 for (ref = e->ref; ref; ref = ref->next)
4672 if (ref->type != REF_ARRAY)
4674 if (ref->u.ar.type == AR_ELEMENT)
4680 /* Set marks according to the reference pattern. */
4681 switch (ref->u.ar.type)
4689 /* Get the start position of array section. */
4690 gfc_get_section_index (ar, section_index, &offset);
4698 if (gfc_array_size (e, &size) == FAILURE)
4700 gfc_error ("Nonconstant array section at %L in DATA statement",
4709 while (mpz_cmp_ui (size, 0) > 0)
4711 if (next_data_value () == FAILURE)
4713 gfc_error ("DATA statement at %L has more variables than values",
4719 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4723 /* If we have more than one element left in the repeat count,
4724 and we have more than one element left in the target variable,
4725 then create a range assignment. */
4726 /* ??? Only done for full arrays for now, since array sections
4728 if (mark == AR_FULL && ref && ref->next == NULL
4729 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4733 if (mpz_cmp_ui (size, values.left) >= 0)
4735 mpz_init_set_ui (range, values.left);
4736 mpz_sub_ui (size, size, values.left);
4741 mpz_init_set (range, size);
4742 values.left -= mpz_get_ui (size);
4743 mpz_set_ui (size, 0);
4746 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4749 mpz_add (offset, offset, range);
4753 /* Assign initial value to symbol. */
4757 mpz_sub_ui (size, size, 1);
4759 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4761 if (mark == AR_FULL)
4762 mpz_add_ui (offset, offset, 1);
4764 /* Modify the array section indexes and recalculate the offset
4765 for next element. */
4766 else if (mark == AR_SECTION)
4767 gfc_advance_section (section_index, ar, &offset);
4771 if (mark == AR_SECTION)
4773 for (i = 0; i < ar->dimen; i++)
4774 mpz_clear (section_index[i]);
4784 static try traverse_data_var (gfc_data_variable *, locus *);
4786 /* Iterate over a list of elements in a DATA statement. */
4789 traverse_data_list (gfc_data_variable * var, locus * where)
4792 iterator_stack frame;
4795 mpz_init (frame.value);
4797 mpz_init_set (trip, var->iter.end->value.integer);
4798 mpz_sub (trip, trip, var->iter.start->value.integer);
4799 mpz_add (trip, trip, var->iter.step->value.integer);
4801 mpz_div (trip, trip, var->iter.step->value.integer);
4803 mpz_set (frame.value, var->iter.start->value.integer);
4805 frame.prev = iter_stack;
4806 frame.variable = var->iter.var->symtree;
4807 iter_stack = &frame;
4809 while (mpz_cmp_ui (trip, 0) > 0)
4811 if (traverse_data_var (var->list, where) == FAILURE)
4817 e = gfc_copy_expr (var->expr);
4818 if (gfc_simplify_expr (e, 1) == FAILURE)
4824 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4826 mpz_sub_ui (trip, trip, 1);
4830 mpz_clear (frame.value);
4832 iter_stack = frame.prev;
4837 /* Type resolve variables in the variable list of a DATA statement. */
4840 traverse_data_var (gfc_data_variable * var, locus * where)
4844 for (; var; var = var->next)
4846 if (var->expr == NULL)
4847 t = traverse_data_list (var, where);
4849 t = check_data_variable (var, where);
4859 /* Resolve the expressions and iterators associated with a data statement.
4860 This is separate from the assignment checking because data lists should
4861 only be resolved once. */
4864 resolve_data_variables (gfc_data_variable * d)
4866 for (; d; d = d->next)
4868 if (d->list == NULL)
4870 if (gfc_resolve_expr (d->expr) == FAILURE)
4875 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
4878 if (d->iter.start->expr_type != EXPR_CONSTANT
4879 || d->iter.end->expr_type != EXPR_CONSTANT
4880 || d->iter.step->expr_type != EXPR_CONSTANT)
4881 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4883 if (resolve_data_variables (d->list) == FAILURE)
4892 /* Resolve a single DATA statement. We implement this by storing a pointer to
4893 the value list into static variables, and then recursively traversing the
4894 variables list, expanding iterators and such. */
4897 resolve_data (gfc_data * d)
4899 if (resolve_data_variables (d->var) == FAILURE)
4902 values.vnode = d->value;
4903 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4905 if (traverse_data_var (d->var, &d->where) == FAILURE)
4908 /* At this point, we better not have any values left. */
4910 if (next_data_value () == SUCCESS)
4911 gfc_error ("DATA statement at %L has more values than variables",
4916 /* Determines if a variable is not 'pure', ie not assignable within a pure
4917 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4921 gfc_impure_variable (gfc_symbol * sym)
4923 if (sym->attr.use_assoc || sym->attr.in_common)
4926 if (sym->ns != gfc_current_ns)
4927 return !sym->attr.function;
4929 /* TODO: Check storage association through EQUIVALENCE statements */
4935 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4936 symbol of the current procedure. */
4939 gfc_pure (gfc_symbol * sym)
4941 symbol_attribute attr;
4944 sym = gfc_current_ns->proc_name;
4950 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4954 /* Test whether the current procedure is elemental or not. */
4957 gfc_elemental (gfc_symbol * sym)
4959 symbol_attribute attr;
4962 sym = gfc_current_ns->proc_name;
4967 return attr.flavor == FL_PROCEDURE && attr.elemental;
4971 /* Warn about unused labels. */
4974 warn_unused_label (gfc_namespace * ns)
4985 for (; l; l = l->prev)
4987 if (l->defined == ST_LABEL_UNKNOWN)
4990 switch (l->referenced)
4992 case ST_LABEL_UNKNOWN:
4993 gfc_warning ("Label %d at %L defined but not used", l->value,
4997 case ST_LABEL_BAD_TARGET:
4998 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
5009 /* Returns the sequence type of a symbol or sequence. */
5012 sequence_type (gfc_typespec ts)
5021 if (ts.derived->components == NULL)
5022 return SEQ_NONDEFAULT;
5024 result = sequence_type (ts.derived->components->ts);
5025 for (c = ts.derived->components->next; c; c = c->next)
5026 if (sequence_type (c->ts) != result)
5032 if (ts.kind != gfc_default_character_kind)
5033 return SEQ_NONDEFAULT;
5035 return SEQ_CHARACTER;
5038 if (ts.kind != gfc_default_integer_kind)
5039 return SEQ_NONDEFAULT;
5044 if (!(ts.kind == gfc_default_real_kind
5045 || ts.kind == gfc_default_double_kind))
5046 return SEQ_NONDEFAULT;
5051 if (ts.kind != gfc_default_complex_kind)
5052 return SEQ_NONDEFAULT;
5057 if (ts.kind != gfc_default_logical_kind)
5058 return SEQ_NONDEFAULT;
5063 return SEQ_NONDEFAULT;
5068 /* Resolve derived type EQUIVALENCE object. */
5071 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5074 gfc_component *c = derived->components;
5079 /* Shall not be an object of nonsequence derived type. */
5080 if (!derived->attr.sequence)
5082 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5083 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5087 for (; c ; c = c->next)
5090 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5093 /* Shall not be an object of sequence derived type containing a pointer
5094 in the structure. */
5097 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5098 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5104 gfc_error ("Derived type variable '%s' at %L with default initializer "
5105 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5113 /* Resolve equivalence object.
5114 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5115 an allocatable array, an object of nonsequence derived type, an object of
5116 sequence derived type containing a pointer at any level of component
5117 selection, an automatic object, a function name, an entry name, a result
5118 name, a named constant, a structure component, or a subobject of any of
5119 the preceding objects. A substring shall not have length zero. A
5120 derived type shall not have components with default initialization nor
5121 shall two objects of an equivalence group be initialized.
5122 The simple constraints are done in symbol.c(check_conflict) and the rest
5123 are implemented here. */
5126 resolve_equivalence (gfc_equiv *eq)
5129 gfc_symbol *derived;
5130 gfc_symbol *first_sym;
5133 locus *last_where = NULL;
5134 seq_type eq_type, last_eq_type;
5135 gfc_typespec *last_ts;
5137 const char *value_name;
5141 last_ts = &eq->expr->symtree->n.sym->ts;
5143 first_sym = eq->expr->symtree->n.sym;
5145 for (object = 1; eq; eq = eq->eq, object++)
5149 e->ts = e->symtree->n.sym->ts;
5150 /* match_varspec might not know yet if it is seeing
5151 array reference or substring reference, as it doesn't
5153 if (e->ref && e->ref->type == REF_ARRAY)
5155 gfc_ref *ref = e->ref;
5156 sym = e->symtree->n.sym;
5158 if (sym->attr.dimension)
5160 ref->u.ar.as = sym->as;
5164 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5165 if (e->ts.type == BT_CHARACTER
5167 && ref->type == REF_ARRAY
5168 && ref->u.ar.dimen == 1
5169 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5170 && ref->u.ar.stride[0] == NULL)
5172 gfc_expr *start = ref->u.ar.start[0];
5173 gfc_expr *end = ref->u.ar.end[0];
5176 /* Optimize away the (:) reference. */
5177 if (start == NULL && end == NULL)
5182 e->ref->next = ref->next;
5187 ref->type = REF_SUBSTRING;
5189 start = gfc_int_expr (1);
5190 ref->u.ss.start = start;
5191 if (end == NULL && e->ts.cl)
5192 end = gfc_copy_expr (e->ts.cl->length);
5193 ref->u.ss.end = end;
5194 ref->u.ss.length = e->ts.cl;
5201 /* Any further ref is an error. */
5204 gcc_assert (ref->type == REF_ARRAY);
5205 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5211 if (gfc_resolve_expr (e) == FAILURE)
5214 sym = e->symtree->n.sym;
5216 /* An equivalence statement cannot have more than one initialized
5220 if (value_name != NULL)
5222 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5223 "be in the EQUIVALENCE statement at %L",
5224 value_name, sym->name, &e->where);
5228 value_name = sym->name;
5231 /* Shall not equivalence common block variables in a PURE procedure. */
5232 if (sym->ns->proc_name
5233 && sym->ns->proc_name->attr.pure
5234 && sym->attr.in_common)
5236 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5237 "object in the pure procedure '%s'",
5238 sym->name, &e->where, sym->ns->proc_name->name);
5242 /* Shall not be a named constant. */
5243 if (e->expr_type == EXPR_CONSTANT)
5245 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5246 "object", sym->name, &e->where);
5250 derived = e->ts.derived;
5251 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5254 /* Check that the types correspond correctly:
5256 A numeric sequence structure may be equivalenced to another sequence
5257 structure, an object of default integer type, default real type, double
5258 precision real type, default logical type such that components of the
5259 structure ultimately only become associated to objects of the same
5260 kind. A character sequence structure may be equivalenced to an object
5261 of default character kind or another character sequence structure.
5262 Other objects may be equivalenced only to objects of the same type and
5265 /* Identical types are unconditionally OK. */
5266 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5267 goto identical_types;
5269 last_eq_type = sequence_type (*last_ts);
5270 eq_type = sequence_type (sym->ts);
5272 /* Since the pair of objects is not of the same type, mixed or
5273 non-default sequences can be rejected. */
5275 msg = "Sequence %s with mixed components in EQUIVALENCE "
5276 "statement at %L with different type objects";
5278 && last_eq_type == SEQ_MIXED
5279 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5280 last_where) == FAILURE)
5281 || (eq_type == SEQ_MIXED
5282 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5283 &e->where) == FAILURE))
5286 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5287 "statement at %L with objects of different type";
5289 && last_eq_type == SEQ_NONDEFAULT
5290 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5291 last_where) == FAILURE)
5292 || (eq_type == SEQ_NONDEFAULT
5293 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5294 &e->where) == FAILURE))
5297 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5298 "EQUIVALENCE statement at %L";
5299 if (last_eq_type == SEQ_CHARACTER
5300 && eq_type != SEQ_CHARACTER
5301 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5302 &e->where) == FAILURE)
5305 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5306 "EQUIVALENCE statement at %L";
5307 if (last_eq_type == SEQ_NUMERIC
5308 && eq_type != SEQ_NUMERIC
5309 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5310 &e->where) == FAILURE)
5315 last_where = &e->where;
5320 /* Shall not be an automatic array. */
5321 if (e->ref->type == REF_ARRAY
5322 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5324 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5325 "an EQUIVALENCE object", sym->name, &e->where);
5332 /* Shall not be a structure component. */
5333 if (r->type == REF_COMPONENT)
5335 gfc_error ("Structure component '%s' at %L cannot be an "
5336 "EQUIVALENCE object",
5337 r->u.c.component->name, &e->where);
5341 /* A substring shall not have length zero. */
5342 if (r->type == REF_SUBSTRING)
5344 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5346 gfc_error ("Substring at %L has length zero",
5347 &r->u.ss.start->where);
5357 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5360 resolve_fntype (gfc_namespace * ns)
5365 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5368 /* If there are any entries, ns->proc_name is the entry master
5369 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5371 sym = ns->entries->sym;
5373 sym = ns->proc_name;
5374 if (sym->result == sym
5375 && sym->ts.type == BT_UNKNOWN
5376 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5377 && !sym->attr.untyped)
5379 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5380 sym->name, &sym->declared_at);
5381 sym->attr.untyped = 1;
5385 for (el = ns->entries->next; el; el = el->next)
5387 if (el->sym->result == el->sym
5388 && el->sym->ts.type == BT_UNKNOWN
5389 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5390 && !el->sym->attr.untyped)
5392 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5393 el->sym->name, &el->sym->declared_at);
5394 el->sym->attr.untyped = 1;
5400 /* This function is called after a complete program unit has been compiled.
5401 Its purpose is to examine all of the expressions associated with a program
5402 unit, assign types to all intermediate expressions, make sure that all
5403 assignments are to compatible types and figure out which names refer to
5404 which functions or subroutines. */
5407 gfc_resolve (gfc_namespace * ns)
5409 gfc_namespace *old_ns, *n;
5414 old_ns = gfc_current_ns;
5415 gfc_current_ns = ns;
5417 resolve_entries (ns);
5419 resolve_contained_functions (ns);
5421 gfc_traverse_ns (ns, resolve_symbol);
5423 resolve_fntype (ns);
5425 for (n = ns->contained; n; n = n->sibling)
5427 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5428 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5429 "also be PURE", n->proc_name->name,
5430 &n->proc_name->declared_at);
5436 gfc_check_interfaces (ns);
5438 for (cl = ns->cl_list; cl; cl = cl->next)
5440 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
5443 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
5446 if (gfc_specification_expr (cl->length) == FAILURE)
5450 gfc_traverse_ns (ns, resolve_values);
5456 for (d = ns->data; d; d = d->next)
5460 gfc_traverse_ns (ns, gfc_formalize_init_value);
5462 for (eq = ns->equiv; eq; eq = eq->next)
5463 resolve_equivalence (eq);
5466 resolve_code (ns->code, ns);
5468 /* Warn about unused labels. */
5469 if (gfc_option.warn_unused_labels)
5470 warn_unused_label (ns);
5472 gfc_current_ns = old_ns;