1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code *head, *current;
44 struct code_stack *prev;
48 static code_stack *cs_base = NULL;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag = 0;
64 gfc_is_formal_arg (void)
66 return formal_arg_flag;
69 /* Resolve types of formal argument lists. These have to be done early so that
70 the formal argument lists of module procedures can be copied to the
71 containing module before the individual procedures are resolved
72 individually. We also resolve argument lists of procedures in interface
73 blocks because they are self-contained scoping units.
75 Since a dummy argument cannot be a non-dummy procedure, the only
76 resort left for untyped names are the IMPLICIT types. */
79 resolve_formal_arglist (gfc_symbol * proc)
81 gfc_formal_arglist *f;
85 /* TODO: Procedures whose return character length parameter is not constant
86 or assumed must also have explicit interfaces. */
87 if (proc->result != NULL)
92 if (gfc_elemental (proc)
93 || sym->attr.pointer || sym->attr.allocatable
94 || (sym->as && sym->as->rank > 0))
95 proc->attr.always_explicit = 1;
99 for (f = proc->formal; f; f = f->next)
105 /* Alternate return placeholder. */
106 if (gfc_elemental (proc))
107 gfc_error ("Alternate return specifier in elemental subroutine "
108 "'%s' at %L is not allowed", proc->name,
110 if (proc->attr.function)
111 gfc_error ("Alternate return specifier in function "
112 "'%s' at %L is not allowed", proc->name,
117 if (sym->attr.if_source != IFSRC_UNKNOWN)
118 resolve_formal_arglist (sym);
120 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
122 if (gfc_pure (proc) && !gfc_pure (sym))
125 ("Dummy procedure '%s' of PURE procedure at %L must also "
126 "be PURE", sym->name, &sym->declared_at);
130 if (gfc_elemental (proc))
133 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
141 if (sym->ts.type == BT_UNKNOWN)
143 if (!sym->attr.function || sym->result == sym)
144 gfc_set_default_type (sym, 1, sym->ns);
147 gfc_resolve_array_spec (sym->as, 0);
149 /* We can't tell if an array with dimension (:) is assumed or deferred
150 shape until we know if it has the pointer or allocatable attributes.
152 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
153 && !(sym->attr.pointer || sym->attr.allocatable))
155 sym->as->type = AS_ASSUMED_SHAPE;
156 for (i = 0; i < sym->as->rank; i++)
157 sym->as->lower[i] = gfc_int_expr (1);
160 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
161 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
162 || sym->attr.optional)
163 proc->attr.always_explicit = 1;
165 /* If the flavor is unknown at this point, it has to be a variable.
166 A procedure specification would have already set the type. */
168 if (sym->attr.flavor == FL_UNKNOWN)
169 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
173 if (proc->attr.function && !sym->attr.pointer
174 && sym->attr.flavor != FL_PROCEDURE
175 && sym->attr.intent != INTENT_IN)
177 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
178 "INTENT(IN)", sym->name, proc->name,
181 if (proc->attr.subroutine && !sym->attr.pointer
182 && sym->attr.intent == INTENT_UNKNOWN)
185 ("Argument '%s' of pure subroutine '%s' at %L must have "
186 "its INTENT specified", sym->name, proc->name,
191 if (gfc_elemental (proc))
196 ("Argument '%s' of elemental procedure at %L must be scalar",
197 sym->name, &sym->declared_at);
201 if (sym->attr.pointer)
204 ("Argument '%s' of elemental procedure at %L cannot have "
205 "the POINTER attribute", sym->name, &sym->declared_at);
210 /* Each dummy shall be specified to be scalar. */
211 if (proc->attr.proc == PROC_ST_FUNCTION)
216 ("Argument '%s' of statement function at %L must be scalar",
217 sym->name, &sym->declared_at);
221 if (sym->ts.type == BT_CHARACTER)
223 gfc_charlen *cl = sym->ts.cl;
224 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
227 ("Character-valued argument '%s' of statement function at "
228 "%L must has constant length",
229 sym->name, &sym->declared_at);
239 /* Work function called when searching for symbols that have argument lists
240 associated with them. */
243 find_arglists (gfc_symbol * sym)
246 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
249 resolve_formal_arglist (sym);
253 /* Given a namespace, resolve all formal argument lists within the namespace.
257 resolve_formal_arglists (gfc_namespace * ns)
263 gfc_traverse_ns (ns, find_arglists);
268 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
272 /* If this namespace is not a function, ignore it. */
274 || !(sym->attr.function
275 || sym->attr.flavor == FL_VARIABLE))
278 /* Try to find out of what the return type is. */
279 if (sym->result != NULL)
282 if (sym->ts.type == BT_UNKNOWN)
284 t = gfc_set_default_type (sym, 0, ns);
286 if (t == FAILURE && !sym->attr.untyped)
288 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
289 sym->name, &sym->declared_at); /* FIXME */
290 sym->attr.untyped = 1;
294 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
295 lists the only ways a character length value of * can be used: dummy arguments
296 of procedures, named constants, and function results in external functions.
297 Internal function results are not on that list; ergo, not permitted. */
299 if (sym->ts.type == BT_CHARACTER)
301 gfc_charlen *cl = sym->ts.cl;
302 if (!cl || !cl->length)
303 gfc_error ("Character-valued internal function '%s' at %L must "
304 "not be assumed length", sym->name, &sym->declared_at);
309 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
310 introduce duplicates. */
313 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
315 gfc_formal_arglist *f, *new_arglist;
318 for (; new_args != NULL; new_args = new_args->next)
320 new_sym = new_args->sym;
321 /* See if ths arg is already in the formal argument list. */
322 for (f = proc->formal; f; f = f->next)
324 if (new_sym == f->sym)
331 /* Add a new argument. Argument order is not important. */
332 new_arglist = gfc_get_formal_arglist ();
333 new_arglist->sym = new_sym;
334 new_arglist->next = proc->formal;
335 proc->formal = new_arglist;
340 /* Resolve alternate entry points. If a symbol has multiple entry points we
341 create a new master symbol for the main routine, and turn the existing
342 symbol into an entry point. */
345 resolve_entries (gfc_namespace * ns)
347 gfc_namespace *old_ns;
351 char name[GFC_MAX_SYMBOL_LEN + 1];
352 static int master_count = 0;
354 if (ns->proc_name == NULL)
357 /* No need to do anything if this procedure doesn't have alternate entry
362 /* We may already have resolved alternate entry points. */
363 if (ns->proc_name->attr.entry_master)
366 /* If this isn't a procedure something has gone horribly wrong. */
367 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
369 /* Remember the current namespace. */
370 old_ns = gfc_current_ns;
374 /* Add the main entry point to the list of entry points. */
375 el = gfc_get_entry_list ();
376 el->sym = ns->proc_name;
378 el->next = ns->entries;
380 ns->proc_name->attr.entry = 1;
382 /* Add an entry statement for it. */
389 /* Create a new symbol for the master function. */
390 /* Give the internal function a unique name (within this file).
391 Also include the function name so the user has some hope of figuring
392 out what is going on. */
393 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
394 master_count++, ns->proc_name->name);
395 gfc_get_ha_symbol (name, &proc);
396 gcc_assert (proc != NULL);
398 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
399 if (ns->proc_name->attr.subroutine)
400 gfc_add_subroutine (&proc->attr, proc->name, NULL);
404 gfc_typespec *ts, *fts;
406 gfc_add_function (&proc->attr, proc->name, NULL);
408 fts = &ns->entries->sym->result->ts;
409 if (fts->type == BT_UNKNOWN)
410 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
411 for (el = ns->entries->next; el; el = el->next)
413 ts = &el->sym->result->ts;
414 if (ts->type == BT_UNKNOWN)
415 ts = gfc_get_default_type (el->sym->result, NULL);
416 if (! gfc_compare_types (ts, fts)
417 || (el->sym->result->attr.dimension
418 != ns->entries->sym->result->attr.dimension)
419 || (el->sym->result->attr.pointer
420 != ns->entries->sym->result->attr.pointer))
426 sym = ns->entries->sym->result;
427 /* All result types the same. */
429 if (sym->attr.dimension)
430 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
431 if (sym->attr.pointer)
432 gfc_add_pointer (&proc->attr, NULL);
436 /* Otherwise the result will be passed through a union by
438 proc->attr.mixed_entry_master = 1;
439 for (el = ns->entries; el; el = el->next)
441 sym = el->sym->result;
442 if (sym->attr.dimension)
444 if (el == ns->entries)
446 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
447 sym->name, ns->entries->sym->name, &sym->declared_at);
450 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
451 sym->name, ns->entries->sym->name, &sym->declared_at);
453 else if (sym->attr.pointer)
455 if (el == ns->entries)
457 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
458 sym->name, ns->entries->sym->name, &sym->declared_at);
461 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
462 sym->name, ns->entries->sym->name, &sym->declared_at);
467 if (ts->type == BT_UNKNOWN)
468 ts = gfc_get_default_type (sym, NULL);
472 if (ts->kind == gfc_default_integer_kind)
476 if (ts->kind == gfc_default_real_kind
477 || ts->kind == gfc_default_double_kind)
481 if (ts->kind == gfc_default_complex_kind)
485 if (ts->kind == gfc_default_logical_kind)
489 /* We will issue error elsewhere. */
497 if (el == ns->entries)
499 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
500 sym->name, gfc_typename (ts), ns->entries->sym->name,
504 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
505 sym->name, gfc_typename (ts), ns->entries->sym->name,
512 proc->attr.access = ACCESS_PRIVATE;
513 proc->attr.entry_master = 1;
515 /* Merge all the entry point arguments. */
516 for (el = ns->entries; el; el = el->next)
517 merge_argument_lists (proc, el->sym->formal);
519 /* Use the master function for the function body. */
520 ns->proc_name = proc;
522 /* Finalize the new symbols. */
523 gfc_commit_symbols ();
525 /* Restore the original namespace. */
526 gfc_current_ns = old_ns;
530 /* Resolve contained function types. Because contained functions can call one
531 another, they have to be worked out before any of the contained procedures
534 The good news is that if a function doesn't already have a type, the only
535 way it can get one is through an IMPLICIT type or a RESULT variable, because
536 by definition contained functions are contained namespace they're contained
537 in, not in a sibling or parent namespace. */
540 resolve_contained_functions (gfc_namespace * ns)
542 gfc_namespace *child;
545 resolve_formal_arglists (ns);
547 for (child = ns->contained; child; child = child->sibling)
549 /* Resolve alternate entry points first. */
550 resolve_entries (child);
552 /* Then check function return types. */
553 resolve_contained_fntype (child->proc_name, child);
554 for (el = child->entries; el; el = el->next)
555 resolve_contained_fntype (el->sym, child);
560 /* Resolve all of the elements of a structure constructor and make sure that
561 the types are correct. */
564 resolve_structure_cons (gfc_expr * expr)
566 gfc_constructor *cons;
571 cons = expr->value.constructor;
572 /* A constructor may have references if it is the result of substituting a
573 parameter variable. In this case we just pull out the component we
576 comp = expr->ref->u.c.sym->components;
578 comp = expr->ts.derived->components;
580 for (; comp; comp = comp->next, cons = cons->next)
588 if (gfc_resolve_expr (cons->expr) == FAILURE)
594 /* If we don't have the right type, try to convert it. */
596 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
599 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
600 gfc_error ("The element in the derived type constructor at %L, "
601 "for pointer component '%s', is %s but should be %s",
602 &cons->expr->where, comp->name,
603 gfc_basic_typename (cons->expr->ts.type),
604 gfc_basic_typename (comp->ts.type));
606 t = gfc_convert_type (cons->expr, &comp->ts, 1);
615 /****************** Expression name resolution ******************/
617 /* Returns 0 if a symbol was not declared with a type or
618 attribute declaration statement, nonzero otherwise. */
621 was_declared (gfc_symbol * sym)
627 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
630 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
631 || a.optional || a.pointer || a.save || a.target
632 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
639 /* Determine if a symbol is generic or not. */
642 generic_sym (gfc_symbol * sym)
646 if (sym->attr.generic ||
647 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
650 if (was_declared (sym) || sym->ns->parent == NULL)
653 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
655 return (s == NULL) ? 0 : generic_sym (s);
659 /* Determine if a symbol is specific or not. */
662 specific_sym (gfc_symbol * sym)
666 if (sym->attr.if_source == IFSRC_IFBODY
667 || sym->attr.proc == PROC_MODULE
668 || sym->attr.proc == PROC_INTERNAL
669 || sym->attr.proc == PROC_ST_FUNCTION
670 || (sym->attr.intrinsic &&
671 gfc_specific_intrinsic (sym->name))
672 || sym->attr.external)
675 if (was_declared (sym) || sym->ns->parent == NULL)
678 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
680 return (s == NULL) ? 0 : specific_sym (s);
684 /* Figure out if the procedure is specific, generic or unknown. */
687 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
691 procedure_kind (gfc_symbol * sym)
694 if (generic_sym (sym))
695 return PTYPE_GENERIC;
697 if (specific_sym (sym))
698 return PTYPE_SPECIFIC;
700 return PTYPE_UNKNOWN;
703 /* Check references to assumed size arrays. The flag need_full_assumed_size
704 is non-zero when matching actual arguments. */
706 static int need_full_assumed_size = 0;
709 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
715 if (need_full_assumed_size
716 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
719 for (ref = e->ref; ref; ref = ref->next)
720 if (ref->type == REF_ARRAY)
721 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
722 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
726 gfc_error ("The upper bound in the last dimension must "
727 "appear in the reference to the assumed size "
728 "array '%s' at %L.", sym->name, &e->where);
735 /* Look for bad assumed size array references in argument expressions
736 of elemental and array valued intrinsic procedures. Since this is
737 called from procedure resolution functions, it only recurses at
741 resolve_assumed_size_actual (gfc_expr *e)
746 switch (e->expr_type)
750 && check_assumed_size_reference (e->symtree->n.sym, e))
755 if (resolve_assumed_size_actual (e->value.op.op1)
756 || resolve_assumed_size_actual (e->value.op.op2))
767 /* Resolve an actual argument list. Most of the time, this is just
768 resolving the expressions in the list.
769 The exception is that we sometimes have to decide whether arguments
770 that look like procedure arguments are really simple variable
774 resolve_actual_arglist (gfc_actual_arglist * arg)
777 gfc_symtree *parent_st;
780 for (; arg; arg = arg->next)
786 /* Check the label is a valid branching target. */
789 if (arg->label->defined == ST_LABEL_UNKNOWN)
791 gfc_error ("Label %d referenced at %L is never defined",
792 arg->label->value, &arg->label->where);
799 if (e->ts.type != BT_PROCEDURE)
801 if (gfc_resolve_expr (e) != SUCCESS)
806 /* See if the expression node should really be a variable
809 sym = e->symtree->n.sym;
811 if (sym->attr.flavor == FL_PROCEDURE
812 || sym->attr.intrinsic
813 || sym->attr.external)
816 if (sym->attr.proc == PROC_ST_FUNCTION)
818 gfc_error ("Statement function '%s' at %L is not allowed as an "
819 "actual argument", sym->name, &e->where);
822 if (sym->attr.contained && !sym->attr.use_assoc
823 && sym->ns->proc_name->attr.flavor != FL_MODULE)
825 gfc_error ("Internal procedure '%s' is not allowed as an "
826 "actual argument at %L", sym->name, &e->where);
829 if (sym->attr.elemental && !sym->attr.intrinsic)
831 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
832 "allowed as an actual argument at %L", sym->name,
836 /* If the symbol is the function that names the current (or
837 parent) scope, then we really have a variable reference. */
839 if (sym->attr.function && sym->result == sym
840 && (sym->ns->proc_name == sym
841 || (sym->ns->parent != NULL
842 && sym->ns->parent->proc_name == sym)))
848 /* See if the name is a module procedure in a parent unit. */
850 if (was_declared (sym) || sym->ns->parent == NULL)
853 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
855 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
859 if (parent_st == NULL)
862 sym = parent_st->n.sym;
863 e->symtree = parent_st; /* Point to the right thing. */
865 if (sym->attr.flavor == FL_PROCEDURE
866 || sym->attr.intrinsic
867 || sym->attr.external)
873 e->expr_type = EXPR_VARIABLE;
877 e->rank = sym->as->rank;
878 e->ref = gfc_get_ref ();
879 e->ref->type = REF_ARRAY;
880 e->ref->u.ar.type = AR_FULL;
881 e->ref->u.ar.as = sym->as;
889 /* Go through each actual argument in ACTUAL and see if it can be
890 implemented as an inlined, non-copying intrinsic. FNSYM is the
891 function being called, or NULL if not known. */
894 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
896 gfc_actual_arglist *ap;
899 for (ap = actual; ap; ap = ap->next)
901 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
902 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
903 ap->expr->inline_noncopying_intrinsic = 1;
906 /* This function does the checking of references to global procedures
907 as defined in sections 18.1 and 14.1, respectively, of the Fortran
908 77 and 95 standards. It checks for a gsymbol for the name, making
909 one if it does not already exist. If it already exists, then the
910 reference being resolved must correspond to the type of gsymbol.
911 Otherwise, the new symbol is equipped with the attributes of the
912 reference. The corresponding code that is called in creating
913 global entities is parse.c. */
916 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
921 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
923 gsym = gfc_get_gsymbol (sym->name);
925 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
926 global_used (gsym, where);
928 if (gsym->type == GSYM_UNKNOWN)
931 gsym->where = *where;
937 /************* Function resolution *************/
939 /* Resolve a function call known to be generic.
940 Section 14.1.2.4.1. */
943 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
947 if (sym->attr.generic)
950 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
953 expr->value.function.name = s->name;
954 expr->value.function.esym = s;
957 expr->rank = s->as->rank;
961 /* TODO: Need to search for elemental references in generic interface */
964 if (sym->attr.intrinsic)
965 return gfc_intrinsic_func_interface (expr, 0);
972 resolve_generic_f (gfc_expr * expr)
977 sym = expr->symtree->n.sym;
981 m = resolve_generic_f0 (expr, sym);
984 else if (m == MATCH_ERROR)
988 if (sym->ns->parent == NULL)
990 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
994 if (!generic_sym (sym))
998 /* Last ditch attempt. */
1000 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1002 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1003 expr->symtree->n.sym->name, &expr->where);
1007 m = gfc_intrinsic_func_interface (expr, 0);
1012 ("Generic function '%s' at %L is not consistent with a specific "
1013 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1019 /* Resolve a function call known to be specific. */
1022 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1026 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1028 if (sym->attr.dummy)
1030 sym->attr.proc = PROC_DUMMY;
1034 sym->attr.proc = PROC_EXTERNAL;
1038 if (sym->attr.proc == PROC_MODULE
1039 || sym->attr.proc == PROC_ST_FUNCTION
1040 || sym->attr.proc == PROC_INTERNAL)
1043 if (sym->attr.intrinsic)
1045 m = gfc_intrinsic_func_interface (expr, 1);
1050 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1051 "an intrinsic", sym->name, &expr->where);
1059 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1062 expr->value.function.name = sym->name;
1063 expr->value.function.esym = sym;
1064 if (sym->as != NULL)
1065 expr->rank = sym->as->rank;
1072 resolve_specific_f (gfc_expr * expr)
1077 sym = expr->symtree->n.sym;
1081 m = resolve_specific_f0 (sym, expr);
1084 if (m == MATCH_ERROR)
1087 if (sym->ns->parent == NULL)
1090 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1096 gfc_error ("Unable to resolve the specific function '%s' at %L",
1097 expr->symtree->n.sym->name, &expr->where);
1103 /* Resolve a procedure call not known to be generic nor specific. */
1106 resolve_unknown_f (gfc_expr * expr)
1111 sym = expr->symtree->n.sym;
1113 if (sym->attr.dummy)
1115 sym->attr.proc = PROC_DUMMY;
1116 expr->value.function.name = sym->name;
1120 /* See if we have an intrinsic function reference. */
1122 if (gfc_intrinsic_name (sym->name, 0))
1124 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1129 /* The reference is to an external name. */
1131 sym->attr.proc = PROC_EXTERNAL;
1132 expr->value.function.name = sym->name;
1133 expr->value.function.esym = expr->symtree->n.sym;
1135 if (sym->as != NULL)
1136 expr->rank = sym->as->rank;
1138 /* Type of the expression is either the type of the symbol or the
1139 default type of the symbol. */
1142 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1144 if (sym->ts.type != BT_UNKNOWN)
1148 ts = gfc_get_default_type (sym, sym->ns);
1150 if (ts->type == BT_UNKNOWN)
1152 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1153 sym->name, &expr->where);
1164 /* Figure out if a function reference is pure or not. Also set the name
1165 of the function for a potential error message. Return nonzero if the
1166 function is PURE, zero if not. */
1169 pure_function (gfc_expr * e, const char **name)
1173 if (e->value.function.esym)
1175 pure = gfc_pure (e->value.function.esym);
1176 *name = e->value.function.esym->name;
1178 else if (e->value.function.isym)
1180 pure = e->value.function.isym->pure
1181 || e->value.function.isym->elemental;
1182 *name = e->value.function.isym->name;
1186 /* Implicit functions are not pure. */
1188 *name = e->value.function.name;
1195 /* Resolve a function call, which means resolving the arguments, then figuring
1196 out which entity the name refers to. */
1197 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1198 to INTENT(OUT) or INTENT(INOUT). */
1201 resolve_function (gfc_expr * expr)
1203 gfc_actual_arglist *arg;
1211 sym = expr->symtree->n.sym;
1213 /* If the procedure is not internal, a statement function or a module
1214 procedure,it must be external and should be checked for usage. */
1215 if (sym && !sym->attr.dummy && !sym->attr.contained
1216 && sym->attr.proc != PROC_ST_FUNCTION
1217 && !sym->attr.use_assoc)
1218 resolve_global_procedure (sym, &expr->where, 0);
1220 /* Switch off assumed size checking and do this again for certain kinds
1221 of procedure, once the procedure itself is resolved. */
1222 need_full_assumed_size++;
1224 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1227 /* Resume assumed_size checking. */
1228 need_full_assumed_size--;
1230 if (sym && sym->ts.type == BT_CHARACTER
1231 && sym->ts.cl && sym->ts.cl->length == NULL)
1233 if (sym->attr.if_source == IFSRC_IFBODY)
1235 /* This follows from a slightly odd requirement at 5.1.1.5 in the
1236 standard that allows assumed character length functions to be
1237 declared in interfaces but not used. Picking up the symbol here,
1238 rather than resolve_symbol, accomplishes that. */
1239 gfc_error ("Function '%s' can be declared in an interface to "
1240 "return CHARACTER(*) but cannot be used at %L",
1241 sym->name, &expr->where);
1245 /* Internal procedures are taken care of in resolve_contained_fntype. */
1246 if (!sym->attr.dummy && !sym->attr.contained)
1248 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1249 "be used at %L since it is not a dummy argument",
1250 sym->name, &expr->where);
1255 /* See if function is already resolved. */
1257 if (expr->value.function.name != NULL)
1259 if (expr->ts.type == BT_UNKNOWN)
1265 /* Apply the rules of section 14.1.2. */
1267 switch (procedure_kind (sym))
1270 t = resolve_generic_f (expr);
1273 case PTYPE_SPECIFIC:
1274 t = resolve_specific_f (expr);
1278 t = resolve_unknown_f (expr);
1282 gfc_internal_error ("resolve_function(): bad function type");
1286 /* If the expression is still a function (it might have simplified),
1287 then we check to see if we are calling an elemental function. */
1289 if (expr->expr_type != EXPR_FUNCTION)
1292 temp = need_full_assumed_size;
1293 need_full_assumed_size = 0;
1295 if (expr->value.function.actual != NULL
1296 && ((expr->value.function.esym != NULL
1297 && expr->value.function.esym->attr.elemental)
1298 || (expr->value.function.isym != NULL
1299 && expr->value.function.isym->elemental)))
1301 /* The rank of an elemental is the rank of its array argument(s). */
1302 for (arg = expr->value.function.actual; arg; arg = arg->next)
1304 if (arg->expr != NULL && arg->expr->rank > 0)
1306 expr->rank = arg->expr->rank;
1311 /* Being elemental, the last upper bound of an assumed size array
1312 argument must be present. */
1313 for (arg = expr->value.function.actual; arg; arg = arg->next)
1315 if (arg->expr != NULL
1316 && arg->expr->rank > 0
1317 && resolve_assumed_size_actual (arg->expr))
1321 if (omp_workshare_flag
1322 && expr->value.function.esym
1323 && ! gfc_elemental (expr->value.function.esym))
1325 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1326 " in WORKSHARE construct", expr->value.function.esym->name,
1331 else if (expr->value.function.actual != NULL
1332 && expr->value.function.isym != NULL
1333 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1334 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1335 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1337 /* Array instrinsics must also have the last upper bound of an
1338 asumed size array argument. UBOUND and SIZE have to be
1339 excluded from the check if the second argument is anything
1342 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1343 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1345 for (arg = expr->value.function.actual; arg; arg = arg->next)
1347 if (inquiry && arg->next != NULL && arg->next->expr
1348 && arg->next->expr->expr_type != EXPR_CONSTANT)
1351 if (arg->expr != NULL
1352 && arg->expr->rank > 0
1353 && resolve_assumed_size_actual (arg->expr))
1358 need_full_assumed_size = temp;
1360 if (!pure_function (expr, &name))
1365 ("Function reference to '%s' at %L is inside a FORALL block",
1366 name, &expr->where);
1369 else if (gfc_pure (NULL))
1371 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1372 "procedure within a PURE procedure", name, &expr->where);
1377 /* Character lengths of use associated functions may contains references to
1378 symbols not referenced from the current program unit otherwise. Make sure
1379 those symbols are marked as referenced. */
1381 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1382 && expr->value.function.esym->attr.use_assoc)
1384 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1388 find_noncopying_intrinsics (expr->value.function.esym,
1389 expr->value.function.actual);
1394 /************* Subroutine resolution *************/
1397 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1404 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1405 sym->name, &c->loc);
1406 else if (gfc_pure (NULL))
1407 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1413 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1417 if (sym->attr.generic)
1419 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1422 c->resolved_sym = s;
1423 pure_subroutine (c, s);
1427 /* TODO: Need to search for elemental references in generic interface. */
1430 if (sym->attr.intrinsic)
1431 return gfc_intrinsic_sub_interface (c, 0);
1438 resolve_generic_s (gfc_code * c)
1443 sym = c->symtree->n.sym;
1445 m = resolve_generic_s0 (c, sym);
1448 if (m == MATCH_ERROR)
1451 if (sym->ns->parent != NULL)
1453 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1456 m = resolve_generic_s0 (c, sym);
1459 if (m == MATCH_ERROR)
1464 /* Last ditch attempt. */
1466 if (!gfc_generic_intrinsic (sym->name))
1469 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1470 sym->name, &c->loc);
1474 m = gfc_intrinsic_sub_interface (c, 0);
1478 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1479 "intrinsic subroutine interface", sym->name, &c->loc);
1485 /* Resolve a subroutine call known to be specific. */
1488 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1492 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1494 if (sym->attr.dummy)
1496 sym->attr.proc = PROC_DUMMY;
1500 sym->attr.proc = PROC_EXTERNAL;
1504 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1507 if (sym->attr.intrinsic)
1509 m = gfc_intrinsic_sub_interface (c, 1);
1513 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1514 "with an intrinsic", sym->name, &c->loc);
1522 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1524 c->resolved_sym = sym;
1525 pure_subroutine (c, sym);
1532 resolve_specific_s (gfc_code * c)
1537 sym = c->symtree->n.sym;
1539 m = resolve_specific_s0 (c, sym);
1542 if (m == MATCH_ERROR)
1545 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1549 m = resolve_specific_s0 (c, sym);
1552 if (m == MATCH_ERROR)
1556 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1557 sym->name, &c->loc);
1563 /* Resolve a subroutine call not known to be generic nor specific. */
1566 resolve_unknown_s (gfc_code * c)
1570 sym = c->symtree->n.sym;
1572 if (sym->attr.dummy)
1574 sym->attr.proc = PROC_DUMMY;
1578 /* See if we have an intrinsic function reference. */
1580 if (gfc_intrinsic_name (sym->name, 1))
1582 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1587 /* The reference is to an external name. */
1590 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1592 c->resolved_sym = sym;
1594 pure_subroutine (c, sym);
1600 /* Resolve a subroutine call. Although it was tempting to use the same code
1601 for functions, subroutines and functions are stored differently and this
1602 makes things awkward. */
1605 resolve_call (gfc_code * c)
1609 if (c->symtree && c->symtree->n.sym
1610 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1612 gfc_error ("'%s' at %L has a type, which is not consistent with "
1613 "the CALL at %L", c->symtree->n.sym->name,
1614 &c->symtree->n.sym->declared_at, &c->loc);
1618 /* If the procedure is not internal or module, it must be external and
1619 should be checked for usage. */
1620 if (c->symtree && c->symtree->n.sym
1621 && !c->symtree->n.sym->attr.dummy
1622 && !c->symtree->n.sym->attr.contained
1623 && !c->symtree->n.sym->attr.use_assoc)
1624 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1626 /* Switch off assumed size checking and do this again for certain kinds
1627 of procedure, once the procedure itself is resolved. */
1628 need_full_assumed_size++;
1630 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1633 /* Resume assumed_size checking. */
1634 need_full_assumed_size--;
1638 if (c->resolved_sym == NULL)
1639 switch (procedure_kind (c->symtree->n.sym))
1642 t = resolve_generic_s (c);
1645 case PTYPE_SPECIFIC:
1646 t = resolve_specific_s (c);
1650 t = resolve_unknown_s (c);
1654 gfc_internal_error ("resolve_subroutine(): bad function type");
1657 if (c->ext.actual != NULL
1658 && c->symtree->n.sym->attr.elemental)
1660 gfc_actual_arglist * a;
1661 /* Being elemental, the last upper bound of an assumed size array
1662 argument must be present. */
1663 for (a = c->ext.actual; a; a = a->next)
1666 && a->expr->rank > 0
1667 && resolve_assumed_size_actual (a->expr))
1673 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1677 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1678 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1679 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1680 if their shapes do not match. If either op1->shape or op2->shape is
1681 NULL, return SUCCESS. */
1684 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1691 if (op1->shape != NULL && op2->shape != NULL)
1693 for (i = 0; i < op1->rank; i++)
1695 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1697 gfc_error ("Shapes for operands at %L and %L are not conformable",
1698 &op1->where, &op2->where);
1708 /* Resolve an operator expression node. This can involve replacing the
1709 operation with a user defined function call. */
1712 resolve_operator (gfc_expr * e)
1714 gfc_expr *op1, *op2;
1718 /* Resolve all subnodes-- give them types. */
1720 switch (e->value.op.operator)
1723 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1726 /* Fall through... */
1729 case INTRINSIC_UPLUS:
1730 case INTRINSIC_UMINUS:
1731 case INTRINSIC_PARENTHESES:
1732 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1737 /* Typecheck the new node. */
1739 op1 = e->value.op.op1;
1740 op2 = e->value.op.op2;
1742 switch (e->value.op.operator)
1744 case INTRINSIC_UPLUS:
1745 case INTRINSIC_UMINUS:
1746 if (op1->ts.type == BT_INTEGER
1747 || op1->ts.type == BT_REAL
1748 || op1->ts.type == BT_COMPLEX)
1754 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1755 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1758 case INTRINSIC_PLUS:
1759 case INTRINSIC_MINUS:
1760 case INTRINSIC_TIMES:
1761 case INTRINSIC_DIVIDE:
1762 case INTRINSIC_POWER:
1763 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1765 gfc_type_convert_binary (e);
1770 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1771 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1772 gfc_typename (&op2->ts));
1775 case INTRINSIC_CONCAT:
1776 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1778 e->ts.type = BT_CHARACTER;
1779 e->ts.kind = op1->ts.kind;
1784 _("Operands of string concatenation operator at %%L are %s/%s"),
1785 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1791 case INTRINSIC_NEQV:
1792 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1794 e->ts.type = BT_LOGICAL;
1795 e->ts.kind = gfc_kind_max (op1, op2);
1796 if (op1->ts.kind < e->ts.kind)
1797 gfc_convert_type (op1, &e->ts, 2);
1798 else if (op2->ts.kind < e->ts.kind)
1799 gfc_convert_type (op2, &e->ts, 2);
1803 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1804 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1805 gfc_typename (&op2->ts));
1810 if (op1->ts.type == BT_LOGICAL)
1812 e->ts.type = BT_LOGICAL;
1813 e->ts.kind = op1->ts.kind;
1817 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1818 gfc_typename (&op1->ts));
1825 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1827 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1831 /* Fall through... */
1835 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1837 e->ts.type = BT_LOGICAL;
1838 e->ts.kind = gfc_default_logical_kind;
1842 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1844 gfc_type_convert_binary (e);
1846 e->ts.type = BT_LOGICAL;
1847 e->ts.kind = gfc_default_logical_kind;
1851 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1853 _("Logicals at %%L must be compared with %s instead of %s"),
1854 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1855 gfc_op2string (e->value.op.operator));
1858 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1859 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1860 gfc_typename (&op2->ts));
1864 case INTRINSIC_USER:
1866 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1867 e->value.op.uop->name, gfc_typename (&op1->ts));
1869 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1870 e->value.op.uop->name, gfc_typename (&op1->ts),
1871 gfc_typename (&op2->ts));
1875 case INTRINSIC_PARENTHESES:
1879 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1882 /* Deal with arrayness of an operand through an operator. */
1886 switch (e->value.op.operator)
1888 case INTRINSIC_PLUS:
1889 case INTRINSIC_MINUS:
1890 case INTRINSIC_TIMES:
1891 case INTRINSIC_DIVIDE:
1892 case INTRINSIC_POWER:
1893 case INTRINSIC_CONCAT:
1897 case INTRINSIC_NEQV:
1905 if (op1->rank == 0 && op2->rank == 0)
1908 if (op1->rank == 0 && op2->rank != 0)
1910 e->rank = op2->rank;
1912 if (e->shape == NULL)
1913 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1916 if (op1->rank != 0 && op2->rank == 0)
1918 e->rank = op1->rank;
1920 if (e->shape == NULL)
1921 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1924 if (op1->rank != 0 && op2->rank != 0)
1926 if (op1->rank == op2->rank)
1928 e->rank = op1->rank;
1929 if (e->shape == NULL)
1931 t = compare_shapes(op1, op2);
1935 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1940 gfc_error ("Inconsistent ranks for operator at %L and %L",
1941 &op1->where, &op2->where);
1944 /* Allow higher level expressions to work. */
1952 case INTRINSIC_UPLUS:
1953 case INTRINSIC_UMINUS:
1954 case INTRINSIC_PARENTHESES:
1955 e->rank = op1->rank;
1957 if (e->shape == NULL)
1958 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1960 /* Simply copy arrayness attribute */
1967 /* Attempt to simplify the expression. */
1969 t = gfc_simplify_expr (e, 0);
1974 if (gfc_extend_expr (e) == SUCCESS)
1977 gfc_error (msg, &e->where);
1983 /************** Array resolution subroutines **************/
1987 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1990 /* Compare two integer expressions. */
1993 compare_bound (gfc_expr * a, gfc_expr * b)
1997 if (a == NULL || a->expr_type != EXPR_CONSTANT
1998 || b == NULL || b->expr_type != EXPR_CONSTANT)
2001 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2002 gfc_internal_error ("compare_bound(): Bad expression");
2004 i = mpz_cmp (a->value.integer, b->value.integer);
2014 /* Compare an integer expression with an integer. */
2017 compare_bound_int (gfc_expr * a, int b)
2021 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2024 if (a->ts.type != BT_INTEGER)
2025 gfc_internal_error ("compare_bound_int(): Bad expression");
2027 i = mpz_cmp_si (a->value.integer, b);
2037 /* Compare a single dimension of an array reference to the array
2041 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2044 /* Given start, end and stride values, calculate the minimum and
2045 maximum referenced indexes. */
2053 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2055 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2061 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2063 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2067 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2069 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2072 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2073 it is legal (see 6.2.2.3.1). */
2078 gfc_internal_error ("check_dimension(): Bad array reference");
2084 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2089 /* Compare an array reference with an array specification. */
2092 compare_spec_to_ref (gfc_array_ref * ar)
2099 /* TODO: Full array sections are only allowed as actual parameters. */
2100 if (as->type == AS_ASSUMED_SIZE
2101 && (/*ar->type == AR_FULL
2102 ||*/ (ar->type == AR_SECTION
2103 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2105 gfc_error ("Rightmost upper bound of assumed size array section"
2106 " not specified at %L", &ar->where);
2110 if (ar->type == AR_FULL)
2113 if (as->rank != ar->dimen)
2115 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2116 &ar->where, ar->dimen, as->rank);
2120 for (i = 0; i < as->rank; i++)
2121 if (check_dimension (i, ar, as) == FAILURE)
2128 /* Resolve one part of an array index. */
2131 gfc_resolve_index (gfc_expr * index, int check_scalar)
2138 if (gfc_resolve_expr (index) == FAILURE)
2141 if (check_scalar && index->rank != 0)
2143 gfc_error ("Array index at %L must be scalar", &index->where);
2147 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2149 gfc_error ("Array index at %L must be of INTEGER type",
2154 if (index->ts.type == BT_REAL)
2155 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
2156 &index->where) == FAILURE)
2159 if (index->ts.kind != gfc_index_integer_kind
2160 || index->ts.type != BT_INTEGER)
2163 ts.type = BT_INTEGER;
2164 ts.kind = gfc_index_integer_kind;
2166 gfc_convert_type_warn (index, &ts, 2, 0);
2172 /* Resolve a dim argument to an intrinsic function. */
2175 gfc_resolve_dim_arg (gfc_expr *dim)
2180 if (gfc_resolve_expr (dim) == FAILURE)
2185 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2189 if (dim->ts.type != BT_INTEGER)
2191 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2194 if (dim->ts.kind != gfc_index_integer_kind)
2198 ts.type = BT_INTEGER;
2199 ts.kind = gfc_index_integer_kind;
2201 gfc_convert_type_warn (dim, &ts, 2, 0);
2207 /* Given an expression that contains array references, update those array
2208 references to point to the right array specifications. While this is
2209 filled in during matching, this information is difficult to save and load
2210 in a module, so we take care of it here.
2212 The idea here is that the original array reference comes from the
2213 base symbol. We traverse the list of reference structures, setting
2214 the stored reference to references. Component references can
2215 provide an additional array specification. */
2218 find_array_spec (gfc_expr * e)
2224 as = e->symtree->n.sym->as;
2226 for (ref = e->ref; ref; ref = ref->next)
2231 gfc_internal_error ("find_array_spec(): Missing spec");
2238 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
2239 if (c == ref->u.c.component)
2243 gfc_internal_error ("find_array_spec(): Component not found");
2248 gfc_internal_error ("find_array_spec(): unused as(1)");
2259 gfc_internal_error ("find_array_spec(): unused as(2)");
2263 /* Resolve an array reference. */
2266 resolve_array_ref (gfc_array_ref * ar)
2268 int i, check_scalar;
2270 for (i = 0; i < ar->dimen; i++)
2272 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2274 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2276 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2278 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2281 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2282 switch (ar->start[i]->rank)
2285 ar->dimen_type[i] = DIMEN_ELEMENT;
2289 ar->dimen_type[i] = DIMEN_VECTOR;
2293 gfc_error ("Array index at %L is an array of rank %d",
2294 &ar->c_where[i], ar->start[i]->rank);
2299 /* If the reference type is unknown, figure out what kind it is. */
2301 if (ar->type == AR_UNKNOWN)
2303 ar->type = AR_ELEMENT;
2304 for (i = 0; i < ar->dimen; i++)
2305 if (ar->dimen_type[i] == DIMEN_RANGE
2306 || ar->dimen_type[i] == DIMEN_VECTOR)
2308 ar->type = AR_SECTION;
2313 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2321 resolve_substring (gfc_ref * ref)
2324 if (ref->u.ss.start != NULL)
2326 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2329 if (ref->u.ss.start->ts.type != BT_INTEGER)
2331 gfc_error ("Substring start index at %L must be of type INTEGER",
2332 &ref->u.ss.start->where);
2336 if (ref->u.ss.start->rank != 0)
2338 gfc_error ("Substring start index at %L must be scalar",
2339 &ref->u.ss.start->where);
2343 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2345 gfc_error ("Substring start index at %L is less than one",
2346 &ref->u.ss.start->where);
2351 if (ref->u.ss.end != NULL)
2353 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2356 if (ref->u.ss.end->ts.type != BT_INTEGER)
2358 gfc_error ("Substring end index at %L must be of type INTEGER",
2359 &ref->u.ss.end->where);
2363 if (ref->u.ss.end->rank != 0)
2365 gfc_error ("Substring end index at %L must be scalar",
2366 &ref->u.ss.end->where);
2370 if (ref->u.ss.length != NULL
2371 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2373 gfc_error ("Substring end index at %L is out of bounds",
2374 &ref->u.ss.start->where);
2383 /* Resolve subtype references. */
2386 resolve_ref (gfc_expr * expr)
2388 int current_part_dimension, n_components, seen_part_dimension;
2391 for (ref = expr->ref; ref; ref = ref->next)
2392 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2394 find_array_spec (expr);
2398 for (ref = expr->ref; ref; ref = ref->next)
2402 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2410 resolve_substring (ref);
2414 /* Check constraints on part references. */
2416 current_part_dimension = 0;
2417 seen_part_dimension = 0;
2420 for (ref = expr->ref; ref; ref = ref->next)
2425 switch (ref->u.ar.type)
2429 current_part_dimension = 1;
2433 current_part_dimension = 0;
2437 gfc_internal_error ("resolve_ref(): Bad array reference");
2443 if ((current_part_dimension || seen_part_dimension)
2444 && ref->u.c.component->pointer)
2447 ("Component to the right of a part reference with nonzero "
2448 "rank must not have the POINTER attribute at %L",
2460 if (((ref->type == REF_COMPONENT && n_components > 1)
2461 || ref->next == NULL)
2462 && current_part_dimension
2463 && seen_part_dimension)
2466 gfc_error ("Two or more part references with nonzero rank must "
2467 "not be specified at %L", &expr->where);
2471 if (ref->type == REF_COMPONENT)
2473 if (current_part_dimension)
2474 seen_part_dimension = 1;
2476 /* reset to make sure */
2477 current_part_dimension = 0;
2485 /* Given an expression, determine its shape. This is easier than it sounds.
2486 Leaves the shape array NULL if it is not possible to determine the shape. */
2489 expression_shape (gfc_expr * e)
2491 mpz_t array[GFC_MAX_DIMENSIONS];
2494 if (e->rank == 0 || e->shape != NULL)
2497 for (i = 0; i < e->rank; i++)
2498 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2501 e->shape = gfc_get_shape (e->rank);
2503 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2508 for (i--; i >= 0; i--)
2509 mpz_clear (array[i]);
2513 /* Given a variable expression node, compute the rank of the expression by
2514 examining the base symbol and any reference structures it may have. */
2517 expression_rank (gfc_expr * e)
2524 if (e->expr_type == EXPR_ARRAY)
2526 /* Constructors can have a rank different from one via RESHAPE(). */
2528 if (e->symtree == NULL)
2534 e->rank = (e->symtree->n.sym->as == NULL)
2535 ? 0 : e->symtree->n.sym->as->rank;
2541 for (ref = e->ref; ref; ref = ref->next)
2543 if (ref->type != REF_ARRAY)
2546 if (ref->u.ar.type == AR_FULL)
2548 rank = ref->u.ar.as->rank;
2552 if (ref->u.ar.type == AR_SECTION)
2554 /* Figure out the rank of the section. */
2556 gfc_internal_error ("expression_rank(): Two array specs");
2558 for (i = 0; i < ref->u.ar.dimen; i++)
2559 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2560 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2570 expression_shape (e);
2574 /* Resolve a variable expression. */
2577 resolve_variable (gfc_expr * e)
2581 if (e->ref && resolve_ref (e) == FAILURE)
2584 if (e->symtree == NULL)
2587 sym = e->symtree->n.sym;
2588 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2590 e->ts.type = BT_PROCEDURE;
2594 if (sym->ts.type != BT_UNKNOWN)
2595 gfc_variable_attr (e, &e->ts);
2598 /* Must be a simple variable reference. */
2599 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2604 if (check_assumed_size_reference (sym, e))
2611 /* Resolve an expression. That is, make sure that types of operands agree
2612 with their operators, intrinsic operators are converted to function calls
2613 for overloaded types and unresolved function references are resolved. */
2616 gfc_resolve_expr (gfc_expr * e)
2623 switch (e->expr_type)
2626 t = resolve_operator (e);
2630 t = resolve_function (e);
2634 t = resolve_variable (e);
2636 expression_rank (e);
2639 case EXPR_SUBSTRING:
2640 t = resolve_ref (e);
2650 if (resolve_ref (e) == FAILURE)
2653 t = gfc_resolve_array_constructor (e);
2654 /* Also try to expand a constructor. */
2657 expression_rank (e);
2658 gfc_expand_constructor (e);
2663 case EXPR_STRUCTURE:
2664 t = resolve_ref (e);
2668 t = resolve_structure_cons (e);
2672 t = gfc_simplify_expr (e, 0);
2676 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2683 /* Resolve an expression from an iterator. They must be scalar and have
2684 INTEGER or (optionally) REAL type. */
2687 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2688 const char * name_msgid)
2690 if (gfc_resolve_expr (expr) == FAILURE)
2693 if (expr->rank != 0)
2695 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2699 if (!(expr->ts.type == BT_INTEGER
2700 || (expr->ts.type == BT_REAL && real_ok)))
2703 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2706 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2713 /* Resolve the expressions in an iterator structure. If REAL_OK is
2714 false allow only INTEGER type iterators, otherwise allow REAL types. */
2717 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2720 if (iter->var->ts.type == BT_REAL)
2721 gfc_notify_std (GFC_STD_F95_DEL,
2722 "Obsolete: REAL DO loop iterator at %L",
2725 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2729 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2731 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2736 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2737 "Start expression in DO loop") == FAILURE)
2740 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2741 "End expression in DO loop") == FAILURE)
2744 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2745 "Step expression in DO loop") == FAILURE)
2748 if (iter->step->expr_type == EXPR_CONSTANT)
2750 if ((iter->step->ts.type == BT_INTEGER
2751 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2752 || (iter->step->ts.type == BT_REAL
2753 && mpfr_sgn (iter->step->value.real) == 0))
2755 gfc_error ("Step expression in DO loop at %L cannot be zero",
2756 &iter->step->where);
2761 /* Convert start, end, and step to the same type as var. */
2762 if (iter->start->ts.kind != iter->var->ts.kind
2763 || iter->start->ts.type != iter->var->ts.type)
2764 gfc_convert_type (iter->start, &iter->var->ts, 2);
2766 if (iter->end->ts.kind != iter->var->ts.kind
2767 || iter->end->ts.type != iter->var->ts.type)
2768 gfc_convert_type (iter->end, &iter->var->ts, 2);
2770 if (iter->step->ts.kind != iter->var->ts.kind
2771 || iter->step->ts.type != iter->var->ts.type)
2772 gfc_convert_type (iter->step, &iter->var->ts, 2);
2778 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2779 to be a scalar INTEGER variable. The subscripts and stride are scalar
2780 INTEGERs, and if stride is a constant it must be nonzero. */
2783 resolve_forall_iterators (gfc_forall_iterator * iter)
2788 if (gfc_resolve_expr (iter->var) == SUCCESS
2789 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2790 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2793 if (gfc_resolve_expr (iter->start) == SUCCESS
2794 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2795 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2796 &iter->start->where);
2797 if (iter->var->ts.kind != iter->start->ts.kind)
2798 gfc_convert_type (iter->start, &iter->var->ts, 2);
2800 if (gfc_resolve_expr (iter->end) == SUCCESS
2801 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2802 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2804 if (iter->var->ts.kind != iter->end->ts.kind)
2805 gfc_convert_type (iter->end, &iter->var->ts, 2);
2807 if (gfc_resolve_expr (iter->stride) == SUCCESS)
2809 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2810 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2811 &iter->stride->where, "INTEGER");
2813 if (iter->stride->expr_type == EXPR_CONSTANT
2814 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2815 gfc_error ("FORALL stride expression at %L cannot be zero",
2816 &iter->stride->where);
2818 if (iter->var->ts.kind != iter->stride->ts.kind)
2819 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2826 /* Given a pointer to a symbol that is a derived type, see if any components
2827 have the POINTER attribute. The search is recursive if necessary.
2828 Returns zero if no pointer components are found, nonzero otherwise. */
2831 derived_pointer (gfc_symbol * sym)
2835 for (c = sym->components; c; c = c->next)
2840 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2848 /* Given a pointer to a symbol that is a derived type, see if it's
2849 inaccessible, i.e. if it's defined in another module and the components are
2850 PRIVATE. The search is recursive if necessary. Returns zero if no
2851 inaccessible components are found, nonzero otherwise. */
2854 derived_inaccessible (gfc_symbol *sym)
2858 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2861 for (c = sym->components; c; c = c->next)
2863 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2871 /* Resolve the argument of a deallocate expression. The expression must be
2872 a pointer or a full array. */
2875 resolve_deallocate_expr (gfc_expr * e)
2877 symbol_attribute attr;
2881 if (gfc_resolve_expr (e) == FAILURE)
2884 attr = gfc_expr_attr (e);
2888 if (e->expr_type != EXPR_VARIABLE)
2891 allocatable = e->symtree->n.sym->attr.allocatable;
2892 for (ref = e->ref; ref; ref = ref->next)
2896 if (ref->u.ar.type != AR_FULL)
2901 allocatable = (ref->u.c.component->as != NULL
2902 && ref->u.c.component->as->type == AS_DEFERRED);
2910 if (allocatable == 0)
2913 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2914 "ALLOCATABLE or a POINTER", &e->where);
2921 /* Given the expression node e for an allocatable/pointer of derived type to be
2922 allocated, get the expression node to be initialized afterwards (needed for
2923 derived types with default initializers). */
2926 expr_to_initialize (gfc_expr * e)
2932 result = gfc_copy_expr (e);
2934 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2935 for (ref = result->ref; ref; ref = ref->next)
2936 if (ref->type == REF_ARRAY && ref->next == NULL)
2938 ref->u.ar.type = AR_FULL;
2940 for (i = 0; i < ref->u.ar.dimen; i++)
2941 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2943 result->rank = ref->u.ar.dimen;
2951 /* Resolve the expression in an ALLOCATE statement, doing the additional
2952 checks to see whether the expression is OK or not. The expression must
2953 have a trailing array reference that gives the size of the array. */
2956 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2958 int i, pointer, allocatable, dimension;
2959 symbol_attribute attr;
2960 gfc_ref *ref, *ref2;
2965 if (gfc_resolve_expr (e) == FAILURE)
2968 /* Make sure the expression is allocatable or a pointer. If it is
2969 pointer, the next-to-last reference must be a pointer. */
2973 if (e->expr_type != EXPR_VARIABLE)
2977 attr = gfc_expr_attr (e);
2978 pointer = attr.pointer;
2979 dimension = attr.dimension;
2984 allocatable = e->symtree->n.sym->attr.allocatable;
2985 pointer = e->symtree->n.sym->attr.pointer;
2986 dimension = e->symtree->n.sym->attr.dimension;
2988 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2992 if (ref->next != NULL)
2997 allocatable = (ref->u.c.component->as != NULL
2998 && ref->u.c.component->as->type == AS_DEFERRED);
3000 pointer = ref->u.c.component->pointer;
3001 dimension = ref->u.c.component->dimension;
3011 if (allocatable == 0 && pointer == 0)
3013 gfc_error ("Expression in ALLOCATE statement at %L must be "
3014 "ALLOCATABLE or a POINTER", &e->where);
3018 /* Add default initializer for those derived types that need them. */
3019 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3021 init_st = gfc_get_code ();
3022 init_st->loc = code->loc;
3023 init_st->op = EXEC_ASSIGN;
3024 init_st->expr = expr_to_initialize (e);
3025 init_st->expr2 = init_e;
3027 init_st->next = code->next;
3028 code->next = init_st;
3031 if (pointer && dimension == 0)
3034 /* Make sure the next-to-last reference node is an array specification. */
3036 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3038 gfc_error ("Array specification required in ALLOCATE statement "
3039 "at %L", &e->where);
3043 if (ref2->u.ar.type == AR_ELEMENT)
3046 /* Make sure that the array section reference makes sense in the
3047 context of an ALLOCATE specification. */
3051 for (i = 0; i < ar->dimen; i++)
3052 switch (ar->dimen_type[i])
3058 if (ar->start[i] != NULL
3059 && ar->end[i] != NULL
3060 && ar->stride[i] == NULL)
3063 /* Fall Through... */
3067 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3076 /************ SELECT CASE resolution subroutines ************/
3078 /* Callback function for our mergesort variant. Determines interval
3079 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3080 op1 > op2. Assumes we're not dealing with the default case.
3081 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3082 There are nine situations to check. */
3085 compare_cases (const gfc_case * op1, const gfc_case * op2)
3089 if (op1->low == NULL) /* op1 = (:L) */
3091 /* op2 = (:N), so overlap. */
3093 /* op2 = (M:) or (M:N), L < M */
3094 if (op2->low != NULL
3095 && gfc_compare_expr (op1->high, op2->low) < 0)
3098 else if (op1->high == NULL) /* op1 = (K:) */
3100 /* op2 = (M:), so overlap. */
3102 /* op2 = (:N) or (M:N), K > N */
3103 if (op2->high != NULL
3104 && gfc_compare_expr (op1->low, op2->high) > 0)
3107 else /* op1 = (K:L) */
3109 if (op2->low == NULL) /* op2 = (:N), K > N */
3110 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3111 else if (op2->high == NULL) /* op2 = (M:), L < M */
3112 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3113 else /* op2 = (M:N) */
3117 if (gfc_compare_expr (op1->high, op2->low) < 0)
3120 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3129 /* Merge-sort a double linked case list, detecting overlap in the
3130 process. LIST is the head of the double linked case list before it
3131 is sorted. Returns the head of the sorted list if we don't see any
3132 overlap, or NULL otherwise. */
3135 check_case_overlap (gfc_case * list)
3137 gfc_case *p, *q, *e, *tail;
3138 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3140 /* If the passed list was empty, return immediately. */
3147 /* Loop unconditionally. The only exit from this loop is a return
3148 statement, when we've finished sorting the case list. */
3155 /* Count the number of merges we do in this pass. */
3158 /* Loop while there exists a merge to be done. */
3163 /* Count this merge. */
3166 /* Cut the list in two pieces by stepping INSIZE places
3167 forward in the list, starting from P. */
3170 for (i = 0; i < insize; i++)
3179 /* Now we have two lists. Merge them! */
3180 while (psize > 0 || (qsize > 0 && q != NULL))
3183 /* See from which the next case to merge comes from. */
3186 /* P is empty so the next case must come from Q. */
3191 else if (qsize == 0 || q == NULL)
3200 cmp = compare_cases (p, q);
3203 /* The whole case range for P is less than the
3211 /* The whole case range for Q is greater than
3212 the case range for P. */
3219 /* The cases overlap, or they are the same
3220 element in the list. Either way, we must
3221 issue an error and get the next case from P. */
3222 /* FIXME: Sort P and Q by line number. */
3223 gfc_error ("CASE label at %L overlaps with CASE "
3224 "label at %L", &p->where, &q->where);
3232 /* Add the next element to the merged list. */
3241 /* P has now stepped INSIZE places along, and so has Q. So
3242 they're the same. */
3247 /* If we have done only one merge or none at all, we've
3248 finished sorting the cases. */
3257 /* Otherwise repeat, merging lists twice the size. */
3263 /* Check to see if an expression is suitable for use in a CASE statement.
3264 Makes sure that all case expressions are scalar constants of the same
3265 type. Return FAILURE if anything is wrong. */
3268 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3270 if (e == NULL) return SUCCESS;
3272 if (e->ts.type != case_expr->ts.type)
3274 gfc_error ("Expression in CASE statement at %L must be of type %s",
3275 &e->where, gfc_basic_typename (case_expr->ts.type));
3279 /* C805 (R808) For a given case-construct, each case-value shall be of
3280 the same type as case-expr. For character type, length differences
3281 are allowed, but the kind type parameters shall be the same. */
3283 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3285 gfc_error("Expression in CASE statement at %L must be kind %d",
3286 &e->where, case_expr->ts.kind);
3290 /* Convert the case value kind to that of case expression kind, if needed.
3291 FIXME: Should a warning be issued? */
3292 if (e->ts.kind != case_expr->ts.kind)
3293 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3297 gfc_error ("Expression in CASE statement at %L must be scalar",
3306 /* Given a completely parsed select statement, we:
3308 - Validate all expressions and code within the SELECT.
3309 - Make sure that the selection expression is not of the wrong type.
3310 - Make sure that no case ranges overlap.
3311 - Eliminate unreachable cases and unreachable code resulting from
3312 removing case labels.
3314 The standard does allow unreachable cases, e.g. CASE (5:3). But
3315 they are a hassle for code generation, and to prevent that, we just
3316 cut them out here. This is not necessary for overlapping cases
3317 because they are illegal and we never even try to generate code.
3319 We have the additional caveat that a SELECT construct could have
3320 been a computed GOTO in the source code. Fortunately we can fairly
3321 easily work around that here: The case_expr for a "real" SELECT CASE
3322 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3323 we have to do is make sure that the case_expr is a scalar integer
3327 resolve_select (gfc_code * code)
3330 gfc_expr *case_expr;
3331 gfc_case *cp, *default_case, *tail, *head;
3332 int seen_unreachable;
3337 if (code->expr == NULL)
3339 /* This was actually a computed GOTO statement. */
3340 case_expr = code->expr2;
3341 if (case_expr->ts.type != BT_INTEGER
3342 || case_expr->rank != 0)
3343 gfc_error ("Selection expression in computed GOTO statement "
3344 "at %L must be a scalar integer expression",
3347 /* Further checking is not necessary because this SELECT was built
3348 by the compiler, so it should always be OK. Just move the
3349 case_expr from expr2 to expr so that we can handle computed
3350 GOTOs as normal SELECTs from here on. */
3351 code->expr = code->expr2;
3356 case_expr = code->expr;
3358 type = case_expr->ts.type;
3359 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3361 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3362 &case_expr->where, gfc_typename (&case_expr->ts));
3364 /* Punt. Going on here just produce more garbage error messages. */
3368 if (case_expr->rank != 0)
3370 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3371 "expression", &case_expr->where);
3377 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3378 of the SELECT CASE expression and its CASE values. Walk the lists
3379 of case values, and if we find a mismatch, promote case_expr to
3380 the appropriate kind. */
3382 if (type == BT_LOGICAL || type == BT_INTEGER)
3384 for (body = code->block; body; body = body->block)
3386 /* Walk the case label list. */
3387 for (cp = body->ext.case_list; cp; cp = cp->next)
3389 /* Intercept the DEFAULT case. It does not have a kind. */
3390 if (cp->low == NULL && cp->high == NULL)
3393 /* Unreachable case ranges are discarded, so ignore. */
3394 if (cp->low != NULL && cp->high != NULL
3395 && cp->low != cp->high
3396 && gfc_compare_expr (cp->low, cp->high) > 0)
3399 /* FIXME: Should a warning be issued? */
3401 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3402 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3404 if (cp->high != NULL
3405 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3406 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3411 /* Assume there is no DEFAULT case. */
3412 default_case = NULL;
3416 for (body = code->block; body; body = body->block)
3418 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3420 seen_unreachable = 0;
3422 /* Walk the case label list, making sure that all case labels
3424 for (cp = body->ext.case_list; cp; cp = cp->next)
3426 /* Count the number of cases in the whole construct. */
3429 /* Intercept the DEFAULT case. */
3430 if (cp->low == NULL && cp->high == NULL)
3432 if (default_case != NULL)
3434 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3435 "by a second DEFAULT CASE at %L",
3436 &default_case->where, &cp->where);
3447 /* Deal with single value cases and case ranges. Errors are
3448 issued from the validation function. */
3449 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3450 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3456 if (type == BT_LOGICAL
3457 && ((cp->low == NULL || cp->high == NULL)
3458 || cp->low != cp->high))
3461 ("Logical range in CASE statement at %L is not allowed",
3467 if (cp->low != NULL && cp->high != NULL
3468 && cp->low != cp->high
3469 && gfc_compare_expr (cp->low, cp->high) > 0)
3471 if (gfc_option.warn_surprising)
3472 gfc_warning ("Range specification at %L can never "
3473 "be matched", &cp->where);
3475 cp->unreachable = 1;
3476 seen_unreachable = 1;
3480 /* If the case range can be matched, it can also overlap with
3481 other cases. To make sure it does not, we put it in a
3482 double linked list here. We sort that with a merge sort
3483 later on to detect any overlapping cases. */
3487 head->right = head->left = NULL;
3492 tail->right->left = tail;
3499 /* It there was a failure in the previous case label, give up
3500 for this case label list. Continue with the next block. */
3504 /* See if any case labels that are unreachable have been seen.
3505 If so, we eliminate them. This is a bit of a kludge because
3506 the case lists for a single case statement (label) is a
3507 single forward linked lists. */
3508 if (seen_unreachable)
3510 /* Advance until the first case in the list is reachable. */
3511 while (body->ext.case_list != NULL
3512 && body->ext.case_list->unreachable)
3514 gfc_case *n = body->ext.case_list;
3515 body->ext.case_list = body->ext.case_list->next;
3517 gfc_free_case_list (n);
3520 /* Strip all other unreachable cases. */
3521 if (body->ext.case_list)
3523 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3525 if (cp->next->unreachable)
3527 gfc_case *n = cp->next;
3528 cp->next = cp->next->next;
3530 gfc_free_case_list (n);
3537 /* See if there were overlapping cases. If the check returns NULL,
3538 there was overlap. In that case we don't do anything. If head
3539 is non-NULL, we prepend the DEFAULT case. The sorted list can
3540 then used during code generation for SELECT CASE constructs with
3541 a case expression of a CHARACTER type. */
3544 head = check_case_overlap (head);
3546 /* Prepend the default_case if it is there. */
3547 if (head != NULL && default_case)
3549 default_case->left = NULL;
3550 default_case->right = head;
3551 head->left = default_case;
3555 /* Eliminate dead blocks that may be the result if we've seen
3556 unreachable case labels for a block. */
3557 for (body = code; body && body->block; body = body->block)
3559 if (body->block->ext.case_list == NULL)
3561 /* Cut the unreachable block from the code chain. */
3562 gfc_code *c = body->block;
3563 body->block = c->block;
3565 /* Kill the dead block, but not the blocks below it. */
3567 gfc_free_statements (c);
3571 /* More than two cases is legal but insane for logical selects.
3572 Issue a warning for it. */
3573 if (gfc_option.warn_surprising && type == BT_LOGICAL
3575 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3580 /* Resolve a transfer statement. This is making sure that:
3581 -- a derived type being transferred has only non-pointer components
3582 -- a derived type being transferred doesn't have private components, unless
3583 it's being transferred from the module where the type was defined
3584 -- we're not trying to transfer a whole assumed size array. */
3587 resolve_transfer (gfc_code * code)
3596 if (exp->expr_type != EXPR_VARIABLE)
3599 sym = exp->symtree->n.sym;
3602 /* Go to actual component transferred. */
3603 for (ref = code->expr->ref; ref; ref = ref->next)
3604 if (ref->type == REF_COMPONENT)
3605 ts = &ref->u.c.component->ts;
3607 if (ts->type == BT_DERIVED)
3609 /* Check that transferred derived type doesn't contain POINTER
3611 if (derived_pointer (ts->derived))
3613 gfc_error ("Data transfer element at %L cannot have "
3614 "POINTER components", &code->loc);
3618 if (derived_inaccessible (ts->derived))
3620 gfc_error ("Data transfer element at %L cannot have "
3621 "PRIVATE components",&code->loc);
3626 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3627 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3629 gfc_error ("Data transfer element at %L cannot be a full reference to "
3630 "an assumed-size array", &code->loc);
3636 /*********** Toplevel code resolution subroutines ***********/
3638 /* Given a branch to a label and a namespace, if the branch is conforming.
3639 The code node described where the branch is located. */
3642 resolve_branch (gfc_st_label * label, gfc_code * code)
3644 gfc_code *block, *found;
3652 /* Step one: is this a valid branching target? */
3654 if (lp->defined == ST_LABEL_UNKNOWN)
3656 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3661 if (lp->defined != ST_LABEL_TARGET)
3663 gfc_error ("Statement at %L is not a valid branch target statement "
3664 "for the branch statement at %L", &lp->where, &code->loc);
3668 /* Step two: make sure this branch is not a branch to itself ;-) */
3670 if (code->here == label)
3672 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3676 /* Step three: Try to find the label in the parse tree. To do this,
3677 we traverse the tree block-by-block: first the block that
3678 contains this GOTO, then the block that it is nested in, etc. We
3679 can ignore other blocks because branching into another block is
3684 for (stack = cs_base; stack; stack = stack->prev)
3686 for (block = stack->head; block; block = block->next)
3688 if (block->here == label)
3701 /* The label is not in an enclosing block, so illegal. This was
3702 allowed in Fortran 66, so we allow it as extension. We also
3703 forego further checks if we run into this. */
3704 gfc_notify_std (GFC_STD_LEGACY,
3705 "Label at %L is not in the same block as the "
3706 "GOTO statement at %L", &lp->where, &code->loc);
3710 /* Step four: Make sure that the branching target is legal if
3711 the statement is an END {SELECT,DO,IF}. */
3713 if (found->op == EXEC_NOP)
3715 for (stack = cs_base; stack; stack = stack->prev)
3716 if (stack->current->next == found)
3720 gfc_notify_std (GFC_STD_F95_DEL,
3721 "Obsolete: GOTO at %L jumps to END of construct at %L",
3722 &code->loc, &found->loc);
3727 /* Check whether EXPR1 has the same shape as EXPR2. */
3730 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3732 mpz_t shape[GFC_MAX_DIMENSIONS];
3733 mpz_t shape2[GFC_MAX_DIMENSIONS];
3734 try result = FAILURE;
3737 /* Compare the rank. */
3738 if (expr1->rank != expr2->rank)
3741 /* Compare the size of each dimension. */
3742 for (i=0; i<expr1->rank; i++)
3744 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3747 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3750 if (mpz_cmp (shape[i], shape2[i]))
3754 /* When either of the two expression is an assumed size array, we
3755 ignore the comparison of dimension sizes. */
3760 for (i--; i>=0; i--)
3762 mpz_clear (shape[i]);
3763 mpz_clear (shape2[i]);
3769 /* Check whether a WHERE assignment target or a WHERE mask expression
3770 has the same shape as the outmost WHERE mask expression. */
3773 resolve_where (gfc_code *code, gfc_expr *mask)
3779 cblock = code->block;
3781 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3782 In case of nested WHERE, only the outmost one is stored. */
3783 if (mask == NULL) /* outmost WHERE */
3785 else /* inner WHERE */
3792 /* Check if the mask-expr has a consistent shape with the
3793 outmost WHERE mask-expr. */
3794 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3795 gfc_error ("WHERE mask at %L has inconsistent shape",
3796 &cblock->expr->where);
3799 /* the assignment statement of a WHERE statement, or the first
3800 statement in where-body-construct of a WHERE construct */
3801 cnext = cblock->next;
3806 /* WHERE assignment statement */
3809 /* Check shape consistent for WHERE assignment target. */
3810 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3811 gfc_error ("WHERE assignment target at %L has "
3812 "inconsistent shape", &cnext->expr->where);
3815 /* WHERE or WHERE construct is part of a where-body-construct */
3817 resolve_where (cnext, e);
3821 gfc_error ("Unsupported statement inside WHERE at %L",
3824 /* the next statement within the same where-body-construct */
3825 cnext = cnext->next;
3827 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3828 cblock = cblock->block;
3833 /* Check whether the FORALL index appears in the expression or not. */
3836 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3840 gfc_actual_arglist *args;
3843 switch (expr->expr_type)
3846 gcc_assert (expr->symtree->n.sym);
3848 /* A scalar assignment */
3851 if (expr->symtree->n.sym == symbol)
3857 /* the expr is array ref, substring or struct component. */
3864 /* Check if the symbol appears in the array subscript. */
3866 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3869 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3873 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3877 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3883 if (expr->symtree->n.sym == symbol)
3886 /* Check if the symbol appears in the substring section. */
3887 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3889 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3897 gfc_error("expresion reference type error at %L", &expr->where);
3903 /* If the expression is a function call, then check if the symbol
3904 appears in the actual arglist of the function. */
3906 for (args = expr->value.function.actual; args; args = args->next)
3908 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3913 /* It seems not to happen. */
3914 case EXPR_SUBSTRING:
3918 gcc_assert (expr->ref->type == REF_SUBSTRING);
3919 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3921 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3926 /* It seems not to happen. */
3927 case EXPR_STRUCTURE:
3929 gfc_error ("Unsupported statement while finding forall index in "
3934 /* Find the FORALL index in the first operand. */
3935 if (expr->value.op.op1)
3937 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3941 /* Find the FORALL index in the second operand. */
3942 if (expr->value.op.op2)
3944 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3957 /* Resolve assignment in FORALL construct.
3958 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3959 FORALL index variables. */
3962 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3966 for (n = 0; n < nvar; n++)
3968 gfc_symbol *forall_index;
3970 forall_index = var_expr[n]->symtree->n.sym;
3972 /* Check whether the assignment target is one of the FORALL index
3974 if ((code->expr->expr_type == EXPR_VARIABLE)
3975 && (code->expr->symtree->n.sym == forall_index))
3976 gfc_error ("Assignment to a FORALL index variable at %L",
3977 &code->expr->where);
3980 /* If one of the FORALL index variables doesn't appear in the
3981 assignment target, then there will be a many-to-one
3983 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3984 gfc_error ("The FORALL with index '%s' cause more than one "
3985 "assignment to this object at %L",
3986 var_expr[n]->symtree->name, &code->expr->where);
3992 /* Resolve WHERE statement in FORALL construct. */
3995 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3999 cblock = code->block;
4002 /* the assignment statement of a WHERE statement, or the first
4003 statement in where-body-construct of a WHERE construct */
4004 cnext = cblock->next;
4009 /* WHERE assignment statement */
4011 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4014 /* WHERE or WHERE construct is part of a where-body-construct */
4016 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4020 gfc_error ("Unsupported statement inside WHERE at %L",
4023 /* the next statement within the same where-body-construct */
4024 cnext = cnext->next;
4026 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4027 cblock = cblock->block;
4032 /* Traverse the FORALL body to check whether the following errors exist:
4033 1. For assignment, check if a many-to-one assignment happens.
4034 2. For WHERE statement, check the WHERE body to see if there is any
4035 many-to-one assignment. */
4038 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4042 c = code->block->next;
4048 case EXEC_POINTER_ASSIGN:
4049 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4052 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4053 there is no need to handle it here. */
4057 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4062 /* The next statement in the FORALL body. */
4068 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4069 gfc_resolve_forall_body to resolve the FORALL body. */
4072 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4074 static gfc_expr **var_expr;
4075 static int total_var = 0;
4076 static int nvar = 0;
4077 gfc_forall_iterator *fa;
4078 gfc_symbol *forall_index;
4082 /* Start to resolve a FORALL construct */
4083 if (forall_save == 0)
4085 /* Count the total number of FORALL index in the nested FORALL
4086 construct in order to allocate the VAR_EXPR with proper size. */
4088 while ((next != NULL) && (next->op == EXEC_FORALL))
4090 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4092 next = next->block->next;
4095 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4096 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4099 /* The information about FORALL iterator, including FORALL index start, end
4100 and stride. The FORALL index can not appear in start, end or stride. */
4101 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4103 /* Check if any outer FORALL index name is the same as the current
4105 for (i = 0; i < nvar; i++)
4107 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4109 gfc_error ("An outer FORALL construct already has an index "
4110 "with this name %L", &fa->var->where);
4114 /* Record the current FORALL index. */
4115 var_expr[nvar] = gfc_copy_expr (fa->var);
4117 forall_index = fa->var->symtree->n.sym;
4119 /* Check if the FORALL index appears in start, end or stride. */
4120 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4121 gfc_error ("A FORALL index must not appear in a limit or stride "
4122 "expression in the same FORALL at %L", &fa->start->where);
4123 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4124 gfc_error ("A FORALL index must not appear in a limit or stride "
4125 "expression in the same FORALL at %L", &fa->end->where);
4126 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4127 gfc_error ("A FORALL index must not appear in a limit or stride "
4128 "expression in the same FORALL at %L", &fa->stride->where);
4132 /* Resolve the FORALL body. */
4133 gfc_resolve_forall_body (code, nvar, var_expr);
4135 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4136 gfc_resolve_blocks (code->block, ns);
4138 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4139 for (i = 0; i < total_var; i++)
4140 gfc_free_expr (var_expr[i]);
4142 /* Reset the counters. */
4148 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4151 static void resolve_code (gfc_code *, gfc_namespace *);
4154 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4158 for (; b; b = b->block)
4160 t = gfc_resolve_expr (b->expr);
4161 if (gfc_resolve_expr (b->expr2) == FAILURE)
4167 if (t == SUCCESS && b->expr != NULL
4168 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4170 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4177 && (b->expr->ts.type != BT_LOGICAL
4178 || b->expr->rank == 0))
4180 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4185 resolve_branch (b->label, b);
4197 case EXEC_OMP_ATOMIC:
4198 case EXEC_OMP_CRITICAL:
4200 case EXEC_OMP_MASTER:
4201 case EXEC_OMP_ORDERED:
4202 case EXEC_OMP_PARALLEL:
4203 case EXEC_OMP_PARALLEL_DO:
4204 case EXEC_OMP_PARALLEL_SECTIONS:
4205 case EXEC_OMP_PARALLEL_WORKSHARE:
4206 case EXEC_OMP_SECTIONS:
4207 case EXEC_OMP_SINGLE:
4208 case EXEC_OMP_WORKSHARE:
4212 gfc_internal_error ("resolve_block(): Bad block type");
4215 resolve_code (b->next, ns);
4220 /* Given a block of code, recursively resolve everything pointed to by this
4224 resolve_code (gfc_code * code, gfc_namespace * ns)
4226 int omp_workshare_save;
4231 frame.prev = cs_base;
4235 for (; code; code = code->next)
4237 frame.current = code;
4239 if (code->op == EXEC_FORALL)
4241 int forall_save = forall_flag;
4244 gfc_resolve_forall (code, ns, forall_save);
4245 forall_flag = forall_save;
4247 else if (code->block)
4249 omp_workshare_save = -1;
4252 case EXEC_OMP_PARALLEL_WORKSHARE:
4253 omp_workshare_save = omp_workshare_flag;
4254 omp_workshare_flag = 1;
4255 gfc_resolve_omp_parallel_blocks (code, ns);
4257 case EXEC_OMP_PARALLEL:
4258 case EXEC_OMP_PARALLEL_DO:
4259 case EXEC_OMP_PARALLEL_SECTIONS:
4260 omp_workshare_save = omp_workshare_flag;
4261 omp_workshare_flag = 0;
4262 gfc_resolve_omp_parallel_blocks (code, ns);
4265 gfc_resolve_omp_do_blocks (code, ns);
4267 case EXEC_OMP_WORKSHARE:
4268 omp_workshare_save = omp_workshare_flag;
4269 omp_workshare_flag = 1;
4272 gfc_resolve_blocks (code->block, ns);
4276 if (omp_workshare_save != -1)
4277 omp_workshare_flag = omp_workshare_save;
4280 t = gfc_resolve_expr (code->expr);
4281 if (gfc_resolve_expr (code->expr2) == FAILURE)
4297 resolve_where (code, NULL);
4301 if (code->expr != NULL)
4303 if (code->expr->ts.type != BT_INTEGER)
4304 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4305 "variable", &code->expr->where);
4306 else if (code->expr->symtree->n.sym->attr.assign != 1)
4307 gfc_error ("Variable '%s' has not been assigned a target label "
4308 "at %L", code->expr->symtree->n.sym->name,
4309 &code->expr->where);
4312 resolve_branch (code->label, code);
4316 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4317 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4318 "return specifier", &code->expr->where);
4325 if (gfc_extend_assign (code, ns) == SUCCESS)
4327 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4329 gfc_error ("Subroutine '%s' called instead of assignment at "
4330 "%L must be PURE", code->symtree->n.sym->name,
4337 if (gfc_pure (NULL))
4339 if (gfc_impure_variable (code->expr->symtree->n.sym))
4342 ("Cannot assign to variable '%s' in PURE procedure at %L",
4343 code->expr->symtree->n.sym->name, &code->expr->where);
4347 if (code->expr2->ts.type == BT_DERIVED
4348 && derived_pointer (code->expr2->ts.derived))
4351 ("Right side of assignment at %L is a derived type "
4352 "containing a POINTER in a PURE procedure",
4353 &code->expr2->where);
4358 gfc_check_assign (code->expr, code->expr2, 1);
4361 case EXEC_LABEL_ASSIGN:
4362 if (code->label->defined == ST_LABEL_UNKNOWN)
4363 gfc_error ("Label %d referenced at %L is never defined",
4364 code->label->value, &code->label->where);
4366 && (code->expr->expr_type != EXPR_VARIABLE
4367 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4368 || code->expr->symtree->n.sym->ts.kind
4369 != gfc_default_integer_kind
4370 || code->expr->symtree->n.sym->as != NULL))
4371 gfc_error ("ASSIGN statement at %L requires a scalar "
4372 "default INTEGER variable", &code->expr->where);
4375 case EXEC_POINTER_ASSIGN:
4379 gfc_check_pointer_assign (code->expr, code->expr2);
4382 case EXEC_ARITHMETIC_IF:
4384 && code->expr->ts.type != BT_INTEGER
4385 && code->expr->ts.type != BT_REAL)
4386 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4387 "expression", &code->expr->where);
4389 resolve_branch (code->label, code);
4390 resolve_branch (code->label2, code);
4391 resolve_branch (code->label3, code);
4395 if (t == SUCCESS && code->expr != NULL
4396 && (code->expr->ts.type != BT_LOGICAL
4397 || code->expr->rank != 0))
4398 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4399 &code->expr->where);
4404 resolve_call (code);
4408 /* Select is complicated. Also, a SELECT construct could be
4409 a transformed computed GOTO. */
4410 resolve_select (code);
4414 if (code->ext.iterator != NULL)
4416 gfc_iterator *iter = code->ext.iterator;
4417 if (gfc_resolve_iterator (iter, true) != FAILURE)
4418 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4423 if (code->expr == NULL)
4424 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4426 && (code->expr->rank != 0
4427 || code->expr->ts.type != BT_LOGICAL))
4428 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4429 "a scalar LOGICAL expression", &code->expr->where);
4433 if (t == SUCCESS && code->expr != NULL
4434 && code->expr->ts.type != BT_INTEGER)
4435 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4436 "of type INTEGER", &code->expr->where);
4438 for (a = code->ext.alloc_list; a; a = a->next)
4439 resolve_allocate_expr (a->expr, code);
4443 case EXEC_DEALLOCATE:
4444 if (t == SUCCESS && code->expr != NULL
4445 && code->expr->ts.type != BT_INTEGER)
4447 ("STAT tag in DEALLOCATE statement at %L must be of type "
4448 "INTEGER", &code->expr->where);
4450 for (a = code->ext.alloc_list; a; a = a->next)
4451 resolve_deallocate_expr (a->expr);
4456 if (gfc_resolve_open (code->ext.open) == FAILURE)
4459 resolve_branch (code->ext.open->err, code);
4463 if (gfc_resolve_close (code->ext.close) == FAILURE)
4466 resolve_branch (code->ext.close->err, code);
4469 case EXEC_BACKSPACE:
4473 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4476 resolve_branch (code->ext.filepos->err, code);
4480 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4483 resolve_branch (code->ext.inquire->err, code);
4487 gcc_assert (code->ext.inquire != NULL);
4488 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4491 resolve_branch (code->ext.inquire->err, code);
4496 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4499 resolve_branch (code->ext.dt->err, code);
4500 resolve_branch (code->ext.dt->end, code);
4501 resolve_branch (code->ext.dt->eor, code);
4505 resolve_transfer (code);
4509 resolve_forall_iterators (code->ext.forall_iterator);
4511 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4513 ("FORALL mask clause at %L requires a LOGICAL expression",
4514 &code->expr->where);
4517 case EXEC_OMP_ATOMIC:
4518 case EXEC_OMP_BARRIER:
4519 case EXEC_OMP_CRITICAL:
4520 case EXEC_OMP_FLUSH:
4522 case EXEC_OMP_MASTER:
4523 case EXEC_OMP_ORDERED:
4524 case EXEC_OMP_SECTIONS:
4525 case EXEC_OMP_SINGLE:
4526 case EXEC_OMP_WORKSHARE:
4527 gfc_resolve_omp_directive (code, ns);
4530 case EXEC_OMP_PARALLEL:
4531 case EXEC_OMP_PARALLEL_DO:
4532 case EXEC_OMP_PARALLEL_SECTIONS:
4533 case EXEC_OMP_PARALLEL_WORKSHARE:
4534 omp_workshare_save = omp_workshare_flag;
4535 omp_workshare_flag = 0;
4536 gfc_resolve_omp_directive (code, ns);
4537 omp_workshare_flag = omp_workshare_save;
4541 gfc_internal_error ("resolve_code(): Bad statement code");
4545 cs_base = frame.prev;
4549 /* Resolve initial values and make sure they are compatible with
4553 resolve_values (gfc_symbol * sym)
4556 if (sym->value == NULL)
4559 if (gfc_resolve_expr (sym->value) == FAILURE)
4562 gfc_check_assign_symbol (sym, sym->value);
4566 /* Resolve an index expression. */
4569 resolve_index_expr (gfc_expr * e)
4572 if (gfc_resolve_expr (e) == FAILURE)
4575 if (gfc_simplify_expr (e, 0) == FAILURE)
4578 if (gfc_specification_expr (e) == FAILURE)
4584 /* Resolve a charlen structure. */
4587 resolve_charlen (gfc_charlen *cl)
4594 if (resolve_index_expr (cl->length) == FAILURE)
4601 /* Resolution of common features of flavors variable and procedure. */
4604 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
4606 /* Constraints on deferred shape variable. */
4607 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4609 if (sym->attr.allocatable)
4611 if (sym->attr.dimension)
4612 gfc_error ("Allocatable array '%s' at %L must have "
4613 "a deferred shape", sym->name, &sym->declared_at);
4615 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4616 sym->name, &sym->declared_at);
4620 if (sym->attr.pointer && sym->attr.dimension)
4622 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4623 sym->name, &sym->declared_at);
4630 if (!mp_flag && !sym->attr.allocatable
4631 && !sym->attr.pointer && !sym->attr.dummy)
4633 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4634 sym->name, &sym->declared_at);
4641 /* Resolve symbols with flavor variable. */
4644 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
4649 gfc_expr *constructor_expr;
4651 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4654 /* The shape of a main program or module array needs to be constant. */
4656 && sym->ns->proc_name
4657 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4658 || sym->ns->proc_name->attr.is_main_program)
4659 && !sym->attr.use_assoc
4660 && !sym->attr.allocatable
4661 && !sym->attr.pointer)
4663 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
4664 has not been simplified; parameter array references. Do the
4665 simplification now. */
4667 for (i = 0; i < sym->as->rank; i++)
4669 e = sym->as->lower[i];
4670 if (e && (resolve_index_expr (e) == FAILURE
4671 || !gfc_is_constant_expr (e)))
4677 e = sym->as->upper[i];
4678 if (e && (resolve_index_expr (e) == FAILURE
4679 || !gfc_is_constant_expr (e)))
4688 gfc_error ("The module or main program array '%s' at %L must "
4689 "have constant shape", sym->name, &sym->declared_at);
4694 if (sym->ts.type == BT_CHARACTER)
4696 /* Make sure that character string variables with assumed length are
4698 e = sym->ts.cl->length;
4699 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
4701 gfc_error ("Entity with assumed character length at %L must be a "
4702 "dummy argument or a PARAMETER", &sym->declared_at);
4706 if (!gfc_is_constant_expr (e)
4707 && !(e->expr_type == EXPR_VARIABLE
4708 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
4709 && sym->ns->proc_name
4710 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4711 || sym->ns->proc_name->attr.is_main_program)
4712 && !sym->attr.use_assoc)
4714 gfc_error ("'%s' at %L must have constant character length "
4715 "in this context", sym->name, &sym->declared_at);
4720 /* Can the symbol have an initializer? */
4722 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4723 || sym->attr.intrinsic || sym->attr.result)
4725 else if (sym->attr.dimension && !sym->attr.pointer)
4727 /* Don't allow initialization of automatic arrays. */
4728 for (i = 0; i < sym->as->rank; i++)
4730 if (sym->as->lower[i] == NULL
4731 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4732 || sym->as->upper[i] == NULL
4733 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4741 /* Reject illegal initializers. */
4742 if (sym->value && flag)
4744 if (sym->attr.allocatable)
4745 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4746 sym->name, &sym->declared_at);
4747 else if (sym->attr.external)
4748 gfc_error ("External '%s' at %L cannot have an initializer",
4749 sym->name, &sym->declared_at);
4750 else if (sym->attr.dummy)
4751 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4752 sym->name, &sym->declared_at);
4753 else if (sym->attr.intrinsic)
4754 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4755 sym->name, &sym->declared_at);
4756 else if (sym->attr.result)
4757 gfc_error ("Function result '%s' at %L cannot have an initializer",
4758 sym->name, &sym->declared_at);
4760 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4761 sym->name, &sym->declared_at);
4765 /* 4th constraint in section 11.3: "If an object of a type for which
4766 component-initialization is specified (R429) appears in the
4767 specification-part of a module and does not have the ALLOCATABLE
4768 or POINTER attribute, the object shall have the SAVE attribute." */
4770 constructor_expr = NULL;
4771 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
4772 constructor_expr = gfc_default_initializer (&sym->ts);
4774 if (sym->ns->proc_name
4775 && sym->ns->proc_name->attr.flavor == FL_MODULE
4777 && !sym->ns->save_all && !sym->attr.save
4778 && !sym->attr.pointer && !sym->attr.allocatable)
4780 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4781 sym->name, &sym->declared_at,
4782 "for default initialization of a component");
4786 /* Assign default initializer. */
4787 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4788 && !sym->attr.pointer)
4789 sym->value = gfc_default_initializer (&sym->ts);
4795 /* Resolve a procedure. */
4798 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
4800 gfc_formal_arglist *arg;
4802 if (sym->attr.function
4803 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4806 if (sym->attr.proc == PROC_ST_FUNCTION)
4808 if (sym->ts.type == BT_CHARACTER)
4810 gfc_charlen *cl = sym->ts.cl;
4811 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4813 gfc_error ("Character-valued statement function '%s' at %L must "
4814 "have constant length", sym->name, &sym->declared_at);
4820 /* Ensure that derived type formal arguments of a public procedure
4821 are not of a private type. */
4822 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4824 for (arg = sym->formal; arg; arg = arg->next)
4827 && arg->sym->ts.type == BT_DERIVED
4828 && !arg->sym->ts.derived->attr.use_assoc
4829 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4830 arg->sym->ts.derived->ns->default_access))
4832 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
4833 "a dummy argument of '%s', which is "
4834 "PUBLIC at %L", arg->sym->name, sym->name,
4836 /* Stop this message from recurring. */
4837 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4843 /* An external symbol may not have an intializer because it is taken to be
4845 if (sym->attr.external && sym->value)
4847 gfc_error ("External object '%s' at %L may not have an initializer",
4848 sym->name, &sym->declared_at);
4852 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4853 char-len-param shall not be array-valued, pointer-valued, recursive
4854 or pure. ....snip... A character value of * may only be used in the
4855 following ways: (i) Dummy arg of procedure - dummy associates with
4856 actual length; (ii) To declare a named constant; or (iii) External
4857 function - but length must be declared in calling scoping unit. */
4858 if (sym->attr.function
4859 && sym->ts.type == BT_CHARACTER
4860 && sym->ts.cl && sym->ts.cl->length == NULL)
4862 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
4863 || (sym->attr.recursive) || (sym->attr.pure))
4865 if (sym->as && sym->as->rank)
4866 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4867 "array-valued", sym->name, &sym->declared_at);
4869 if (sym->attr.pointer)
4870 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4871 "pointer-valued", sym->name, &sym->declared_at);
4874 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4875 "pure", sym->name, &sym->declared_at);
4877 if (sym->attr.recursive)
4878 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4879 "recursive", sym->name, &sym->declared_at);
4884 /* Appendix B.2 of the standard. Contained functions give an
4885 error anyway. Fixed-form is likely to be F77/legacy. */
4886 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
4887 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
4888 "'%s' at %L is obsolescent in fortran 95",
4889 sym->name, &sym->declared_at);
4895 /* Resolve the components of a derived type. */
4898 resolve_fl_derived (gfc_symbol *sym)
4901 gfc_dt_list * dt_list;
4904 for (c = sym->components; c != NULL; c = c->next)
4906 if (c->ts.type == BT_CHARACTER)
4908 if (c->ts.cl->length == NULL
4909 || (resolve_charlen (c->ts.cl) == FAILURE)
4910 || !gfc_is_constant_expr (c->ts.cl->length))
4912 gfc_error ("Character length of component '%s' needs to "
4913 "be a constant specification expression at %L.",
4915 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
4920 if (c->ts.type == BT_DERIVED
4921 && sym->component_access != ACCESS_PRIVATE
4922 && gfc_check_access(sym->attr.access, sym->ns->default_access)
4923 && !c->ts.derived->attr.use_assoc
4924 && !gfc_check_access(c->ts.derived->attr.access,
4925 c->ts.derived->ns->default_access))
4927 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4928 "a component of '%s', which is PUBLIC at %L",
4929 c->name, sym->name, &sym->declared_at);
4933 if (c->pointer || c->as == NULL)
4936 for (i = 0; i < c->as->rank; i++)
4938 if (c->as->lower[i] == NULL
4939 || !gfc_is_constant_expr (c->as->lower[i])
4940 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
4941 || c->as->upper[i] == NULL
4942 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
4943 || !gfc_is_constant_expr (c->as->upper[i]))
4945 gfc_error ("Component '%s' of '%s' at %L must have "
4946 "constant array bounds.",
4947 c->name, sym->name, &c->loc);
4953 /* Add derived type to the derived type list. */
4954 dt_list = gfc_get_dt_list ();
4955 dt_list->next = sym->ns->derived_types;
4956 dt_list->derived = sym;
4957 sym->ns->derived_types = dt_list;
4964 resolve_fl_parameter (gfc_symbol *sym)
4966 /* A parameter array's shape needs to be constant. */
4967 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
4969 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4970 "or assumed shape", sym->name, &sym->declared_at);
4974 /* Make sure a parameter that has been implicitly typed still
4975 matches the implicit type, since PARAMETER statements can precede
4976 IMPLICIT statements. */
4977 if (sym->attr.implicit_type
4978 && !gfc_compare_types (&sym->ts,
4979 gfc_get_default_type (sym, sym->ns)))
4981 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4982 "later IMPLICIT type", sym->name, &sym->declared_at);
4986 /* Make sure the types of derived parameters are consistent. This
4987 type checking is deferred until resolution because the type may
4988 refer to a derived type from the host. */
4989 if (sym->ts.type == BT_DERIVED
4990 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4992 gfc_error ("Incompatible derived type in PARAMETER at %L",
4993 &sym->value->where);
5000 /* Do anything necessary to resolve a symbol. Right now, we just
5001 assume that an otherwise unknown symbol is a variable. This sort
5002 of thing commonly happens for symbols in module. */
5005 resolve_symbol (gfc_symbol * sym)
5007 /* Zero if we are checking a formal namespace. */
5008 static int formal_ns_flag = 1;
5009 int formal_ns_save, check_constant, mp_flag;
5011 gfc_symtree *symtree;
5012 gfc_symtree *this_symtree;
5016 if (sym->attr.flavor == FL_UNKNOWN)
5019 /* If we find that a flavorless symbol is an interface in one of the
5020 parent namespaces, find its symtree in this namespace, free the
5021 symbol and set the symtree to point to the interface symbol. */
5022 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5024 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5025 if (symtree && symtree->n.sym->generic)
5027 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5031 gfc_free_symbol (sym);
5032 symtree->n.sym->refs++;
5033 this_symtree->n.sym = symtree->n.sym;
5038 /* Otherwise give it a flavor according to such attributes as
5040 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5041 sym->attr.flavor = FL_VARIABLE;
5044 sym->attr.flavor = FL_PROCEDURE;
5045 if (sym->attr.dimension)
5046 sym->attr.function = 1;
5050 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5053 /* Symbols that are module procedures with results (functions) have
5054 the types and array specification copied for type checking in
5055 procedures that call them, as well as for saving to a module
5056 file. These symbols can't stand the scrutiny that their results
5058 mp_flag = (sym->result != NULL && sym->result != sym);
5060 /* Assign default type to symbols that need one and don't have one. */
5061 if (sym->ts.type == BT_UNKNOWN)
5063 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5064 gfc_set_default_type (sym, 1, NULL);
5066 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5068 /* The specific case of an external procedure should emit an error
5069 in the case that there is no implicit type. */
5071 gfc_set_default_type (sym, sym->attr.external, NULL);
5074 /* Result may be in another namespace. */
5075 resolve_symbol (sym->result);
5077 sym->ts = sym->result->ts;
5078 sym->as = gfc_copy_array_spec (sym->result->as);
5079 sym->attr.dimension = sym->result->attr.dimension;
5080 sym->attr.pointer = sym->result->attr.pointer;
5085 /* Assumed size arrays and assumed shape arrays must be dummy
5089 && (sym->as->type == AS_ASSUMED_SIZE
5090 || sym->as->type == AS_ASSUMED_SHAPE)
5091 && sym->attr.dummy == 0)
5093 if (sym->as->type == AS_ASSUMED_SIZE)
5094 gfc_error ("Assumed size array at %L must be a dummy argument",
5097 gfc_error ("Assumed shape array at %L must be a dummy argument",
5102 /* Make sure symbols with known intent or optional are really dummy
5103 variable. Because of ENTRY statement, this has to be deferred
5104 until resolution time. */
5106 if (!sym->attr.dummy
5107 && (sym->attr.optional
5108 || sym->attr.intent != INTENT_UNKNOWN))
5110 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5114 /* If a derived type symbol has reached this point, without its
5115 type being declared, we have an error. Notice that most
5116 conditions that produce undefined derived types have already
5117 been dealt with. However, the likes of:
5118 implicit type(t) (t) ..... call foo (t) will get us here if
5119 the type is not declared in the scope of the implicit
5120 statement. Change the type to BT_UNKNOWN, both because it is so
5121 and to prevent an ICE. */
5122 if (sym->ts.type == BT_DERIVED
5123 && sym->ts.derived->components == NULL)
5125 gfc_error ("The derived type '%s' at %L is of type '%s', "
5126 "which has not been defined.", sym->name,
5127 &sym->declared_at, sym->ts.derived->name);
5128 sym->ts.type = BT_UNKNOWN;
5132 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5133 default initialization is defined (5.1.2.4.4). */
5134 if (sym->ts.type == BT_DERIVED
5136 && sym->attr.intent == INTENT_OUT
5138 && sym->as->type == AS_ASSUMED_SIZE)
5140 for (c = sym->ts.derived->components; c; c = c->next)
5144 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5145 "ASSUMED SIZE and so cannot have a default initializer",
5146 sym->name, &sym->declared_at);
5152 switch (sym->attr.flavor)
5155 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5160 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5165 /* Reject PRIVATE objects in a PUBLIC namelist. */
5166 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5168 for (nl = sym->namelist; nl; nl = nl->next)
5170 if (!nl->sym->attr.use_assoc
5172 !(sym->ns->parent == nl->sym->ns)
5174 !gfc_check_access(nl->sym->attr.access,
5175 nl->sym->ns->default_access))
5176 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5177 "PUBLIC namelist at %L", nl->sym->name,
5185 if (resolve_fl_parameter (sym) == FAILURE)
5196 /* Make sure that intrinsic exist */
5197 if (sym->attr.intrinsic
5198 && ! gfc_intrinsic_name(sym->name, 0)
5199 && ! gfc_intrinsic_name(sym->name, 1))
5200 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5202 /* Resolve array specifier. Check as well some constraints
5203 on COMMON blocks. */
5205 check_constant = sym->attr.in_common && !sym->attr.pointer;
5206 gfc_resolve_array_spec (sym->as, check_constant);
5208 /* Resolve formal namespaces. */
5210 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5212 formal_ns_save = formal_ns_flag;
5214 gfc_resolve (sym->formal_ns);
5215 formal_ns_flag = formal_ns_save;
5218 /* Check threadprivate restrictions. */
5219 if (sym->attr.threadprivate && !sym->attr.save
5220 && (!sym->attr.in_common
5221 && sym->module == NULL
5222 && (sym->ns->proc_name == NULL
5223 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5224 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5229 /************* Resolve DATA statements *************/
5233 gfc_data_value *vnode;
5239 /* Advance the values structure to point to the next value in the data list. */
5242 next_data_value (void)
5244 while (values.left == 0)
5246 if (values.vnode->next == NULL)
5249 values.vnode = values.vnode->next;
5250 values.left = values.vnode->repeat;
5258 check_data_variable (gfc_data_variable * var, locus * where)
5264 ar_type mark = AR_UNKNOWN;
5266 mpz_t section_index[GFC_MAX_DIMENSIONS];
5270 if (gfc_resolve_expr (var->expr) == FAILURE)
5274 mpz_init_set_si (offset, 0);
5277 if (e->expr_type != EXPR_VARIABLE)
5278 gfc_internal_error ("check_data_variable(): Bad expression");
5280 if (e->symtree->n.sym->ns->is_block_data
5281 && !e->symtree->n.sym->attr.in_common)
5283 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5284 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5289 mpz_init_set_ui (size, 1);
5296 /* Find the array section reference. */
5297 for (ref = e->ref; ref; ref = ref->next)
5299 if (ref->type != REF_ARRAY)
5301 if (ref->u.ar.type == AR_ELEMENT)
5307 /* Set marks according to the reference pattern. */
5308 switch (ref->u.ar.type)
5316 /* Get the start position of array section. */
5317 gfc_get_section_index (ar, section_index, &offset);
5325 if (gfc_array_size (e, &size) == FAILURE)
5327 gfc_error ("Nonconstant array section at %L in DATA statement",
5336 while (mpz_cmp_ui (size, 0) > 0)
5338 if (next_data_value () == FAILURE)
5340 gfc_error ("DATA statement at %L has more variables than values",
5346 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5350 /* If we have more than one element left in the repeat count,
5351 and we have more than one element left in the target variable,
5352 then create a range assignment. */
5353 /* ??? Only done for full arrays for now, since array sections
5355 if (mark == AR_FULL && ref && ref->next == NULL
5356 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5360 if (mpz_cmp_ui (size, values.left) >= 0)
5362 mpz_init_set_ui (range, values.left);
5363 mpz_sub_ui (size, size, values.left);
5368 mpz_init_set (range, size);
5369 values.left -= mpz_get_ui (size);
5370 mpz_set_ui (size, 0);
5373 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5376 mpz_add (offset, offset, range);
5380 /* Assign initial value to symbol. */
5384 mpz_sub_ui (size, size, 1);
5386 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5388 if (mark == AR_FULL)
5389 mpz_add_ui (offset, offset, 1);
5391 /* Modify the array section indexes and recalculate the offset
5392 for next element. */
5393 else if (mark == AR_SECTION)
5394 gfc_advance_section (section_index, ar, &offset);
5398 if (mark == AR_SECTION)
5400 for (i = 0; i < ar->dimen; i++)
5401 mpz_clear (section_index[i]);
5411 static try traverse_data_var (gfc_data_variable *, locus *);
5413 /* Iterate over a list of elements in a DATA statement. */
5416 traverse_data_list (gfc_data_variable * var, locus * where)
5419 iterator_stack frame;
5422 mpz_init (frame.value);
5424 mpz_init_set (trip, var->iter.end->value.integer);
5425 mpz_sub (trip, trip, var->iter.start->value.integer);
5426 mpz_add (trip, trip, var->iter.step->value.integer);
5428 mpz_div (trip, trip, var->iter.step->value.integer);
5430 mpz_set (frame.value, var->iter.start->value.integer);
5432 frame.prev = iter_stack;
5433 frame.variable = var->iter.var->symtree;
5434 iter_stack = &frame;
5436 while (mpz_cmp_ui (trip, 0) > 0)
5438 if (traverse_data_var (var->list, where) == FAILURE)
5444 e = gfc_copy_expr (var->expr);
5445 if (gfc_simplify_expr (e, 1) == FAILURE)
5451 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5453 mpz_sub_ui (trip, trip, 1);
5457 mpz_clear (frame.value);
5459 iter_stack = frame.prev;
5464 /* Type resolve variables in the variable list of a DATA statement. */
5467 traverse_data_var (gfc_data_variable * var, locus * where)
5471 for (; var; var = var->next)
5473 if (var->expr == NULL)
5474 t = traverse_data_list (var, where);
5476 t = check_data_variable (var, where);
5486 /* Resolve the expressions and iterators associated with a data statement.
5487 This is separate from the assignment checking because data lists should
5488 only be resolved once. */
5491 resolve_data_variables (gfc_data_variable * d)
5493 for (; d; d = d->next)
5495 if (d->list == NULL)
5497 if (gfc_resolve_expr (d->expr) == FAILURE)
5502 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5505 if (d->iter.start->expr_type != EXPR_CONSTANT
5506 || d->iter.end->expr_type != EXPR_CONSTANT
5507 || d->iter.step->expr_type != EXPR_CONSTANT)
5508 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5510 if (resolve_data_variables (d->list) == FAILURE)
5519 /* Resolve a single DATA statement. We implement this by storing a pointer to
5520 the value list into static variables, and then recursively traversing the
5521 variables list, expanding iterators and such. */
5524 resolve_data (gfc_data * d)
5526 if (resolve_data_variables (d->var) == FAILURE)
5529 values.vnode = d->value;
5530 values.left = (d->value == NULL) ? 0 : d->value->repeat;
5532 if (traverse_data_var (d->var, &d->where) == FAILURE)
5535 /* At this point, we better not have any values left. */
5537 if (next_data_value () == SUCCESS)
5538 gfc_error ("DATA statement at %L has more values than variables",
5543 /* Determines if a variable is not 'pure', ie not assignable within a pure
5544 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5548 gfc_impure_variable (gfc_symbol * sym)
5550 if (sym->attr.use_assoc || sym->attr.in_common)
5553 if (sym->ns != gfc_current_ns)
5554 return !sym->attr.function;
5556 /* TODO: Check storage association through EQUIVALENCE statements */
5562 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5563 symbol of the current procedure. */
5566 gfc_pure (gfc_symbol * sym)
5568 symbol_attribute attr;
5571 sym = gfc_current_ns->proc_name;
5577 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5581 /* Test whether the current procedure is elemental or not. */
5584 gfc_elemental (gfc_symbol * sym)
5586 symbol_attribute attr;
5589 sym = gfc_current_ns->proc_name;
5594 return attr.flavor == FL_PROCEDURE && attr.elemental;
5598 /* Warn about unused labels. */
5601 warn_unused_label (gfc_st_label * label)
5606 warn_unused_label (label->left);
5608 if (label->defined == ST_LABEL_UNKNOWN)
5611 switch (label->referenced)
5613 case ST_LABEL_UNKNOWN:
5614 gfc_warning ("Label %d at %L defined but not used", label->value,
5618 case ST_LABEL_BAD_TARGET:
5619 gfc_warning ("Label %d at %L defined but cannot be used",
5620 label->value, &label->where);
5627 warn_unused_label (label->right);
5631 /* Returns the sequence type of a symbol or sequence. */
5634 sequence_type (gfc_typespec ts)
5643 if (ts.derived->components == NULL)
5644 return SEQ_NONDEFAULT;
5646 result = sequence_type (ts.derived->components->ts);
5647 for (c = ts.derived->components->next; c; c = c->next)
5648 if (sequence_type (c->ts) != result)
5654 if (ts.kind != gfc_default_character_kind)
5655 return SEQ_NONDEFAULT;
5657 return SEQ_CHARACTER;
5660 if (ts.kind != gfc_default_integer_kind)
5661 return SEQ_NONDEFAULT;
5666 if (!(ts.kind == gfc_default_real_kind
5667 || ts.kind == gfc_default_double_kind))
5668 return SEQ_NONDEFAULT;
5673 if (ts.kind != gfc_default_complex_kind)
5674 return SEQ_NONDEFAULT;
5679 if (ts.kind != gfc_default_logical_kind)
5680 return SEQ_NONDEFAULT;
5685 return SEQ_NONDEFAULT;
5690 /* Resolve derived type EQUIVALENCE object. */
5693 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5696 gfc_component *c = derived->components;
5701 /* Shall not be an object of nonsequence derived type. */
5702 if (!derived->attr.sequence)
5704 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5705 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5709 for (; c ; c = c->next)
5712 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5715 /* Shall not be an object of sequence derived type containing a pointer
5716 in the structure. */
5719 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5720 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5726 gfc_error ("Derived type variable '%s' at %L with default initializer "
5727 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5735 /* Resolve equivalence object.
5736 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5737 an allocatable array, an object of nonsequence derived type, an object of
5738 sequence derived type containing a pointer at any level of component
5739 selection, an automatic object, a function name, an entry name, a result
5740 name, a named constant, a structure component, or a subobject of any of
5741 the preceding objects. A substring shall not have length zero. A
5742 derived type shall not have components with default initialization nor
5743 shall two objects of an equivalence group be initialized.
5744 The simple constraints are done in symbol.c(check_conflict) and the rest
5745 are implemented here. */
5748 resolve_equivalence (gfc_equiv *eq)
5751 gfc_symbol *derived;
5752 gfc_symbol *first_sym;
5755 locus *last_where = NULL;
5756 seq_type eq_type, last_eq_type;
5757 gfc_typespec *last_ts;
5759 const char *value_name;
5763 last_ts = &eq->expr->symtree->n.sym->ts;
5765 first_sym = eq->expr->symtree->n.sym;
5767 for (object = 1; eq; eq = eq->eq, object++)
5771 e->ts = e->symtree->n.sym->ts;
5772 /* match_varspec might not know yet if it is seeing
5773 array reference or substring reference, as it doesn't
5775 if (e->ref && e->ref->type == REF_ARRAY)
5777 gfc_ref *ref = e->ref;
5778 sym = e->symtree->n.sym;
5780 if (sym->attr.dimension)
5782 ref->u.ar.as = sym->as;
5786 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5787 if (e->ts.type == BT_CHARACTER
5789 && ref->type == REF_ARRAY
5790 && ref->u.ar.dimen == 1
5791 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5792 && ref->u.ar.stride[0] == NULL)
5794 gfc_expr *start = ref->u.ar.start[0];
5795 gfc_expr *end = ref->u.ar.end[0];
5798 /* Optimize away the (:) reference. */
5799 if (start == NULL && end == NULL)
5804 e->ref->next = ref->next;
5809 ref->type = REF_SUBSTRING;
5811 start = gfc_int_expr (1);
5812 ref->u.ss.start = start;
5813 if (end == NULL && e->ts.cl)
5814 end = gfc_copy_expr (e->ts.cl->length);
5815 ref->u.ss.end = end;
5816 ref->u.ss.length = e->ts.cl;
5823 /* Any further ref is an error. */
5826 gcc_assert (ref->type == REF_ARRAY);
5827 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5833 if (gfc_resolve_expr (e) == FAILURE)
5836 sym = e->symtree->n.sym;
5838 /* An equivalence statement cannot have more than one initialized
5842 if (value_name != NULL)
5844 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5845 "be in the EQUIVALENCE statement at %L",
5846 value_name, sym->name, &e->where);
5850 value_name = sym->name;
5853 /* Shall not equivalence common block variables in a PURE procedure. */
5854 if (sym->ns->proc_name
5855 && sym->ns->proc_name->attr.pure
5856 && sym->attr.in_common)
5858 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5859 "object in the pure procedure '%s'",
5860 sym->name, &e->where, sym->ns->proc_name->name);
5864 /* Shall not be a named constant. */
5865 if (e->expr_type == EXPR_CONSTANT)
5867 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5868 "object", sym->name, &e->where);
5872 derived = e->ts.derived;
5873 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5876 /* Check that the types correspond correctly:
5878 A numeric sequence structure may be equivalenced to another sequence
5879 structure, an object of default integer type, default real type, double
5880 precision real type, default logical type such that components of the
5881 structure ultimately only become associated to objects of the same
5882 kind. A character sequence structure may be equivalenced to an object
5883 of default character kind or another character sequence structure.
5884 Other objects may be equivalenced only to objects of the same type and
5887 /* Identical types are unconditionally OK. */
5888 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5889 goto identical_types;
5891 last_eq_type = sequence_type (*last_ts);
5892 eq_type = sequence_type (sym->ts);
5894 /* Since the pair of objects is not of the same type, mixed or
5895 non-default sequences can be rejected. */
5897 msg = "Sequence %s with mixed components in EQUIVALENCE "
5898 "statement at %L with different type objects";
5900 && last_eq_type == SEQ_MIXED
5901 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5902 last_where) == FAILURE)
5903 || (eq_type == SEQ_MIXED
5904 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5905 &e->where) == FAILURE))
5908 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5909 "statement at %L with objects of different type";
5911 && last_eq_type == SEQ_NONDEFAULT
5912 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5913 last_where) == FAILURE)
5914 || (eq_type == SEQ_NONDEFAULT
5915 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5916 &e->where) == FAILURE))
5919 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5920 "EQUIVALENCE statement at %L";
5921 if (last_eq_type == SEQ_CHARACTER
5922 && eq_type != SEQ_CHARACTER
5923 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5924 &e->where) == FAILURE)
5927 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5928 "EQUIVALENCE statement at %L";
5929 if (last_eq_type == SEQ_NUMERIC
5930 && eq_type != SEQ_NUMERIC
5931 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5932 &e->where) == FAILURE)
5937 last_where = &e->where;
5942 /* Shall not be an automatic array. */
5943 if (e->ref->type == REF_ARRAY
5944 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5946 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5947 "an EQUIVALENCE object", sym->name, &e->where);
5954 /* Shall not be a structure component. */
5955 if (r->type == REF_COMPONENT)
5957 gfc_error ("Structure component '%s' at %L cannot be an "
5958 "EQUIVALENCE object",
5959 r->u.c.component->name, &e->where);
5963 /* A substring shall not have length zero. */
5964 if (r->type == REF_SUBSTRING)
5966 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5968 gfc_error ("Substring at %L has length zero",
5969 &r->u.ss.start->where);
5979 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5982 resolve_fntype (gfc_namespace * ns)
5987 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5990 /* If there are any entries, ns->proc_name is the entry master
5991 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5993 sym = ns->entries->sym;
5995 sym = ns->proc_name;
5996 if (sym->result == sym
5997 && sym->ts.type == BT_UNKNOWN
5998 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5999 && !sym->attr.untyped)
6001 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6002 sym->name, &sym->declared_at);
6003 sym->attr.untyped = 1;
6006 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6007 && !gfc_check_access (sym->ts.derived->attr.access,
6008 sym->ts.derived->ns->default_access)
6009 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6011 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6012 sym->name, &sym->declared_at, sym->ts.derived->name);
6016 for (el = ns->entries->next; el; el = el->next)
6018 if (el->sym->result == el->sym
6019 && el->sym->ts.type == BT_UNKNOWN
6020 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6021 && !el->sym->attr.untyped)
6023 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6024 el->sym->name, &el->sym->declared_at);
6025 el->sym->attr.untyped = 1;
6031 /* Examine all of the expressions associated with a program unit,
6032 assign types to all intermediate expressions, make sure that all
6033 assignments are to compatible types and figure out which names
6034 refer to which functions or subroutines. It doesn't check code
6035 block, which is handled by resolve_code. */
6038 resolve_types (gfc_namespace * ns)
6045 gfc_current_ns = ns;
6047 resolve_entries (ns);
6049 resolve_contained_functions (ns);
6051 gfc_traverse_ns (ns, resolve_symbol);
6053 resolve_fntype (ns);
6055 for (n = ns->contained; n; n = n->sibling)
6057 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6058 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6059 "also be PURE", n->proc_name->name,
6060 &n->proc_name->declared_at);
6066 gfc_check_interfaces (ns);
6068 for (cl = ns->cl_list; cl; cl = cl->next)
6069 resolve_charlen (cl);
6071 gfc_traverse_ns (ns, resolve_values);
6077 for (d = ns->data; d; d = d->next)
6081 gfc_traverse_ns (ns, gfc_formalize_init_value);
6083 for (eq = ns->equiv; eq; eq = eq->next)
6084 resolve_equivalence (eq);
6086 /* Warn about unused labels. */
6087 if (gfc_option.warn_unused_labels)
6088 warn_unused_label (ns->st_labels);
6092 /* Call resolve_code recursively. */
6095 resolve_codes (gfc_namespace * ns)
6099 for (n = ns->contained; n; n = n->sibling)
6102 gfc_current_ns = ns;
6104 resolve_code (ns->code, ns);
6108 /* This function is called after a complete program unit has been compiled.
6109 Its purpose is to examine all of the expressions associated with a program
6110 unit, assign types to all intermediate expressions, make sure that all
6111 assignments are to compatible types and figure out which names refer to
6112 which functions or subroutines. */
6115 gfc_resolve (gfc_namespace * ns)
6117 gfc_namespace *old_ns;
6119 old_ns = gfc_current_ns;
6124 gfc_current_ns = old_ns;