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(). */
27 #include "dependency.h"
29 /* Types used in equivalence statements. */
33 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
37 /* Stack to push the current if we descend into a block during
38 resolution. See resolve_branch() and resolve_code(). */
40 typedef struct code_stack
42 struct gfc_code *head, *current;
43 struct code_stack *prev;
47 static code_stack *cs_base = NULL;
50 /* Nonzero if we're inside a FORALL block */
52 static int forall_flag;
54 /* Nonzero if we are processing a formal arglist. The corresponding function
55 resets the flag each time that it is read. */
56 static int formal_arg_flag = 0;
59 gfc_is_formal_arg (void)
61 return formal_arg_flag;
64 /* Resolve types of formal argument lists. These have to be done early so that
65 the formal argument lists of module procedures can be copied to the
66 containing module before the individual procedures are resolved
67 individually. We also resolve argument lists of procedures in interface
68 blocks because they are self-contained scoping units.
70 Since a dummy argument cannot be a non-dummy procedure, the only
71 resort left for untyped names are the IMPLICIT types. */
74 resolve_formal_arglist (gfc_symbol * proc)
76 gfc_formal_arglist *f;
80 /* TODO: Procedures whose return character length parameter is not constant
81 or assumed must also have explicit interfaces. */
82 if (proc->result != NULL)
87 if (gfc_elemental (proc)
88 || sym->attr.pointer || sym->attr.allocatable
89 || (sym->as && sym->as->rank > 0))
90 proc->attr.always_explicit = 1;
94 for (f = proc->formal; f; f = f->next)
100 /* Alternate return placeholder. */
101 if (gfc_elemental (proc))
102 gfc_error ("Alternate return specifier in elemental subroutine "
103 "'%s' at %L is not allowed", proc->name,
105 if (proc->attr.function)
106 gfc_error ("Alternate return specifier in function "
107 "'%s' at %L is not allowed", proc->name,
112 if (sym->attr.if_source != IFSRC_UNKNOWN)
113 resolve_formal_arglist (sym);
115 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
117 if (gfc_pure (proc) && !gfc_pure (sym))
120 ("Dummy procedure '%s' of PURE procedure at %L must also "
121 "be PURE", sym->name, &sym->declared_at);
125 if (gfc_elemental (proc))
128 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
136 if (sym->ts.type == BT_UNKNOWN)
138 if (!sym->attr.function || sym->result == sym)
139 gfc_set_default_type (sym, 1, sym->ns);
142 /* Set the type of the RESULT, then copy. */
143 if (sym->result->ts.type == BT_UNKNOWN)
144 gfc_set_default_type (sym->result, 1, sym->result->ns);
146 sym->ts = sym->result->ts;
148 sym->as = gfc_copy_array_spec (sym->result->as);
152 gfc_resolve_array_spec (sym->as, 0);
154 /* We can't tell if an array with dimension (:) is assumed or deferred
155 shape until we know if it has the pointer or allocatable attributes.
157 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
158 && !(sym->attr.pointer || sym->attr.allocatable))
160 sym->as->type = AS_ASSUMED_SHAPE;
161 for (i = 0; i < sym->as->rank; i++)
162 sym->as->lower[i] = gfc_int_expr (1);
165 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
166 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
167 || sym->attr.optional)
168 proc->attr.always_explicit = 1;
170 /* If the flavor is unknown at this point, it has to be a variable.
171 A procedure specification would have already set the type. */
173 if (sym->attr.flavor == FL_UNKNOWN)
174 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
178 if (proc->attr.function && !sym->attr.pointer
179 && sym->attr.flavor != FL_PROCEDURE
180 && sym->attr.intent != INTENT_IN)
182 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
183 "INTENT(IN)", sym->name, proc->name,
186 if (proc->attr.subroutine && !sym->attr.pointer
187 && sym->attr.intent == INTENT_UNKNOWN)
190 ("Argument '%s' of pure subroutine '%s' at %L must have "
191 "its INTENT specified", sym->name, proc->name,
196 if (gfc_elemental (proc))
201 ("Argument '%s' of elemental procedure at %L must be scalar",
202 sym->name, &sym->declared_at);
206 if (sym->attr.pointer)
209 ("Argument '%s' of elemental procedure at %L cannot have "
210 "the POINTER attribute", sym->name, &sym->declared_at);
215 /* Each dummy shall be specified to be scalar. */
216 if (proc->attr.proc == PROC_ST_FUNCTION)
221 ("Argument '%s' of statement function at %L must be scalar",
222 sym->name, &sym->declared_at);
226 if (sym->ts.type == BT_CHARACTER)
228 gfc_charlen *cl = sym->ts.cl;
229 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
232 ("Character-valued argument '%s' of statement function at "
233 "%L must has constant length",
234 sym->name, &sym->declared_at);
244 /* Work function called when searching for symbols that have argument lists
245 associated with them. */
248 find_arglists (gfc_symbol * sym)
251 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
254 resolve_formal_arglist (sym);
258 /* Given a namespace, resolve all formal argument lists within the namespace.
262 resolve_formal_arglists (gfc_namespace * ns)
268 gfc_traverse_ns (ns, find_arglists);
273 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
277 /* If this namespace is not a function, ignore it. */
279 || !(sym->attr.function
280 || sym->attr.flavor == FL_VARIABLE))
283 /* Try to find out of what the return type is. */
284 if (sym->result != NULL)
287 if (sym->ts.type == BT_UNKNOWN)
289 t = gfc_set_default_type (sym, 0, ns);
291 if (t == FAILURE && !sym->attr.untyped)
293 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
294 sym->name, &sym->declared_at); /* FIXME */
295 sym->attr.untyped = 1;
299 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
300 lists the only ways a character length value of * can be used: dummy arguments
301 of proceedures, named constants, and function results in external functions.
302 Internal function results are not on that list; ergo, not permitted. */
304 if (sym->ts.type == BT_CHARACTER)
306 gfc_charlen *cl = sym->ts.cl;
307 if (!cl || !cl->length)
308 gfc_error ("Character-valued internal function '%s' at %L must "
309 "not be assumed length", sym->name, &sym->declared_at);
314 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
315 introduce duplicates. */
318 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
320 gfc_formal_arglist *f, *new_arglist;
323 for (; new_args != NULL; new_args = new_args->next)
325 new_sym = new_args->sym;
326 /* See if ths arg is already in the formal argument list. */
327 for (f = proc->formal; f; f = f->next)
329 if (new_sym == f->sym)
336 /* Add a new argument. Argument order is not important. */
337 new_arglist = gfc_get_formal_arglist ();
338 new_arglist->sym = new_sym;
339 new_arglist->next = proc->formal;
340 proc->formal = new_arglist;
345 /* Resolve alternate entry points. If a symbol has multiple entry points we
346 create a new master symbol for the main routine, and turn the existing
347 symbol into an entry point. */
350 resolve_entries (gfc_namespace * ns)
352 gfc_namespace *old_ns;
356 char name[GFC_MAX_SYMBOL_LEN + 1];
357 static int master_count = 0;
359 if (ns->proc_name == NULL)
362 /* No need to do anything if this procedure doesn't have alternate entry
367 /* We may already have resolved alternate entry points. */
368 if (ns->proc_name->attr.entry_master)
371 /* If this isn't a procedure something has gone horribly wrong. */
372 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
374 /* Remember the current namespace. */
375 old_ns = gfc_current_ns;
379 /* Add the main entry point to the list of entry points. */
380 el = gfc_get_entry_list ();
381 el->sym = ns->proc_name;
383 el->next = ns->entries;
385 ns->proc_name->attr.entry = 1;
387 /* Add an entry statement for it. */
394 /* Create a new symbol for the master function. */
395 /* Give the internal function a unique name (within this file).
396 Also include the function name so the user has some hope of figuring
397 out what is going on. */
398 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
399 master_count++, ns->proc_name->name);
400 gfc_get_ha_symbol (name, &proc);
401 gcc_assert (proc != NULL);
403 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
404 if (ns->proc_name->attr.subroutine)
405 gfc_add_subroutine (&proc->attr, proc->name, NULL);
409 gfc_typespec *ts, *fts;
411 gfc_add_function (&proc->attr, proc->name, NULL);
413 fts = &ns->entries->sym->result->ts;
414 if (fts->type == BT_UNKNOWN)
415 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
416 for (el = ns->entries->next; el; el = el->next)
418 ts = &el->sym->result->ts;
419 if (ts->type == BT_UNKNOWN)
420 ts = gfc_get_default_type (el->sym->result, NULL);
421 if (! gfc_compare_types (ts, fts)
422 || (el->sym->result->attr.dimension
423 != ns->entries->sym->result->attr.dimension)
424 || (el->sym->result->attr.pointer
425 != ns->entries->sym->result->attr.pointer))
431 sym = ns->entries->sym->result;
432 /* All result types the same. */
434 if (sym->attr.dimension)
435 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
436 if (sym->attr.pointer)
437 gfc_add_pointer (&proc->attr, NULL);
441 /* Otherwise the result will be passed through a union by
443 proc->attr.mixed_entry_master = 1;
444 for (el = ns->entries; el; el = el->next)
446 sym = el->sym->result;
447 if (sym->attr.dimension)
449 if (el == ns->entries)
451 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
452 sym->name, ns->entries->sym->name, &sym->declared_at);
455 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
456 sym->name, ns->entries->sym->name, &sym->declared_at);
458 else if (sym->attr.pointer)
460 if (el == ns->entries)
462 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
463 sym->name, ns->entries->sym->name, &sym->declared_at);
466 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
467 sym->name, ns->entries->sym->name, &sym->declared_at);
472 if (ts->type == BT_UNKNOWN)
473 ts = gfc_get_default_type (sym, NULL);
477 if (ts->kind == gfc_default_integer_kind)
481 if (ts->kind == gfc_default_real_kind
482 || ts->kind == gfc_default_double_kind)
486 if (ts->kind == gfc_default_complex_kind)
490 if (ts->kind == gfc_default_logical_kind)
494 /* We will issue error elsewhere. */
502 if (el == ns->entries)
504 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
505 sym->name, gfc_typename (ts), ns->entries->sym->name,
509 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
510 sym->name, gfc_typename (ts), ns->entries->sym->name,
517 proc->attr.access = ACCESS_PRIVATE;
518 proc->attr.entry_master = 1;
520 /* Merge all the entry point arguments. */
521 for (el = ns->entries; el; el = el->next)
522 merge_argument_lists (proc, el->sym->formal);
524 /* Use the master function for the function body. */
525 ns->proc_name = proc;
527 /* Finalize the new symbols. */
528 gfc_commit_symbols ();
530 /* Restore the original namespace. */
531 gfc_current_ns = old_ns;
535 /* Resolve contained function types. Because contained functions can call one
536 another, they have to be worked out before any of the contained procedures
539 The good news is that if a function doesn't already have a type, the only
540 way it can get one is through an IMPLICIT type or a RESULT variable, because
541 by definition contained functions are contained namespace they're contained
542 in, not in a sibling or parent namespace. */
545 resolve_contained_functions (gfc_namespace * ns)
547 gfc_namespace *child;
550 resolve_formal_arglists (ns);
552 for (child = ns->contained; child; child = child->sibling)
554 /* Resolve alternate entry points first. */
555 resolve_entries (child);
557 /* Then check function return types. */
558 resolve_contained_fntype (child->proc_name, child);
559 for (el = child->entries; el; el = el->next)
560 resolve_contained_fntype (el->sym, child);
565 /* Resolve all of the elements of a structure constructor and make sure that
566 the types are correct. */
569 resolve_structure_cons (gfc_expr * expr)
571 gfc_constructor *cons;
576 cons = expr->value.constructor;
577 /* A constructor may have references if it is the result of substituting a
578 parameter variable. In this case we just pull out the component we
581 comp = expr->ref->u.c.sym->components;
583 comp = expr->ts.derived->components;
585 for (; comp; comp = comp->next, cons = cons->next)
593 if (gfc_resolve_expr (cons->expr) == FAILURE)
599 /* If we don't have the right type, try to convert it. */
601 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
602 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
611 /****************** Expression name resolution ******************/
613 /* Returns 0 if a symbol was not declared with a type or
614 attribute declaration statement, nonzero otherwise. */
617 was_declared (gfc_symbol * sym)
623 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
626 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
627 || a.optional || a.pointer || a.save || a.target
628 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
635 /* Determine if a symbol is generic or not. */
638 generic_sym (gfc_symbol * sym)
642 if (sym->attr.generic ||
643 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
646 if (was_declared (sym) || sym->ns->parent == NULL)
649 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
651 return (s == NULL) ? 0 : generic_sym (s);
655 /* Determine if a symbol is specific or not. */
658 specific_sym (gfc_symbol * sym)
662 if (sym->attr.if_source == IFSRC_IFBODY
663 || sym->attr.proc == PROC_MODULE
664 || sym->attr.proc == PROC_INTERNAL
665 || sym->attr.proc == PROC_ST_FUNCTION
666 || (sym->attr.intrinsic &&
667 gfc_specific_intrinsic (sym->name))
668 || sym->attr.external)
671 if (was_declared (sym) || sym->ns->parent == NULL)
674 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
676 return (s == NULL) ? 0 : specific_sym (s);
680 /* Figure out if the procedure is specific, generic or unknown. */
683 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
687 procedure_kind (gfc_symbol * sym)
690 if (generic_sym (sym))
691 return PTYPE_GENERIC;
693 if (specific_sym (sym))
694 return PTYPE_SPECIFIC;
696 return PTYPE_UNKNOWN;
700 /* Resolve an actual argument list. Most of the time, this is just
701 resolving the expressions in the list.
702 The exception is that we sometimes have to decide whether arguments
703 that look like procedure arguments are really simple variable
707 resolve_actual_arglist (gfc_actual_arglist * arg)
710 gfc_symtree *parent_st;
713 for (; arg; arg = arg->next)
719 /* Check the label is a valid branching target. */
722 if (arg->label->defined == ST_LABEL_UNKNOWN)
724 gfc_error ("Label %d referenced at %L is never defined",
725 arg->label->value, &arg->label->where);
732 if (e->ts.type != BT_PROCEDURE)
734 if (gfc_resolve_expr (e) != SUCCESS)
739 /* See if the expression node should really be a variable
742 sym = e->symtree->n.sym;
744 if (sym->attr.flavor == FL_PROCEDURE
745 || sym->attr.intrinsic
746 || sym->attr.external)
749 if (sym->attr.proc == PROC_ST_FUNCTION)
751 gfc_error ("Statement function '%s' at %L is not allowed as an "
752 "actual argument", sym->name, &e->where);
755 /* If the symbol is the function that names the current (or
756 parent) scope, then we really have a variable reference. */
758 if (sym->attr.function && sym->result == sym
759 && (sym->ns->proc_name == sym
760 || (sym->ns->parent != NULL
761 && sym->ns->parent->proc_name == sym)))
767 /* See if the name is a module procedure in a parent unit. */
769 if (was_declared (sym) || sym->ns->parent == NULL)
772 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
774 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
778 if (parent_st == NULL)
781 sym = parent_st->n.sym;
782 e->symtree = parent_st; /* Point to the right thing. */
784 if (sym->attr.flavor == FL_PROCEDURE
785 || sym->attr.intrinsic
786 || sym->attr.external)
792 e->expr_type = EXPR_VARIABLE;
796 e->rank = sym->as->rank;
797 e->ref = gfc_get_ref ();
798 e->ref->type = REF_ARRAY;
799 e->ref->u.ar.type = AR_FULL;
800 e->ref->u.ar.as = sym->as;
808 /* Go through each actual argument in ACTUAL and see if it can be
809 implemented as an inlined, non-copying intrinsic. FNSYM is the
810 function being called, or NULL if not known. */
813 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
815 gfc_actual_arglist *ap;
818 for (ap = actual; ap; ap = ap->next)
820 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
821 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
822 ap->expr->inline_noncopying_intrinsic = 1;
826 /************* Function resolution *************/
828 /* Resolve a function call known to be generic.
829 Section 14.1.2.4.1. */
832 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
836 if (sym->attr.generic)
839 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
842 expr->value.function.name = s->name;
843 expr->value.function.esym = s;
846 expr->rank = s->as->rank;
850 /* TODO: Need to search for elemental references in generic interface */
853 if (sym->attr.intrinsic)
854 return gfc_intrinsic_func_interface (expr, 0);
861 resolve_generic_f (gfc_expr * expr)
866 sym = expr->symtree->n.sym;
870 m = resolve_generic_f0 (expr, sym);
873 else if (m == MATCH_ERROR)
877 if (sym->ns->parent == NULL)
879 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
883 if (!generic_sym (sym))
887 /* Last ditch attempt. */
889 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
891 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
892 expr->symtree->n.sym->name, &expr->where);
896 m = gfc_intrinsic_func_interface (expr, 0);
901 ("Generic function '%s' at %L is not consistent with a specific "
902 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
908 /* Resolve a function call known to be specific. */
911 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
915 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
919 sym->attr.proc = PROC_DUMMY;
923 sym->attr.proc = PROC_EXTERNAL;
927 if (sym->attr.proc == PROC_MODULE
928 || sym->attr.proc == PROC_ST_FUNCTION
929 || sym->attr.proc == PROC_INTERNAL)
932 if (sym->attr.intrinsic)
934 m = gfc_intrinsic_func_interface (expr, 1);
939 ("Function '%s' at %L is INTRINSIC but is not compatible with "
940 "an intrinsic", sym->name, &expr->where);
948 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
951 expr->value.function.name = sym->name;
952 expr->value.function.esym = sym;
954 expr->rank = sym->as->rank;
961 resolve_specific_f (gfc_expr * expr)
966 sym = expr->symtree->n.sym;
970 m = resolve_specific_f0 (sym, expr);
973 if (m == MATCH_ERROR)
976 if (sym->ns->parent == NULL)
979 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
985 gfc_error ("Unable to resolve the specific function '%s' at %L",
986 expr->symtree->n.sym->name, &expr->where);
992 /* Resolve a procedure call not known to be generic nor specific. */
995 resolve_unknown_f (gfc_expr * expr)
1000 sym = expr->symtree->n.sym;
1002 if (sym->attr.dummy)
1004 sym->attr.proc = PROC_DUMMY;
1005 expr->value.function.name = sym->name;
1009 /* See if we have an intrinsic function reference. */
1011 if (gfc_intrinsic_name (sym->name, 0))
1013 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1018 /* The reference is to an external name. */
1020 sym->attr.proc = PROC_EXTERNAL;
1021 expr->value.function.name = sym->name;
1022 expr->value.function.esym = expr->symtree->n.sym;
1024 if (sym->as != NULL)
1025 expr->rank = sym->as->rank;
1027 /* Type of the expression is either the type of the symbol or the
1028 default type of the symbol. */
1031 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1033 if (sym->ts.type != BT_UNKNOWN)
1037 ts = gfc_get_default_type (sym, sym->ns);
1039 if (ts->type == BT_UNKNOWN)
1041 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1042 sym->name, &expr->where);
1053 /* Figure out if a function reference is pure or not. Also set the name
1054 of the function for a potential error message. Return nonzero if the
1055 function is PURE, zero if not. */
1058 pure_function (gfc_expr * e, const char **name)
1062 if (e->value.function.esym)
1064 pure = gfc_pure (e->value.function.esym);
1065 *name = e->value.function.esym->name;
1067 else if (e->value.function.isym)
1069 pure = e->value.function.isym->pure
1070 || e->value.function.isym->elemental;
1071 *name = e->value.function.isym->name;
1075 /* Implicit functions are not pure. */
1077 *name = e->value.function.name;
1084 /* Resolve a function call, which means resolving the arguments, then figuring
1085 out which entity the name refers to. */
1086 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1087 to INTENT(OUT) or INTENT(INOUT). */
1090 resolve_function (gfc_expr * expr)
1092 gfc_actual_arglist *arg;
1096 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1099 /* See if function is already resolved. */
1101 if (expr->value.function.name != NULL)
1103 if (expr->ts.type == BT_UNKNOWN)
1104 expr->ts = expr->symtree->n.sym->ts;
1109 /* Apply the rules of section 14.1.2. */
1111 switch (procedure_kind (expr->symtree->n.sym))
1114 t = resolve_generic_f (expr);
1117 case PTYPE_SPECIFIC:
1118 t = resolve_specific_f (expr);
1122 t = resolve_unknown_f (expr);
1126 gfc_internal_error ("resolve_function(): bad function type");
1130 /* If the expression is still a function (it might have simplified),
1131 then we check to see if we are calling an elemental function. */
1133 if (expr->expr_type != EXPR_FUNCTION)
1136 if (expr->value.function.actual != NULL
1137 && ((expr->value.function.esym != NULL
1138 && expr->value.function.esym->attr.elemental)
1139 || (expr->value.function.isym != NULL
1140 && expr->value.function.isym->elemental)))
1143 /* The rank of an elemental is the rank of its array argument(s). */
1145 for (arg = expr->value.function.actual; arg; arg = arg->next)
1147 if (arg->expr != NULL && arg->expr->rank > 0)
1149 expr->rank = arg->expr->rank;
1155 if (!pure_function (expr, &name))
1160 ("Function reference to '%s' at %L is inside a FORALL block",
1161 name, &expr->where);
1164 else if (gfc_pure (NULL))
1166 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1167 "procedure within a PURE procedure", name, &expr->where);
1173 find_noncopying_intrinsics (expr->value.function.esym,
1174 expr->value.function.actual);
1179 /************* Subroutine resolution *************/
1182 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1189 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1190 sym->name, &c->loc);
1191 else if (gfc_pure (NULL))
1192 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1198 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1202 if (sym->attr.generic)
1204 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1207 c->resolved_sym = s;
1208 pure_subroutine (c, s);
1212 /* TODO: Need to search for elemental references in generic interface. */
1215 if (sym->attr.intrinsic)
1216 return gfc_intrinsic_sub_interface (c, 0);
1223 resolve_generic_s (gfc_code * c)
1228 sym = c->symtree->n.sym;
1230 m = resolve_generic_s0 (c, sym);
1233 if (m == MATCH_ERROR)
1236 if (sym->ns->parent != NULL)
1238 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1241 m = resolve_generic_s0 (c, sym);
1244 if (m == MATCH_ERROR)
1249 /* Last ditch attempt. */
1251 if (!gfc_generic_intrinsic (sym->name))
1254 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1255 sym->name, &c->loc);
1259 m = gfc_intrinsic_sub_interface (c, 0);
1263 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1264 "intrinsic subroutine interface", sym->name, &c->loc);
1270 /* Resolve a subroutine call known to be specific. */
1273 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1277 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1279 if (sym->attr.dummy)
1281 sym->attr.proc = PROC_DUMMY;
1285 sym->attr.proc = PROC_EXTERNAL;
1289 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1292 if (sym->attr.intrinsic)
1294 m = gfc_intrinsic_sub_interface (c, 1);
1298 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1299 "with an intrinsic", sym->name, &c->loc);
1307 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1309 c->resolved_sym = sym;
1310 pure_subroutine (c, sym);
1317 resolve_specific_s (gfc_code * c)
1322 sym = c->symtree->n.sym;
1324 m = resolve_specific_s0 (c, sym);
1327 if (m == MATCH_ERROR)
1330 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1334 m = resolve_specific_s0 (c, sym);
1337 if (m == MATCH_ERROR)
1341 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1342 sym->name, &c->loc);
1348 /* Resolve a subroutine call not known to be generic nor specific. */
1351 resolve_unknown_s (gfc_code * c)
1355 sym = c->symtree->n.sym;
1357 if (sym->attr.dummy)
1359 sym->attr.proc = PROC_DUMMY;
1363 /* See if we have an intrinsic function reference. */
1365 if (gfc_intrinsic_name (sym->name, 1))
1367 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1372 /* The reference is to an external name. */
1375 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1377 c->resolved_sym = sym;
1379 pure_subroutine (c, sym);
1385 /* Resolve a subroutine call. Although it was tempting to use the same code
1386 for functions, subroutines and functions are stored differently and this
1387 makes things awkward. */
1390 resolve_call (gfc_code * c)
1394 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1398 if (c->resolved_sym == NULL)
1399 switch (procedure_kind (c->symtree->n.sym))
1402 t = resolve_generic_s (c);
1405 case PTYPE_SPECIFIC:
1406 t = resolve_specific_s (c);
1410 t = resolve_unknown_s (c);
1414 gfc_internal_error ("resolve_subroutine(): bad function type");
1418 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1422 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1423 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1424 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1425 if their shapes do not match. If either op1->shape or op2->shape is
1426 NULL, return SUCCESS. */
1429 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1436 if (op1->shape != NULL && op2->shape != NULL)
1438 for (i = 0; i < op1->rank; i++)
1440 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1442 gfc_error ("Shapes for operands at %L and %L are not conformable",
1443 &op1->where, &op2->where);
1453 /* Resolve an operator expression node. This can involve replacing the
1454 operation with a user defined function call. */
1457 resolve_operator (gfc_expr * e)
1459 gfc_expr *op1, *op2;
1463 /* Resolve all subnodes-- give them types. */
1465 switch (e->value.op.operator)
1468 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1471 /* Fall through... */
1474 case INTRINSIC_UPLUS:
1475 case INTRINSIC_UMINUS:
1476 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1481 /* Typecheck the new node. */
1483 op1 = e->value.op.op1;
1484 op2 = e->value.op.op2;
1486 switch (e->value.op.operator)
1488 case INTRINSIC_UPLUS:
1489 case INTRINSIC_UMINUS:
1490 if (op1->ts.type == BT_INTEGER
1491 || op1->ts.type == BT_REAL
1492 || op1->ts.type == BT_COMPLEX)
1498 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1499 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1502 case INTRINSIC_PLUS:
1503 case INTRINSIC_MINUS:
1504 case INTRINSIC_TIMES:
1505 case INTRINSIC_DIVIDE:
1506 case INTRINSIC_POWER:
1507 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1509 gfc_type_convert_binary (e);
1514 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1515 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1516 gfc_typename (&op2->ts));
1519 case INTRINSIC_CONCAT:
1520 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1522 e->ts.type = BT_CHARACTER;
1523 e->ts.kind = op1->ts.kind;
1528 _("Operands of string concatenation operator at %%L are %s/%s"),
1529 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1535 case INTRINSIC_NEQV:
1536 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1538 e->ts.type = BT_LOGICAL;
1539 e->ts.kind = gfc_kind_max (op1, op2);
1540 if (op1->ts.kind < e->ts.kind)
1541 gfc_convert_type (op1, &e->ts, 2);
1542 else if (op2->ts.kind < e->ts.kind)
1543 gfc_convert_type (op2, &e->ts, 2);
1547 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1548 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1549 gfc_typename (&op2->ts));
1554 if (op1->ts.type == BT_LOGICAL)
1556 e->ts.type = BT_LOGICAL;
1557 e->ts.kind = op1->ts.kind;
1561 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1562 gfc_typename (&op1->ts));
1569 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1571 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1575 /* Fall through... */
1579 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1581 e->ts.type = BT_LOGICAL;
1582 e->ts.kind = gfc_default_logical_kind;
1586 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1588 gfc_type_convert_binary (e);
1590 e->ts.type = BT_LOGICAL;
1591 e->ts.kind = gfc_default_logical_kind;
1595 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1597 _("Logicals at %%L must be compared with %s instead of %s"),
1598 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1599 gfc_op2string (e->value.op.operator));
1602 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1603 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1604 gfc_typename (&op2->ts));
1608 case INTRINSIC_USER:
1610 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1611 e->value.op.uop->name, gfc_typename (&op1->ts));
1613 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1614 e->value.op.uop->name, gfc_typename (&op1->ts),
1615 gfc_typename (&op2->ts));
1620 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1623 /* Deal with arrayness of an operand through an operator. */
1627 switch (e->value.op.operator)
1629 case INTRINSIC_PLUS:
1630 case INTRINSIC_MINUS:
1631 case INTRINSIC_TIMES:
1632 case INTRINSIC_DIVIDE:
1633 case INTRINSIC_POWER:
1634 case INTRINSIC_CONCAT:
1638 case INTRINSIC_NEQV:
1646 if (op1->rank == 0 && op2->rank == 0)
1649 if (op1->rank == 0 && op2->rank != 0)
1651 e->rank = op2->rank;
1653 if (e->shape == NULL)
1654 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1657 if (op1->rank != 0 && op2->rank == 0)
1659 e->rank = op1->rank;
1661 if (e->shape == NULL)
1662 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1665 if (op1->rank != 0 && op2->rank != 0)
1667 if (op1->rank == op2->rank)
1669 e->rank = op1->rank;
1670 if (e->shape == NULL)
1672 t = compare_shapes(op1, op2);
1676 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1681 gfc_error ("Inconsistent ranks for operator at %L and %L",
1682 &op1->where, &op2->where);
1685 /* Allow higher level expressions to work. */
1693 case INTRINSIC_UPLUS:
1694 case INTRINSIC_UMINUS:
1695 e->rank = op1->rank;
1697 if (e->shape == NULL)
1698 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1700 /* Simply copy arrayness attribute */
1707 /* Attempt to simplify the expression. */
1709 t = gfc_simplify_expr (e, 0);
1714 if (gfc_extend_expr (e) == SUCCESS)
1717 gfc_error (msg, &e->where);
1723 /************** Array resolution subroutines **************/
1727 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1730 /* Compare two integer expressions. */
1733 compare_bound (gfc_expr * a, gfc_expr * b)
1737 if (a == NULL || a->expr_type != EXPR_CONSTANT
1738 || b == NULL || b->expr_type != EXPR_CONSTANT)
1741 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1742 gfc_internal_error ("compare_bound(): Bad expression");
1744 i = mpz_cmp (a->value.integer, b->value.integer);
1754 /* Compare an integer expression with an integer. */
1757 compare_bound_int (gfc_expr * a, int b)
1761 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1764 if (a->ts.type != BT_INTEGER)
1765 gfc_internal_error ("compare_bound_int(): Bad expression");
1767 i = mpz_cmp_si (a->value.integer, b);
1777 /* Compare a single dimension of an array reference to the array
1781 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1784 /* Given start, end and stride values, calculate the minimum and
1785 maximum referenced indexes. */
1793 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1795 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1801 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1803 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1807 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1809 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1812 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1813 it is legal (see 6.2.2.3.1). */
1818 gfc_internal_error ("check_dimension(): Bad array reference");
1824 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1829 /* Compare an array reference with an array specification. */
1832 compare_spec_to_ref (gfc_array_ref * ar)
1839 /* TODO: Full array sections are only allowed as actual parameters. */
1840 if (as->type == AS_ASSUMED_SIZE
1841 && (/*ar->type == AR_FULL
1842 ||*/ (ar->type == AR_SECTION
1843 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1845 gfc_error ("Rightmost upper bound of assumed size array section"
1846 " not specified at %L", &ar->where);
1850 if (ar->type == AR_FULL)
1853 if (as->rank != ar->dimen)
1855 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1856 &ar->where, ar->dimen, as->rank);
1860 for (i = 0; i < as->rank; i++)
1861 if (check_dimension (i, ar, as) == FAILURE)
1868 /* Resolve one part of an array index. */
1871 gfc_resolve_index (gfc_expr * index, int check_scalar)
1878 if (gfc_resolve_expr (index) == FAILURE)
1881 if (check_scalar && index->rank != 0)
1883 gfc_error ("Array index at %L must be scalar", &index->where);
1887 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1889 gfc_error ("Array index at %L must be of INTEGER type",
1894 if (index->ts.type == BT_REAL)
1895 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1896 &index->where) == FAILURE)
1899 if (index->ts.kind != gfc_index_integer_kind
1900 || index->ts.type != BT_INTEGER)
1902 ts.type = BT_INTEGER;
1903 ts.kind = gfc_index_integer_kind;
1905 gfc_convert_type_warn (index, &ts, 2, 0);
1911 /* Resolve a dim argument to an intrinsic function. */
1914 gfc_resolve_dim_arg (gfc_expr *dim)
1919 if (gfc_resolve_expr (dim) == FAILURE)
1924 gfc_error ("Argument dim at %L must be scalar", &dim->where);
1928 if (dim->ts.type != BT_INTEGER)
1930 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1933 if (dim->ts.kind != gfc_index_integer_kind)
1937 ts.type = BT_INTEGER;
1938 ts.kind = gfc_index_integer_kind;
1940 gfc_convert_type_warn (dim, &ts, 2, 0);
1946 /* Given an expression that contains array references, update those array
1947 references to point to the right array specifications. While this is
1948 filled in during matching, this information is difficult to save and load
1949 in a module, so we take care of it here.
1951 The idea here is that the original array reference comes from the
1952 base symbol. We traverse the list of reference structures, setting
1953 the stored reference to references. Component references can
1954 provide an additional array specification. */
1957 find_array_spec (gfc_expr * e)
1963 as = e->symtree->n.sym->as;
1965 for (ref = e->ref; ref; ref = ref->next)
1970 gfc_internal_error ("find_array_spec(): Missing spec");
1977 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
1978 if (c == ref->u.c.component)
1982 gfc_internal_error ("find_array_spec(): Component not found");
1987 gfc_internal_error ("find_array_spec(): unused as(1)");
1998 gfc_internal_error ("find_array_spec(): unused as(2)");
2002 /* Resolve an array reference. */
2005 resolve_array_ref (gfc_array_ref * ar)
2007 int i, check_scalar;
2009 for (i = 0; i < ar->dimen; i++)
2011 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2013 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2015 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2017 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2020 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2021 switch (ar->start[i]->rank)
2024 ar->dimen_type[i] = DIMEN_ELEMENT;
2028 ar->dimen_type[i] = DIMEN_VECTOR;
2032 gfc_error ("Array index at %L is an array of rank %d",
2033 &ar->c_where[i], ar->start[i]->rank);
2038 /* If the reference type is unknown, figure out what kind it is. */
2040 if (ar->type == AR_UNKNOWN)
2042 ar->type = AR_ELEMENT;
2043 for (i = 0; i < ar->dimen; i++)
2044 if (ar->dimen_type[i] == DIMEN_RANGE
2045 || ar->dimen_type[i] == DIMEN_VECTOR)
2047 ar->type = AR_SECTION;
2052 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2060 resolve_substring (gfc_ref * ref)
2063 if (ref->u.ss.start != NULL)
2065 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2068 if (ref->u.ss.start->ts.type != BT_INTEGER)
2070 gfc_error ("Substring start index at %L must be of type INTEGER",
2071 &ref->u.ss.start->where);
2075 if (ref->u.ss.start->rank != 0)
2077 gfc_error ("Substring start index at %L must be scalar",
2078 &ref->u.ss.start->where);
2082 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2084 gfc_error ("Substring start index at %L is less than one",
2085 &ref->u.ss.start->where);
2090 if (ref->u.ss.end != NULL)
2092 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2095 if (ref->u.ss.end->ts.type != BT_INTEGER)
2097 gfc_error ("Substring end index at %L must be of type INTEGER",
2098 &ref->u.ss.end->where);
2102 if (ref->u.ss.end->rank != 0)
2104 gfc_error ("Substring end index at %L must be scalar",
2105 &ref->u.ss.end->where);
2109 if (ref->u.ss.length != NULL
2110 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2112 gfc_error ("Substring end index at %L is out of bounds",
2113 &ref->u.ss.start->where);
2122 /* Resolve subtype references. */
2125 resolve_ref (gfc_expr * expr)
2127 int current_part_dimension, n_components, seen_part_dimension;
2130 for (ref = expr->ref; ref; ref = ref->next)
2131 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2133 find_array_spec (expr);
2137 for (ref = expr->ref; ref; ref = ref->next)
2141 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2149 resolve_substring (ref);
2153 /* Check constraints on part references. */
2155 current_part_dimension = 0;
2156 seen_part_dimension = 0;
2159 for (ref = expr->ref; ref; ref = ref->next)
2164 switch (ref->u.ar.type)
2168 current_part_dimension = 1;
2172 current_part_dimension = 0;
2176 gfc_internal_error ("resolve_ref(): Bad array reference");
2182 if ((current_part_dimension || seen_part_dimension)
2183 && ref->u.c.component->pointer)
2186 ("Component to the right of a part reference with nonzero "
2187 "rank must not have the POINTER attribute at %L",
2199 if (((ref->type == REF_COMPONENT && n_components > 1)
2200 || ref->next == NULL)
2201 && current_part_dimension
2202 && seen_part_dimension)
2205 gfc_error ("Two or more part references with nonzero rank must "
2206 "not be specified at %L", &expr->where);
2210 if (ref->type == REF_COMPONENT)
2212 if (current_part_dimension)
2213 seen_part_dimension = 1;
2215 /* reset to make sure */
2216 current_part_dimension = 0;
2224 /* Given an expression, determine its shape. This is easier than it sounds.
2225 Leaves the shape array NULL if it is not possible to determine the shape. */
2228 expression_shape (gfc_expr * e)
2230 mpz_t array[GFC_MAX_DIMENSIONS];
2233 if (e->rank == 0 || e->shape != NULL)
2236 for (i = 0; i < e->rank; i++)
2237 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2240 e->shape = gfc_get_shape (e->rank);
2242 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2247 for (i--; i >= 0; i--)
2248 mpz_clear (array[i]);
2252 /* Given a variable expression node, compute the rank of the expression by
2253 examining the base symbol and any reference structures it may have. */
2256 expression_rank (gfc_expr * e)
2263 if (e->expr_type == EXPR_ARRAY)
2265 /* Constructors can have a rank different from one via RESHAPE(). */
2267 if (e->symtree == NULL)
2273 e->rank = (e->symtree->n.sym->as == NULL)
2274 ? 0 : e->symtree->n.sym->as->rank;
2280 for (ref = e->ref; ref; ref = ref->next)
2282 if (ref->type != REF_ARRAY)
2285 if (ref->u.ar.type == AR_FULL)
2287 rank = ref->u.ar.as->rank;
2291 if (ref->u.ar.type == AR_SECTION)
2293 /* Figure out the rank of the section. */
2295 gfc_internal_error ("expression_rank(): Two array specs");
2297 for (i = 0; i < ref->u.ar.dimen; i++)
2298 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2299 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2309 expression_shape (e);
2313 /* Resolve a variable expression. */
2316 resolve_variable (gfc_expr * e)
2320 if (e->ref && resolve_ref (e) == FAILURE)
2323 if (e->symtree == NULL)
2326 sym = e->symtree->n.sym;
2327 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2329 e->ts.type = BT_PROCEDURE;
2333 if (sym->ts.type != BT_UNKNOWN)
2334 gfc_variable_attr (e, &e->ts);
2337 /* Must be a simple variable reference. */
2338 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2347 /* Resolve an expression. That is, make sure that types of operands agree
2348 with their operators, intrinsic operators are converted to function calls
2349 for overloaded types and unresolved function references are resolved. */
2352 gfc_resolve_expr (gfc_expr * e)
2359 switch (e->expr_type)
2362 t = resolve_operator (e);
2366 t = resolve_function (e);
2370 t = resolve_variable (e);
2372 expression_rank (e);
2375 case EXPR_SUBSTRING:
2376 t = resolve_ref (e);
2386 if (resolve_ref (e) == FAILURE)
2389 t = gfc_resolve_array_constructor (e);
2390 /* Also try to expand a constructor. */
2393 expression_rank (e);
2394 gfc_expand_constructor (e);
2399 case EXPR_STRUCTURE:
2400 t = resolve_ref (e);
2404 t = resolve_structure_cons (e);
2408 t = gfc_simplify_expr (e, 0);
2412 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2419 /* Resolve an expression from an iterator. They must be scalar and have
2420 INTEGER or (optionally) REAL type. */
2423 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2424 const char * name_msgid)
2426 if (gfc_resolve_expr (expr) == FAILURE)
2429 if (expr->rank != 0)
2431 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2435 if (!(expr->ts.type == BT_INTEGER
2436 || (expr->ts.type == BT_REAL && real_ok)))
2439 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2442 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2449 /* Resolve the expressions in an iterator structure. If REAL_OK is
2450 false allow only INTEGER type iterators, otherwise allow REAL types. */
2453 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2456 if (iter->var->ts.type == BT_REAL)
2457 gfc_notify_std (GFC_STD_F95_DEL,
2458 "Obsolete: REAL DO loop iterator at %L",
2461 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2465 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2467 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2472 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2473 "Start expression in DO loop") == FAILURE)
2476 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2477 "End expression in DO loop") == FAILURE)
2480 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2481 "Step expression in DO loop") == FAILURE)
2484 if (iter->step->expr_type == EXPR_CONSTANT)
2486 if ((iter->step->ts.type == BT_INTEGER
2487 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2488 || (iter->step->ts.type == BT_REAL
2489 && mpfr_sgn (iter->step->value.real) == 0))
2491 gfc_error ("Step expression in DO loop at %L cannot be zero",
2492 &iter->step->where);
2497 /* Convert start, end, and step to the same type as var. */
2498 if (iter->start->ts.kind != iter->var->ts.kind
2499 || iter->start->ts.type != iter->var->ts.type)
2500 gfc_convert_type (iter->start, &iter->var->ts, 2);
2502 if (iter->end->ts.kind != iter->var->ts.kind
2503 || iter->end->ts.type != iter->var->ts.type)
2504 gfc_convert_type (iter->end, &iter->var->ts, 2);
2506 if (iter->step->ts.kind != iter->var->ts.kind
2507 || iter->step->ts.type != iter->var->ts.type)
2508 gfc_convert_type (iter->step, &iter->var->ts, 2);
2514 /* Resolve a list of FORALL iterators. */
2517 resolve_forall_iterators (gfc_forall_iterator * iter)
2522 if (gfc_resolve_expr (iter->var) == SUCCESS
2523 && iter->var->ts.type != BT_INTEGER)
2524 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2527 if (gfc_resolve_expr (iter->start) == SUCCESS
2528 && iter->start->ts.type != BT_INTEGER)
2529 gfc_error ("FORALL start expression at %L must be INTEGER",
2530 &iter->start->where);
2531 if (iter->var->ts.kind != iter->start->ts.kind)
2532 gfc_convert_type (iter->start, &iter->var->ts, 2);
2534 if (gfc_resolve_expr (iter->end) == SUCCESS
2535 && iter->end->ts.type != BT_INTEGER)
2536 gfc_error ("FORALL end expression at %L must be INTEGER",
2538 if (iter->var->ts.kind != iter->end->ts.kind)
2539 gfc_convert_type (iter->end, &iter->var->ts, 2);
2541 if (gfc_resolve_expr (iter->stride) == SUCCESS
2542 && iter->stride->ts.type != BT_INTEGER)
2543 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2544 &iter->stride->where);
2545 if (iter->var->ts.kind != iter->stride->ts.kind)
2546 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2553 /* Given a pointer to a symbol that is a derived type, see if any components
2554 have the POINTER attribute. The search is recursive if necessary.
2555 Returns zero if no pointer components are found, nonzero otherwise. */
2558 derived_pointer (gfc_symbol * sym)
2562 for (c = sym->components; c; c = c->next)
2567 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2575 /* Given a pointer to a symbol that is a derived type, see if it's
2576 inaccessible, i.e. if it's defined in another module and the components are
2577 PRIVATE. The search is recursive if necessary. Returns zero if no
2578 inaccessible components are found, nonzero otherwise. */
2581 derived_inaccessible (gfc_symbol *sym)
2585 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2588 for (c = sym->components; c; c = c->next)
2590 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2598 /* Resolve the argument of a deallocate expression. The expression must be
2599 a pointer or a full array. */
2602 resolve_deallocate_expr (gfc_expr * e)
2604 symbol_attribute attr;
2608 if (gfc_resolve_expr (e) == FAILURE)
2611 attr = gfc_expr_attr (e);
2615 if (e->expr_type != EXPR_VARIABLE)
2618 allocatable = e->symtree->n.sym->attr.allocatable;
2619 for (ref = e->ref; ref; ref = ref->next)
2623 if (ref->u.ar.type != AR_FULL)
2628 allocatable = (ref->u.c.component->as != NULL
2629 && ref->u.c.component->as->type == AS_DEFERRED);
2637 if (allocatable == 0)
2640 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2641 "ALLOCATABLE or a POINTER", &e->where);
2648 /* Given the expression node e for an allocatable/pointer of derived type to be
2649 allocated, get the expression node to be initialized afterwards (needed for
2650 derived types with default initializers). */
2653 expr_to_initialize (gfc_expr * e)
2659 result = gfc_copy_expr (e);
2661 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2662 for (ref = result->ref; ref; ref = ref->next)
2663 if (ref->type == REF_ARRAY && ref->next == NULL)
2665 ref->u.ar.type = AR_FULL;
2667 for (i = 0; i < ref->u.ar.dimen; i++)
2668 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2670 result->rank = ref->u.ar.dimen;
2678 /* Resolve the expression in an ALLOCATE statement, doing the additional
2679 checks to see whether the expression is OK or not. The expression must
2680 have a trailing array reference that gives the size of the array. */
2683 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2685 int i, pointer, allocatable, dimension;
2686 symbol_attribute attr;
2687 gfc_ref *ref, *ref2;
2692 if (gfc_resolve_expr (e) == FAILURE)
2695 /* Make sure the expression is allocatable or a pointer. If it is
2696 pointer, the next-to-last reference must be a pointer. */
2700 if (e->expr_type != EXPR_VARIABLE)
2704 attr = gfc_expr_attr (e);
2705 pointer = attr.pointer;
2706 dimension = attr.dimension;
2711 allocatable = e->symtree->n.sym->attr.allocatable;
2712 pointer = e->symtree->n.sym->attr.pointer;
2713 dimension = e->symtree->n.sym->attr.dimension;
2715 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2719 if (ref->next != NULL)
2724 allocatable = (ref->u.c.component->as != NULL
2725 && ref->u.c.component->as->type == AS_DEFERRED);
2727 pointer = ref->u.c.component->pointer;
2728 dimension = ref->u.c.component->dimension;
2738 if (allocatable == 0 && pointer == 0)
2740 gfc_error ("Expression in ALLOCATE statement at %L must be "
2741 "ALLOCATABLE or a POINTER", &e->where);
2745 /* Add default initializer for those derived types that need them. */
2746 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2748 init_st = gfc_get_code ();
2749 init_st->loc = code->loc;
2750 init_st->op = EXEC_ASSIGN;
2751 init_st->expr = expr_to_initialize (e);
2752 init_st->expr2 = init_e;
2754 init_st->next = code->next;
2755 code->next = init_st;
2758 if (pointer && dimension == 0)
2761 /* Make sure the next-to-last reference node is an array specification. */
2763 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2765 gfc_error ("Array specification required in ALLOCATE statement "
2766 "at %L", &e->where);
2770 if (ref2->u.ar.type == AR_ELEMENT)
2773 /* Make sure that the array section reference makes sense in the
2774 context of an ALLOCATE specification. */
2778 for (i = 0; i < ar->dimen; i++)
2779 switch (ar->dimen_type[i])
2785 if (ar->start[i] != NULL
2786 && ar->end[i] != NULL
2787 && ar->stride[i] == NULL)
2790 /* Fall Through... */
2794 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2803 /************ SELECT CASE resolution subroutines ************/
2805 /* Callback function for our mergesort variant. Determines interval
2806 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2807 op1 > op2. Assumes we're not dealing with the default case.
2808 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2809 There are nine situations to check. */
2812 compare_cases (const gfc_case * op1, const gfc_case * op2)
2816 if (op1->low == NULL) /* op1 = (:L) */
2818 /* op2 = (:N), so overlap. */
2820 /* op2 = (M:) or (M:N), L < M */
2821 if (op2->low != NULL
2822 && gfc_compare_expr (op1->high, op2->low) < 0)
2825 else if (op1->high == NULL) /* op1 = (K:) */
2827 /* op2 = (M:), so overlap. */
2829 /* op2 = (:N) or (M:N), K > N */
2830 if (op2->high != NULL
2831 && gfc_compare_expr (op1->low, op2->high) > 0)
2834 else /* op1 = (K:L) */
2836 if (op2->low == NULL) /* op2 = (:N), K > N */
2837 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2838 else if (op2->high == NULL) /* op2 = (M:), L < M */
2839 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2840 else /* op2 = (M:N) */
2844 if (gfc_compare_expr (op1->high, op2->low) < 0)
2847 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2856 /* Merge-sort a double linked case list, detecting overlap in the
2857 process. LIST is the head of the double linked case list before it
2858 is sorted. Returns the head of the sorted list if we don't see any
2859 overlap, or NULL otherwise. */
2862 check_case_overlap (gfc_case * list)
2864 gfc_case *p, *q, *e, *tail;
2865 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2867 /* If the passed list was empty, return immediately. */
2874 /* Loop unconditionally. The only exit from this loop is a return
2875 statement, when we've finished sorting the case list. */
2882 /* Count the number of merges we do in this pass. */
2885 /* Loop while there exists a merge to be done. */
2890 /* Count this merge. */
2893 /* Cut the list in two pieces by stepping INSIZE places
2894 forward in the list, starting from P. */
2897 for (i = 0; i < insize; i++)
2906 /* Now we have two lists. Merge them! */
2907 while (psize > 0 || (qsize > 0 && q != NULL))
2910 /* See from which the next case to merge comes from. */
2913 /* P is empty so the next case must come from Q. */
2918 else if (qsize == 0 || q == NULL)
2927 cmp = compare_cases (p, q);
2930 /* The whole case range for P is less than the
2938 /* The whole case range for Q is greater than
2939 the case range for P. */
2946 /* The cases overlap, or they are the same
2947 element in the list. Either way, we must
2948 issue an error and get the next case from P. */
2949 /* FIXME: Sort P and Q by line number. */
2950 gfc_error ("CASE label at %L overlaps with CASE "
2951 "label at %L", &p->where, &q->where);
2959 /* Add the next element to the merged list. */
2968 /* P has now stepped INSIZE places along, and so has Q. So
2969 they're the same. */
2974 /* If we have done only one merge or none at all, we've
2975 finished sorting the cases. */
2984 /* Otherwise repeat, merging lists twice the size. */
2990 /* Check to see if an expression is suitable for use in a CASE statement.
2991 Makes sure that all case expressions are scalar constants of the same
2992 type. Return FAILURE if anything is wrong. */
2995 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2997 if (e == NULL) return SUCCESS;
2999 if (e->ts.type != case_expr->ts.type)
3001 gfc_error ("Expression in CASE statement at %L must be of type %s",
3002 &e->where, gfc_basic_typename (case_expr->ts.type));
3006 /* C805 (R808) For a given case-construct, each case-value shall be of
3007 the same type as case-expr. For character type, length differences
3008 are allowed, but the kind type parameters shall be the same. */
3010 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3012 gfc_error("Expression in CASE statement at %L must be kind %d",
3013 &e->where, case_expr->ts.kind);
3017 /* Convert the case value kind to that of case expression kind, if needed.
3018 FIXME: Should a warning be issued? */
3019 if (e->ts.kind != case_expr->ts.kind)
3020 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3024 gfc_error ("Expression in CASE statement at %L must be scalar",
3033 /* Given a completely parsed select statement, we:
3035 - Validate all expressions and code within the SELECT.
3036 - Make sure that the selection expression is not of the wrong type.
3037 - Make sure that no case ranges overlap.
3038 - Eliminate unreachable cases and unreachable code resulting from
3039 removing case labels.
3041 The standard does allow unreachable cases, e.g. CASE (5:3). But
3042 they are a hassle for code generation, and to prevent that, we just
3043 cut them out here. This is not necessary for overlapping cases
3044 because they are illegal and we never even try to generate code.
3046 We have the additional caveat that a SELECT construct could have
3047 been a computed GOTO in the source code. Fortunately we can fairly
3048 easily work around that here: The case_expr for a "real" SELECT CASE
3049 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3050 we have to do is make sure that the case_expr is a scalar integer
3054 resolve_select (gfc_code * code)
3057 gfc_expr *case_expr;
3058 gfc_case *cp, *default_case, *tail, *head;
3059 int seen_unreachable;
3064 if (code->expr == NULL)
3066 /* This was actually a computed GOTO statement. */
3067 case_expr = code->expr2;
3068 if (case_expr->ts.type != BT_INTEGER
3069 || case_expr->rank != 0)
3070 gfc_error ("Selection expression in computed GOTO statement "
3071 "at %L must be a scalar integer expression",
3074 /* Further checking is not necessary because this SELECT was built
3075 by the compiler, so it should always be OK. Just move the
3076 case_expr from expr2 to expr so that we can handle computed
3077 GOTOs as normal SELECTs from here on. */
3078 code->expr = code->expr2;
3083 case_expr = code->expr;
3085 type = case_expr->ts.type;
3086 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3088 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3089 &case_expr->where, gfc_typename (&case_expr->ts));
3091 /* Punt. Going on here just produce more garbage error messages. */
3095 if (case_expr->rank != 0)
3097 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3098 "expression", &case_expr->where);
3104 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3105 of the SELECT CASE expression and its CASE values. Walk the lists
3106 of case values, and if we find a mismatch, promote case_expr to
3107 the appropriate kind. */
3109 if (type == BT_LOGICAL || type == BT_INTEGER)
3111 for (body = code->block; body; body = body->block)
3113 /* Walk the case label list. */
3114 for (cp = body->ext.case_list; cp; cp = cp->next)
3116 /* Intercept the DEFAULT case. It does not have a kind. */
3117 if (cp->low == NULL && cp->high == NULL)
3120 /* Unreachable case ranges are discarded, so ignore. */
3121 if (cp->low != NULL && cp->high != NULL
3122 && cp->low != cp->high
3123 && gfc_compare_expr (cp->low, cp->high) > 0)
3126 /* FIXME: Should a warning be issued? */
3128 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3129 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3131 if (cp->high != NULL
3132 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3133 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3138 /* Assume there is no DEFAULT case. */
3139 default_case = NULL;
3143 for (body = code->block; body; body = body->block)
3145 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3147 seen_unreachable = 0;
3149 /* Walk the case label list, making sure that all case labels
3151 for (cp = body->ext.case_list; cp; cp = cp->next)
3153 /* Count the number of cases in the whole construct. */
3156 /* Intercept the DEFAULT case. */
3157 if (cp->low == NULL && cp->high == NULL)
3159 if (default_case != NULL)
3161 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3162 "by a second DEFAULT CASE at %L",
3163 &default_case->where, &cp->where);
3174 /* Deal with single value cases and case ranges. Errors are
3175 issued from the validation function. */
3176 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3177 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3183 if (type == BT_LOGICAL
3184 && ((cp->low == NULL || cp->high == NULL)
3185 || cp->low != cp->high))
3188 ("Logical range in CASE statement at %L is not allowed",
3194 if (cp->low != NULL && cp->high != NULL
3195 && cp->low != cp->high
3196 && gfc_compare_expr (cp->low, cp->high) > 0)
3198 if (gfc_option.warn_surprising)
3199 gfc_warning ("Range specification at %L can never "
3200 "be matched", &cp->where);
3202 cp->unreachable = 1;
3203 seen_unreachable = 1;
3207 /* If the case range can be matched, it can also overlap with
3208 other cases. To make sure it does not, we put it in a
3209 double linked list here. We sort that with a merge sort
3210 later on to detect any overlapping cases. */
3214 head->right = head->left = NULL;
3219 tail->right->left = tail;
3226 /* It there was a failure in the previous case label, give up
3227 for this case label list. Continue with the next block. */
3231 /* See if any case labels that are unreachable have been seen.
3232 If so, we eliminate them. This is a bit of a kludge because
3233 the case lists for a single case statement (label) is a
3234 single forward linked lists. */
3235 if (seen_unreachable)
3237 /* Advance until the first case in the list is reachable. */
3238 while (body->ext.case_list != NULL
3239 && body->ext.case_list->unreachable)
3241 gfc_case *n = body->ext.case_list;
3242 body->ext.case_list = body->ext.case_list->next;
3244 gfc_free_case_list (n);
3247 /* Strip all other unreachable cases. */
3248 if (body->ext.case_list)
3250 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3252 if (cp->next->unreachable)
3254 gfc_case *n = cp->next;
3255 cp->next = cp->next->next;
3257 gfc_free_case_list (n);
3264 /* See if there were overlapping cases. If the check returns NULL,
3265 there was overlap. In that case we don't do anything. If head
3266 is non-NULL, we prepend the DEFAULT case. The sorted list can
3267 then used during code generation for SELECT CASE constructs with
3268 a case expression of a CHARACTER type. */
3271 head = check_case_overlap (head);
3273 /* Prepend the default_case if it is there. */
3274 if (head != NULL && default_case)
3276 default_case->left = NULL;
3277 default_case->right = head;
3278 head->left = default_case;
3282 /* Eliminate dead blocks that may be the result if we've seen
3283 unreachable case labels for a block. */
3284 for (body = code; body && body->block; body = body->block)
3286 if (body->block->ext.case_list == NULL)
3288 /* Cut the unreachable block from the code chain. */
3289 gfc_code *c = body->block;
3290 body->block = c->block;
3292 /* Kill the dead block, but not the blocks below it. */
3294 gfc_free_statements (c);
3298 /* More than two cases is legal but insane for logical selects.
3299 Issue a warning for it. */
3300 if (gfc_option.warn_surprising && type == BT_LOGICAL
3302 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3307 /* Resolve a transfer statement. This is making sure that:
3308 -- a derived type being transferred has only non-pointer components
3309 -- a derived type being transferred doesn't have private components, unless
3310 it's being transferred from the module where the type was defined
3311 -- we're not trying to transfer a whole assumed size array. */
3314 resolve_transfer (gfc_code * code)
3323 if (exp->expr_type != EXPR_VARIABLE)
3326 sym = exp->symtree->n.sym;
3329 /* Go to actual component transferred. */
3330 for (ref = code->expr->ref; ref; ref = ref->next)
3331 if (ref->type == REF_COMPONENT)
3332 ts = &ref->u.c.component->ts;
3334 if (ts->type == BT_DERIVED)
3336 /* Check that transferred derived type doesn't contain POINTER
3338 if (derived_pointer (ts->derived))
3340 gfc_error ("Data transfer element at %L cannot have "
3341 "POINTER components", &code->loc);
3345 if (derived_inaccessible (ts->derived))
3347 gfc_error ("Data transfer element at %L cannot have "
3348 "PRIVATE components",&code->loc);
3353 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3354 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3356 gfc_error ("Data transfer element at %L cannot be a full reference to "
3357 "an assumed-size array", &code->loc);
3363 /*********** Toplevel code resolution subroutines ***********/
3365 /* Given a branch to a label and a namespace, if the branch is conforming.
3366 The code node described where the branch is located. */
3369 resolve_branch (gfc_st_label * label, gfc_code * code)
3371 gfc_code *block, *found;
3379 /* Step one: is this a valid branching target? */
3381 if (lp->defined == ST_LABEL_UNKNOWN)
3383 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3388 if (lp->defined != ST_LABEL_TARGET)
3390 gfc_error ("Statement at %L is not a valid branch target statement "
3391 "for the branch statement at %L", &lp->where, &code->loc);
3395 /* Step two: make sure this branch is not a branch to itself ;-) */
3397 if (code->here == label)
3399 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3403 /* Step three: Try to find the label in the parse tree. To do this,
3404 we traverse the tree block-by-block: first the block that
3405 contains this GOTO, then the block that it is nested in, etc. We
3406 can ignore other blocks because branching into another block is
3411 for (stack = cs_base; stack; stack = stack->prev)
3413 for (block = stack->head; block; block = block->next)
3415 if (block->here == label)
3428 /* still nothing, so illegal. */
3429 gfc_error_now ("Label at %L is not in the same block as the "
3430 "GOTO statement at %L", &lp->where, &code->loc);
3434 /* Step four: Make sure that the branching target is legal if
3435 the statement is an END {SELECT,DO,IF}. */
3437 if (found->op == EXEC_NOP)
3439 for (stack = cs_base; stack; stack = stack->prev)
3440 if (stack->current->next == found)
3444 gfc_notify_std (GFC_STD_F95_DEL,
3445 "Obsolete: GOTO at %L jumps to END of construct at %L",
3446 &code->loc, &found->loc);
3451 /* Check whether EXPR1 has the same shape as EXPR2. */
3454 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3456 mpz_t shape[GFC_MAX_DIMENSIONS];
3457 mpz_t shape2[GFC_MAX_DIMENSIONS];
3458 try result = FAILURE;
3461 /* Compare the rank. */
3462 if (expr1->rank != expr2->rank)
3465 /* Compare the size of each dimension. */
3466 for (i=0; i<expr1->rank; i++)
3468 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3471 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3474 if (mpz_cmp (shape[i], shape2[i]))
3478 /* When either of the two expression is an assumed size array, we
3479 ignore the comparison of dimension sizes. */
3484 for (i--; i>=0; i--)
3486 mpz_clear (shape[i]);
3487 mpz_clear (shape2[i]);
3493 /* Check whether a WHERE assignment target or a WHERE mask expression
3494 has the same shape as the outmost WHERE mask expression. */
3497 resolve_where (gfc_code *code, gfc_expr *mask)
3503 cblock = code->block;
3505 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3506 In case of nested WHERE, only the outmost one is stored. */
3507 if (mask == NULL) /* outmost WHERE */
3509 else /* inner WHERE */
3516 /* Check if the mask-expr has a consistent shape with the
3517 outmost WHERE mask-expr. */
3518 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3519 gfc_error ("WHERE mask at %L has inconsistent shape",
3520 &cblock->expr->where);
3523 /* the assignment statement of a WHERE statement, or the first
3524 statement in where-body-construct of a WHERE construct */
3525 cnext = cblock->next;
3530 /* WHERE assignment statement */
3533 /* Check shape consistent for WHERE assignment target. */
3534 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3535 gfc_error ("WHERE assignment target at %L has "
3536 "inconsistent shape", &cnext->expr->where);
3539 /* WHERE or WHERE construct is part of a where-body-construct */
3541 resolve_where (cnext, e);
3545 gfc_error ("Unsupported statement inside WHERE at %L",
3548 /* the next statement within the same where-body-construct */
3549 cnext = cnext->next;
3551 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3552 cblock = cblock->block;
3557 /* Check whether the FORALL index appears in the expression or not. */
3560 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3564 gfc_actual_arglist *args;
3567 switch (expr->expr_type)
3570 gcc_assert (expr->symtree->n.sym);
3572 /* A scalar assignment */
3575 if (expr->symtree->n.sym == symbol)
3581 /* the expr is array ref, substring or struct component. */
3588 /* Check if the symbol appears in the array subscript. */
3590 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3593 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3597 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3601 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3607 if (expr->symtree->n.sym == symbol)
3610 /* Check if the symbol appears in the substring section. */
3611 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3613 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3621 gfc_error("expresion reference type error at %L", &expr->where);
3627 /* If the expression is a function call, then check if the symbol
3628 appears in the actual arglist of the function. */
3630 for (args = expr->value.function.actual; args; args = args->next)
3632 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3637 /* It seems not to happen. */
3638 case EXPR_SUBSTRING:
3642 gcc_assert (expr->ref->type == REF_SUBSTRING);
3643 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3645 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3650 /* It seems not to happen. */
3651 case EXPR_STRUCTURE:
3653 gfc_error ("Unsupported statement while finding forall index in "
3658 /* Find the FORALL index in the first operand. */
3659 if (expr->value.op.op1)
3661 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3665 /* Find the FORALL index in the second operand. */
3666 if (expr->value.op.op2)
3668 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3681 /* Resolve assignment in FORALL construct.
3682 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3683 FORALL index variables. */
3686 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3690 for (n = 0; n < nvar; n++)
3692 gfc_symbol *forall_index;
3694 forall_index = var_expr[n]->symtree->n.sym;
3696 /* Check whether the assignment target is one of the FORALL index
3698 if ((code->expr->expr_type == EXPR_VARIABLE)
3699 && (code->expr->symtree->n.sym == forall_index))
3700 gfc_error ("Assignment to a FORALL index variable at %L",
3701 &code->expr->where);
3704 /* If one of the FORALL index variables doesn't appear in the
3705 assignment target, then there will be a many-to-one
3707 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3708 gfc_error ("The FORALL with index '%s' cause more than one "
3709 "assignment to this object at %L",
3710 var_expr[n]->symtree->name, &code->expr->where);
3716 /* Resolve WHERE statement in FORALL construct. */
3719 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3723 cblock = code->block;
3726 /* the assignment statement of a WHERE statement, or the first
3727 statement in where-body-construct of a WHERE construct */
3728 cnext = cblock->next;
3733 /* WHERE assignment statement */
3735 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3738 /* WHERE or WHERE construct is part of a where-body-construct */
3740 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3744 gfc_error ("Unsupported statement inside WHERE at %L",
3747 /* the next statement within the same where-body-construct */
3748 cnext = cnext->next;
3750 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3751 cblock = cblock->block;
3756 /* Traverse the FORALL body to check whether the following errors exist:
3757 1. For assignment, check if a many-to-one assignment happens.
3758 2. For WHERE statement, check the WHERE body to see if there is any
3759 many-to-one assignment. */
3762 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3766 c = code->block->next;
3772 case EXEC_POINTER_ASSIGN:
3773 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3776 /* Because the resolve_blocks() will handle the nested FORALL,
3777 there is no need to handle it here. */
3781 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3786 /* The next statement in the FORALL body. */
3792 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3793 gfc_resolve_forall_body to resolve the FORALL body. */
3795 static void resolve_blocks (gfc_code *, gfc_namespace *);
3798 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3800 static gfc_expr **var_expr;
3801 static int total_var = 0;
3802 static int nvar = 0;
3803 gfc_forall_iterator *fa;
3804 gfc_symbol *forall_index;
3808 /* Start to resolve a FORALL construct */
3809 if (forall_save == 0)
3811 /* Count the total number of FORALL index in the nested FORALL
3812 construct in order to allocate the VAR_EXPR with proper size. */
3814 while ((next != NULL) && (next->op == EXEC_FORALL))
3816 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3818 next = next->block->next;
3821 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3822 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3825 /* The information about FORALL iterator, including FORALL index start, end
3826 and stride. The FORALL index can not appear in start, end or stride. */
3827 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3829 /* Check if any outer FORALL index name is the same as the current
3831 for (i = 0; i < nvar; i++)
3833 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3835 gfc_error ("An outer FORALL construct already has an index "
3836 "with this name %L", &fa->var->where);
3840 /* Record the current FORALL index. */
3841 var_expr[nvar] = gfc_copy_expr (fa->var);
3843 forall_index = fa->var->symtree->n.sym;
3845 /* Check if the FORALL index appears in start, end or stride. */
3846 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3847 gfc_error ("A FORALL index must not appear in a limit or stride "
3848 "expression in the same FORALL at %L", &fa->start->where);
3849 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3850 gfc_error ("A FORALL index must not appear in a limit or stride "
3851 "expression in the same FORALL at %L", &fa->end->where);
3852 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3853 gfc_error ("A FORALL index must not appear in a limit or stride "
3854 "expression in the same FORALL at %L", &fa->stride->where);
3858 /* Resolve the FORALL body. */
3859 gfc_resolve_forall_body (code, nvar, var_expr);
3861 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3862 resolve_blocks (code->block, ns);
3864 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3865 for (i = 0; i < total_var; i++)
3866 gfc_free_expr (var_expr[i]);
3868 /* Reset the counters. */
3874 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3877 static void resolve_code (gfc_code *, gfc_namespace *);
3880 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3884 for (; b; b = b->block)
3886 t = gfc_resolve_expr (b->expr);
3887 if (gfc_resolve_expr (b->expr2) == FAILURE)
3893 if (t == SUCCESS && b->expr != NULL
3894 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3896 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3903 && (b->expr->ts.type != BT_LOGICAL
3904 || b->expr->rank == 0))
3906 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3911 resolve_branch (b->label, b);
3924 gfc_internal_error ("resolve_block(): Bad block type");
3927 resolve_code (b->next, ns);
3932 /* Given a block of code, recursively resolve everything pointed to by this
3936 resolve_code (gfc_code * code, gfc_namespace * ns)
3938 int forall_save = 0;
3943 frame.prev = cs_base;
3947 for (; code; code = code->next)
3949 frame.current = code;
3951 if (code->op == EXEC_FORALL)
3953 forall_save = forall_flag;
3955 gfc_resolve_forall (code, ns, forall_save);
3958 resolve_blocks (code->block, ns);
3960 if (code->op == EXEC_FORALL)
3961 forall_flag = forall_save;
3963 t = gfc_resolve_expr (code->expr);
3964 if (gfc_resolve_expr (code->expr2) == FAILURE)
3980 resolve_where (code, NULL);
3984 if (code->expr != NULL)
3986 if (code->expr->ts.type != BT_INTEGER)
3987 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3988 "variable", &code->expr->where);
3989 else if (code->expr->symtree->n.sym->attr.assign != 1)
3990 gfc_error ("Variable '%s' has not been assigned a target label "
3991 "at %L", code->expr->symtree->n.sym->name,
3992 &code->expr->where);
3995 resolve_branch (code->label, code);
3999 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4000 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4001 "return specifier", &code->expr->where);
4008 if (gfc_extend_assign (code, ns) == SUCCESS)
4011 if (gfc_pure (NULL))
4013 if (gfc_impure_variable (code->expr->symtree->n.sym))
4016 ("Cannot assign to variable '%s' in PURE procedure at %L",
4017 code->expr->symtree->n.sym->name, &code->expr->where);
4021 if (code->expr2->ts.type == BT_DERIVED
4022 && derived_pointer (code->expr2->ts.derived))
4025 ("Right side of assignment at %L is a derived type "
4026 "containing a POINTER in a PURE procedure",
4027 &code->expr2->where);
4032 gfc_check_assign (code->expr, code->expr2, 1);
4035 case EXEC_LABEL_ASSIGN:
4036 if (code->label->defined == ST_LABEL_UNKNOWN)
4037 gfc_error ("Label %d referenced at %L is never defined",
4038 code->label->value, &code->label->where);
4040 && (code->expr->expr_type != EXPR_VARIABLE
4041 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4042 || code->expr->symtree->n.sym->ts.kind
4043 != gfc_default_integer_kind
4044 || code->expr->symtree->n.sym->as != NULL))
4045 gfc_error ("ASSIGN statement at %L requires a scalar "
4046 "default INTEGER variable", &code->expr->where);
4049 case EXEC_POINTER_ASSIGN:
4053 gfc_check_pointer_assign (code->expr, code->expr2);
4056 case EXEC_ARITHMETIC_IF:
4058 && code->expr->ts.type != BT_INTEGER
4059 && code->expr->ts.type != BT_REAL)
4060 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4061 "expression", &code->expr->where);
4063 resolve_branch (code->label, code);
4064 resolve_branch (code->label2, code);
4065 resolve_branch (code->label3, code);
4069 if (t == SUCCESS && code->expr != NULL
4070 && (code->expr->ts.type != BT_LOGICAL
4071 || code->expr->rank != 0))
4072 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4073 &code->expr->where);
4078 resolve_call (code);
4082 /* Select is complicated. Also, a SELECT construct could be
4083 a transformed computed GOTO. */
4084 resolve_select (code);
4088 if (code->ext.iterator != NULL)
4089 gfc_resolve_iterator (code->ext.iterator, true);
4093 if (code->expr == NULL)
4094 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4096 && (code->expr->rank != 0
4097 || code->expr->ts.type != BT_LOGICAL))
4098 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4099 "a scalar LOGICAL expression", &code->expr->where);
4103 if (t == SUCCESS && code->expr != NULL
4104 && code->expr->ts.type != BT_INTEGER)
4105 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4106 "of type INTEGER", &code->expr->where);
4108 for (a = code->ext.alloc_list; a; a = a->next)
4109 resolve_allocate_expr (a->expr, code);
4113 case EXEC_DEALLOCATE:
4114 if (t == SUCCESS && code->expr != NULL
4115 && code->expr->ts.type != BT_INTEGER)
4117 ("STAT tag in DEALLOCATE statement at %L must be of type "
4118 "INTEGER", &code->expr->where);
4120 for (a = code->ext.alloc_list; a; a = a->next)
4121 resolve_deallocate_expr (a->expr);
4126 if (gfc_resolve_open (code->ext.open) == FAILURE)
4129 resolve_branch (code->ext.open->err, code);
4133 if (gfc_resolve_close (code->ext.close) == FAILURE)
4136 resolve_branch (code->ext.close->err, code);
4139 case EXEC_BACKSPACE:
4143 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4146 resolve_branch (code->ext.filepos->err, code);
4150 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4153 resolve_branch (code->ext.inquire->err, code);
4157 gcc_assert (code->ext.inquire != NULL);
4158 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4161 resolve_branch (code->ext.inquire->err, code);
4166 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4169 resolve_branch (code->ext.dt->err, code);
4170 resolve_branch (code->ext.dt->end, code);
4171 resolve_branch (code->ext.dt->eor, code);
4175 resolve_transfer (code);
4179 resolve_forall_iterators (code->ext.forall_iterator);
4181 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4183 ("FORALL mask clause at %L requires a LOGICAL expression",
4184 &code->expr->where);
4188 gfc_internal_error ("resolve_code(): Bad statement code");
4192 cs_base = frame.prev;
4196 /* Resolve initial values and make sure they are compatible with
4200 resolve_values (gfc_symbol * sym)
4203 if (sym->value == NULL)
4206 if (gfc_resolve_expr (sym->value) == FAILURE)
4209 gfc_check_assign_symbol (sym, sym->value);
4213 /* Do anything necessary to resolve a symbol. Right now, we just
4214 assume that an otherwise unknown symbol is a variable. This sort
4215 of thing commonly happens for symbols in module. */
4218 resolve_symbol (gfc_symbol * sym)
4220 /* Zero if we are checking a formal namespace. */
4221 static int formal_ns_flag = 1;
4222 int formal_ns_save, check_constant, mp_flag;
4225 gfc_symtree * symtree;
4226 gfc_symtree * this_symtree;
4229 gfc_formal_arglist * arg;
4231 if (sym->attr.flavor == FL_UNKNOWN)
4234 /* If we find that a flavorless symbol is an interface in one of the
4235 parent namespaces, find its symtree in this namespace, free the
4236 symbol and set the symtree to point to the interface symbol. */
4237 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4239 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4240 if (symtree && symtree->n.sym->generic)
4242 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4246 gfc_free_symbol (sym);
4247 symtree->n.sym->refs++;
4248 this_symtree->n.sym = symtree->n.sym;
4253 /* Otherwise give it a flavor according to such attributes as
4255 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4256 sym->attr.flavor = FL_VARIABLE;
4259 sym->attr.flavor = FL_PROCEDURE;
4260 if (sym->attr.dimension)
4261 sym->attr.function = 1;
4265 /* Symbols that are module procedures with results (functions) have
4266 the types and array specification copied for type checking in
4267 procedures that call them, as well as for saving to a module
4268 file. These symbols can't stand the scrutiny that their results
4270 mp_flag = (sym->result != NULL && sym->result != sym);
4272 /* Assign default type to symbols that need one and don't have one. */
4273 if (sym->ts.type == BT_UNKNOWN)
4275 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4276 gfc_set_default_type (sym, 1, NULL);
4278 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4280 /* The specific case of an external procedure should emit an error
4281 in the case that there is no implicit type. */
4283 gfc_set_default_type (sym, sym->attr.external, NULL);
4286 /* Result may be in another namespace. */
4287 resolve_symbol (sym->result);
4289 sym->ts = sym->result->ts;
4290 sym->as = gfc_copy_array_spec (sym->result->as);
4291 sym->attr.dimension = sym->result->attr.dimension;
4292 sym->attr.pointer = sym->result->attr.pointer;
4297 /* Assumed size arrays and assumed shape arrays must be dummy
4301 && (sym->as->type == AS_ASSUMED_SIZE
4302 || sym->as->type == AS_ASSUMED_SHAPE)
4303 && sym->attr.dummy == 0)
4305 if (sym->as->type == AS_ASSUMED_SIZE)
4306 gfc_error ("Assumed size array at %L must be a dummy argument",
4309 gfc_error ("Assumed shape array at %L must be a dummy argument",
4314 /* A parameter array's shape needs to be constant. */
4316 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4317 && !gfc_is_compile_time_shape (sym->as))
4319 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4320 "or assumed shape", sym->name, &sym->declared_at);
4324 /* A module array's shape needs to be constant. */
4326 if (sym->ns->proc_name
4327 && sym->attr.flavor == FL_VARIABLE
4328 && sym->ns->proc_name->attr.flavor == FL_MODULE
4329 && !sym->attr.use_assoc
4330 && !sym->attr.allocatable
4331 && !sym->attr.pointer
4333 && !gfc_is_compile_time_shape (sym->as))
4335 gfc_error ("Module array '%s' at %L cannot be automatic "
4336 "or assumed shape", sym->name, &sym->declared_at);
4340 /* Make sure that character string variables with assumed length are
4343 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4344 && sym->ts.type == BT_CHARACTER
4345 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4347 gfc_error ("Entity with assumed character length at %L must be a "
4348 "dummy argument or a PARAMETER", &sym->declared_at);
4352 /* Make sure a parameter that has been implicitly typed still
4353 matches the implicit type, since PARAMETER statements can precede
4354 IMPLICIT statements. */
4356 if (sym->attr.flavor == FL_PARAMETER
4357 && sym->attr.implicit_type
4358 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4359 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4360 "later IMPLICIT type", sym->name, &sym->declared_at);
4362 /* Make sure the types of derived parameters are consistent. This
4363 type checking is deferred until resolution because the type may
4364 refer to a derived type from the host. */
4366 if (sym->attr.flavor == FL_PARAMETER
4367 && sym->ts.type == BT_DERIVED
4368 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4369 gfc_error ("Incompatible derived type in PARAMETER at %L",
4370 &sym->value->where);
4372 /* Make sure symbols with known intent or optional are really dummy
4373 variable. Because of ENTRY statement, this has to be deferred
4374 until resolution time. */
4376 if (! sym->attr.dummy
4377 && (sym->attr.optional
4378 || sym->attr.intent != INTENT_UNKNOWN))
4380 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4384 if (sym->attr.proc == PROC_ST_FUNCTION)
4386 if (sym->ts.type == BT_CHARACTER)
4388 gfc_charlen *cl = sym->ts.cl;
4389 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4391 gfc_error ("Character-valued statement function '%s' at %L must "
4392 "have constant length", sym->name, &sym->declared_at);
4398 /* If a derived type symbol has reached this point, without its
4399 type being declared, we have an error. Notice that most
4400 conditions that produce undefined derived types have already
4401 been dealt with. However, the likes of:
4402 implicit type(t) (t) ..... call foo (t) will get us here if
4403 the type is not declared in the scope of the implicit
4404 statement. Change the type to BT_UNKNOWN, both because it is so
4405 and to prevent an ICE. */
4406 if (sym->ts.type == BT_DERIVED
4407 && sym->ts.derived->components == NULL)
4409 gfc_error ("The derived type '%s' at %L is of type '%s', "
4410 "which has not been defined.", sym->name,
4411 &sym->declared_at, sym->ts.derived->name);
4412 sym->ts.type = BT_UNKNOWN;
4416 /* If a component of a derived type is of a type declared to be private,
4417 either the derived type definition must contain the PRIVATE statement,
4418 or the derived type must be private. (4.4.1 just after R427) */
4419 if (sym->attr.flavor == FL_DERIVED
4420 && sym->component_access != ACCESS_PRIVATE
4421 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4423 for (c = sym->components; c; c = c->next)
4425 if (c->ts.type == BT_DERIVED
4426 && !c->ts.derived->attr.use_assoc
4427 && !gfc_check_access(c->ts.derived->attr.access,
4428 c->ts.derived->ns->default_access))
4430 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4431 "a component of '%s', which is PUBLIC at %L",
4432 c->name, sym->name, &sym->declared_at);
4438 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4439 default initialization is defined (5.1.2.4.4). */
4440 if (sym->ts.type == BT_DERIVED
4442 && sym->attr.intent == INTENT_OUT
4444 && sym->as->type == AS_ASSUMED_SIZE)
4446 for (c = sym->ts.derived->components; c; c = c->next)
4450 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4451 "ASSUMED SIZE and so cannot have a default initializer",
4452 sym->name, &sym->declared_at);
4459 /* Ensure that derived type formal arguments of a public procedure
4460 are not of a private type. */
4461 if (sym->attr.flavor == FL_PROCEDURE
4462 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4464 for (arg = sym->formal; arg; arg = arg->next)
4467 && arg->sym->ts.type == BT_DERIVED
4468 && !arg->sym->ts.derived->attr.use_assoc
4469 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4470 arg->sym->ts.derived->ns->default_access))
4472 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4473 "a dummy argument of '%s', which is PUBLIC at %L",
4474 arg->sym->name, sym->name, &sym->declared_at);
4475 /* Stop this message from recurring. */
4476 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4482 /* Constraints on deferred shape variable. */
4483 if (sym->attr.flavor == FL_VARIABLE
4484 || (sym->attr.flavor == FL_PROCEDURE
4485 && sym->attr.function))
4487 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4489 if (sym->attr.allocatable)
4491 if (sym->attr.dimension)
4492 gfc_error ("Allocatable array '%s' at %L must have "
4493 "a deferred shape", sym->name, &sym->declared_at);
4495 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4496 sym->name, &sym->declared_at);
4500 if (sym->attr.pointer && sym->attr.dimension)
4502 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4503 sym->name, &sym->declared_at);
4510 if (!mp_flag && !sym->attr.allocatable
4511 && !sym->attr.pointer && !sym->attr.dummy)
4513 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4514 sym->name, &sym->declared_at);
4520 switch (sym->attr.flavor)
4523 /* Can the symbol have an initializer? */
4525 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4526 || sym->attr.intrinsic || sym->attr.result)
4528 else if (sym->attr.dimension && !sym->attr.pointer)
4530 /* Don't allow initialization of automatic arrays. */
4531 for (i = 0; i < sym->as->rank; i++)
4533 if (sym->as->lower[i] == NULL
4534 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4535 || sym->as->upper[i] == NULL
4536 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4544 /* Reject illegal initializers. */
4545 if (sym->value && flag)
4547 if (sym->attr.allocatable)
4548 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4549 sym->name, &sym->declared_at);
4550 else if (sym->attr.external)
4551 gfc_error ("External '%s' at %L cannot have an initializer",
4552 sym->name, &sym->declared_at);
4553 else if (sym->attr.dummy)
4554 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4555 sym->name, &sym->declared_at);
4556 else if (sym->attr.intrinsic)
4557 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4558 sym->name, &sym->declared_at);
4559 else if (sym->attr.result)
4560 gfc_error ("Function result '%s' at %L cannot have an initializer",
4561 sym->name, &sym->declared_at);
4563 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4564 sym->name, &sym->declared_at);
4568 /* Assign default initializer. */
4569 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4570 && !sym->attr.pointer)
4571 sym->value = gfc_default_initializer (&sym->ts);
4575 /* Reject PRIVATE objects in a PUBLIC namelist. */
4576 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4578 for (nl = sym->namelist; nl; nl = nl->next)
4580 if (!nl->sym->attr.use_assoc
4582 !(sym->ns->parent == nl->sym->ns)
4584 !gfc_check_access(nl->sym->attr.access,
4585 nl->sym->ns->default_access))
4586 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4587 "PUBLIC namelist at %L", nl->sym->name,
4595 /* An external symbol falls through to here if it is not referenced. */
4596 if (sym->attr.external && sym->value)
4598 gfc_error ("External object '%s' at %L may not have an initializer",
4599 sym->name, &sym->declared_at);
4607 /* Make sure that intrinsic exist */
4608 if (sym->attr.intrinsic
4609 && ! gfc_intrinsic_name(sym->name, 0)
4610 && ! gfc_intrinsic_name(sym->name, 1))
4611 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4613 /* Resolve array specifier. Check as well some constraints
4614 on COMMON blocks. */
4616 check_constant = sym->attr.in_common && !sym->attr.pointer;
4617 gfc_resolve_array_spec (sym->as, check_constant);
4619 /* Resolve formal namespaces. */
4621 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4623 formal_ns_save = formal_ns_flag;
4625 gfc_resolve (sym->formal_ns);
4626 formal_ns_flag = formal_ns_save;
4632 /************* Resolve DATA statements *************/
4636 gfc_data_value *vnode;
4642 /* Advance the values structure to point to the next value in the data list. */
4645 next_data_value (void)
4647 while (values.left == 0)
4649 if (values.vnode->next == NULL)
4652 values.vnode = values.vnode->next;
4653 values.left = values.vnode->repeat;
4661 check_data_variable (gfc_data_variable * var, locus * where)
4667 ar_type mark = AR_UNKNOWN;
4669 mpz_t section_index[GFC_MAX_DIMENSIONS];
4673 if (gfc_resolve_expr (var->expr) == FAILURE)
4677 mpz_init_set_si (offset, 0);
4680 if (e->expr_type != EXPR_VARIABLE)
4681 gfc_internal_error ("check_data_variable(): Bad expression");
4685 mpz_init_set_ui (size, 1);
4692 /* Find the array section reference. */
4693 for (ref = e->ref; ref; ref = ref->next)
4695 if (ref->type != REF_ARRAY)
4697 if (ref->u.ar.type == AR_ELEMENT)
4703 /* Set marks according to the reference pattern. */
4704 switch (ref->u.ar.type)
4712 /* Get the start position of array section. */
4713 gfc_get_section_index (ar, section_index, &offset);
4721 if (gfc_array_size (e, &size) == FAILURE)
4723 gfc_error ("Nonconstant array section at %L in DATA statement",
4732 while (mpz_cmp_ui (size, 0) > 0)
4734 if (next_data_value () == FAILURE)
4736 gfc_error ("DATA statement at %L has more variables than values",
4742 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4746 /* If we have more than one element left in the repeat count,
4747 and we have more than one element left in the target variable,
4748 then create a range assignment. */
4749 /* ??? Only done for full arrays for now, since array sections
4751 if (mark == AR_FULL && ref && ref->next == NULL
4752 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4756 if (mpz_cmp_ui (size, values.left) >= 0)
4758 mpz_init_set_ui (range, values.left);
4759 mpz_sub_ui (size, size, values.left);
4764 mpz_init_set (range, size);
4765 values.left -= mpz_get_ui (size);
4766 mpz_set_ui (size, 0);
4769 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4772 mpz_add (offset, offset, range);
4776 /* Assign initial value to symbol. */
4780 mpz_sub_ui (size, size, 1);
4782 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4784 if (mark == AR_FULL)
4785 mpz_add_ui (offset, offset, 1);
4787 /* Modify the array section indexes and recalculate the offset
4788 for next element. */
4789 else if (mark == AR_SECTION)
4790 gfc_advance_section (section_index, ar, &offset);
4794 if (mark == AR_SECTION)
4796 for (i = 0; i < ar->dimen; i++)
4797 mpz_clear (section_index[i]);
4807 static try traverse_data_var (gfc_data_variable *, locus *);
4809 /* Iterate over a list of elements in a DATA statement. */
4812 traverse_data_list (gfc_data_variable * var, locus * where)
4815 iterator_stack frame;
4818 mpz_init (frame.value);
4820 mpz_init_set (trip, var->iter.end->value.integer);
4821 mpz_sub (trip, trip, var->iter.start->value.integer);
4822 mpz_add (trip, trip, var->iter.step->value.integer);
4824 mpz_div (trip, trip, var->iter.step->value.integer);
4826 mpz_set (frame.value, var->iter.start->value.integer);
4828 frame.prev = iter_stack;
4829 frame.variable = var->iter.var->symtree;
4830 iter_stack = &frame;
4832 while (mpz_cmp_ui (trip, 0) > 0)
4834 if (traverse_data_var (var->list, where) == FAILURE)
4840 e = gfc_copy_expr (var->expr);
4841 if (gfc_simplify_expr (e, 1) == FAILURE)
4847 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4849 mpz_sub_ui (trip, trip, 1);
4853 mpz_clear (frame.value);
4855 iter_stack = frame.prev;
4860 /* Type resolve variables in the variable list of a DATA statement. */
4863 traverse_data_var (gfc_data_variable * var, locus * where)
4867 for (; var; var = var->next)
4869 if (var->expr == NULL)
4870 t = traverse_data_list (var, where);
4872 t = check_data_variable (var, where);
4882 /* Resolve the expressions and iterators associated with a data statement.
4883 This is separate from the assignment checking because data lists should
4884 only be resolved once. */
4887 resolve_data_variables (gfc_data_variable * d)
4889 for (; d; d = d->next)
4891 if (d->list == NULL)
4893 if (gfc_resolve_expr (d->expr) == FAILURE)
4898 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
4901 if (d->iter.start->expr_type != EXPR_CONSTANT
4902 || d->iter.end->expr_type != EXPR_CONSTANT
4903 || d->iter.step->expr_type != EXPR_CONSTANT)
4904 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4906 if (resolve_data_variables (d->list) == FAILURE)
4915 /* Resolve a single DATA statement. We implement this by storing a pointer to
4916 the value list into static variables, and then recursively traversing the
4917 variables list, expanding iterators and such. */
4920 resolve_data (gfc_data * d)
4922 if (resolve_data_variables (d->var) == FAILURE)
4925 values.vnode = d->value;
4926 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4928 if (traverse_data_var (d->var, &d->where) == FAILURE)
4931 /* At this point, we better not have any values left. */
4933 if (next_data_value () == SUCCESS)
4934 gfc_error ("DATA statement at %L has more values than variables",
4939 /* Determines if a variable is not 'pure', ie not assignable within a pure
4940 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4944 gfc_impure_variable (gfc_symbol * sym)
4946 if (sym->attr.use_assoc || sym->attr.in_common)
4949 if (sym->ns != gfc_current_ns)
4950 return !sym->attr.function;
4952 /* TODO: Check storage association through EQUIVALENCE statements */
4958 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4959 symbol of the current procedure. */
4962 gfc_pure (gfc_symbol * sym)
4964 symbol_attribute attr;
4967 sym = gfc_current_ns->proc_name;
4973 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4977 /* Test whether the current procedure is elemental or not. */
4980 gfc_elemental (gfc_symbol * sym)
4982 symbol_attribute attr;
4985 sym = gfc_current_ns->proc_name;
4990 return attr.flavor == FL_PROCEDURE && attr.elemental;
4994 /* Warn about unused labels. */
4997 warn_unused_label (gfc_namespace * ns)
5008 for (; l; l = l->prev)
5010 if (l->defined == ST_LABEL_UNKNOWN)
5013 switch (l->referenced)
5015 case ST_LABEL_UNKNOWN:
5016 gfc_warning ("Label %d at %L defined but not used", l->value,
5020 case ST_LABEL_BAD_TARGET:
5021 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
5032 /* Returns the sequence type of a symbol or sequence. */
5035 sequence_type (gfc_typespec ts)
5044 if (ts.derived->components == NULL)
5045 return SEQ_NONDEFAULT;
5047 result = sequence_type (ts.derived->components->ts);
5048 for (c = ts.derived->components->next; c; c = c->next)
5049 if (sequence_type (c->ts) != result)
5055 if (ts.kind != gfc_default_character_kind)
5056 return SEQ_NONDEFAULT;
5058 return SEQ_CHARACTER;
5061 if (ts.kind != gfc_default_integer_kind)
5062 return SEQ_NONDEFAULT;
5067 if (!(ts.kind == gfc_default_real_kind
5068 || ts.kind == gfc_default_double_kind))
5069 return SEQ_NONDEFAULT;
5074 if (ts.kind != gfc_default_complex_kind)
5075 return SEQ_NONDEFAULT;
5080 if (ts.kind != gfc_default_logical_kind)
5081 return SEQ_NONDEFAULT;
5086 return SEQ_NONDEFAULT;
5091 /* Resolve derived type EQUIVALENCE object. */
5094 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5097 gfc_component *c = derived->components;
5102 /* Shall not be an object of nonsequence derived type. */
5103 if (!derived->attr.sequence)
5105 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5106 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5110 for (; c ; c = c->next)
5113 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5116 /* Shall not be an object of sequence derived type containing a pointer
5117 in the structure. */
5120 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5121 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5127 gfc_error ("Derived type variable '%s' at %L with default initializer "
5128 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5136 /* Resolve equivalence object.
5137 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5138 an allocatable array, an object of nonsequence derived type, an object of
5139 sequence derived type containing a pointer at any level of component
5140 selection, an automatic object, a function name, an entry name, a result
5141 name, a named constant, a structure component, or a subobject of any of
5142 the preceding objects. A substring shall not have length zero. A
5143 derived type shall not have components with default initialization nor
5144 shall two objects of an equivalence group be initialized.
5145 The simple constraints are done in symbol.c(check_conflict) and the rest
5146 are implemented here. */
5149 resolve_equivalence (gfc_equiv *eq)
5152 gfc_symbol *derived;
5153 gfc_symbol *first_sym;
5156 locus *last_where = NULL;
5157 seq_type eq_type, last_eq_type;
5158 gfc_typespec *last_ts;
5160 const char *value_name;
5164 last_ts = &eq->expr->symtree->n.sym->ts;
5166 first_sym = eq->expr->symtree->n.sym;
5168 for (object = 1; eq; eq = eq->eq, object++)
5172 e->ts = e->symtree->n.sym->ts;
5173 /* match_varspec might not know yet if it is seeing
5174 array reference or substring reference, as it doesn't
5176 if (e->ref && e->ref->type == REF_ARRAY)
5178 gfc_ref *ref = e->ref;
5179 sym = e->symtree->n.sym;
5181 if (sym->attr.dimension)
5183 ref->u.ar.as = sym->as;
5187 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5188 if (e->ts.type == BT_CHARACTER
5190 && ref->type == REF_ARRAY
5191 && ref->u.ar.dimen == 1
5192 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5193 && ref->u.ar.stride[0] == NULL)
5195 gfc_expr *start = ref->u.ar.start[0];
5196 gfc_expr *end = ref->u.ar.end[0];
5199 /* Optimize away the (:) reference. */
5200 if (start == NULL && end == NULL)
5205 e->ref->next = ref->next;
5210 ref->type = REF_SUBSTRING;
5212 start = gfc_int_expr (1);
5213 ref->u.ss.start = start;
5214 if (end == NULL && e->ts.cl)
5215 end = gfc_copy_expr (e->ts.cl->length);
5216 ref->u.ss.end = end;
5217 ref->u.ss.length = e->ts.cl;
5224 /* Any further ref is an error. */
5227 gcc_assert (ref->type == REF_ARRAY);
5228 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5234 if (gfc_resolve_expr (e) == FAILURE)
5237 sym = e->symtree->n.sym;
5239 /* An equivalence statement cannot have more than one initialized
5243 if (value_name != NULL)
5245 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5246 "be in the EQUIVALENCE statement at %L",
5247 value_name, sym->name, &e->where);
5251 value_name = sym->name;
5254 /* Shall not equivalence common block variables in a PURE procedure. */
5255 if (sym->ns->proc_name
5256 && sym->ns->proc_name->attr.pure
5257 && sym->attr.in_common)
5259 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5260 "object in the pure procedure '%s'",
5261 sym->name, &e->where, sym->ns->proc_name->name);
5265 /* Shall not be a named constant. */
5266 if (e->expr_type == EXPR_CONSTANT)
5268 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5269 "object", sym->name, &e->where);
5273 derived = e->ts.derived;
5274 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5277 /* Check that the types correspond correctly:
5279 A numeric sequence structure may be equivalenced to another sequence
5280 structure, an object of default integer type, default real type, double
5281 precision real type, default logical type such that components of the
5282 structure ultimately only become associated to objects of the same
5283 kind. A character sequence structure may be equivalenced to an object
5284 of default character kind or another character sequence structure.
5285 Other objects may be equivalenced only to objects of the same type and
5288 /* Identical types are unconditionally OK. */
5289 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5290 goto identical_types;
5292 last_eq_type = sequence_type (*last_ts);
5293 eq_type = sequence_type (sym->ts);
5295 /* Since the pair of objects is not of the same type, mixed or
5296 non-default sequences can be rejected. */
5298 msg = "Sequence %s with mixed components in EQUIVALENCE "
5299 "statement at %L with different type objects";
5301 && last_eq_type == SEQ_MIXED
5302 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5303 last_where) == FAILURE)
5304 || (eq_type == SEQ_MIXED
5305 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5306 &e->where) == FAILURE))
5309 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5310 "statement at %L with objects of different type";
5312 && last_eq_type == SEQ_NONDEFAULT
5313 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5314 last_where) == FAILURE)
5315 || (eq_type == SEQ_NONDEFAULT
5316 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5317 &e->where) == FAILURE))
5320 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5321 "EQUIVALENCE statement at %L";
5322 if (last_eq_type == SEQ_CHARACTER
5323 && eq_type != SEQ_CHARACTER
5324 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5325 &e->where) == FAILURE)
5328 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5329 "EQUIVALENCE statement at %L";
5330 if (last_eq_type == SEQ_NUMERIC
5331 && eq_type != SEQ_NUMERIC
5332 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5333 &e->where) == FAILURE)
5338 last_where = &e->where;
5343 /* Shall not be an automatic array. */
5344 if (e->ref->type == REF_ARRAY
5345 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5347 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5348 "an EQUIVALENCE object", sym->name, &e->where);
5355 /* Shall not be a structure component. */
5356 if (r->type == REF_COMPONENT)
5358 gfc_error ("Structure component '%s' at %L cannot be an "
5359 "EQUIVALENCE object",
5360 r->u.c.component->name, &e->where);
5364 /* A substring shall not have length zero. */
5365 if (r->type == REF_SUBSTRING)
5367 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5369 gfc_error ("Substring at %L has length zero",
5370 &r->u.ss.start->where);
5380 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5383 resolve_fntype (gfc_namespace * ns)
5388 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5391 /* If there are any entries, ns->proc_name is the entry master
5392 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5394 sym = ns->entries->sym;
5396 sym = ns->proc_name;
5397 if (sym->result == sym
5398 && sym->ts.type == BT_UNKNOWN
5399 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5400 && !sym->attr.untyped)
5402 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5403 sym->name, &sym->declared_at);
5404 sym->attr.untyped = 1;
5408 for (el = ns->entries->next; el; el = el->next)
5410 if (el->sym->result == el->sym
5411 && el->sym->ts.type == BT_UNKNOWN
5412 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5413 && !el->sym->attr.untyped)
5415 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5416 el->sym->name, &el->sym->declared_at);
5417 el->sym->attr.untyped = 1;
5423 /* This function is called after a complete program unit has been compiled.
5424 Its purpose is to examine all of the expressions associated with a program
5425 unit, assign types to all intermediate expressions, make sure that all
5426 assignments are to compatible types and figure out which names refer to
5427 which functions or subroutines. */
5430 gfc_resolve (gfc_namespace * ns)
5432 gfc_namespace *old_ns, *n;
5437 old_ns = gfc_current_ns;
5438 gfc_current_ns = ns;
5440 resolve_entries (ns);
5442 resolve_contained_functions (ns);
5444 gfc_traverse_ns (ns, resolve_symbol);
5446 resolve_fntype (ns);
5448 for (n = ns->contained; n; n = n->sibling)
5450 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5451 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5452 "also be PURE", n->proc_name->name,
5453 &n->proc_name->declared_at);
5459 gfc_check_interfaces (ns);
5461 for (cl = ns->cl_list; cl; cl = cl->next)
5463 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
5466 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
5469 if (gfc_specification_expr (cl->length) == FAILURE)
5473 gfc_traverse_ns (ns, resolve_values);
5479 for (d = ns->data; d; d = d->next)
5483 gfc_traverse_ns (ns, gfc_formalize_init_value);
5485 for (eq = ns->equiv; eq; eq = eq->next)
5486 resolve_equivalence (eq);
5489 resolve_code (ns->code, ns);
5491 /* Warn about unused labels. */
5492 if (gfc_option.warn_unused_labels)
5493 warn_unused_label (ns);
5495 gfc_current_ns = old_ns;