1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code *head, *current;
44 struct code_stack *prev;
48 static code_stack *cs_base = NULL;
51 /* Nonzero if we're inside a FORALL block */
53 static int forall_flag;
55 /* Nonzero if we are processing a formal arglist. The corresponding function
56 resets the flag each time that it is read. */
57 static int formal_arg_flag = 0;
60 gfc_is_formal_arg (void)
62 return formal_arg_flag;
65 /* Resolve types of formal argument lists. These have to be done early so that
66 the formal argument lists of module procedures can be copied to the
67 containing module before the individual procedures are resolved
68 individually. We also resolve argument lists of procedures in interface
69 blocks because they are self-contained scoping units.
71 Since a dummy argument cannot be a non-dummy procedure, the only
72 resort left for untyped names are the IMPLICIT types. */
75 resolve_formal_arglist (gfc_symbol * proc)
77 gfc_formal_arglist *f;
81 /* TODO: Procedures whose return character length parameter is not constant
82 or assumed must also have explicit interfaces. */
83 if (proc->result != NULL)
88 if (gfc_elemental (proc)
89 || sym->attr.pointer || sym->attr.allocatable
90 || (sym->as && sym->as->rank > 0))
91 proc->attr.always_explicit = 1;
95 for (f = proc->formal; f; f = f->next)
101 /* Alternate return placeholder. */
102 if (gfc_elemental (proc))
103 gfc_error ("Alternate return specifier in elemental subroutine "
104 "'%s' at %L is not allowed", proc->name,
106 if (proc->attr.function)
107 gfc_error ("Alternate return specifier in function "
108 "'%s' at %L is not allowed", proc->name,
113 if (sym->attr.if_source != IFSRC_UNKNOWN)
114 resolve_formal_arglist (sym);
116 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
118 if (gfc_pure (proc) && !gfc_pure (sym))
121 ("Dummy procedure '%s' of PURE procedure at %L must also "
122 "be PURE", sym->name, &sym->declared_at);
126 if (gfc_elemental (proc))
129 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
137 if (sym->ts.type == BT_UNKNOWN)
139 if (!sym->attr.function || sym->result == sym)
140 gfc_set_default_type (sym, 1, sym->ns);
143 gfc_resolve_array_spec (sym->as, 0);
145 /* We can't tell if an array with dimension (:) is assumed or deferred
146 shape until we know if it has the pointer or allocatable attributes.
148 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
149 && !(sym->attr.pointer || sym->attr.allocatable))
151 sym->as->type = AS_ASSUMED_SHAPE;
152 for (i = 0; i < sym->as->rank; i++)
153 sym->as->lower[i] = gfc_int_expr (1);
156 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
157 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
158 || sym->attr.optional)
159 proc->attr.always_explicit = 1;
161 /* If the flavor is unknown at this point, it has to be a variable.
162 A procedure specification would have already set the type. */
164 if (sym->attr.flavor == FL_UNKNOWN)
165 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
169 if (proc->attr.function && !sym->attr.pointer
170 && sym->attr.flavor != FL_PROCEDURE
171 && sym->attr.intent != INTENT_IN)
173 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
174 "INTENT(IN)", sym->name, proc->name,
177 if (proc->attr.subroutine && !sym->attr.pointer
178 && sym->attr.intent == INTENT_UNKNOWN)
181 ("Argument '%s' of pure subroutine '%s' at %L must have "
182 "its INTENT specified", sym->name, proc->name,
187 if (gfc_elemental (proc))
192 ("Argument '%s' of elemental procedure at %L must be scalar",
193 sym->name, &sym->declared_at);
197 if (sym->attr.pointer)
200 ("Argument '%s' of elemental procedure at %L cannot have "
201 "the POINTER attribute", sym->name, &sym->declared_at);
206 /* Each dummy shall be specified to be scalar. */
207 if (proc->attr.proc == PROC_ST_FUNCTION)
212 ("Argument '%s' of statement function at %L must be scalar",
213 sym->name, &sym->declared_at);
217 if (sym->ts.type == BT_CHARACTER)
219 gfc_charlen *cl = sym->ts.cl;
220 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
223 ("Character-valued argument '%s' of statement function at "
224 "%L must has constant length",
225 sym->name, &sym->declared_at);
235 /* Work function called when searching for symbols that have argument lists
236 associated with them. */
239 find_arglists (gfc_symbol * sym)
242 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
245 resolve_formal_arglist (sym);
249 /* Given a namespace, resolve all formal argument lists within the namespace.
253 resolve_formal_arglists (gfc_namespace * ns)
259 gfc_traverse_ns (ns, find_arglists);
264 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
268 /* If this namespace is not a function, ignore it. */
270 || !(sym->attr.function
271 || sym->attr.flavor == FL_VARIABLE))
274 /* Try to find out of what the return type is. */
275 if (sym->result != NULL)
278 if (sym->ts.type == BT_UNKNOWN)
280 t = gfc_set_default_type (sym, 0, ns);
282 if (t == FAILURE && !sym->attr.untyped)
284 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
285 sym->name, &sym->declared_at); /* FIXME */
286 sym->attr.untyped = 1;
290 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
291 lists the only ways a character length value of * can be used: dummy arguments
292 of procedures, named constants, and function results in external functions.
293 Internal function results are not on that list; ergo, not permitted. */
295 if (sym->ts.type == BT_CHARACTER)
297 gfc_charlen *cl = sym->ts.cl;
298 if (!cl || !cl->length)
299 gfc_error ("Character-valued internal function '%s' at %L must "
300 "not be assumed length", sym->name, &sym->declared_at);
305 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
306 introduce duplicates. */
309 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
311 gfc_formal_arglist *f, *new_arglist;
314 for (; new_args != NULL; new_args = new_args->next)
316 new_sym = new_args->sym;
317 /* See if ths arg is already in the formal argument list. */
318 for (f = proc->formal; f; f = f->next)
320 if (new_sym == f->sym)
327 /* Add a new argument. Argument order is not important. */
328 new_arglist = gfc_get_formal_arglist ();
329 new_arglist->sym = new_sym;
330 new_arglist->next = proc->formal;
331 proc->formal = new_arglist;
336 /* Resolve alternate entry points. If a symbol has multiple entry points we
337 create a new master symbol for the main routine, and turn the existing
338 symbol into an entry point. */
341 resolve_entries (gfc_namespace * ns)
343 gfc_namespace *old_ns;
347 char name[GFC_MAX_SYMBOL_LEN + 1];
348 static int master_count = 0;
350 if (ns->proc_name == NULL)
353 /* No need to do anything if this procedure doesn't have alternate entry
358 /* We may already have resolved alternate entry points. */
359 if (ns->proc_name->attr.entry_master)
362 /* If this isn't a procedure something has gone horribly wrong. */
363 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
365 /* Remember the current namespace. */
366 old_ns = gfc_current_ns;
370 /* Add the main entry point to the list of entry points. */
371 el = gfc_get_entry_list ();
372 el->sym = ns->proc_name;
374 el->next = ns->entries;
376 ns->proc_name->attr.entry = 1;
378 /* Add an entry statement for it. */
385 /* Create a new symbol for the master function. */
386 /* Give the internal function a unique name (within this file).
387 Also include the function name so the user has some hope of figuring
388 out what is going on. */
389 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
390 master_count++, ns->proc_name->name);
391 gfc_get_ha_symbol (name, &proc);
392 gcc_assert (proc != NULL);
394 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
395 if (ns->proc_name->attr.subroutine)
396 gfc_add_subroutine (&proc->attr, proc->name, NULL);
400 gfc_typespec *ts, *fts;
402 gfc_add_function (&proc->attr, proc->name, NULL);
404 fts = &ns->entries->sym->result->ts;
405 if (fts->type == BT_UNKNOWN)
406 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
407 for (el = ns->entries->next; el; el = el->next)
409 ts = &el->sym->result->ts;
410 if (ts->type == BT_UNKNOWN)
411 ts = gfc_get_default_type (el->sym->result, NULL);
412 if (! gfc_compare_types (ts, fts)
413 || (el->sym->result->attr.dimension
414 != ns->entries->sym->result->attr.dimension)
415 || (el->sym->result->attr.pointer
416 != ns->entries->sym->result->attr.pointer))
422 sym = ns->entries->sym->result;
423 /* All result types the same. */
425 if (sym->attr.dimension)
426 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
427 if (sym->attr.pointer)
428 gfc_add_pointer (&proc->attr, NULL);
432 /* Otherwise the result will be passed through a union by
434 proc->attr.mixed_entry_master = 1;
435 for (el = ns->entries; el; el = el->next)
437 sym = el->sym->result;
438 if (sym->attr.dimension)
440 if (el == ns->entries)
442 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
443 sym->name, ns->entries->sym->name, &sym->declared_at);
446 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
447 sym->name, ns->entries->sym->name, &sym->declared_at);
449 else if (sym->attr.pointer)
451 if (el == ns->entries)
453 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
454 sym->name, ns->entries->sym->name, &sym->declared_at);
457 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
458 sym->name, ns->entries->sym->name, &sym->declared_at);
463 if (ts->type == BT_UNKNOWN)
464 ts = gfc_get_default_type (sym, NULL);
468 if (ts->kind == gfc_default_integer_kind)
472 if (ts->kind == gfc_default_real_kind
473 || ts->kind == gfc_default_double_kind)
477 if (ts->kind == gfc_default_complex_kind)
481 if (ts->kind == gfc_default_logical_kind)
485 /* We will issue error elsewhere. */
493 if (el == ns->entries)
495 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
496 sym->name, gfc_typename (ts), ns->entries->sym->name,
500 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
501 sym->name, gfc_typename (ts), ns->entries->sym->name,
508 proc->attr.access = ACCESS_PRIVATE;
509 proc->attr.entry_master = 1;
511 /* Merge all the entry point arguments. */
512 for (el = ns->entries; el; el = el->next)
513 merge_argument_lists (proc, el->sym->formal);
515 /* Use the master function for the function body. */
516 ns->proc_name = proc;
518 /* Finalize the new symbols. */
519 gfc_commit_symbols ();
521 /* Restore the original namespace. */
522 gfc_current_ns = old_ns;
526 /* Resolve contained function types. Because contained functions can call one
527 another, they have to be worked out before any of the contained procedures
530 The good news is that if a function doesn't already have a type, the only
531 way it can get one is through an IMPLICIT type or a RESULT variable, because
532 by definition contained functions are contained namespace they're contained
533 in, not in a sibling or parent namespace. */
536 resolve_contained_functions (gfc_namespace * ns)
538 gfc_namespace *child;
541 resolve_formal_arglists (ns);
543 for (child = ns->contained; child; child = child->sibling)
545 /* Resolve alternate entry points first. */
546 resolve_entries (child);
548 /* Then check function return types. */
549 resolve_contained_fntype (child->proc_name, child);
550 for (el = child->entries; el; el = el->next)
551 resolve_contained_fntype (el->sym, child);
556 /* Resolve all of the elements of a structure constructor and make sure that
557 the types are correct. */
560 resolve_structure_cons (gfc_expr * expr)
562 gfc_constructor *cons;
567 cons = expr->value.constructor;
568 /* A constructor may have references if it is the result of substituting a
569 parameter variable. In this case we just pull out the component we
572 comp = expr->ref->u.c.sym->components;
574 comp = expr->ts.derived->components;
576 for (; comp; comp = comp->next, cons = cons->next)
584 if (gfc_resolve_expr (cons->expr) == FAILURE)
590 /* If we don't have the right type, try to convert it. */
592 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
595 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
596 gfc_error ("The element in the derived type constructor at %L, "
597 "for pointer component '%s', is %s but should be %s",
598 &cons->expr->where, comp->name,
599 gfc_basic_typename (cons->expr->ts.type),
600 gfc_basic_typename (comp->ts.type));
602 t = gfc_convert_type (cons->expr, &comp->ts, 1);
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;
699 /* Check references to assumed size arrays. The flag need_full_assumed_size
700 is non-zero when matching actual arguments. */
702 static int need_full_assumed_size = 0;
705 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
711 if (need_full_assumed_size
712 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
715 for (ref = e->ref; ref; ref = ref->next)
716 if (ref->type == REF_ARRAY)
717 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
718 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
722 gfc_error ("The upper bound in the last dimension must "
723 "appear in the reference to the assumed size "
724 "array '%s' at %L.", sym->name, &e->where);
731 /* Look for bad assumed size array references in argument expressions
732 of elemental and array valued intrinsic procedures. Since this is
733 called from procedure resolution functions, it only recurses at
737 resolve_assumed_size_actual (gfc_expr *e)
742 switch (e->expr_type)
746 && check_assumed_size_reference (e->symtree->n.sym, e))
751 if (resolve_assumed_size_actual (e->value.op.op1)
752 || resolve_assumed_size_actual (e->value.op.op2))
763 /* Resolve an actual argument list. Most of the time, this is just
764 resolving the expressions in the list.
765 The exception is that we sometimes have to decide whether arguments
766 that look like procedure arguments are really simple variable
770 resolve_actual_arglist (gfc_actual_arglist * arg)
773 gfc_symtree *parent_st;
776 for (; arg; arg = arg->next)
782 /* Check the label is a valid branching target. */
785 if (arg->label->defined == ST_LABEL_UNKNOWN)
787 gfc_error ("Label %d referenced at %L is never defined",
788 arg->label->value, &arg->label->where);
795 if (e->ts.type != BT_PROCEDURE)
797 if (gfc_resolve_expr (e) != SUCCESS)
802 /* See if the expression node should really be a variable
805 sym = e->symtree->n.sym;
807 if (sym->attr.flavor == FL_PROCEDURE
808 || sym->attr.intrinsic
809 || sym->attr.external)
812 if (sym->attr.proc == PROC_ST_FUNCTION)
814 gfc_error ("Statement function '%s' at %L is not allowed as an "
815 "actual argument", sym->name, &e->where);
818 /* If the symbol is the function that names the current (or
819 parent) scope, then we really have a variable reference. */
821 if (sym->attr.function && sym->result == sym
822 && (sym->ns->proc_name == sym
823 || (sym->ns->parent != NULL
824 && sym->ns->parent->proc_name == sym)))
830 /* See if the name is a module procedure in a parent unit. */
832 if (was_declared (sym) || sym->ns->parent == NULL)
835 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
837 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
841 if (parent_st == NULL)
844 sym = parent_st->n.sym;
845 e->symtree = parent_st; /* Point to the right thing. */
847 if (sym->attr.flavor == FL_PROCEDURE
848 || sym->attr.intrinsic
849 || sym->attr.external)
855 e->expr_type = EXPR_VARIABLE;
859 e->rank = sym->as->rank;
860 e->ref = gfc_get_ref ();
861 e->ref->type = REF_ARRAY;
862 e->ref->u.ar.type = AR_FULL;
863 e->ref->u.ar.as = sym->as;
871 /* Go through each actual argument in ACTUAL and see if it can be
872 implemented as an inlined, non-copying intrinsic. FNSYM is the
873 function being called, or NULL if not known. */
876 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
878 gfc_actual_arglist *ap;
881 for (ap = actual; ap; ap = ap->next)
883 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
884 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
885 ap->expr->inline_noncopying_intrinsic = 1;
888 /* This function does the checking of references to global procedures
889 as defined in sections 18.1 and 14.1, respectively, of the Fortran
890 77 and 95 standards. It checks for a gsymbol for the name, making
891 one if it does not already exist. If it already exists, then the
892 reference being resolved must correspond to the type of gsymbol.
893 Otherwise, the new symbol is equipped with the attributes of the
894 reference. The corresponding code that is called in creating
895 global entities is parse.c. */
898 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
903 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
905 gsym = gfc_get_gsymbol (sym->name);
907 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
908 global_used (gsym, where);
910 if (gsym->type == GSYM_UNKNOWN)
913 gsym->where = *where;
919 /************* Function resolution *************/
921 /* Resolve a function call known to be generic.
922 Section 14.1.2.4.1. */
925 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
929 if (sym->attr.generic)
932 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
935 expr->value.function.name = s->name;
936 expr->value.function.esym = s;
939 expr->rank = s->as->rank;
943 /* TODO: Need to search for elemental references in generic interface */
946 if (sym->attr.intrinsic)
947 return gfc_intrinsic_func_interface (expr, 0);
954 resolve_generic_f (gfc_expr * expr)
959 sym = expr->symtree->n.sym;
963 m = resolve_generic_f0 (expr, sym);
966 else if (m == MATCH_ERROR)
970 if (sym->ns->parent == NULL)
972 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
976 if (!generic_sym (sym))
980 /* Last ditch attempt. */
982 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
984 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
985 expr->symtree->n.sym->name, &expr->where);
989 m = gfc_intrinsic_func_interface (expr, 0);
994 ("Generic function '%s' at %L is not consistent with a specific "
995 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1001 /* Resolve a function call known to be specific. */
1004 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1008 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1010 if (sym->attr.dummy)
1012 sym->attr.proc = PROC_DUMMY;
1016 sym->attr.proc = PROC_EXTERNAL;
1020 if (sym->attr.proc == PROC_MODULE
1021 || sym->attr.proc == PROC_ST_FUNCTION
1022 || sym->attr.proc == PROC_INTERNAL)
1025 if (sym->attr.intrinsic)
1027 m = gfc_intrinsic_func_interface (expr, 1);
1032 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1033 "an intrinsic", sym->name, &expr->where);
1041 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1044 expr->value.function.name = sym->name;
1045 expr->value.function.esym = sym;
1046 if (sym->as != NULL)
1047 expr->rank = sym->as->rank;
1054 resolve_specific_f (gfc_expr * expr)
1059 sym = expr->symtree->n.sym;
1063 m = resolve_specific_f0 (sym, expr);
1066 if (m == MATCH_ERROR)
1069 if (sym->ns->parent == NULL)
1072 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1078 gfc_error ("Unable to resolve the specific function '%s' at %L",
1079 expr->symtree->n.sym->name, &expr->where);
1085 /* Resolve a procedure call not known to be generic nor specific. */
1088 resolve_unknown_f (gfc_expr * expr)
1093 sym = expr->symtree->n.sym;
1095 if (sym->attr.dummy)
1097 sym->attr.proc = PROC_DUMMY;
1098 expr->value.function.name = sym->name;
1102 /* See if we have an intrinsic function reference. */
1104 if (gfc_intrinsic_name (sym->name, 0))
1106 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1111 /* The reference is to an external name. */
1113 sym->attr.proc = PROC_EXTERNAL;
1114 expr->value.function.name = sym->name;
1115 expr->value.function.esym = expr->symtree->n.sym;
1117 if (sym->as != NULL)
1118 expr->rank = sym->as->rank;
1120 /* Type of the expression is either the type of the symbol or the
1121 default type of the symbol. */
1124 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1126 if (sym->ts.type != BT_UNKNOWN)
1130 ts = gfc_get_default_type (sym, sym->ns);
1132 if (ts->type == BT_UNKNOWN)
1134 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1135 sym->name, &expr->where);
1146 /* Figure out if a function reference is pure or not. Also set the name
1147 of the function for a potential error message. Return nonzero if the
1148 function is PURE, zero if not. */
1151 pure_function (gfc_expr * e, const char **name)
1155 if (e->value.function.esym)
1157 pure = gfc_pure (e->value.function.esym);
1158 *name = e->value.function.esym->name;
1160 else if (e->value.function.isym)
1162 pure = e->value.function.isym->pure
1163 || e->value.function.isym->elemental;
1164 *name = e->value.function.isym->name;
1168 /* Implicit functions are not pure. */
1170 *name = e->value.function.name;
1177 /* Resolve a function call, which means resolving the arguments, then figuring
1178 out which entity the name refers to. */
1179 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1180 to INTENT(OUT) or INTENT(INOUT). */
1183 resolve_function (gfc_expr * expr)
1185 gfc_actual_arglist *arg;
1193 sym = expr->symtree->n.sym;
1195 /* If the procedure is not internal, a statement function or a module
1196 procedure,it must be external and should be checked for usage. */
1197 if (sym && !sym->attr.dummy && !sym->attr.contained
1198 && sym->attr.proc != PROC_ST_FUNCTION
1199 && !sym->attr.use_assoc)
1200 resolve_global_procedure (sym, &expr->where, 0);
1202 /* Switch off assumed size checking and do this again for certain kinds
1203 of procedure, once the procedure itself is resolved. */
1204 need_full_assumed_size++;
1206 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1209 /* Resume assumed_size checking. */
1210 need_full_assumed_size--;
1212 if (sym && sym->ts.type == BT_CHARACTER
1213 && sym->ts.cl && sym->ts.cl->length == NULL)
1215 if (sym->attr.if_source == IFSRC_IFBODY)
1217 /* This follows from a slightly odd requirement at 5.1.1.5 in the
1218 standard that allows assumed character length functions to be
1219 declared in interfaces but not used. Picking up the symbol here,
1220 rather than resolve_symbol, accomplishes that. */
1221 gfc_error ("Function '%s' can be declared in an interface to "
1222 "return CHARACTER(*) but cannot be used at %L",
1223 sym->name, &expr->where);
1227 /* Internal procedures are taken care of in resolve_contained_fntype. */
1228 if (!sym->attr.dummy && !sym->attr.contained)
1230 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1231 "be used at %L since it is not a dummy argument",
1232 sym->name, &expr->where);
1237 /* See if function is already resolved. */
1239 if (expr->value.function.name != NULL)
1241 if (expr->ts.type == BT_UNKNOWN)
1247 /* Apply the rules of section 14.1.2. */
1249 switch (procedure_kind (sym))
1252 t = resolve_generic_f (expr);
1255 case PTYPE_SPECIFIC:
1256 t = resolve_specific_f (expr);
1260 t = resolve_unknown_f (expr);
1264 gfc_internal_error ("resolve_function(): bad function type");
1268 /* If the expression is still a function (it might have simplified),
1269 then we check to see if we are calling an elemental function. */
1271 if (expr->expr_type != EXPR_FUNCTION)
1274 temp = need_full_assumed_size;
1275 need_full_assumed_size = 0;
1277 if (expr->value.function.actual != NULL
1278 && ((expr->value.function.esym != NULL
1279 && expr->value.function.esym->attr.elemental)
1280 || (expr->value.function.isym != NULL
1281 && expr->value.function.isym->elemental)))
1283 /* The rank of an elemental is the rank of its array argument(s). */
1284 for (arg = expr->value.function.actual; arg; arg = arg->next)
1286 if (arg->expr != NULL && arg->expr->rank > 0)
1288 expr->rank = arg->expr->rank;
1293 /* Being elemental, the last upper bound of an assumed size array
1294 argument must be present. */
1295 for (arg = expr->value.function.actual; arg; arg = arg->next)
1297 if (arg->expr != NULL
1298 && arg->expr->rank > 0
1299 && resolve_assumed_size_actual (arg->expr))
1304 else if (expr->value.function.actual != NULL
1305 && expr->value.function.isym != NULL
1306 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1307 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1308 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1310 /* Array instrinsics must also have the last upper bound of an
1311 asumed size array argument. UBOUND and SIZE have to be
1312 excluded from the check if the second argument is anything
1315 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1316 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1318 for (arg = expr->value.function.actual; arg; arg = arg->next)
1320 if (inquiry && arg->next != NULL && arg->next->expr
1321 && arg->next->expr->expr_type != EXPR_CONSTANT)
1324 if (arg->expr != NULL
1325 && arg->expr->rank > 0
1326 && resolve_assumed_size_actual (arg->expr))
1331 need_full_assumed_size = temp;
1333 if (!pure_function (expr, &name))
1338 ("Function reference to '%s' at %L is inside a FORALL block",
1339 name, &expr->where);
1342 else if (gfc_pure (NULL))
1344 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1345 "procedure within a PURE procedure", name, &expr->where);
1350 /* Character lengths of use associated functions may contains references to
1351 symbols not referenced from the current program unit otherwise. Make sure
1352 those symbols are marked as referenced. */
1354 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1355 && expr->value.function.esym->attr.use_assoc)
1357 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1361 find_noncopying_intrinsics (expr->value.function.esym,
1362 expr->value.function.actual);
1367 /************* Subroutine resolution *************/
1370 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1377 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1378 sym->name, &c->loc);
1379 else if (gfc_pure (NULL))
1380 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1386 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1390 if (sym->attr.generic)
1392 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1395 c->resolved_sym = s;
1396 pure_subroutine (c, s);
1400 /* TODO: Need to search for elemental references in generic interface. */
1403 if (sym->attr.intrinsic)
1404 return gfc_intrinsic_sub_interface (c, 0);
1411 resolve_generic_s (gfc_code * c)
1416 sym = c->symtree->n.sym;
1418 m = resolve_generic_s0 (c, sym);
1421 if (m == MATCH_ERROR)
1424 if (sym->ns->parent != NULL)
1426 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1429 m = resolve_generic_s0 (c, sym);
1432 if (m == MATCH_ERROR)
1437 /* Last ditch attempt. */
1439 if (!gfc_generic_intrinsic (sym->name))
1442 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1443 sym->name, &c->loc);
1447 m = gfc_intrinsic_sub_interface (c, 0);
1451 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1452 "intrinsic subroutine interface", sym->name, &c->loc);
1458 /* Resolve a subroutine call known to be specific. */
1461 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1465 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1467 if (sym->attr.dummy)
1469 sym->attr.proc = PROC_DUMMY;
1473 sym->attr.proc = PROC_EXTERNAL;
1477 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1480 if (sym->attr.intrinsic)
1482 m = gfc_intrinsic_sub_interface (c, 1);
1486 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1487 "with an intrinsic", sym->name, &c->loc);
1495 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1497 c->resolved_sym = sym;
1498 pure_subroutine (c, sym);
1505 resolve_specific_s (gfc_code * c)
1510 sym = c->symtree->n.sym;
1512 m = resolve_specific_s0 (c, sym);
1515 if (m == MATCH_ERROR)
1518 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1522 m = resolve_specific_s0 (c, sym);
1525 if (m == MATCH_ERROR)
1529 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1530 sym->name, &c->loc);
1536 /* Resolve a subroutine call not known to be generic nor specific. */
1539 resolve_unknown_s (gfc_code * c)
1543 sym = c->symtree->n.sym;
1545 if (sym->attr.dummy)
1547 sym->attr.proc = PROC_DUMMY;
1551 /* See if we have an intrinsic function reference. */
1553 if (gfc_intrinsic_name (sym->name, 1))
1555 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1560 /* The reference is to an external name. */
1563 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1565 c->resolved_sym = sym;
1567 pure_subroutine (c, sym);
1573 /* Resolve a subroutine call. Although it was tempting to use the same code
1574 for functions, subroutines and functions are stored differently and this
1575 makes things awkward. */
1578 resolve_call (gfc_code * c)
1582 /* If the procedure is not internal or module, it must be external and
1583 should be checked for usage. */
1584 if (c->symtree && c->symtree->n.sym
1585 && !c->symtree->n.sym->attr.dummy
1586 && !c->symtree->n.sym->attr.contained
1587 && !c->symtree->n.sym->attr.use_assoc)
1588 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1590 /* Switch off assumed size checking and do this again for certain kinds
1591 of procedure, once the procedure itself is resolved. */
1592 need_full_assumed_size++;
1594 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1597 /* Resume assumed_size checking. */
1598 need_full_assumed_size--;
1602 if (c->resolved_sym == NULL)
1603 switch (procedure_kind (c->symtree->n.sym))
1606 t = resolve_generic_s (c);
1609 case PTYPE_SPECIFIC:
1610 t = resolve_specific_s (c);
1614 t = resolve_unknown_s (c);
1618 gfc_internal_error ("resolve_subroutine(): bad function type");
1621 if (c->ext.actual != NULL
1622 && c->symtree->n.sym->attr.elemental)
1624 gfc_actual_arglist * a;
1625 /* Being elemental, the last upper bound of an assumed size array
1626 argument must be present. */
1627 for (a = c->ext.actual; a; a = a->next)
1630 && a->expr->rank > 0
1631 && resolve_assumed_size_actual (a->expr))
1637 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1641 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1642 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1643 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1644 if their shapes do not match. If either op1->shape or op2->shape is
1645 NULL, return SUCCESS. */
1648 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1655 if (op1->shape != NULL && op2->shape != NULL)
1657 for (i = 0; i < op1->rank; i++)
1659 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1661 gfc_error ("Shapes for operands at %L and %L are not conformable",
1662 &op1->where, &op2->where);
1672 /* Resolve an operator expression node. This can involve replacing the
1673 operation with a user defined function call. */
1676 resolve_operator (gfc_expr * e)
1678 gfc_expr *op1, *op2;
1682 /* Resolve all subnodes-- give them types. */
1684 switch (e->value.op.operator)
1687 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1690 /* Fall through... */
1693 case INTRINSIC_UPLUS:
1694 case INTRINSIC_UMINUS:
1695 case INTRINSIC_PARENTHESES:
1696 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1701 /* Typecheck the new node. */
1703 op1 = e->value.op.op1;
1704 op2 = e->value.op.op2;
1706 switch (e->value.op.operator)
1708 case INTRINSIC_UPLUS:
1709 case INTRINSIC_UMINUS:
1710 if (op1->ts.type == BT_INTEGER
1711 || op1->ts.type == BT_REAL
1712 || op1->ts.type == BT_COMPLEX)
1718 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1719 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1722 case INTRINSIC_PLUS:
1723 case INTRINSIC_MINUS:
1724 case INTRINSIC_TIMES:
1725 case INTRINSIC_DIVIDE:
1726 case INTRINSIC_POWER:
1727 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1729 gfc_type_convert_binary (e);
1734 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1735 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1736 gfc_typename (&op2->ts));
1739 case INTRINSIC_CONCAT:
1740 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1742 e->ts.type = BT_CHARACTER;
1743 e->ts.kind = op1->ts.kind;
1748 _("Operands of string concatenation operator at %%L are %s/%s"),
1749 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1755 case INTRINSIC_NEQV:
1756 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1758 e->ts.type = BT_LOGICAL;
1759 e->ts.kind = gfc_kind_max (op1, op2);
1760 if (op1->ts.kind < e->ts.kind)
1761 gfc_convert_type (op1, &e->ts, 2);
1762 else if (op2->ts.kind < e->ts.kind)
1763 gfc_convert_type (op2, &e->ts, 2);
1767 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1768 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1769 gfc_typename (&op2->ts));
1774 if (op1->ts.type == BT_LOGICAL)
1776 e->ts.type = BT_LOGICAL;
1777 e->ts.kind = op1->ts.kind;
1781 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1782 gfc_typename (&op1->ts));
1789 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1791 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1795 /* Fall through... */
1799 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1801 e->ts.type = BT_LOGICAL;
1802 e->ts.kind = gfc_default_logical_kind;
1806 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1808 gfc_type_convert_binary (e);
1810 e->ts.type = BT_LOGICAL;
1811 e->ts.kind = gfc_default_logical_kind;
1815 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1817 _("Logicals at %%L must be compared with %s instead of %s"),
1818 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1819 gfc_op2string (e->value.op.operator));
1822 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1823 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1824 gfc_typename (&op2->ts));
1828 case INTRINSIC_USER:
1830 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1831 e->value.op.uop->name, gfc_typename (&op1->ts));
1833 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1834 e->value.op.uop->name, gfc_typename (&op1->ts),
1835 gfc_typename (&op2->ts));
1839 case INTRINSIC_PARENTHESES:
1843 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1846 /* Deal with arrayness of an operand through an operator. */
1850 switch (e->value.op.operator)
1852 case INTRINSIC_PLUS:
1853 case INTRINSIC_MINUS:
1854 case INTRINSIC_TIMES:
1855 case INTRINSIC_DIVIDE:
1856 case INTRINSIC_POWER:
1857 case INTRINSIC_CONCAT:
1861 case INTRINSIC_NEQV:
1869 if (op1->rank == 0 && op2->rank == 0)
1872 if (op1->rank == 0 && op2->rank != 0)
1874 e->rank = op2->rank;
1876 if (e->shape == NULL)
1877 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1880 if (op1->rank != 0 && op2->rank == 0)
1882 e->rank = op1->rank;
1884 if (e->shape == NULL)
1885 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1888 if (op1->rank != 0 && op2->rank != 0)
1890 if (op1->rank == op2->rank)
1892 e->rank = op1->rank;
1893 if (e->shape == NULL)
1895 t = compare_shapes(op1, op2);
1899 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1904 gfc_error ("Inconsistent ranks for operator at %L and %L",
1905 &op1->where, &op2->where);
1908 /* Allow higher level expressions to work. */
1916 case INTRINSIC_UPLUS:
1917 case INTRINSIC_UMINUS:
1918 case INTRINSIC_PARENTHESES:
1919 e->rank = op1->rank;
1921 if (e->shape == NULL)
1922 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1924 /* Simply copy arrayness attribute */
1931 /* Attempt to simplify the expression. */
1933 t = gfc_simplify_expr (e, 0);
1938 if (gfc_extend_expr (e) == SUCCESS)
1941 gfc_error (msg, &e->where);
1947 /************** Array resolution subroutines **************/
1951 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1954 /* Compare two integer expressions. */
1957 compare_bound (gfc_expr * a, gfc_expr * b)
1961 if (a == NULL || a->expr_type != EXPR_CONSTANT
1962 || b == NULL || b->expr_type != EXPR_CONSTANT)
1965 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1966 gfc_internal_error ("compare_bound(): Bad expression");
1968 i = mpz_cmp (a->value.integer, b->value.integer);
1978 /* Compare an integer expression with an integer. */
1981 compare_bound_int (gfc_expr * a, int b)
1985 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1988 if (a->ts.type != BT_INTEGER)
1989 gfc_internal_error ("compare_bound_int(): Bad expression");
1991 i = mpz_cmp_si (a->value.integer, b);
2001 /* Compare a single dimension of an array reference to the array
2005 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2008 /* Given start, end and stride values, calculate the minimum and
2009 maximum referenced indexes. */
2017 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2019 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2025 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2027 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2031 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2033 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2036 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2037 it is legal (see 6.2.2.3.1). */
2042 gfc_internal_error ("check_dimension(): Bad array reference");
2048 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2053 /* Compare an array reference with an array specification. */
2056 compare_spec_to_ref (gfc_array_ref * ar)
2063 /* TODO: Full array sections are only allowed as actual parameters. */
2064 if (as->type == AS_ASSUMED_SIZE
2065 && (/*ar->type == AR_FULL
2066 ||*/ (ar->type == AR_SECTION
2067 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2069 gfc_error ("Rightmost upper bound of assumed size array section"
2070 " not specified at %L", &ar->where);
2074 if (ar->type == AR_FULL)
2077 if (as->rank != ar->dimen)
2079 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2080 &ar->where, ar->dimen, as->rank);
2084 for (i = 0; i < as->rank; i++)
2085 if (check_dimension (i, ar, as) == FAILURE)
2092 /* Resolve one part of an array index. */
2095 gfc_resolve_index (gfc_expr * index, int check_scalar)
2102 if (gfc_resolve_expr (index) == FAILURE)
2105 if (check_scalar && index->rank != 0)
2107 gfc_error ("Array index at %L must be scalar", &index->where);
2111 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2113 gfc_error ("Array index at %L must be of INTEGER type",
2118 if (index->ts.type == BT_REAL)
2119 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
2120 &index->where) == FAILURE)
2123 if (index->ts.kind != gfc_index_integer_kind
2124 || index->ts.type != BT_INTEGER)
2127 ts.type = BT_INTEGER;
2128 ts.kind = gfc_index_integer_kind;
2130 gfc_convert_type_warn (index, &ts, 2, 0);
2136 /* Resolve a dim argument to an intrinsic function. */
2139 gfc_resolve_dim_arg (gfc_expr *dim)
2144 if (gfc_resolve_expr (dim) == FAILURE)
2149 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2153 if (dim->ts.type != BT_INTEGER)
2155 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2158 if (dim->ts.kind != gfc_index_integer_kind)
2162 ts.type = BT_INTEGER;
2163 ts.kind = gfc_index_integer_kind;
2165 gfc_convert_type_warn (dim, &ts, 2, 0);
2171 /* Given an expression that contains array references, update those array
2172 references to point to the right array specifications. While this is
2173 filled in during matching, this information is difficult to save and load
2174 in a module, so we take care of it here.
2176 The idea here is that the original array reference comes from the
2177 base symbol. We traverse the list of reference structures, setting
2178 the stored reference to references. Component references can
2179 provide an additional array specification. */
2182 find_array_spec (gfc_expr * e)
2188 as = e->symtree->n.sym->as;
2190 for (ref = e->ref; ref; ref = ref->next)
2195 gfc_internal_error ("find_array_spec(): Missing spec");
2202 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
2203 if (c == ref->u.c.component)
2207 gfc_internal_error ("find_array_spec(): Component not found");
2212 gfc_internal_error ("find_array_spec(): unused as(1)");
2223 gfc_internal_error ("find_array_spec(): unused as(2)");
2227 /* Resolve an array reference. */
2230 resolve_array_ref (gfc_array_ref * ar)
2232 int i, check_scalar;
2234 for (i = 0; i < ar->dimen; i++)
2236 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2238 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2240 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2242 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2245 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2246 switch (ar->start[i]->rank)
2249 ar->dimen_type[i] = DIMEN_ELEMENT;
2253 ar->dimen_type[i] = DIMEN_VECTOR;
2257 gfc_error ("Array index at %L is an array of rank %d",
2258 &ar->c_where[i], ar->start[i]->rank);
2263 /* If the reference type is unknown, figure out what kind it is. */
2265 if (ar->type == AR_UNKNOWN)
2267 ar->type = AR_ELEMENT;
2268 for (i = 0; i < ar->dimen; i++)
2269 if (ar->dimen_type[i] == DIMEN_RANGE
2270 || ar->dimen_type[i] == DIMEN_VECTOR)
2272 ar->type = AR_SECTION;
2277 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2285 resolve_substring (gfc_ref * ref)
2288 if (ref->u.ss.start != NULL)
2290 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2293 if (ref->u.ss.start->ts.type != BT_INTEGER)
2295 gfc_error ("Substring start index at %L must be of type INTEGER",
2296 &ref->u.ss.start->where);
2300 if (ref->u.ss.start->rank != 0)
2302 gfc_error ("Substring start index at %L must be scalar",
2303 &ref->u.ss.start->where);
2307 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2309 gfc_error ("Substring start index at %L is less than one",
2310 &ref->u.ss.start->where);
2315 if (ref->u.ss.end != NULL)
2317 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2320 if (ref->u.ss.end->ts.type != BT_INTEGER)
2322 gfc_error ("Substring end index at %L must be of type INTEGER",
2323 &ref->u.ss.end->where);
2327 if (ref->u.ss.end->rank != 0)
2329 gfc_error ("Substring end index at %L must be scalar",
2330 &ref->u.ss.end->where);
2334 if (ref->u.ss.length != NULL
2335 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2337 gfc_error ("Substring end index at %L is out of bounds",
2338 &ref->u.ss.start->where);
2347 /* Resolve subtype references. */
2350 resolve_ref (gfc_expr * expr)
2352 int current_part_dimension, n_components, seen_part_dimension;
2355 for (ref = expr->ref; ref; ref = ref->next)
2356 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2358 find_array_spec (expr);
2362 for (ref = expr->ref; ref; ref = ref->next)
2366 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2374 resolve_substring (ref);
2378 /* Check constraints on part references. */
2380 current_part_dimension = 0;
2381 seen_part_dimension = 0;
2384 for (ref = expr->ref; ref; ref = ref->next)
2389 switch (ref->u.ar.type)
2393 current_part_dimension = 1;
2397 current_part_dimension = 0;
2401 gfc_internal_error ("resolve_ref(): Bad array reference");
2407 if ((current_part_dimension || seen_part_dimension)
2408 && ref->u.c.component->pointer)
2411 ("Component to the right of a part reference with nonzero "
2412 "rank must not have the POINTER attribute at %L",
2424 if (((ref->type == REF_COMPONENT && n_components > 1)
2425 || ref->next == NULL)
2426 && current_part_dimension
2427 && seen_part_dimension)
2430 gfc_error ("Two or more part references with nonzero rank must "
2431 "not be specified at %L", &expr->where);
2435 if (ref->type == REF_COMPONENT)
2437 if (current_part_dimension)
2438 seen_part_dimension = 1;
2440 /* reset to make sure */
2441 current_part_dimension = 0;
2449 /* Given an expression, determine its shape. This is easier than it sounds.
2450 Leaves the shape array NULL if it is not possible to determine the shape. */
2453 expression_shape (gfc_expr * e)
2455 mpz_t array[GFC_MAX_DIMENSIONS];
2458 if (e->rank == 0 || e->shape != NULL)
2461 for (i = 0; i < e->rank; i++)
2462 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2465 e->shape = gfc_get_shape (e->rank);
2467 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2472 for (i--; i >= 0; i--)
2473 mpz_clear (array[i]);
2477 /* Given a variable expression node, compute the rank of the expression by
2478 examining the base symbol and any reference structures it may have. */
2481 expression_rank (gfc_expr * e)
2488 if (e->expr_type == EXPR_ARRAY)
2490 /* Constructors can have a rank different from one via RESHAPE(). */
2492 if (e->symtree == NULL)
2498 e->rank = (e->symtree->n.sym->as == NULL)
2499 ? 0 : e->symtree->n.sym->as->rank;
2505 for (ref = e->ref; ref; ref = ref->next)
2507 if (ref->type != REF_ARRAY)
2510 if (ref->u.ar.type == AR_FULL)
2512 rank = ref->u.ar.as->rank;
2516 if (ref->u.ar.type == AR_SECTION)
2518 /* Figure out the rank of the section. */
2520 gfc_internal_error ("expression_rank(): Two array specs");
2522 for (i = 0; i < ref->u.ar.dimen; i++)
2523 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2524 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2534 expression_shape (e);
2538 /* Resolve a variable expression. */
2541 resolve_variable (gfc_expr * e)
2545 if (e->ref && resolve_ref (e) == FAILURE)
2548 if (e->symtree == NULL)
2551 sym = e->symtree->n.sym;
2552 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2554 e->ts.type = BT_PROCEDURE;
2558 if (sym->ts.type != BT_UNKNOWN)
2559 gfc_variable_attr (e, &e->ts);
2562 /* Must be a simple variable reference. */
2563 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2568 if (check_assumed_size_reference (sym, e))
2575 /* Resolve an expression. That is, make sure that types of operands agree
2576 with their operators, intrinsic operators are converted to function calls
2577 for overloaded types and unresolved function references are resolved. */
2580 gfc_resolve_expr (gfc_expr * e)
2587 switch (e->expr_type)
2590 t = resolve_operator (e);
2594 t = resolve_function (e);
2598 t = resolve_variable (e);
2600 expression_rank (e);
2603 case EXPR_SUBSTRING:
2604 t = resolve_ref (e);
2614 if (resolve_ref (e) == FAILURE)
2617 t = gfc_resolve_array_constructor (e);
2618 /* Also try to expand a constructor. */
2621 expression_rank (e);
2622 gfc_expand_constructor (e);
2627 case EXPR_STRUCTURE:
2628 t = resolve_ref (e);
2632 t = resolve_structure_cons (e);
2636 t = gfc_simplify_expr (e, 0);
2640 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2647 /* Resolve an expression from an iterator. They must be scalar and have
2648 INTEGER or (optionally) REAL type. */
2651 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2652 const char * name_msgid)
2654 if (gfc_resolve_expr (expr) == FAILURE)
2657 if (expr->rank != 0)
2659 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2663 if (!(expr->ts.type == BT_INTEGER
2664 || (expr->ts.type == BT_REAL && real_ok)))
2667 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2670 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2677 /* Resolve the expressions in an iterator structure. If REAL_OK is
2678 false allow only INTEGER type iterators, otherwise allow REAL types. */
2681 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2684 if (iter->var->ts.type == BT_REAL)
2685 gfc_notify_std (GFC_STD_F95_DEL,
2686 "Obsolete: REAL DO loop iterator at %L",
2689 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2693 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2695 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2700 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2701 "Start expression in DO loop") == FAILURE)
2704 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2705 "End expression in DO loop") == FAILURE)
2708 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2709 "Step expression in DO loop") == FAILURE)
2712 if (iter->step->expr_type == EXPR_CONSTANT)
2714 if ((iter->step->ts.type == BT_INTEGER
2715 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2716 || (iter->step->ts.type == BT_REAL
2717 && mpfr_sgn (iter->step->value.real) == 0))
2719 gfc_error ("Step expression in DO loop at %L cannot be zero",
2720 &iter->step->where);
2725 /* Convert start, end, and step to the same type as var. */
2726 if (iter->start->ts.kind != iter->var->ts.kind
2727 || iter->start->ts.type != iter->var->ts.type)
2728 gfc_convert_type (iter->start, &iter->var->ts, 2);
2730 if (iter->end->ts.kind != iter->var->ts.kind
2731 || iter->end->ts.type != iter->var->ts.type)
2732 gfc_convert_type (iter->end, &iter->var->ts, 2);
2734 if (iter->step->ts.kind != iter->var->ts.kind
2735 || iter->step->ts.type != iter->var->ts.type)
2736 gfc_convert_type (iter->step, &iter->var->ts, 2);
2742 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2743 to be a scalar INTEGER variable. The subscripts and stride are scalar
2744 INTEGERs, and if stride is a constant it must be nonzero. */
2747 resolve_forall_iterators (gfc_forall_iterator * iter)
2752 if (gfc_resolve_expr (iter->var) == SUCCESS
2753 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2754 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2757 if (gfc_resolve_expr (iter->start) == SUCCESS
2758 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2759 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2760 &iter->start->where);
2761 if (iter->var->ts.kind != iter->start->ts.kind)
2762 gfc_convert_type (iter->start, &iter->var->ts, 2);
2764 if (gfc_resolve_expr (iter->end) == SUCCESS
2765 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2766 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2768 if (iter->var->ts.kind != iter->end->ts.kind)
2769 gfc_convert_type (iter->end, &iter->var->ts, 2);
2771 if (gfc_resolve_expr (iter->stride) == SUCCESS)
2773 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2774 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2775 &iter->stride->where, "INTEGER");
2777 if (iter->stride->expr_type == EXPR_CONSTANT
2778 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2779 gfc_error ("FORALL stride expression at %L cannot be zero",
2780 &iter->stride->where);
2782 if (iter->var->ts.kind != iter->stride->ts.kind)
2783 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2790 /* Given a pointer to a symbol that is a derived type, see if any components
2791 have the POINTER attribute. The search is recursive if necessary.
2792 Returns zero if no pointer components are found, nonzero otherwise. */
2795 derived_pointer (gfc_symbol * sym)
2799 for (c = sym->components; c; c = c->next)
2804 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2812 /* Given a pointer to a symbol that is a derived type, see if it's
2813 inaccessible, i.e. if it's defined in another module and the components are
2814 PRIVATE. The search is recursive if necessary. Returns zero if no
2815 inaccessible components are found, nonzero otherwise. */
2818 derived_inaccessible (gfc_symbol *sym)
2822 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2825 for (c = sym->components; c; c = c->next)
2827 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2835 /* Resolve the argument of a deallocate expression. The expression must be
2836 a pointer or a full array. */
2839 resolve_deallocate_expr (gfc_expr * e)
2841 symbol_attribute attr;
2845 if (gfc_resolve_expr (e) == FAILURE)
2848 attr = gfc_expr_attr (e);
2852 if (e->expr_type != EXPR_VARIABLE)
2855 allocatable = e->symtree->n.sym->attr.allocatable;
2856 for (ref = e->ref; ref; ref = ref->next)
2860 if (ref->u.ar.type != AR_FULL)
2865 allocatable = (ref->u.c.component->as != NULL
2866 && ref->u.c.component->as->type == AS_DEFERRED);
2874 if (allocatable == 0)
2877 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2878 "ALLOCATABLE or a POINTER", &e->where);
2885 /* Given the expression node e for an allocatable/pointer of derived type to be
2886 allocated, get the expression node to be initialized afterwards (needed for
2887 derived types with default initializers). */
2890 expr_to_initialize (gfc_expr * e)
2896 result = gfc_copy_expr (e);
2898 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2899 for (ref = result->ref; ref; ref = ref->next)
2900 if (ref->type == REF_ARRAY && ref->next == NULL)
2902 ref->u.ar.type = AR_FULL;
2904 for (i = 0; i < ref->u.ar.dimen; i++)
2905 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2907 result->rank = ref->u.ar.dimen;
2915 /* Resolve the expression in an ALLOCATE statement, doing the additional
2916 checks to see whether the expression is OK or not. The expression must
2917 have a trailing array reference that gives the size of the array. */
2920 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2922 int i, pointer, allocatable, dimension;
2923 symbol_attribute attr;
2924 gfc_ref *ref, *ref2;
2929 if (gfc_resolve_expr (e) == FAILURE)
2932 /* Make sure the expression is allocatable or a pointer. If it is
2933 pointer, the next-to-last reference must be a pointer. */
2937 if (e->expr_type != EXPR_VARIABLE)
2941 attr = gfc_expr_attr (e);
2942 pointer = attr.pointer;
2943 dimension = attr.dimension;
2948 allocatable = e->symtree->n.sym->attr.allocatable;
2949 pointer = e->symtree->n.sym->attr.pointer;
2950 dimension = e->symtree->n.sym->attr.dimension;
2952 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2956 if (ref->next != NULL)
2961 allocatable = (ref->u.c.component->as != NULL
2962 && ref->u.c.component->as->type == AS_DEFERRED);
2964 pointer = ref->u.c.component->pointer;
2965 dimension = ref->u.c.component->dimension;
2975 if (allocatable == 0 && pointer == 0)
2977 gfc_error ("Expression in ALLOCATE statement at %L must be "
2978 "ALLOCATABLE or a POINTER", &e->where);
2982 /* Add default initializer for those derived types that need them. */
2983 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2985 init_st = gfc_get_code ();
2986 init_st->loc = code->loc;
2987 init_st->op = EXEC_ASSIGN;
2988 init_st->expr = expr_to_initialize (e);
2989 init_st->expr2 = init_e;
2991 init_st->next = code->next;
2992 code->next = init_st;
2995 if (pointer && dimension == 0)
2998 /* Make sure the next-to-last reference node is an array specification. */
3000 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3002 gfc_error ("Array specification required in ALLOCATE statement "
3003 "at %L", &e->where);
3007 if (ref2->u.ar.type == AR_ELEMENT)
3010 /* Make sure that the array section reference makes sense in the
3011 context of an ALLOCATE specification. */
3015 for (i = 0; i < ar->dimen; i++)
3016 switch (ar->dimen_type[i])
3022 if (ar->start[i] != NULL
3023 && ar->end[i] != NULL
3024 && ar->stride[i] == NULL)
3027 /* Fall Through... */
3031 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3040 /************ SELECT CASE resolution subroutines ************/
3042 /* Callback function for our mergesort variant. Determines interval
3043 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3044 op1 > op2. Assumes we're not dealing with the default case.
3045 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3046 There are nine situations to check. */
3049 compare_cases (const gfc_case * op1, const gfc_case * op2)
3053 if (op1->low == NULL) /* op1 = (:L) */
3055 /* op2 = (:N), so overlap. */
3057 /* op2 = (M:) or (M:N), L < M */
3058 if (op2->low != NULL
3059 && gfc_compare_expr (op1->high, op2->low) < 0)
3062 else if (op1->high == NULL) /* op1 = (K:) */
3064 /* op2 = (M:), so overlap. */
3066 /* op2 = (:N) or (M:N), K > N */
3067 if (op2->high != NULL
3068 && gfc_compare_expr (op1->low, op2->high) > 0)
3071 else /* op1 = (K:L) */
3073 if (op2->low == NULL) /* op2 = (:N), K > N */
3074 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3075 else if (op2->high == NULL) /* op2 = (M:), L < M */
3076 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3077 else /* op2 = (M:N) */
3081 if (gfc_compare_expr (op1->high, op2->low) < 0)
3084 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3093 /* Merge-sort a double linked case list, detecting overlap in the
3094 process. LIST is the head of the double linked case list before it
3095 is sorted. Returns the head of the sorted list if we don't see any
3096 overlap, or NULL otherwise. */
3099 check_case_overlap (gfc_case * list)
3101 gfc_case *p, *q, *e, *tail;
3102 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3104 /* If the passed list was empty, return immediately. */
3111 /* Loop unconditionally. The only exit from this loop is a return
3112 statement, when we've finished sorting the case list. */
3119 /* Count the number of merges we do in this pass. */
3122 /* Loop while there exists a merge to be done. */
3127 /* Count this merge. */
3130 /* Cut the list in two pieces by stepping INSIZE places
3131 forward in the list, starting from P. */
3134 for (i = 0; i < insize; i++)
3143 /* Now we have two lists. Merge them! */
3144 while (psize > 0 || (qsize > 0 && q != NULL))
3147 /* See from which the next case to merge comes from. */
3150 /* P is empty so the next case must come from Q. */
3155 else if (qsize == 0 || q == NULL)
3164 cmp = compare_cases (p, q);
3167 /* The whole case range for P is less than the
3175 /* The whole case range for Q is greater than
3176 the case range for P. */
3183 /* The cases overlap, or they are the same
3184 element in the list. Either way, we must
3185 issue an error and get the next case from P. */
3186 /* FIXME: Sort P and Q by line number. */
3187 gfc_error ("CASE label at %L overlaps with CASE "
3188 "label at %L", &p->where, &q->where);
3196 /* Add the next element to the merged list. */
3205 /* P has now stepped INSIZE places along, and so has Q. So
3206 they're the same. */
3211 /* If we have done only one merge or none at all, we've
3212 finished sorting the cases. */
3221 /* Otherwise repeat, merging lists twice the size. */
3227 /* Check to see if an expression is suitable for use in a CASE statement.
3228 Makes sure that all case expressions are scalar constants of the same
3229 type. Return FAILURE if anything is wrong. */
3232 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3234 if (e == NULL) return SUCCESS;
3236 if (e->ts.type != case_expr->ts.type)
3238 gfc_error ("Expression in CASE statement at %L must be of type %s",
3239 &e->where, gfc_basic_typename (case_expr->ts.type));
3243 /* C805 (R808) For a given case-construct, each case-value shall be of
3244 the same type as case-expr. For character type, length differences
3245 are allowed, but the kind type parameters shall be the same. */
3247 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3249 gfc_error("Expression in CASE statement at %L must be kind %d",
3250 &e->where, case_expr->ts.kind);
3254 /* Convert the case value kind to that of case expression kind, if needed.
3255 FIXME: Should a warning be issued? */
3256 if (e->ts.kind != case_expr->ts.kind)
3257 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3261 gfc_error ("Expression in CASE statement at %L must be scalar",
3270 /* Given a completely parsed select statement, we:
3272 - Validate all expressions and code within the SELECT.
3273 - Make sure that the selection expression is not of the wrong type.
3274 - Make sure that no case ranges overlap.
3275 - Eliminate unreachable cases and unreachable code resulting from
3276 removing case labels.
3278 The standard does allow unreachable cases, e.g. CASE (5:3). But
3279 they are a hassle for code generation, and to prevent that, we just
3280 cut them out here. This is not necessary for overlapping cases
3281 because they are illegal and we never even try to generate code.
3283 We have the additional caveat that a SELECT construct could have
3284 been a computed GOTO in the source code. Fortunately we can fairly
3285 easily work around that here: The case_expr for a "real" SELECT CASE
3286 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3287 we have to do is make sure that the case_expr is a scalar integer
3291 resolve_select (gfc_code * code)
3294 gfc_expr *case_expr;
3295 gfc_case *cp, *default_case, *tail, *head;
3296 int seen_unreachable;
3301 if (code->expr == NULL)
3303 /* This was actually a computed GOTO statement. */
3304 case_expr = code->expr2;
3305 if (case_expr->ts.type != BT_INTEGER
3306 || case_expr->rank != 0)
3307 gfc_error ("Selection expression in computed GOTO statement "
3308 "at %L must be a scalar integer expression",
3311 /* Further checking is not necessary because this SELECT was built
3312 by the compiler, so it should always be OK. Just move the
3313 case_expr from expr2 to expr so that we can handle computed
3314 GOTOs as normal SELECTs from here on. */
3315 code->expr = code->expr2;
3320 case_expr = code->expr;
3322 type = case_expr->ts.type;
3323 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3325 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3326 &case_expr->where, gfc_typename (&case_expr->ts));
3328 /* Punt. Going on here just produce more garbage error messages. */
3332 if (case_expr->rank != 0)
3334 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3335 "expression", &case_expr->where);
3341 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3342 of the SELECT CASE expression and its CASE values. Walk the lists
3343 of case values, and if we find a mismatch, promote case_expr to
3344 the appropriate kind. */
3346 if (type == BT_LOGICAL || type == BT_INTEGER)
3348 for (body = code->block; body; body = body->block)
3350 /* Walk the case label list. */
3351 for (cp = body->ext.case_list; cp; cp = cp->next)
3353 /* Intercept the DEFAULT case. It does not have a kind. */
3354 if (cp->low == NULL && cp->high == NULL)
3357 /* Unreachable case ranges are discarded, so ignore. */
3358 if (cp->low != NULL && cp->high != NULL
3359 && cp->low != cp->high
3360 && gfc_compare_expr (cp->low, cp->high) > 0)
3363 /* FIXME: Should a warning be issued? */
3365 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3366 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3368 if (cp->high != NULL
3369 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3370 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3375 /* Assume there is no DEFAULT case. */
3376 default_case = NULL;
3380 for (body = code->block; body; body = body->block)
3382 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3384 seen_unreachable = 0;
3386 /* Walk the case label list, making sure that all case labels
3388 for (cp = body->ext.case_list; cp; cp = cp->next)
3390 /* Count the number of cases in the whole construct. */
3393 /* Intercept the DEFAULT case. */
3394 if (cp->low == NULL && cp->high == NULL)
3396 if (default_case != NULL)
3398 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3399 "by a second DEFAULT CASE at %L",
3400 &default_case->where, &cp->where);
3411 /* Deal with single value cases and case ranges. Errors are
3412 issued from the validation function. */
3413 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3414 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3420 if (type == BT_LOGICAL
3421 && ((cp->low == NULL || cp->high == NULL)
3422 || cp->low != cp->high))
3425 ("Logical range in CASE statement at %L is not allowed",
3431 if (cp->low != NULL && cp->high != NULL
3432 && cp->low != cp->high
3433 && gfc_compare_expr (cp->low, cp->high) > 0)
3435 if (gfc_option.warn_surprising)
3436 gfc_warning ("Range specification at %L can never "
3437 "be matched", &cp->where);
3439 cp->unreachable = 1;
3440 seen_unreachable = 1;
3444 /* If the case range can be matched, it can also overlap with
3445 other cases. To make sure it does not, we put it in a
3446 double linked list here. We sort that with a merge sort
3447 later on to detect any overlapping cases. */
3451 head->right = head->left = NULL;
3456 tail->right->left = tail;
3463 /* It there was a failure in the previous case label, give up
3464 for this case label list. Continue with the next block. */
3468 /* See if any case labels that are unreachable have been seen.
3469 If so, we eliminate them. This is a bit of a kludge because
3470 the case lists for a single case statement (label) is a
3471 single forward linked lists. */
3472 if (seen_unreachable)
3474 /* Advance until the first case in the list is reachable. */
3475 while (body->ext.case_list != NULL
3476 && body->ext.case_list->unreachable)
3478 gfc_case *n = body->ext.case_list;
3479 body->ext.case_list = body->ext.case_list->next;
3481 gfc_free_case_list (n);
3484 /* Strip all other unreachable cases. */
3485 if (body->ext.case_list)
3487 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3489 if (cp->next->unreachable)
3491 gfc_case *n = cp->next;
3492 cp->next = cp->next->next;
3494 gfc_free_case_list (n);
3501 /* See if there were overlapping cases. If the check returns NULL,
3502 there was overlap. In that case we don't do anything. If head
3503 is non-NULL, we prepend the DEFAULT case. The sorted list can
3504 then used during code generation for SELECT CASE constructs with
3505 a case expression of a CHARACTER type. */
3508 head = check_case_overlap (head);
3510 /* Prepend the default_case if it is there. */
3511 if (head != NULL && default_case)
3513 default_case->left = NULL;
3514 default_case->right = head;
3515 head->left = default_case;
3519 /* Eliminate dead blocks that may be the result if we've seen
3520 unreachable case labels for a block. */
3521 for (body = code; body && body->block; body = body->block)
3523 if (body->block->ext.case_list == NULL)
3525 /* Cut the unreachable block from the code chain. */
3526 gfc_code *c = body->block;
3527 body->block = c->block;
3529 /* Kill the dead block, but not the blocks below it. */
3531 gfc_free_statements (c);
3535 /* More than two cases is legal but insane for logical selects.
3536 Issue a warning for it. */
3537 if (gfc_option.warn_surprising && type == BT_LOGICAL
3539 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3544 /* Resolve a transfer statement. This is making sure that:
3545 -- a derived type being transferred has only non-pointer components
3546 -- a derived type being transferred doesn't have private components, unless
3547 it's being transferred from the module where the type was defined
3548 -- we're not trying to transfer a whole assumed size array. */
3551 resolve_transfer (gfc_code * code)
3560 if (exp->expr_type != EXPR_VARIABLE)
3563 sym = exp->symtree->n.sym;
3566 /* Go to actual component transferred. */
3567 for (ref = code->expr->ref; ref; ref = ref->next)
3568 if (ref->type == REF_COMPONENT)
3569 ts = &ref->u.c.component->ts;
3571 if (ts->type == BT_DERIVED)
3573 /* Check that transferred derived type doesn't contain POINTER
3575 if (derived_pointer (ts->derived))
3577 gfc_error ("Data transfer element at %L cannot have "
3578 "POINTER components", &code->loc);
3582 if (derived_inaccessible (ts->derived))
3584 gfc_error ("Data transfer element at %L cannot have "
3585 "PRIVATE components",&code->loc);
3590 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3591 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3593 gfc_error ("Data transfer element at %L cannot be a full reference to "
3594 "an assumed-size array", &code->loc);
3600 /*********** Toplevel code resolution subroutines ***********/
3602 /* Given a branch to a label and a namespace, if the branch is conforming.
3603 The code node described where the branch is located. */
3606 resolve_branch (gfc_st_label * label, gfc_code * code)
3608 gfc_code *block, *found;
3616 /* Step one: is this a valid branching target? */
3618 if (lp->defined == ST_LABEL_UNKNOWN)
3620 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3625 if (lp->defined != ST_LABEL_TARGET)
3627 gfc_error ("Statement at %L is not a valid branch target statement "
3628 "for the branch statement at %L", &lp->where, &code->loc);
3632 /* Step two: make sure this branch is not a branch to itself ;-) */
3634 if (code->here == label)
3636 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3640 /* Step three: Try to find the label in the parse tree. To do this,
3641 we traverse the tree block-by-block: first the block that
3642 contains this GOTO, then the block that it is nested in, etc. We
3643 can ignore other blocks because branching into another block is
3648 for (stack = cs_base; stack; stack = stack->prev)
3650 for (block = stack->head; block; block = block->next)
3652 if (block->here == label)
3665 /* The label is not in an enclosing block, so illegal. This was
3666 allowed in Fortran 66, so we allow it as extension. We also
3667 forego further checks if we run into this. */
3668 gfc_notify_std (GFC_STD_LEGACY,
3669 "Label at %L is not in the same block as the "
3670 "GOTO statement at %L", &lp->where, &code->loc);
3674 /* Step four: Make sure that the branching target is legal if
3675 the statement is an END {SELECT,DO,IF}. */
3677 if (found->op == EXEC_NOP)
3679 for (stack = cs_base; stack; stack = stack->prev)
3680 if (stack->current->next == found)
3684 gfc_notify_std (GFC_STD_F95_DEL,
3685 "Obsolete: GOTO at %L jumps to END of construct at %L",
3686 &code->loc, &found->loc);
3691 /* Check whether EXPR1 has the same shape as EXPR2. */
3694 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3696 mpz_t shape[GFC_MAX_DIMENSIONS];
3697 mpz_t shape2[GFC_MAX_DIMENSIONS];
3698 try result = FAILURE;
3701 /* Compare the rank. */
3702 if (expr1->rank != expr2->rank)
3705 /* Compare the size of each dimension. */
3706 for (i=0; i<expr1->rank; i++)
3708 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3711 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3714 if (mpz_cmp (shape[i], shape2[i]))
3718 /* When either of the two expression is an assumed size array, we
3719 ignore the comparison of dimension sizes. */
3724 for (i--; i>=0; i--)
3726 mpz_clear (shape[i]);
3727 mpz_clear (shape2[i]);
3733 /* Check whether a WHERE assignment target or a WHERE mask expression
3734 has the same shape as the outmost WHERE mask expression. */
3737 resolve_where (gfc_code *code, gfc_expr *mask)
3743 cblock = code->block;
3745 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3746 In case of nested WHERE, only the outmost one is stored. */
3747 if (mask == NULL) /* outmost WHERE */
3749 else /* inner WHERE */
3756 /* Check if the mask-expr has a consistent shape with the
3757 outmost WHERE mask-expr. */
3758 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3759 gfc_error ("WHERE mask at %L has inconsistent shape",
3760 &cblock->expr->where);
3763 /* the assignment statement of a WHERE statement, or the first
3764 statement in where-body-construct of a WHERE construct */
3765 cnext = cblock->next;
3770 /* WHERE assignment statement */
3773 /* Check shape consistent for WHERE assignment target. */
3774 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3775 gfc_error ("WHERE assignment target at %L has "
3776 "inconsistent shape", &cnext->expr->where);
3779 /* WHERE or WHERE construct is part of a where-body-construct */
3781 resolve_where (cnext, e);
3785 gfc_error ("Unsupported statement inside WHERE at %L",
3788 /* the next statement within the same where-body-construct */
3789 cnext = cnext->next;
3791 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3792 cblock = cblock->block;
3797 /* Check whether the FORALL index appears in the expression or not. */
3800 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3804 gfc_actual_arglist *args;
3807 switch (expr->expr_type)
3810 gcc_assert (expr->symtree->n.sym);
3812 /* A scalar assignment */
3815 if (expr->symtree->n.sym == symbol)
3821 /* the expr is array ref, substring or struct component. */
3828 /* Check if the symbol appears in the array subscript. */
3830 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3833 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3837 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3841 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3847 if (expr->symtree->n.sym == symbol)
3850 /* Check if the symbol appears in the substring section. */
3851 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3853 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3861 gfc_error("expresion reference type error at %L", &expr->where);
3867 /* If the expression is a function call, then check if the symbol
3868 appears in the actual arglist of the function. */
3870 for (args = expr->value.function.actual; args; args = args->next)
3872 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3877 /* It seems not to happen. */
3878 case EXPR_SUBSTRING:
3882 gcc_assert (expr->ref->type == REF_SUBSTRING);
3883 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3885 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3890 /* It seems not to happen. */
3891 case EXPR_STRUCTURE:
3893 gfc_error ("Unsupported statement while finding forall index in "
3898 /* Find the FORALL index in the first operand. */
3899 if (expr->value.op.op1)
3901 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3905 /* Find the FORALL index in the second operand. */
3906 if (expr->value.op.op2)
3908 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3921 /* Resolve assignment in FORALL construct.
3922 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3923 FORALL index variables. */
3926 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3930 for (n = 0; n < nvar; n++)
3932 gfc_symbol *forall_index;
3934 forall_index = var_expr[n]->symtree->n.sym;
3936 /* Check whether the assignment target is one of the FORALL index
3938 if ((code->expr->expr_type == EXPR_VARIABLE)
3939 && (code->expr->symtree->n.sym == forall_index))
3940 gfc_error ("Assignment to a FORALL index variable at %L",
3941 &code->expr->where);
3944 /* If one of the FORALL index variables doesn't appear in the
3945 assignment target, then there will be a many-to-one
3947 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3948 gfc_error ("The FORALL with index '%s' cause more than one "
3949 "assignment to this object at %L",
3950 var_expr[n]->symtree->name, &code->expr->where);
3956 /* Resolve WHERE statement in FORALL construct. */
3959 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3963 cblock = code->block;
3966 /* the assignment statement of a WHERE statement, or the first
3967 statement in where-body-construct of a WHERE construct */
3968 cnext = cblock->next;
3973 /* WHERE assignment statement */
3975 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3978 /* WHERE or WHERE construct is part of a where-body-construct */
3980 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3984 gfc_error ("Unsupported statement inside WHERE at %L",
3987 /* the next statement within the same where-body-construct */
3988 cnext = cnext->next;
3990 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3991 cblock = cblock->block;
3996 /* Traverse the FORALL body to check whether the following errors exist:
3997 1. For assignment, check if a many-to-one assignment happens.
3998 2. For WHERE statement, check the WHERE body to see if there is any
3999 many-to-one assignment. */
4002 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4006 c = code->block->next;
4012 case EXEC_POINTER_ASSIGN:
4013 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4016 /* Because the resolve_blocks() will handle the nested FORALL,
4017 there is no need to handle it here. */
4021 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4026 /* The next statement in the FORALL body. */
4032 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4033 gfc_resolve_forall_body to resolve the FORALL body. */
4035 static void resolve_blocks (gfc_code *, gfc_namespace *);
4038 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4040 static gfc_expr **var_expr;
4041 static int total_var = 0;
4042 static int nvar = 0;
4043 gfc_forall_iterator *fa;
4044 gfc_symbol *forall_index;
4048 /* Start to resolve a FORALL construct */
4049 if (forall_save == 0)
4051 /* Count the total number of FORALL index in the nested FORALL
4052 construct in order to allocate the VAR_EXPR with proper size. */
4054 while ((next != NULL) && (next->op == EXEC_FORALL))
4056 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4058 next = next->block->next;
4061 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4062 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4065 /* The information about FORALL iterator, including FORALL index start, end
4066 and stride. The FORALL index can not appear in start, end or stride. */
4067 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4069 /* Check if any outer FORALL index name is the same as the current
4071 for (i = 0; i < nvar; i++)
4073 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4075 gfc_error ("An outer FORALL construct already has an index "
4076 "with this name %L", &fa->var->where);
4080 /* Record the current FORALL index. */
4081 var_expr[nvar] = gfc_copy_expr (fa->var);
4083 forall_index = fa->var->symtree->n.sym;
4085 /* Check if the FORALL index appears in start, end or stride. */
4086 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4087 gfc_error ("A FORALL index must not appear in a limit or stride "
4088 "expression in the same FORALL at %L", &fa->start->where);
4089 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4090 gfc_error ("A FORALL index must not appear in a limit or stride "
4091 "expression in the same FORALL at %L", &fa->end->where);
4092 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4093 gfc_error ("A FORALL index must not appear in a limit or stride "
4094 "expression in the same FORALL at %L", &fa->stride->where);
4098 /* Resolve the FORALL body. */
4099 gfc_resolve_forall_body (code, nvar, var_expr);
4101 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4102 resolve_blocks (code->block, ns);
4104 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4105 for (i = 0; i < total_var; i++)
4106 gfc_free_expr (var_expr[i]);
4108 /* Reset the counters. */
4114 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4117 static void resolve_code (gfc_code *, gfc_namespace *);
4120 resolve_blocks (gfc_code * b, gfc_namespace * ns)
4124 for (; b; b = b->block)
4126 t = gfc_resolve_expr (b->expr);
4127 if (gfc_resolve_expr (b->expr2) == FAILURE)
4133 if (t == SUCCESS && b->expr != NULL
4134 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4136 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4143 && (b->expr->ts.type != BT_LOGICAL
4144 || b->expr->rank == 0))
4146 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4151 resolve_branch (b->label, b);
4164 gfc_internal_error ("resolve_block(): Bad block type");
4167 resolve_code (b->next, ns);
4172 /* Given a block of code, recursively resolve everything pointed to by this
4176 resolve_code (gfc_code * code, gfc_namespace * ns)
4178 int forall_save = 0;
4183 frame.prev = cs_base;
4187 for (; code; code = code->next)
4189 frame.current = code;
4191 if (code->op == EXEC_FORALL)
4193 forall_save = forall_flag;
4195 gfc_resolve_forall (code, ns, forall_save);
4198 resolve_blocks (code->block, ns);
4200 if (code->op == EXEC_FORALL)
4201 forall_flag = forall_save;
4203 t = gfc_resolve_expr (code->expr);
4204 if (gfc_resolve_expr (code->expr2) == FAILURE)
4220 resolve_where (code, NULL);
4224 if (code->expr != NULL)
4226 if (code->expr->ts.type != BT_INTEGER)
4227 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4228 "variable", &code->expr->where);
4229 else if (code->expr->symtree->n.sym->attr.assign != 1)
4230 gfc_error ("Variable '%s' has not been assigned a target label "
4231 "at %L", code->expr->symtree->n.sym->name,
4232 &code->expr->where);
4235 resolve_branch (code->label, code);
4239 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4240 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4241 "return specifier", &code->expr->where);
4248 if (gfc_extend_assign (code, ns) == SUCCESS)
4250 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4252 gfc_error ("Subroutine '%s' called instead of assignment at "
4253 "%L must be PURE", code->symtree->n.sym->name,
4260 if (gfc_pure (NULL))
4262 if (gfc_impure_variable (code->expr->symtree->n.sym))
4265 ("Cannot assign to variable '%s' in PURE procedure at %L",
4266 code->expr->symtree->n.sym->name, &code->expr->where);
4270 if (code->expr2->ts.type == BT_DERIVED
4271 && derived_pointer (code->expr2->ts.derived))
4274 ("Right side of assignment at %L is a derived type "
4275 "containing a POINTER in a PURE procedure",
4276 &code->expr2->where);
4281 gfc_check_assign (code->expr, code->expr2, 1);
4284 case EXEC_LABEL_ASSIGN:
4285 if (code->label->defined == ST_LABEL_UNKNOWN)
4286 gfc_error ("Label %d referenced at %L is never defined",
4287 code->label->value, &code->label->where);
4289 && (code->expr->expr_type != EXPR_VARIABLE
4290 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4291 || code->expr->symtree->n.sym->ts.kind
4292 != gfc_default_integer_kind
4293 || code->expr->symtree->n.sym->as != NULL))
4294 gfc_error ("ASSIGN statement at %L requires a scalar "
4295 "default INTEGER variable", &code->expr->where);
4298 case EXEC_POINTER_ASSIGN:
4302 gfc_check_pointer_assign (code->expr, code->expr2);
4305 case EXEC_ARITHMETIC_IF:
4307 && code->expr->ts.type != BT_INTEGER
4308 && code->expr->ts.type != BT_REAL)
4309 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4310 "expression", &code->expr->where);
4312 resolve_branch (code->label, code);
4313 resolve_branch (code->label2, code);
4314 resolve_branch (code->label3, code);
4318 if (t == SUCCESS && code->expr != NULL
4319 && (code->expr->ts.type != BT_LOGICAL
4320 || code->expr->rank != 0))
4321 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4322 &code->expr->where);
4327 resolve_call (code);
4331 /* Select is complicated. Also, a SELECT construct could be
4332 a transformed computed GOTO. */
4333 resolve_select (code);
4337 if (code->ext.iterator != NULL)
4338 gfc_resolve_iterator (code->ext.iterator, true);
4342 if (code->expr == NULL)
4343 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4345 && (code->expr->rank != 0
4346 || code->expr->ts.type != BT_LOGICAL))
4347 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4348 "a scalar LOGICAL expression", &code->expr->where);
4352 if (t == SUCCESS && code->expr != NULL
4353 && code->expr->ts.type != BT_INTEGER)
4354 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4355 "of type INTEGER", &code->expr->where);
4357 for (a = code->ext.alloc_list; a; a = a->next)
4358 resolve_allocate_expr (a->expr, code);
4362 case EXEC_DEALLOCATE:
4363 if (t == SUCCESS && code->expr != NULL
4364 && code->expr->ts.type != BT_INTEGER)
4366 ("STAT tag in DEALLOCATE statement at %L must be of type "
4367 "INTEGER", &code->expr->where);
4369 for (a = code->ext.alloc_list; a; a = a->next)
4370 resolve_deallocate_expr (a->expr);
4375 if (gfc_resolve_open (code->ext.open) == FAILURE)
4378 resolve_branch (code->ext.open->err, code);
4382 if (gfc_resolve_close (code->ext.close) == FAILURE)
4385 resolve_branch (code->ext.close->err, code);
4388 case EXEC_BACKSPACE:
4392 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4395 resolve_branch (code->ext.filepos->err, code);
4399 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4402 resolve_branch (code->ext.inquire->err, code);
4406 gcc_assert (code->ext.inquire != NULL);
4407 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4410 resolve_branch (code->ext.inquire->err, code);
4415 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4418 resolve_branch (code->ext.dt->err, code);
4419 resolve_branch (code->ext.dt->end, code);
4420 resolve_branch (code->ext.dt->eor, code);
4424 resolve_transfer (code);
4428 resolve_forall_iterators (code->ext.forall_iterator);
4430 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4432 ("FORALL mask clause at %L requires a LOGICAL expression",
4433 &code->expr->where);
4437 gfc_internal_error ("resolve_code(): Bad statement code");
4441 cs_base = frame.prev;
4445 /* Resolve initial values and make sure they are compatible with
4449 resolve_values (gfc_symbol * sym)
4452 if (sym->value == NULL)
4455 if (gfc_resolve_expr (sym->value) == FAILURE)
4458 gfc_check_assign_symbol (sym, sym->value);
4462 /* Resolve a charlen structure. */
4465 resolve_charlen (gfc_charlen *cl)
4472 if (gfc_resolve_expr (cl->length) == FAILURE)
4475 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
4478 if (gfc_specification_expr (cl->length) == FAILURE)
4485 /* Resolve the components of a derived type. */
4488 resolve_derived (gfc_symbol *sym)
4492 for (c = sym->components; c != NULL; c = c->next)
4494 if (c->ts.type == BT_CHARACTER)
4496 if (resolve_charlen (c->ts.cl) == FAILURE)
4499 if (c->ts.cl->length == NULL
4500 || !gfc_is_constant_expr (c->ts.cl->length))
4502 gfc_error ("Character length of component '%s' needs to "
4503 "be a constant specification expression at %L.",
4505 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
4510 /* TODO: Anything else that should be done here? */
4516 /* Do anything necessary to resolve a symbol. Right now, we just
4517 assume that an otherwise unknown symbol is a variable. This sort
4518 of thing commonly happens for symbols in module. */
4521 resolve_symbol (gfc_symbol * sym)
4523 /* Zero if we are checking a formal namespace. */
4524 static int formal_ns_flag = 1;
4525 int formal_ns_save, check_constant, mp_flag;
4528 gfc_symtree *symtree;
4529 gfc_symtree *this_symtree;
4532 gfc_formal_arglist *arg;
4533 gfc_expr *constructor_expr;
4535 if (sym->attr.flavor == FL_UNKNOWN)
4538 /* If we find that a flavorless symbol is an interface in one of the
4539 parent namespaces, find its symtree in this namespace, free the
4540 symbol and set the symtree to point to the interface symbol. */
4541 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4543 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4544 if (symtree && symtree->n.sym->generic)
4546 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4550 gfc_free_symbol (sym);
4551 symtree->n.sym->refs++;
4552 this_symtree->n.sym = symtree->n.sym;
4557 /* Otherwise give it a flavor according to such attributes as
4559 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4560 sym->attr.flavor = FL_VARIABLE;
4563 sym->attr.flavor = FL_PROCEDURE;
4564 if (sym->attr.dimension)
4565 sym->attr.function = 1;
4569 if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
4572 /* Symbols that are module procedures with results (functions) have
4573 the types and array specification copied for type checking in
4574 procedures that call them, as well as for saving to a module
4575 file. These symbols can't stand the scrutiny that their results
4577 mp_flag = (sym->result != NULL && sym->result != sym);
4579 /* Assign default type to symbols that need one and don't have one. */
4580 if (sym->ts.type == BT_UNKNOWN)
4582 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4583 gfc_set_default_type (sym, 1, NULL);
4585 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4587 /* The specific case of an external procedure should emit an error
4588 in the case that there is no implicit type. */
4590 gfc_set_default_type (sym, sym->attr.external, NULL);
4593 /* Result may be in another namespace. */
4594 resolve_symbol (sym->result);
4596 sym->ts = sym->result->ts;
4597 sym->as = gfc_copy_array_spec (sym->result->as);
4598 sym->attr.dimension = sym->result->attr.dimension;
4599 sym->attr.pointer = sym->result->attr.pointer;
4604 /* Assumed size arrays and assumed shape arrays must be dummy
4608 && (sym->as->type == AS_ASSUMED_SIZE
4609 || sym->as->type == AS_ASSUMED_SHAPE)
4610 && sym->attr.dummy == 0)
4612 if (sym->as->type == AS_ASSUMED_SIZE)
4613 gfc_error ("Assumed size array at %L must be a dummy argument",
4616 gfc_error ("Assumed shape array at %L must be a dummy argument",
4621 /* A parameter array's shape needs to be constant. */
4623 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4624 && !gfc_is_compile_time_shape (sym->as))
4626 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4627 "or assumed shape", sym->name, &sym->declared_at);
4631 /* A module array's shape needs to be constant. */
4633 if (sym->ns->proc_name
4634 && sym->attr.flavor == FL_VARIABLE
4635 && sym->ns->proc_name->attr.flavor == FL_MODULE
4636 && !sym->attr.use_assoc
4637 && !sym->attr.allocatable
4638 && !sym->attr.pointer
4640 && !gfc_is_compile_time_shape (sym->as))
4642 gfc_error ("Module array '%s' at %L cannot be automatic "
4643 "or assumed shape", sym->name, &sym->declared_at);
4647 /* Make sure that character string variables with assumed length are
4650 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4651 && sym->ts.type == BT_CHARACTER
4652 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4654 gfc_error ("Entity with assumed character length at %L must be a "
4655 "dummy argument or a PARAMETER", &sym->declared_at);
4659 /* Make sure a parameter that has been implicitly typed still
4660 matches the implicit type, since PARAMETER statements can precede
4661 IMPLICIT statements. */
4663 if (sym->attr.flavor == FL_PARAMETER
4664 && sym->attr.implicit_type
4665 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4666 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4667 "later IMPLICIT type", sym->name, &sym->declared_at);
4669 /* Make sure the types of derived parameters are consistent. This
4670 type checking is deferred until resolution because the type may
4671 refer to a derived type from the host. */
4673 if (sym->attr.flavor == FL_PARAMETER
4674 && sym->ts.type == BT_DERIVED
4675 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4676 gfc_error ("Incompatible derived type in PARAMETER at %L",
4677 &sym->value->where);
4679 /* Make sure symbols with known intent or optional are really dummy
4680 variable. Because of ENTRY statement, this has to be deferred
4681 until resolution time. */
4683 if (! sym->attr.dummy
4684 && (sym->attr.optional
4685 || sym->attr.intent != INTENT_UNKNOWN))
4687 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4691 if (sym->attr.proc == PROC_ST_FUNCTION)
4693 if (sym->ts.type == BT_CHARACTER)
4695 gfc_charlen *cl = sym->ts.cl;
4696 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4698 gfc_error ("Character-valued statement function '%s' at %L must "
4699 "have constant length", sym->name, &sym->declared_at);
4705 /* If a derived type symbol has reached this point, without its
4706 type being declared, we have an error. Notice that most
4707 conditions that produce undefined derived types have already
4708 been dealt with. However, the likes of:
4709 implicit type(t) (t) ..... call foo (t) will get us here if
4710 the type is not declared in the scope of the implicit
4711 statement. Change the type to BT_UNKNOWN, both because it is so
4712 and to prevent an ICE. */
4713 if (sym->ts.type == BT_DERIVED
4714 && sym->ts.derived->components == NULL)
4716 gfc_error ("The derived type '%s' at %L is of type '%s', "
4717 "which has not been defined.", sym->name,
4718 &sym->declared_at, sym->ts.derived->name);
4719 sym->ts.type = BT_UNKNOWN;
4723 /* If a component of a derived type is of a type declared to be private,
4724 either the derived type definition must contain the PRIVATE statement,
4725 or the derived type must be private. (4.4.1 just after R427) */
4726 if (sym->attr.flavor == FL_DERIVED
4727 && sym->component_access != ACCESS_PRIVATE
4728 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4730 for (c = sym->components; c; c = c->next)
4732 if (c->ts.type == BT_DERIVED
4733 && !c->ts.derived->attr.use_assoc
4734 && !gfc_check_access(c->ts.derived->attr.access,
4735 c->ts.derived->ns->default_access))
4737 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4738 "a component of '%s', which is PUBLIC at %L",
4739 c->name, sym->name, &sym->declared_at);
4745 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4746 default initialization is defined (5.1.2.4.4). */
4747 if (sym->ts.type == BT_DERIVED
4749 && sym->attr.intent == INTENT_OUT
4751 && sym->as->type == AS_ASSUMED_SIZE)
4753 for (c = sym->ts.derived->components; c; c = c->next)
4757 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4758 "ASSUMED SIZE and so cannot have a default initializer",
4759 sym->name, &sym->declared_at);
4766 /* Ensure that derived type formal arguments of a public procedure
4767 are not of a private type. */
4768 if (sym->attr.flavor == FL_PROCEDURE
4769 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4771 for (arg = sym->formal; arg; arg = arg->next)
4774 && arg->sym->ts.type == BT_DERIVED
4775 && !arg->sym->ts.derived->attr.use_assoc
4776 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4777 arg->sym->ts.derived->ns->default_access))
4779 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4780 "a dummy argument of '%s', which is PUBLIC at %L",
4781 arg->sym->name, sym->name, &sym->declared_at);
4782 /* Stop this message from recurring. */
4783 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4789 /* Constraints on deferred shape variable. */
4790 if (sym->attr.flavor == FL_VARIABLE
4791 || (sym->attr.flavor == FL_PROCEDURE
4792 && sym->attr.function))
4794 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4796 if (sym->attr.allocatable)
4798 if (sym->attr.dimension)
4799 gfc_error ("Allocatable array '%s' at %L must have "
4800 "a deferred shape", sym->name, &sym->declared_at);
4802 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4803 sym->name, &sym->declared_at);
4807 if (sym->attr.pointer && sym->attr.dimension)
4809 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4810 sym->name, &sym->declared_at);
4817 if (!mp_flag && !sym->attr.allocatable
4818 && !sym->attr.pointer && !sym->attr.dummy)
4820 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4821 sym->name, &sym->declared_at);
4827 switch (sym->attr.flavor)
4830 /* Can the symbol have an initializer? */
4832 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4833 || sym->attr.intrinsic || sym->attr.result)
4835 else if (sym->attr.dimension && !sym->attr.pointer)
4837 /* Don't allow initialization of automatic arrays. */
4838 for (i = 0; i < sym->as->rank; i++)
4840 if (sym->as->lower[i] == NULL
4841 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4842 || sym->as->upper[i] == NULL
4843 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4851 /* Reject illegal initializers. */
4852 if (sym->value && flag)
4854 if (sym->attr.allocatable)
4855 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4856 sym->name, &sym->declared_at);
4857 else if (sym->attr.external)
4858 gfc_error ("External '%s' at %L cannot have an initializer",
4859 sym->name, &sym->declared_at);
4860 else if (sym->attr.dummy)
4861 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4862 sym->name, &sym->declared_at);
4863 else if (sym->attr.intrinsic)
4864 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4865 sym->name, &sym->declared_at);
4866 else if (sym->attr.result)
4867 gfc_error ("Function result '%s' at %L cannot have an initializer",
4868 sym->name, &sym->declared_at);
4870 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4871 sym->name, &sym->declared_at);
4875 /* 4th constraint in section 11.3: "If an object of a type for which
4876 component-initialization is specified (R429) appears in the
4877 specification-part of a module and does not have the ALLOCATABLE
4878 or POINTER attribute, the object shall have the SAVE attribute." */
4880 constructor_expr = NULL;
4881 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
4882 constructor_expr = gfc_default_initializer (&sym->ts);
4884 if (sym->ns->proc_name
4885 && sym->ns->proc_name->attr.flavor == FL_MODULE
4887 && !sym->ns->save_all && !sym->attr.save
4888 && !sym->attr.pointer && !sym->attr.allocatable)
4890 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4891 sym->name, &sym->declared_at,
4892 "for default initialization of a component");
4896 /* Assign default initializer. */
4897 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4898 && !sym->attr.pointer)
4899 sym->value = gfc_default_initializer (&sym->ts);
4903 /* Reject PRIVATE objects in a PUBLIC namelist. */
4904 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4906 for (nl = sym->namelist; nl; nl = nl->next)
4908 if (!nl->sym->attr.use_assoc
4910 !(sym->ns->parent == nl->sym->ns)
4912 !gfc_check_access(nl->sym->attr.access,
4913 nl->sym->ns->default_access))
4914 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4915 "PUBLIC namelist at %L", nl->sym->name,
4922 /* An external symbol may not have an intializer because it is taken to be
4924 if (sym->attr.external && sym->value)
4926 gfc_error ("External object '%s' at %L may not have an initializer",
4927 sym->name, &sym->declared_at);
4931 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4932 char-len-param shall not be array-valued, pointer-valued, recursive
4933 or pure. ....snip... A character value of * may only be used in the
4934 following ways: (i) Dummy arg of procedure - dummy associates with
4935 actual length; (ii) To declare a named constant; or (iii) External
4936 function - but length must be declared in calling scoping unit. */
4937 if (sym->attr.function
4938 && sym->ts.type == BT_CHARACTER
4939 && sym->ts.cl && sym->ts.cl->length == NULL)
4941 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
4942 || (sym->attr.recursive) || (sym->attr.pure))
4944 if (sym->as && sym->as->rank)
4945 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4946 "array-valued", sym->name, &sym->declared_at);
4948 if (sym->attr.pointer)
4949 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4950 "pointer-valued", sym->name, &sym->declared_at);
4953 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4954 "pure", sym->name, &sym->declared_at);
4956 if (sym->attr.recursive)
4957 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4958 "recursive", sym->name, &sym->declared_at);
4963 /* Appendix B.2 of the standard. Contained functions give an
4964 error anyway. Fixed-form is likely to be F77/legacy. */
4965 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
4966 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
4967 "'%s' at %L is obsolescent in fortran 95",
4968 sym->name, &sym->declared_at);
4974 /* Add derived type to the derived type list. */
4976 gfc_dt_list * dt_list;
4977 dt_list = gfc_get_dt_list ();
4978 dt_list->next = sym->ns->derived_types;
4979 dt_list->derived = sym;
4980 sym->ns->derived_types = dt_list;
4990 /* Make sure that intrinsic exist */
4991 if (sym->attr.intrinsic
4992 && ! gfc_intrinsic_name(sym->name, 0)
4993 && ! gfc_intrinsic_name(sym->name, 1))
4994 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4996 /* Resolve array specifier. Check as well some constraints
4997 on COMMON blocks. */
4999 check_constant = sym->attr.in_common && !sym->attr.pointer;
5000 gfc_resolve_array_spec (sym->as, check_constant);
5002 /* Resolve formal namespaces. */
5004 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5006 formal_ns_save = formal_ns_flag;
5008 gfc_resolve (sym->formal_ns);
5009 formal_ns_flag = formal_ns_save;
5015 /************* Resolve DATA statements *************/
5019 gfc_data_value *vnode;
5025 /* Advance the values structure to point to the next value in the data list. */
5028 next_data_value (void)
5030 while (values.left == 0)
5032 if (values.vnode->next == NULL)
5035 values.vnode = values.vnode->next;
5036 values.left = values.vnode->repeat;
5044 check_data_variable (gfc_data_variable * var, locus * where)
5050 ar_type mark = AR_UNKNOWN;
5052 mpz_t section_index[GFC_MAX_DIMENSIONS];
5056 if (gfc_resolve_expr (var->expr) == FAILURE)
5060 mpz_init_set_si (offset, 0);
5063 if (e->expr_type != EXPR_VARIABLE)
5064 gfc_internal_error ("check_data_variable(): Bad expression");
5068 mpz_init_set_ui (size, 1);
5075 /* Find the array section reference. */
5076 for (ref = e->ref; ref; ref = ref->next)
5078 if (ref->type != REF_ARRAY)
5080 if (ref->u.ar.type == AR_ELEMENT)
5086 /* Set marks according to the reference pattern. */
5087 switch (ref->u.ar.type)
5095 /* Get the start position of array section. */
5096 gfc_get_section_index (ar, section_index, &offset);
5104 if (gfc_array_size (e, &size) == FAILURE)
5106 gfc_error ("Nonconstant array section at %L in DATA statement",
5115 while (mpz_cmp_ui (size, 0) > 0)
5117 if (next_data_value () == FAILURE)
5119 gfc_error ("DATA statement at %L has more variables than values",
5125 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5129 /* If we have more than one element left in the repeat count,
5130 and we have more than one element left in the target variable,
5131 then create a range assignment. */
5132 /* ??? Only done for full arrays for now, since array sections
5134 if (mark == AR_FULL && ref && ref->next == NULL
5135 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5139 if (mpz_cmp_ui (size, values.left) >= 0)
5141 mpz_init_set_ui (range, values.left);
5142 mpz_sub_ui (size, size, values.left);
5147 mpz_init_set (range, size);
5148 values.left -= mpz_get_ui (size);
5149 mpz_set_ui (size, 0);
5152 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5155 mpz_add (offset, offset, range);
5159 /* Assign initial value to symbol. */
5163 mpz_sub_ui (size, size, 1);
5165 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5167 if (mark == AR_FULL)
5168 mpz_add_ui (offset, offset, 1);
5170 /* Modify the array section indexes and recalculate the offset
5171 for next element. */
5172 else if (mark == AR_SECTION)
5173 gfc_advance_section (section_index, ar, &offset);
5177 if (mark == AR_SECTION)
5179 for (i = 0; i < ar->dimen; i++)
5180 mpz_clear (section_index[i]);
5190 static try traverse_data_var (gfc_data_variable *, locus *);
5192 /* Iterate over a list of elements in a DATA statement. */
5195 traverse_data_list (gfc_data_variable * var, locus * where)
5198 iterator_stack frame;
5201 mpz_init (frame.value);
5203 mpz_init_set (trip, var->iter.end->value.integer);
5204 mpz_sub (trip, trip, var->iter.start->value.integer);
5205 mpz_add (trip, trip, var->iter.step->value.integer);
5207 mpz_div (trip, trip, var->iter.step->value.integer);
5209 mpz_set (frame.value, var->iter.start->value.integer);
5211 frame.prev = iter_stack;
5212 frame.variable = var->iter.var->symtree;
5213 iter_stack = &frame;
5215 while (mpz_cmp_ui (trip, 0) > 0)
5217 if (traverse_data_var (var->list, where) == FAILURE)
5223 e = gfc_copy_expr (var->expr);
5224 if (gfc_simplify_expr (e, 1) == FAILURE)
5230 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5232 mpz_sub_ui (trip, trip, 1);
5236 mpz_clear (frame.value);
5238 iter_stack = frame.prev;
5243 /* Type resolve variables in the variable list of a DATA statement. */
5246 traverse_data_var (gfc_data_variable * var, locus * where)
5250 for (; var; var = var->next)
5252 if (var->expr == NULL)
5253 t = traverse_data_list (var, where);
5255 t = check_data_variable (var, where);
5265 /* Resolve the expressions and iterators associated with a data statement.
5266 This is separate from the assignment checking because data lists should
5267 only be resolved once. */
5270 resolve_data_variables (gfc_data_variable * d)
5272 for (; d; d = d->next)
5274 if (d->list == NULL)
5276 if (gfc_resolve_expr (d->expr) == FAILURE)
5281 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5284 if (d->iter.start->expr_type != EXPR_CONSTANT
5285 || d->iter.end->expr_type != EXPR_CONSTANT
5286 || d->iter.step->expr_type != EXPR_CONSTANT)
5287 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5289 if (resolve_data_variables (d->list) == FAILURE)
5298 /* Resolve a single DATA statement. We implement this by storing a pointer to
5299 the value list into static variables, and then recursively traversing the
5300 variables list, expanding iterators and such. */
5303 resolve_data (gfc_data * d)
5305 if (resolve_data_variables (d->var) == FAILURE)
5308 values.vnode = d->value;
5309 values.left = (d->value == NULL) ? 0 : d->value->repeat;
5311 if (traverse_data_var (d->var, &d->where) == FAILURE)
5314 /* At this point, we better not have any values left. */
5316 if (next_data_value () == SUCCESS)
5317 gfc_error ("DATA statement at %L has more values than variables",
5322 /* Determines if a variable is not 'pure', ie not assignable within a pure
5323 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5327 gfc_impure_variable (gfc_symbol * sym)
5329 if (sym->attr.use_assoc || sym->attr.in_common)
5332 if (sym->ns != gfc_current_ns)
5333 return !sym->attr.function;
5335 /* TODO: Check storage association through EQUIVALENCE statements */
5341 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5342 symbol of the current procedure. */
5345 gfc_pure (gfc_symbol * sym)
5347 symbol_attribute attr;
5350 sym = gfc_current_ns->proc_name;
5356 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5360 /* Test whether the current procedure is elemental or not. */
5363 gfc_elemental (gfc_symbol * sym)
5365 symbol_attribute attr;
5368 sym = gfc_current_ns->proc_name;
5373 return attr.flavor == FL_PROCEDURE && attr.elemental;
5377 /* Warn about unused labels. */
5380 warn_unused_label (gfc_st_label * label)
5385 warn_unused_label (label->left);
5387 if (label->defined == ST_LABEL_UNKNOWN)
5390 switch (label->referenced)
5392 case ST_LABEL_UNKNOWN:
5393 gfc_warning ("Label %d at %L defined but not used", label->value,
5397 case ST_LABEL_BAD_TARGET:
5398 gfc_warning ("Label %d at %L defined but cannot be used",
5399 label->value, &label->where);
5406 warn_unused_label (label->right);
5410 /* Returns the sequence type of a symbol or sequence. */
5413 sequence_type (gfc_typespec ts)
5422 if (ts.derived->components == NULL)
5423 return SEQ_NONDEFAULT;
5425 result = sequence_type (ts.derived->components->ts);
5426 for (c = ts.derived->components->next; c; c = c->next)
5427 if (sequence_type (c->ts) != result)
5433 if (ts.kind != gfc_default_character_kind)
5434 return SEQ_NONDEFAULT;
5436 return SEQ_CHARACTER;
5439 if (ts.kind != gfc_default_integer_kind)
5440 return SEQ_NONDEFAULT;
5445 if (!(ts.kind == gfc_default_real_kind
5446 || ts.kind == gfc_default_double_kind))
5447 return SEQ_NONDEFAULT;
5452 if (ts.kind != gfc_default_complex_kind)
5453 return SEQ_NONDEFAULT;
5458 if (ts.kind != gfc_default_logical_kind)
5459 return SEQ_NONDEFAULT;
5464 return SEQ_NONDEFAULT;
5469 /* Resolve derived type EQUIVALENCE object. */
5472 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5475 gfc_component *c = derived->components;
5480 /* Shall not be an object of nonsequence derived type. */
5481 if (!derived->attr.sequence)
5483 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5484 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5488 for (; c ; c = c->next)
5491 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5494 /* Shall not be an object of sequence derived type containing a pointer
5495 in the structure. */
5498 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5499 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5505 gfc_error ("Derived type variable '%s' at %L with default initializer "
5506 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5514 /* Resolve equivalence object.
5515 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5516 an allocatable array, an object of nonsequence derived type, an object of
5517 sequence derived type containing a pointer at any level of component
5518 selection, an automatic object, a function name, an entry name, a result
5519 name, a named constant, a structure component, or a subobject of any of
5520 the preceding objects. A substring shall not have length zero. A
5521 derived type shall not have components with default initialization nor
5522 shall two objects of an equivalence group be initialized.
5523 The simple constraints are done in symbol.c(check_conflict) and the rest
5524 are implemented here. */
5527 resolve_equivalence (gfc_equiv *eq)
5530 gfc_symbol *derived;
5531 gfc_symbol *first_sym;
5534 locus *last_where = NULL;
5535 seq_type eq_type, last_eq_type;
5536 gfc_typespec *last_ts;
5538 const char *value_name;
5542 last_ts = &eq->expr->symtree->n.sym->ts;
5544 first_sym = eq->expr->symtree->n.sym;
5546 for (object = 1; eq; eq = eq->eq, object++)
5550 e->ts = e->symtree->n.sym->ts;
5551 /* match_varspec might not know yet if it is seeing
5552 array reference or substring reference, as it doesn't
5554 if (e->ref && e->ref->type == REF_ARRAY)
5556 gfc_ref *ref = e->ref;
5557 sym = e->symtree->n.sym;
5559 if (sym->attr.dimension)
5561 ref->u.ar.as = sym->as;
5565 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5566 if (e->ts.type == BT_CHARACTER
5568 && ref->type == REF_ARRAY
5569 && ref->u.ar.dimen == 1
5570 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5571 && ref->u.ar.stride[0] == NULL)
5573 gfc_expr *start = ref->u.ar.start[0];
5574 gfc_expr *end = ref->u.ar.end[0];
5577 /* Optimize away the (:) reference. */
5578 if (start == NULL && end == NULL)
5583 e->ref->next = ref->next;
5588 ref->type = REF_SUBSTRING;
5590 start = gfc_int_expr (1);
5591 ref->u.ss.start = start;
5592 if (end == NULL && e->ts.cl)
5593 end = gfc_copy_expr (e->ts.cl->length);
5594 ref->u.ss.end = end;
5595 ref->u.ss.length = e->ts.cl;
5602 /* Any further ref is an error. */
5605 gcc_assert (ref->type == REF_ARRAY);
5606 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5612 if (gfc_resolve_expr (e) == FAILURE)
5615 sym = e->symtree->n.sym;
5617 /* An equivalence statement cannot have more than one initialized
5621 if (value_name != NULL)
5623 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5624 "be in the EQUIVALENCE statement at %L",
5625 value_name, sym->name, &e->where);
5629 value_name = sym->name;
5632 /* Shall not equivalence common block variables in a PURE procedure. */
5633 if (sym->ns->proc_name
5634 && sym->ns->proc_name->attr.pure
5635 && sym->attr.in_common)
5637 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5638 "object in the pure procedure '%s'",
5639 sym->name, &e->where, sym->ns->proc_name->name);
5643 /* Shall not be a named constant. */
5644 if (e->expr_type == EXPR_CONSTANT)
5646 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5647 "object", sym->name, &e->where);
5651 derived = e->ts.derived;
5652 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5655 /* Check that the types correspond correctly:
5657 A numeric sequence structure may be equivalenced to another sequence
5658 structure, an object of default integer type, default real type, double
5659 precision real type, default logical type such that components of the
5660 structure ultimately only become associated to objects of the same
5661 kind. A character sequence structure may be equivalenced to an object
5662 of default character kind or another character sequence structure.
5663 Other objects may be equivalenced only to objects of the same type and
5666 /* Identical types are unconditionally OK. */
5667 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5668 goto identical_types;
5670 last_eq_type = sequence_type (*last_ts);
5671 eq_type = sequence_type (sym->ts);
5673 /* Since the pair of objects is not of the same type, mixed or
5674 non-default sequences can be rejected. */
5676 msg = "Sequence %s with mixed components in EQUIVALENCE "
5677 "statement at %L with different type objects";
5679 && last_eq_type == SEQ_MIXED
5680 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5681 last_where) == FAILURE)
5682 || (eq_type == SEQ_MIXED
5683 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5684 &e->where) == FAILURE))
5687 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5688 "statement at %L with objects of different type";
5690 && last_eq_type == SEQ_NONDEFAULT
5691 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5692 last_where) == FAILURE)
5693 || (eq_type == SEQ_NONDEFAULT
5694 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5695 &e->where) == FAILURE))
5698 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5699 "EQUIVALENCE statement at %L";
5700 if (last_eq_type == SEQ_CHARACTER
5701 && eq_type != SEQ_CHARACTER
5702 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5703 &e->where) == FAILURE)
5706 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5707 "EQUIVALENCE statement at %L";
5708 if (last_eq_type == SEQ_NUMERIC
5709 && eq_type != SEQ_NUMERIC
5710 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5711 &e->where) == FAILURE)
5716 last_where = &e->where;
5721 /* Shall not be an automatic array. */
5722 if (e->ref->type == REF_ARRAY
5723 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5725 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5726 "an EQUIVALENCE object", sym->name, &e->where);
5733 /* Shall not be a structure component. */
5734 if (r->type == REF_COMPONENT)
5736 gfc_error ("Structure component '%s' at %L cannot be an "
5737 "EQUIVALENCE object",
5738 r->u.c.component->name, &e->where);
5742 /* A substring shall not have length zero. */
5743 if (r->type == REF_SUBSTRING)
5745 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5747 gfc_error ("Substring at %L has length zero",
5748 &r->u.ss.start->where);
5758 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5761 resolve_fntype (gfc_namespace * ns)
5766 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5769 /* If there are any entries, ns->proc_name is the entry master
5770 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5772 sym = ns->entries->sym;
5774 sym = ns->proc_name;
5775 if (sym->result == sym
5776 && sym->ts.type == BT_UNKNOWN
5777 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5778 && !sym->attr.untyped)
5780 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5781 sym->name, &sym->declared_at);
5782 sym->attr.untyped = 1;
5785 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
5786 && !gfc_check_access (sym->ts.derived->attr.access,
5787 sym->ts.derived->ns->default_access)
5788 && gfc_check_access (sym->attr.access, sym->ns->default_access))
5790 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
5791 sym->name, &sym->declared_at, sym->ts.derived->name);
5795 for (el = ns->entries->next; el; el = el->next)
5797 if (el->sym->result == el->sym
5798 && el->sym->ts.type == BT_UNKNOWN
5799 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5800 && !el->sym->attr.untyped)
5802 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5803 el->sym->name, &el->sym->declared_at);
5804 el->sym->attr.untyped = 1;
5810 /* Examine all of the expressions associated with a program unit,
5811 assign types to all intermediate expressions, make sure that all
5812 assignments are to compatible types and figure out which names
5813 refer to which functions or subroutines. It doesn't check code
5814 block, which is handled by resolve_code. */
5817 resolve_types (gfc_namespace * ns)
5824 gfc_current_ns = ns;
5826 resolve_entries (ns);
5828 resolve_contained_functions (ns);
5830 gfc_traverse_ns (ns, resolve_symbol);
5832 resolve_fntype (ns);
5834 for (n = ns->contained; n; n = n->sibling)
5836 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5837 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5838 "also be PURE", n->proc_name->name,
5839 &n->proc_name->declared_at);
5845 gfc_check_interfaces (ns);
5847 for (cl = ns->cl_list; cl; cl = cl->next)
5848 resolve_charlen (cl);
5850 gfc_traverse_ns (ns, resolve_values);
5856 for (d = ns->data; d; d = d->next)
5860 gfc_traverse_ns (ns, gfc_formalize_init_value);
5862 for (eq = ns->equiv; eq; eq = eq->next)
5863 resolve_equivalence (eq);
5865 /* Warn about unused labels. */
5866 if (gfc_option.warn_unused_labels)
5867 warn_unused_label (ns->st_labels);
5871 /* Call resolve_code recursively. */
5874 resolve_codes (gfc_namespace * ns)
5878 for (n = ns->contained; n; n = n->sibling)
5881 gfc_current_ns = ns;
5883 resolve_code (ns->code, ns);
5887 /* This function is called after a complete program unit has been compiled.
5888 Its purpose is to examine all of the expressions associated with a program
5889 unit, assign types to all intermediate expressions, make sure that all
5890 assignments are to compatible types and figure out which names refer to
5891 which functions or subroutines. */
5894 gfc_resolve (gfc_namespace * ns)
5896 gfc_namespace *old_ns;
5898 old_ns = gfc_current_ns;
5903 gfc_current_ns = old_ns;