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_entries (ns);
547 resolve_formal_arglists (ns);
549 for (child = ns->contained; child; child = child->sibling)
551 /* Resolve alternate entry points first. */
552 resolve_entries (child);
554 /* Then check function return types. */
555 resolve_contained_fntype (child->proc_name, child);
556 for (el = child->entries; el; el = el->next)
557 resolve_contained_fntype (el->sym, child);
562 /* Resolve all of the elements of a structure constructor and make sure that
563 the types are correct. */
566 resolve_structure_cons (gfc_expr * expr)
568 gfc_constructor *cons;
573 cons = expr->value.constructor;
574 /* A constructor may have references if it is the result of substituting a
575 parameter variable. In this case we just pull out the component we
578 comp = expr->ref->u.c.sym->components;
580 comp = expr->ts.derived->components;
582 for (; comp; comp = comp->next, cons = cons->next)
590 if (gfc_resolve_expr (cons->expr) == FAILURE)
596 /* If we don't have the right type, try to convert it. */
598 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
601 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
602 gfc_error ("The element in the derived type constructor at %L, "
603 "for pointer component '%s', is %s but should be %s",
604 &cons->expr->where, comp->name,
605 gfc_basic_typename (cons->expr->ts.type),
606 gfc_basic_typename (comp->ts.type));
608 t = gfc_convert_type (cons->expr, &comp->ts, 1);
617 /****************** Expression name resolution ******************/
619 /* Returns 0 if a symbol was not declared with a type or
620 attribute declaration statement, nonzero otherwise. */
623 was_declared (gfc_symbol * sym)
629 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
632 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
633 || a.optional || a.pointer || a.save || a.target
634 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
641 /* Determine if a symbol is generic or not. */
644 generic_sym (gfc_symbol * sym)
648 if (sym->attr.generic ||
649 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
652 if (was_declared (sym) || sym->ns->parent == NULL)
655 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
657 return (s == NULL) ? 0 : generic_sym (s);
661 /* Determine if a symbol is specific or not. */
664 specific_sym (gfc_symbol * sym)
668 if (sym->attr.if_source == IFSRC_IFBODY
669 || sym->attr.proc == PROC_MODULE
670 || sym->attr.proc == PROC_INTERNAL
671 || sym->attr.proc == PROC_ST_FUNCTION
672 || (sym->attr.intrinsic &&
673 gfc_specific_intrinsic (sym->name))
674 || sym->attr.external)
677 if (was_declared (sym) || sym->ns->parent == NULL)
680 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
682 return (s == NULL) ? 0 : specific_sym (s);
686 /* Figure out if the procedure is specific, generic or unknown. */
689 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
693 procedure_kind (gfc_symbol * sym)
696 if (generic_sym (sym))
697 return PTYPE_GENERIC;
699 if (specific_sym (sym))
700 return PTYPE_SPECIFIC;
702 return PTYPE_UNKNOWN;
705 /* Check references to assumed size arrays. The flag need_full_assumed_size
706 is non-zero when matching actual arguments. */
708 static int need_full_assumed_size = 0;
711 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
717 if (need_full_assumed_size
718 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
721 for (ref = e->ref; ref; ref = ref->next)
722 if (ref->type == REF_ARRAY)
723 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
724 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
728 gfc_error ("The upper bound in the last dimension must "
729 "appear in the reference to the assumed size "
730 "array '%s' at %L.", sym->name, &e->where);
737 /* Look for bad assumed size array references in argument expressions
738 of elemental and array valued intrinsic procedures. Since this is
739 called from procedure resolution functions, it only recurses at
743 resolve_assumed_size_actual (gfc_expr *e)
748 switch (e->expr_type)
752 && check_assumed_size_reference (e->symtree->n.sym, e))
757 if (resolve_assumed_size_actual (e->value.op.op1)
758 || resolve_assumed_size_actual (e->value.op.op2))
769 /* Resolve an actual argument list. Most of the time, this is just
770 resolving the expressions in the list.
771 The exception is that we sometimes have to decide whether arguments
772 that look like procedure arguments are really simple variable
776 resolve_actual_arglist (gfc_actual_arglist * arg)
779 gfc_symtree *parent_st;
782 for (; arg; arg = arg->next)
788 /* Check the label is a valid branching target. */
791 if (arg->label->defined == ST_LABEL_UNKNOWN)
793 gfc_error ("Label %d referenced at %L is never defined",
794 arg->label->value, &arg->label->where);
801 if (e->ts.type != BT_PROCEDURE)
803 if (gfc_resolve_expr (e) != SUCCESS)
808 /* See if the expression node should really be a variable
811 sym = e->symtree->n.sym;
813 if (sym->attr.flavor == FL_PROCEDURE
814 || sym->attr.intrinsic
815 || sym->attr.external)
818 if (sym->attr.proc == PROC_ST_FUNCTION)
820 gfc_error ("Statement function '%s' at %L is not allowed as an "
821 "actual argument", sym->name, &e->where);
824 if (sym->attr.contained && !sym->attr.use_assoc
825 && sym->ns->proc_name->attr.flavor != FL_MODULE)
827 gfc_error ("Internal procedure '%s' is not allowed as an "
828 "actual argument at %L", sym->name, &e->where);
831 if (sym->attr.elemental && !sym->attr.intrinsic)
833 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
834 "allowed as an actual argument at %L", sym->name,
838 /* If the symbol is the function that names the current (or
839 parent) scope, then we really have a variable reference. */
841 if (sym->attr.function && sym->result == sym
842 && (sym->ns->proc_name == sym
843 || (sym->ns->parent != NULL
844 && sym->ns->parent->proc_name == sym)))
850 /* See if the name is a module procedure in a parent unit. */
852 if (was_declared (sym) || sym->ns->parent == NULL)
855 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
857 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
861 if (parent_st == NULL)
864 sym = parent_st->n.sym;
865 e->symtree = parent_st; /* Point to the right thing. */
867 if (sym->attr.flavor == FL_PROCEDURE
868 || sym->attr.intrinsic
869 || sym->attr.external)
875 e->expr_type = EXPR_VARIABLE;
879 e->rank = sym->as->rank;
880 e->ref = gfc_get_ref ();
881 e->ref->type = REF_ARRAY;
882 e->ref->u.ar.type = AR_FULL;
883 e->ref->u.ar.as = sym->as;
891 /* Go through each actual argument in ACTUAL and see if it can be
892 implemented as an inlined, non-copying intrinsic. FNSYM is the
893 function being called, or NULL if not known. */
896 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
898 gfc_actual_arglist *ap;
901 for (ap = actual; ap; ap = ap->next)
903 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
904 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
905 ap->expr->inline_noncopying_intrinsic = 1;
908 /* This function does the checking of references to global procedures
909 as defined in sections 18.1 and 14.1, respectively, of the Fortran
910 77 and 95 standards. It checks for a gsymbol for the name, making
911 one if it does not already exist. If it already exists, then the
912 reference being resolved must correspond to the type of gsymbol.
913 Otherwise, the new symbol is equipped with the attributes of the
914 reference. The corresponding code that is called in creating
915 global entities is parse.c. */
918 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
923 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
925 gsym = gfc_get_gsymbol (sym->name);
927 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
928 global_used (gsym, where);
930 if (gsym->type == GSYM_UNKNOWN)
933 gsym->where = *where;
939 /************* Function resolution *************/
941 /* Resolve a function call known to be generic.
942 Section 14.1.2.4.1. */
945 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
949 if (sym->attr.generic)
952 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
955 expr->value.function.name = s->name;
956 expr->value.function.esym = s;
959 expr->rank = s->as->rank;
963 /* TODO: Need to search for elemental references in generic interface */
966 if (sym->attr.intrinsic)
967 return gfc_intrinsic_func_interface (expr, 0);
974 resolve_generic_f (gfc_expr * expr)
979 sym = expr->symtree->n.sym;
983 m = resolve_generic_f0 (expr, sym);
986 else if (m == MATCH_ERROR)
990 if (sym->ns->parent == NULL)
992 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
996 if (!generic_sym (sym))
1000 /* Last ditch attempt. */
1002 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1004 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1005 expr->symtree->n.sym->name, &expr->where);
1009 m = gfc_intrinsic_func_interface (expr, 0);
1014 ("Generic function '%s' at %L is not consistent with a specific "
1015 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1021 /* Resolve a function call known to be specific. */
1024 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1028 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1030 if (sym->attr.dummy)
1032 sym->attr.proc = PROC_DUMMY;
1036 sym->attr.proc = PROC_EXTERNAL;
1040 if (sym->attr.proc == PROC_MODULE
1041 || sym->attr.proc == PROC_ST_FUNCTION
1042 || sym->attr.proc == PROC_INTERNAL)
1045 if (sym->attr.intrinsic)
1047 m = gfc_intrinsic_func_interface (expr, 1);
1052 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1053 "an intrinsic", sym->name, &expr->where);
1061 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1064 expr->value.function.name = sym->name;
1065 expr->value.function.esym = sym;
1066 if (sym->as != NULL)
1067 expr->rank = sym->as->rank;
1074 resolve_specific_f (gfc_expr * expr)
1079 sym = expr->symtree->n.sym;
1083 m = resolve_specific_f0 (sym, expr);
1086 if (m == MATCH_ERROR)
1089 if (sym->ns->parent == NULL)
1092 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1098 gfc_error ("Unable to resolve the specific function '%s' at %L",
1099 expr->symtree->n.sym->name, &expr->where);
1105 /* Resolve a procedure call not known to be generic nor specific. */
1108 resolve_unknown_f (gfc_expr * expr)
1113 sym = expr->symtree->n.sym;
1115 if (sym->attr.dummy)
1117 sym->attr.proc = PROC_DUMMY;
1118 expr->value.function.name = sym->name;
1122 /* See if we have an intrinsic function reference. */
1124 if (gfc_intrinsic_name (sym->name, 0))
1126 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1131 /* The reference is to an external name. */
1133 sym->attr.proc = PROC_EXTERNAL;
1134 expr->value.function.name = sym->name;
1135 expr->value.function.esym = expr->symtree->n.sym;
1137 if (sym->as != NULL)
1138 expr->rank = sym->as->rank;
1140 /* Type of the expression is either the type of the symbol or the
1141 default type of the symbol. */
1144 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1146 if (sym->ts.type != BT_UNKNOWN)
1150 ts = gfc_get_default_type (sym, sym->ns);
1152 if (ts->type == BT_UNKNOWN)
1154 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1155 sym->name, &expr->where);
1166 /* Figure out if a function reference is pure or not. Also set the name
1167 of the function for a potential error message. Return nonzero if the
1168 function is PURE, zero if not. */
1171 pure_function (gfc_expr * e, const char **name)
1175 if (e->value.function.esym)
1177 pure = gfc_pure (e->value.function.esym);
1178 *name = e->value.function.esym->name;
1180 else if (e->value.function.isym)
1182 pure = e->value.function.isym->pure
1183 || e->value.function.isym->elemental;
1184 *name = e->value.function.isym->name;
1188 /* Implicit functions are not pure. */
1190 *name = e->value.function.name;
1197 /* Resolve a function call, which means resolving the arguments, then figuring
1198 out which entity the name refers to. */
1199 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1200 to INTENT(OUT) or INTENT(INOUT). */
1203 resolve_function (gfc_expr * expr)
1205 gfc_actual_arglist *arg;
1213 sym = expr->symtree->n.sym;
1215 /* If the procedure is not internal, a statement function or a module
1216 procedure,it must be external and should be checked for usage. */
1217 if (sym && !sym->attr.dummy && !sym->attr.contained
1218 && sym->attr.proc != PROC_ST_FUNCTION
1219 && !sym->attr.use_assoc)
1220 resolve_global_procedure (sym, &expr->where, 0);
1222 /* Switch off assumed size checking and do this again for certain kinds
1223 of procedure, once the procedure itself is resolved. */
1224 need_full_assumed_size++;
1226 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1229 /* Resume assumed_size checking. */
1230 need_full_assumed_size--;
1232 if (sym && sym->ts.type == BT_CHARACTER
1233 && sym->ts.cl && sym->ts.cl->length == NULL)
1235 if (sym->attr.if_source == IFSRC_IFBODY)
1237 /* This follows from a slightly odd requirement at 5.1.1.5 in the
1238 standard that allows assumed character length functions to be
1239 declared in interfaces but not used. Picking up the symbol here,
1240 rather than resolve_symbol, accomplishes that. */
1241 gfc_error ("Function '%s' can be declared in an interface to "
1242 "return CHARACTER(*) but cannot be used at %L",
1243 sym->name, &expr->where);
1247 /* Internal procedures are taken care of in resolve_contained_fntype. */
1248 if (!sym->attr.dummy && !sym->attr.contained)
1250 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1251 "be used at %L since it is not a dummy argument",
1252 sym->name, &expr->where);
1257 /* See if function is already resolved. */
1259 if (expr->value.function.name != NULL)
1261 if (expr->ts.type == BT_UNKNOWN)
1267 /* Apply the rules of section 14.1.2. */
1269 switch (procedure_kind (sym))
1272 t = resolve_generic_f (expr);
1275 case PTYPE_SPECIFIC:
1276 t = resolve_specific_f (expr);
1280 t = resolve_unknown_f (expr);
1284 gfc_internal_error ("resolve_function(): bad function type");
1288 /* If the expression is still a function (it might have simplified),
1289 then we check to see if we are calling an elemental function. */
1291 if (expr->expr_type != EXPR_FUNCTION)
1294 temp = need_full_assumed_size;
1295 need_full_assumed_size = 0;
1297 if (expr->value.function.actual != NULL
1298 && ((expr->value.function.esym != NULL
1299 && expr->value.function.esym->attr.elemental)
1300 || (expr->value.function.isym != NULL
1301 && expr->value.function.isym->elemental)))
1303 /* The rank of an elemental is the rank of its array argument(s). */
1304 for (arg = expr->value.function.actual; arg; arg = arg->next)
1306 if (arg->expr != NULL && arg->expr->rank > 0)
1308 expr->rank = arg->expr->rank;
1313 /* Being elemental, the last upper bound of an assumed size array
1314 argument must be present. */
1315 for (arg = expr->value.function.actual; arg; arg = arg->next)
1317 if (arg->expr != NULL
1318 && arg->expr->rank > 0
1319 && resolve_assumed_size_actual (arg->expr))
1323 if (omp_workshare_flag
1324 && expr->value.function.esym
1325 && ! gfc_elemental (expr->value.function.esym))
1327 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1328 " in WORKSHARE construct", expr->value.function.esym->name,
1333 else if (expr->value.function.actual != NULL
1334 && expr->value.function.isym != NULL
1335 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1336 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1337 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1339 /* Array instrinsics must also have the last upper bound of an
1340 asumed size array argument. UBOUND and SIZE have to be
1341 excluded from the check if the second argument is anything
1344 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1345 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1347 for (arg = expr->value.function.actual; arg; arg = arg->next)
1349 if (inquiry && arg->next != NULL && arg->next->expr
1350 && arg->next->expr->expr_type != EXPR_CONSTANT)
1353 if (arg->expr != NULL
1354 && arg->expr->rank > 0
1355 && resolve_assumed_size_actual (arg->expr))
1360 need_full_assumed_size = temp;
1362 if (!pure_function (expr, &name))
1367 ("Function reference to '%s' at %L is inside a FORALL block",
1368 name, &expr->where);
1371 else if (gfc_pure (NULL))
1373 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1374 "procedure within a PURE procedure", name, &expr->where);
1379 /* Character lengths of use associated functions may contains references to
1380 symbols not referenced from the current program unit otherwise. Make sure
1381 those symbols are marked as referenced. */
1383 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1384 && expr->value.function.esym->attr.use_assoc)
1386 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1390 find_noncopying_intrinsics (expr->value.function.esym,
1391 expr->value.function.actual);
1396 /************* Subroutine resolution *************/
1399 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1406 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1407 sym->name, &c->loc);
1408 else if (gfc_pure (NULL))
1409 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1415 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1419 if (sym->attr.generic)
1421 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1424 c->resolved_sym = s;
1425 pure_subroutine (c, s);
1429 /* TODO: Need to search for elemental references in generic interface. */
1432 if (sym->attr.intrinsic)
1433 return gfc_intrinsic_sub_interface (c, 0);
1440 resolve_generic_s (gfc_code * c)
1445 sym = c->symtree->n.sym;
1447 m = resolve_generic_s0 (c, sym);
1450 if (m == MATCH_ERROR)
1453 if (sym->ns->parent != NULL)
1455 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1458 m = resolve_generic_s0 (c, sym);
1461 if (m == MATCH_ERROR)
1466 /* Last ditch attempt. */
1468 if (!gfc_generic_intrinsic (sym->name))
1471 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1472 sym->name, &c->loc);
1476 m = gfc_intrinsic_sub_interface (c, 0);
1480 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1481 "intrinsic subroutine interface", sym->name, &c->loc);
1487 /* Resolve a subroutine call known to be specific. */
1490 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1494 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1496 if (sym->attr.dummy)
1498 sym->attr.proc = PROC_DUMMY;
1502 sym->attr.proc = PROC_EXTERNAL;
1506 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1509 if (sym->attr.intrinsic)
1511 m = gfc_intrinsic_sub_interface (c, 1);
1515 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1516 "with an intrinsic", sym->name, &c->loc);
1524 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1526 c->resolved_sym = sym;
1527 pure_subroutine (c, sym);
1534 resolve_specific_s (gfc_code * c)
1539 sym = c->symtree->n.sym;
1541 m = resolve_specific_s0 (c, sym);
1544 if (m == MATCH_ERROR)
1547 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1551 m = resolve_specific_s0 (c, sym);
1554 if (m == MATCH_ERROR)
1558 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1559 sym->name, &c->loc);
1565 /* Resolve a subroutine call not known to be generic nor specific. */
1568 resolve_unknown_s (gfc_code * c)
1572 sym = c->symtree->n.sym;
1574 if (sym->attr.dummy)
1576 sym->attr.proc = PROC_DUMMY;
1580 /* See if we have an intrinsic function reference. */
1582 if (gfc_intrinsic_name (sym->name, 1))
1584 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1589 /* The reference is to an external name. */
1592 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1594 c->resolved_sym = sym;
1596 pure_subroutine (c, sym);
1602 /* Resolve a subroutine call. Although it was tempting to use the same code
1603 for functions, subroutines and functions are stored differently and this
1604 makes things awkward. */
1607 resolve_call (gfc_code * c)
1611 if (c->symtree && c->symtree->n.sym
1612 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1614 gfc_error ("'%s' at %L has a type, which is not consistent with "
1615 "the CALL at %L", c->symtree->n.sym->name,
1616 &c->symtree->n.sym->declared_at, &c->loc);
1620 /* If the procedure is not internal or module, it must be external and
1621 should be checked for usage. */
1622 if (c->symtree && c->symtree->n.sym
1623 && !c->symtree->n.sym->attr.dummy
1624 && !c->symtree->n.sym->attr.contained
1625 && !c->symtree->n.sym->attr.use_assoc)
1626 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1628 /* Switch off assumed size checking and do this again for certain kinds
1629 of procedure, once the procedure itself is resolved. */
1630 need_full_assumed_size++;
1632 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1635 /* Resume assumed_size checking. */
1636 need_full_assumed_size--;
1640 if (c->resolved_sym == NULL)
1641 switch (procedure_kind (c->symtree->n.sym))
1644 t = resolve_generic_s (c);
1647 case PTYPE_SPECIFIC:
1648 t = resolve_specific_s (c);
1652 t = resolve_unknown_s (c);
1656 gfc_internal_error ("resolve_subroutine(): bad function type");
1659 if (c->ext.actual != NULL
1660 && c->symtree->n.sym->attr.elemental)
1662 gfc_actual_arglist * a;
1663 /* Being elemental, the last upper bound of an assumed size array
1664 argument must be present. */
1665 for (a = c->ext.actual; a; a = a->next)
1668 && a->expr->rank > 0
1669 && resolve_assumed_size_actual (a->expr))
1675 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1679 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1680 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1681 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1682 if their shapes do not match. If either op1->shape or op2->shape is
1683 NULL, return SUCCESS. */
1686 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1693 if (op1->shape != NULL && op2->shape != NULL)
1695 for (i = 0; i < op1->rank; i++)
1697 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1699 gfc_error ("Shapes for operands at %L and %L are not conformable",
1700 &op1->where, &op2->where);
1710 /* Resolve an operator expression node. This can involve replacing the
1711 operation with a user defined function call. */
1714 resolve_operator (gfc_expr * e)
1716 gfc_expr *op1, *op2;
1720 /* Resolve all subnodes-- give them types. */
1722 switch (e->value.op.operator)
1725 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1728 /* Fall through... */
1731 case INTRINSIC_UPLUS:
1732 case INTRINSIC_UMINUS:
1733 case INTRINSIC_PARENTHESES:
1734 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1739 /* Typecheck the new node. */
1741 op1 = e->value.op.op1;
1742 op2 = e->value.op.op2;
1744 switch (e->value.op.operator)
1746 case INTRINSIC_UPLUS:
1747 case INTRINSIC_UMINUS:
1748 if (op1->ts.type == BT_INTEGER
1749 || op1->ts.type == BT_REAL
1750 || op1->ts.type == BT_COMPLEX)
1756 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1757 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1760 case INTRINSIC_PLUS:
1761 case INTRINSIC_MINUS:
1762 case INTRINSIC_TIMES:
1763 case INTRINSIC_DIVIDE:
1764 case INTRINSIC_POWER:
1765 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1767 gfc_type_convert_binary (e);
1772 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1773 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1774 gfc_typename (&op2->ts));
1777 case INTRINSIC_CONCAT:
1778 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1780 e->ts.type = BT_CHARACTER;
1781 e->ts.kind = op1->ts.kind;
1786 _("Operands of string concatenation operator at %%L are %s/%s"),
1787 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1793 case INTRINSIC_NEQV:
1794 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1796 e->ts.type = BT_LOGICAL;
1797 e->ts.kind = gfc_kind_max (op1, op2);
1798 if (op1->ts.kind < e->ts.kind)
1799 gfc_convert_type (op1, &e->ts, 2);
1800 else if (op2->ts.kind < e->ts.kind)
1801 gfc_convert_type (op2, &e->ts, 2);
1805 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1806 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1807 gfc_typename (&op2->ts));
1812 if (op1->ts.type == BT_LOGICAL)
1814 e->ts.type = BT_LOGICAL;
1815 e->ts.kind = op1->ts.kind;
1819 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1820 gfc_typename (&op1->ts));
1827 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1829 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1833 /* Fall through... */
1837 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1839 e->ts.type = BT_LOGICAL;
1840 e->ts.kind = gfc_default_logical_kind;
1844 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1846 gfc_type_convert_binary (e);
1848 e->ts.type = BT_LOGICAL;
1849 e->ts.kind = gfc_default_logical_kind;
1853 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1855 _("Logicals at %%L must be compared with %s instead of %s"),
1856 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1857 gfc_op2string (e->value.op.operator));
1860 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1861 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1862 gfc_typename (&op2->ts));
1866 case INTRINSIC_USER:
1868 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1869 e->value.op.uop->name, gfc_typename (&op1->ts));
1871 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1872 e->value.op.uop->name, gfc_typename (&op1->ts),
1873 gfc_typename (&op2->ts));
1877 case INTRINSIC_PARENTHESES:
1881 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1884 /* Deal with arrayness of an operand through an operator. */
1888 switch (e->value.op.operator)
1890 case INTRINSIC_PLUS:
1891 case INTRINSIC_MINUS:
1892 case INTRINSIC_TIMES:
1893 case INTRINSIC_DIVIDE:
1894 case INTRINSIC_POWER:
1895 case INTRINSIC_CONCAT:
1899 case INTRINSIC_NEQV:
1907 if (op1->rank == 0 && op2->rank == 0)
1910 if (op1->rank == 0 && op2->rank != 0)
1912 e->rank = op2->rank;
1914 if (e->shape == NULL)
1915 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1918 if (op1->rank != 0 && op2->rank == 0)
1920 e->rank = op1->rank;
1922 if (e->shape == NULL)
1923 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1926 if (op1->rank != 0 && op2->rank != 0)
1928 if (op1->rank == op2->rank)
1930 e->rank = op1->rank;
1931 if (e->shape == NULL)
1933 t = compare_shapes(op1, op2);
1937 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1942 gfc_error ("Inconsistent ranks for operator at %L and %L",
1943 &op1->where, &op2->where);
1946 /* Allow higher level expressions to work. */
1954 case INTRINSIC_UPLUS:
1955 case INTRINSIC_UMINUS:
1956 case INTRINSIC_PARENTHESES:
1957 e->rank = op1->rank;
1959 if (e->shape == NULL)
1960 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1962 /* Simply copy arrayness attribute */
1969 /* Attempt to simplify the expression. */
1971 t = gfc_simplify_expr (e, 0);
1976 if (gfc_extend_expr (e) == SUCCESS)
1979 gfc_error (msg, &e->where);
1985 /************** Array resolution subroutines **************/
1989 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1992 /* Compare two integer expressions. */
1995 compare_bound (gfc_expr * a, gfc_expr * b)
1999 if (a == NULL || a->expr_type != EXPR_CONSTANT
2000 || b == NULL || b->expr_type != EXPR_CONSTANT)
2003 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2004 gfc_internal_error ("compare_bound(): Bad expression");
2006 i = mpz_cmp (a->value.integer, b->value.integer);
2016 /* Compare an integer expression with an integer. */
2019 compare_bound_int (gfc_expr * a, int b)
2023 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2026 if (a->ts.type != BT_INTEGER)
2027 gfc_internal_error ("compare_bound_int(): Bad expression");
2029 i = mpz_cmp_si (a->value.integer, b);
2039 /* Compare a single dimension of an array reference to the array
2043 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2046 /* Given start, end and stride values, calculate the minimum and
2047 maximum referenced indexes. */
2055 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2057 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2063 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2065 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2069 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2071 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2074 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2075 it is legal (see 6.2.2.3.1). */
2080 gfc_internal_error ("check_dimension(): Bad array reference");
2086 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2091 /* Compare an array reference with an array specification. */
2094 compare_spec_to_ref (gfc_array_ref * ar)
2101 /* TODO: Full array sections are only allowed as actual parameters. */
2102 if (as->type == AS_ASSUMED_SIZE
2103 && (/*ar->type == AR_FULL
2104 ||*/ (ar->type == AR_SECTION
2105 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2107 gfc_error ("Rightmost upper bound of assumed size array section"
2108 " not specified at %L", &ar->where);
2112 if (ar->type == AR_FULL)
2115 if (as->rank != ar->dimen)
2117 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2118 &ar->where, ar->dimen, as->rank);
2122 for (i = 0; i < as->rank; i++)
2123 if (check_dimension (i, ar, as) == FAILURE)
2130 /* Resolve one part of an array index. */
2133 gfc_resolve_index (gfc_expr * index, int check_scalar)
2140 if (gfc_resolve_expr (index) == FAILURE)
2143 if (check_scalar && index->rank != 0)
2145 gfc_error ("Array index at %L must be scalar", &index->where);
2149 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2151 gfc_error ("Array index at %L must be of INTEGER type",
2156 if (index->ts.type == BT_REAL)
2157 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
2158 &index->where) == FAILURE)
2161 if (index->ts.kind != gfc_index_integer_kind
2162 || index->ts.type != BT_INTEGER)
2165 ts.type = BT_INTEGER;
2166 ts.kind = gfc_index_integer_kind;
2168 gfc_convert_type_warn (index, &ts, 2, 0);
2174 /* Resolve a dim argument to an intrinsic function. */
2177 gfc_resolve_dim_arg (gfc_expr *dim)
2182 if (gfc_resolve_expr (dim) == FAILURE)
2187 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2191 if (dim->ts.type != BT_INTEGER)
2193 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2196 if (dim->ts.kind != gfc_index_integer_kind)
2200 ts.type = BT_INTEGER;
2201 ts.kind = gfc_index_integer_kind;
2203 gfc_convert_type_warn (dim, &ts, 2, 0);
2209 /* Given an expression that contains array references, update those array
2210 references to point to the right array specifications. While this is
2211 filled in during matching, this information is difficult to save and load
2212 in a module, so we take care of it here.
2214 The idea here is that the original array reference comes from the
2215 base symbol. We traverse the list of reference structures, setting
2216 the stored reference to references. Component references can
2217 provide an additional array specification. */
2220 find_array_spec (gfc_expr * e)
2226 as = e->symtree->n.sym->as;
2228 for (ref = e->ref; ref; ref = ref->next)
2233 gfc_internal_error ("find_array_spec(): Missing spec");
2240 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
2241 if (c == ref->u.c.component)
2245 gfc_internal_error ("find_array_spec(): Component not found");
2250 gfc_internal_error ("find_array_spec(): unused as(1)");
2261 gfc_internal_error ("find_array_spec(): unused as(2)");
2265 /* Resolve an array reference. */
2268 resolve_array_ref (gfc_array_ref * ar)
2270 int i, check_scalar;
2272 for (i = 0; i < ar->dimen; i++)
2274 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2276 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2278 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2280 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2283 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2284 switch (ar->start[i]->rank)
2287 ar->dimen_type[i] = DIMEN_ELEMENT;
2291 ar->dimen_type[i] = DIMEN_VECTOR;
2295 gfc_error ("Array index at %L is an array of rank %d",
2296 &ar->c_where[i], ar->start[i]->rank);
2301 /* If the reference type is unknown, figure out what kind it is. */
2303 if (ar->type == AR_UNKNOWN)
2305 ar->type = AR_ELEMENT;
2306 for (i = 0; i < ar->dimen; i++)
2307 if (ar->dimen_type[i] == DIMEN_RANGE
2308 || ar->dimen_type[i] == DIMEN_VECTOR)
2310 ar->type = AR_SECTION;
2315 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2323 resolve_substring (gfc_ref * ref)
2326 if (ref->u.ss.start != NULL)
2328 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2331 if (ref->u.ss.start->ts.type != BT_INTEGER)
2333 gfc_error ("Substring start index at %L must be of type INTEGER",
2334 &ref->u.ss.start->where);
2338 if (ref->u.ss.start->rank != 0)
2340 gfc_error ("Substring start index at %L must be scalar",
2341 &ref->u.ss.start->where);
2345 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2347 gfc_error ("Substring start index at %L is less than one",
2348 &ref->u.ss.start->where);
2353 if (ref->u.ss.end != NULL)
2355 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2358 if (ref->u.ss.end->ts.type != BT_INTEGER)
2360 gfc_error ("Substring end index at %L must be of type INTEGER",
2361 &ref->u.ss.end->where);
2365 if (ref->u.ss.end->rank != 0)
2367 gfc_error ("Substring end index at %L must be scalar",
2368 &ref->u.ss.end->where);
2372 if (ref->u.ss.length != NULL
2373 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2375 gfc_error ("Substring end index at %L is out of bounds",
2376 &ref->u.ss.start->where);
2385 /* Resolve subtype references. */
2388 resolve_ref (gfc_expr * expr)
2390 int current_part_dimension, n_components, seen_part_dimension;
2393 for (ref = expr->ref; ref; ref = ref->next)
2394 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2396 find_array_spec (expr);
2400 for (ref = expr->ref; ref; ref = ref->next)
2404 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2412 resolve_substring (ref);
2416 /* Check constraints on part references. */
2418 current_part_dimension = 0;
2419 seen_part_dimension = 0;
2422 for (ref = expr->ref; ref; ref = ref->next)
2427 switch (ref->u.ar.type)
2431 current_part_dimension = 1;
2435 current_part_dimension = 0;
2439 gfc_internal_error ("resolve_ref(): Bad array reference");
2445 if ((current_part_dimension || seen_part_dimension)
2446 && ref->u.c.component->pointer)
2449 ("Component to the right of a part reference with nonzero "
2450 "rank must not have the POINTER attribute at %L",
2462 if (((ref->type == REF_COMPONENT && n_components > 1)
2463 || ref->next == NULL)
2464 && current_part_dimension
2465 && seen_part_dimension)
2468 gfc_error ("Two or more part references with nonzero rank must "
2469 "not be specified at %L", &expr->where);
2473 if (ref->type == REF_COMPONENT)
2475 if (current_part_dimension)
2476 seen_part_dimension = 1;
2478 /* reset to make sure */
2479 current_part_dimension = 0;
2487 /* Given an expression, determine its shape. This is easier than it sounds.
2488 Leaves the shape array NULL if it is not possible to determine the shape. */
2491 expression_shape (gfc_expr * e)
2493 mpz_t array[GFC_MAX_DIMENSIONS];
2496 if (e->rank == 0 || e->shape != NULL)
2499 for (i = 0; i < e->rank; i++)
2500 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2503 e->shape = gfc_get_shape (e->rank);
2505 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2510 for (i--; i >= 0; i--)
2511 mpz_clear (array[i]);
2515 /* Given a variable expression node, compute the rank of the expression by
2516 examining the base symbol and any reference structures it may have. */
2519 expression_rank (gfc_expr * e)
2526 if (e->expr_type == EXPR_ARRAY)
2528 /* Constructors can have a rank different from one via RESHAPE(). */
2530 if (e->symtree == NULL)
2536 e->rank = (e->symtree->n.sym->as == NULL)
2537 ? 0 : e->symtree->n.sym->as->rank;
2543 for (ref = e->ref; ref; ref = ref->next)
2545 if (ref->type != REF_ARRAY)
2548 if (ref->u.ar.type == AR_FULL)
2550 rank = ref->u.ar.as->rank;
2554 if (ref->u.ar.type == AR_SECTION)
2556 /* Figure out the rank of the section. */
2558 gfc_internal_error ("expression_rank(): Two array specs");
2560 for (i = 0; i < ref->u.ar.dimen; i++)
2561 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2562 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2572 expression_shape (e);
2576 /* Resolve a variable expression. */
2579 resolve_variable (gfc_expr * e)
2583 if (e->ref && resolve_ref (e) == FAILURE)
2586 if (e->symtree == NULL)
2589 sym = e->symtree->n.sym;
2590 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2592 e->ts.type = BT_PROCEDURE;
2596 if (sym->ts.type != BT_UNKNOWN)
2597 gfc_variable_attr (e, &e->ts);
2600 /* Must be a simple variable reference. */
2601 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2606 if (check_assumed_size_reference (sym, e))
2613 /* Resolve an expression. That is, make sure that types of operands agree
2614 with their operators, intrinsic operators are converted to function calls
2615 for overloaded types and unresolved function references are resolved. */
2618 gfc_resolve_expr (gfc_expr * e)
2625 switch (e->expr_type)
2628 t = resolve_operator (e);
2632 t = resolve_function (e);
2636 t = resolve_variable (e);
2638 expression_rank (e);
2641 case EXPR_SUBSTRING:
2642 t = resolve_ref (e);
2652 if (resolve_ref (e) == FAILURE)
2655 t = gfc_resolve_array_constructor (e);
2656 /* Also try to expand a constructor. */
2659 expression_rank (e);
2660 gfc_expand_constructor (e);
2665 case EXPR_STRUCTURE:
2666 t = resolve_ref (e);
2670 t = resolve_structure_cons (e);
2674 t = gfc_simplify_expr (e, 0);
2678 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2685 /* Resolve an expression from an iterator. They must be scalar and have
2686 INTEGER or (optionally) REAL type. */
2689 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2690 const char * name_msgid)
2692 if (gfc_resolve_expr (expr) == FAILURE)
2695 if (expr->rank != 0)
2697 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2701 if (!(expr->ts.type == BT_INTEGER
2702 || (expr->ts.type == BT_REAL && real_ok)))
2705 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2708 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2715 /* Resolve the expressions in an iterator structure. If REAL_OK is
2716 false allow only INTEGER type iterators, otherwise allow REAL types. */
2719 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2722 if (iter->var->ts.type == BT_REAL)
2723 gfc_notify_std (GFC_STD_F95_DEL,
2724 "Obsolete: REAL DO loop iterator at %L",
2727 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2731 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2733 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2738 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2739 "Start expression in DO loop") == FAILURE)
2742 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2743 "End expression in DO loop") == FAILURE)
2746 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2747 "Step expression in DO loop") == FAILURE)
2750 if (iter->step->expr_type == EXPR_CONSTANT)
2752 if ((iter->step->ts.type == BT_INTEGER
2753 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2754 || (iter->step->ts.type == BT_REAL
2755 && mpfr_sgn (iter->step->value.real) == 0))
2757 gfc_error ("Step expression in DO loop at %L cannot be zero",
2758 &iter->step->where);
2763 /* Convert start, end, and step to the same type as var. */
2764 if (iter->start->ts.kind != iter->var->ts.kind
2765 || iter->start->ts.type != iter->var->ts.type)
2766 gfc_convert_type (iter->start, &iter->var->ts, 2);
2768 if (iter->end->ts.kind != iter->var->ts.kind
2769 || iter->end->ts.type != iter->var->ts.type)
2770 gfc_convert_type (iter->end, &iter->var->ts, 2);
2772 if (iter->step->ts.kind != iter->var->ts.kind
2773 || iter->step->ts.type != iter->var->ts.type)
2774 gfc_convert_type (iter->step, &iter->var->ts, 2);
2780 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2781 to be a scalar INTEGER variable. The subscripts and stride are scalar
2782 INTEGERs, and if stride is a constant it must be nonzero. */
2785 resolve_forall_iterators (gfc_forall_iterator * iter)
2790 if (gfc_resolve_expr (iter->var) == SUCCESS
2791 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2792 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2795 if (gfc_resolve_expr (iter->start) == SUCCESS
2796 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2797 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2798 &iter->start->where);
2799 if (iter->var->ts.kind != iter->start->ts.kind)
2800 gfc_convert_type (iter->start, &iter->var->ts, 2);
2802 if (gfc_resolve_expr (iter->end) == SUCCESS
2803 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2804 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2806 if (iter->var->ts.kind != iter->end->ts.kind)
2807 gfc_convert_type (iter->end, &iter->var->ts, 2);
2809 if (gfc_resolve_expr (iter->stride) == SUCCESS)
2811 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2812 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2813 &iter->stride->where, "INTEGER");
2815 if (iter->stride->expr_type == EXPR_CONSTANT
2816 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2817 gfc_error ("FORALL stride expression at %L cannot be zero",
2818 &iter->stride->where);
2820 if (iter->var->ts.kind != iter->stride->ts.kind)
2821 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2828 /* Given a pointer to a symbol that is a derived type, see if any components
2829 have the POINTER attribute. The search is recursive if necessary.
2830 Returns zero if no pointer components are found, nonzero otherwise. */
2833 derived_pointer (gfc_symbol * sym)
2837 for (c = sym->components; c; c = c->next)
2842 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2850 /* Given a pointer to a symbol that is a derived type, see if it's
2851 inaccessible, i.e. if it's defined in another module and the components are
2852 PRIVATE. The search is recursive if necessary. Returns zero if no
2853 inaccessible components are found, nonzero otherwise. */
2856 derived_inaccessible (gfc_symbol *sym)
2860 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2863 for (c = sym->components; c; c = c->next)
2865 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2873 /* Resolve the argument of a deallocate expression. The expression must be
2874 a pointer or a full array. */
2877 resolve_deallocate_expr (gfc_expr * e)
2879 symbol_attribute attr;
2883 if (gfc_resolve_expr (e) == FAILURE)
2886 attr = gfc_expr_attr (e);
2890 if (e->expr_type != EXPR_VARIABLE)
2893 allocatable = e->symtree->n.sym->attr.allocatable;
2894 for (ref = e->ref; ref; ref = ref->next)
2898 if (ref->u.ar.type != AR_FULL)
2903 allocatable = (ref->u.c.component->as != NULL
2904 && ref->u.c.component->as->type == AS_DEFERRED);
2912 if (allocatable == 0)
2915 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2916 "ALLOCATABLE or a POINTER", &e->where);
2923 /* Given the expression node e for an allocatable/pointer of derived type to be
2924 allocated, get the expression node to be initialized afterwards (needed for
2925 derived types with default initializers). */
2928 expr_to_initialize (gfc_expr * e)
2934 result = gfc_copy_expr (e);
2936 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2937 for (ref = result->ref; ref; ref = ref->next)
2938 if (ref->type == REF_ARRAY && ref->next == NULL)
2940 ref->u.ar.type = AR_FULL;
2942 for (i = 0; i < ref->u.ar.dimen; i++)
2943 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2945 result->rank = ref->u.ar.dimen;
2953 /* Resolve the expression in an ALLOCATE statement, doing the additional
2954 checks to see whether the expression is OK or not. The expression must
2955 have a trailing array reference that gives the size of the array. */
2958 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2960 int i, pointer, allocatable, dimension;
2961 symbol_attribute attr;
2962 gfc_ref *ref, *ref2;
2967 if (gfc_resolve_expr (e) == FAILURE)
2970 /* Make sure the expression is allocatable or a pointer. If it is
2971 pointer, the next-to-last reference must be a pointer. */
2975 if (e->expr_type != EXPR_VARIABLE)
2979 attr = gfc_expr_attr (e);
2980 pointer = attr.pointer;
2981 dimension = attr.dimension;
2986 allocatable = e->symtree->n.sym->attr.allocatable;
2987 pointer = e->symtree->n.sym->attr.pointer;
2988 dimension = e->symtree->n.sym->attr.dimension;
2990 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2994 if (ref->next != NULL)
2999 allocatable = (ref->u.c.component->as != NULL
3000 && ref->u.c.component->as->type == AS_DEFERRED);
3002 pointer = ref->u.c.component->pointer;
3003 dimension = ref->u.c.component->dimension;
3013 if (allocatable == 0 && pointer == 0)
3015 gfc_error ("Expression in ALLOCATE statement at %L must be "
3016 "ALLOCATABLE or a POINTER", &e->where);
3020 /* Add default initializer for those derived types that need them. */
3021 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3023 init_st = gfc_get_code ();
3024 init_st->loc = code->loc;
3025 init_st->op = EXEC_ASSIGN;
3026 init_st->expr = expr_to_initialize (e);
3027 init_st->expr2 = init_e;
3029 init_st->next = code->next;
3030 code->next = init_st;
3033 if (pointer && dimension == 0)
3036 /* Make sure the next-to-last reference node is an array specification. */
3038 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3040 gfc_error ("Array specification required in ALLOCATE statement "
3041 "at %L", &e->where);
3045 if (ref2->u.ar.type == AR_ELEMENT)
3048 /* Make sure that the array section reference makes sense in the
3049 context of an ALLOCATE specification. */
3053 for (i = 0; i < ar->dimen; i++)
3054 switch (ar->dimen_type[i])
3060 if (ar->start[i] != NULL
3061 && ar->end[i] != NULL
3062 && ar->stride[i] == NULL)
3065 /* Fall Through... */
3069 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3078 /************ SELECT CASE resolution subroutines ************/
3080 /* Callback function for our mergesort variant. Determines interval
3081 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3082 op1 > op2. Assumes we're not dealing with the default case.
3083 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3084 There are nine situations to check. */
3087 compare_cases (const gfc_case * op1, const gfc_case * op2)
3091 if (op1->low == NULL) /* op1 = (:L) */
3093 /* op2 = (:N), so overlap. */
3095 /* op2 = (M:) or (M:N), L < M */
3096 if (op2->low != NULL
3097 && gfc_compare_expr (op1->high, op2->low) < 0)
3100 else if (op1->high == NULL) /* op1 = (K:) */
3102 /* op2 = (M:), so overlap. */
3104 /* op2 = (:N) or (M:N), K > N */
3105 if (op2->high != NULL
3106 && gfc_compare_expr (op1->low, op2->high) > 0)
3109 else /* op1 = (K:L) */
3111 if (op2->low == NULL) /* op2 = (:N), K > N */
3112 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3113 else if (op2->high == NULL) /* op2 = (M:), L < M */
3114 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3115 else /* op2 = (M:N) */
3119 if (gfc_compare_expr (op1->high, op2->low) < 0)
3122 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3131 /* Merge-sort a double linked case list, detecting overlap in the
3132 process. LIST is the head of the double linked case list before it
3133 is sorted. Returns the head of the sorted list if we don't see any
3134 overlap, or NULL otherwise. */
3137 check_case_overlap (gfc_case * list)
3139 gfc_case *p, *q, *e, *tail;
3140 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3142 /* If the passed list was empty, return immediately. */
3149 /* Loop unconditionally. The only exit from this loop is a return
3150 statement, when we've finished sorting the case list. */
3157 /* Count the number of merges we do in this pass. */
3160 /* Loop while there exists a merge to be done. */
3165 /* Count this merge. */
3168 /* Cut the list in two pieces by stepping INSIZE places
3169 forward in the list, starting from P. */
3172 for (i = 0; i < insize; i++)
3181 /* Now we have two lists. Merge them! */
3182 while (psize > 0 || (qsize > 0 && q != NULL))
3185 /* See from which the next case to merge comes from. */
3188 /* P is empty so the next case must come from Q. */
3193 else if (qsize == 0 || q == NULL)
3202 cmp = compare_cases (p, q);
3205 /* The whole case range for P is less than the
3213 /* The whole case range for Q is greater than
3214 the case range for P. */
3221 /* The cases overlap, or they are the same
3222 element in the list. Either way, we must
3223 issue an error and get the next case from P. */
3224 /* FIXME: Sort P and Q by line number. */
3225 gfc_error ("CASE label at %L overlaps with CASE "
3226 "label at %L", &p->where, &q->where);
3234 /* Add the next element to the merged list. */
3243 /* P has now stepped INSIZE places along, and so has Q. So
3244 they're the same. */
3249 /* If we have done only one merge or none at all, we've
3250 finished sorting the cases. */
3259 /* Otherwise repeat, merging lists twice the size. */
3265 /* Check to see if an expression is suitable for use in a CASE statement.
3266 Makes sure that all case expressions are scalar constants of the same
3267 type. Return FAILURE if anything is wrong. */
3270 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3272 if (e == NULL) return SUCCESS;
3274 if (e->ts.type != case_expr->ts.type)
3276 gfc_error ("Expression in CASE statement at %L must be of type %s",
3277 &e->where, gfc_basic_typename (case_expr->ts.type));
3281 /* C805 (R808) For a given case-construct, each case-value shall be of
3282 the same type as case-expr. For character type, length differences
3283 are allowed, but the kind type parameters shall be the same. */
3285 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3287 gfc_error("Expression in CASE statement at %L must be kind %d",
3288 &e->where, case_expr->ts.kind);
3292 /* Convert the case value kind to that of case expression kind, if needed.
3293 FIXME: Should a warning be issued? */
3294 if (e->ts.kind != case_expr->ts.kind)
3295 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3299 gfc_error ("Expression in CASE statement at %L must be scalar",
3308 /* Given a completely parsed select statement, we:
3310 - Validate all expressions and code within the SELECT.
3311 - Make sure that the selection expression is not of the wrong type.
3312 - Make sure that no case ranges overlap.
3313 - Eliminate unreachable cases and unreachable code resulting from
3314 removing case labels.
3316 The standard does allow unreachable cases, e.g. CASE (5:3). But
3317 they are a hassle for code generation, and to prevent that, we just
3318 cut them out here. This is not necessary for overlapping cases
3319 because they are illegal and we never even try to generate code.
3321 We have the additional caveat that a SELECT construct could have
3322 been a computed GOTO in the source code. Fortunately we can fairly
3323 easily work around that here: The case_expr for a "real" SELECT CASE
3324 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3325 we have to do is make sure that the case_expr is a scalar integer
3329 resolve_select (gfc_code * code)
3332 gfc_expr *case_expr;
3333 gfc_case *cp, *default_case, *tail, *head;
3334 int seen_unreachable;
3339 if (code->expr == NULL)
3341 /* This was actually a computed GOTO statement. */
3342 case_expr = code->expr2;
3343 if (case_expr->ts.type != BT_INTEGER
3344 || case_expr->rank != 0)
3345 gfc_error ("Selection expression in computed GOTO statement "
3346 "at %L must be a scalar integer expression",
3349 /* Further checking is not necessary because this SELECT was built
3350 by the compiler, so it should always be OK. Just move the
3351 case_expr from expr2 to expr so that we can handle computed
3352 GOTOs as normal SELECTs from here on. */
3353 code->expr = code->expr2;
3358 case_expr = code->expr;
3360 type = case_expr->ts.type;
3361 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3363 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3364 &case_expr->where, gfc_typename (&case_expr->ts));
3366 /* Punt. Going on here just produce more garbage error messages. */
3370 if (case_expr->rank != 0)
3372 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3373 "expression", &case_expr->where);
3379 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3380 of the SELECT CASE expression and its CASE values. Walk the lists
3381 of case values, and if we find a mismatch, promote case_expr to
3382 the appropriate kind. */
3384 if (type == BT_LOGICAL || type == BT_INTEGER)
3386 for (body = code->block; body; body = body->block)
3388 /* Walk the case label list. */
3389 for (cp = body->ext.case_list; cp; cp = cp->next)
3391 /* Intercept the DEFAULT case. It does not have a kind. */
3392 if (cp->low == NULL && cp->high == NULL)
3395 /* Unreachable case ranges are discarded, so ignore. */
3396 if (cp->low != NULL && cp->high != NULL
3397 && cp->low != cp->high
3398 && gfc_compare_expr (cp->low, cp->high) > 0)
3401 /* FIXME: Should a warning be issued? */
3403 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3404 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3406 if (cp->high != NULL
3407 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3408 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3413 /* Assume there is no DEFAULT case. */
3414 default_case = NULL;
3418 for (body = code->block; body; body = body->block)
3420 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3422 seen_unreachable = 0;
3424 /* Walk the case label list, making sure that all case labels
3426 for (cp = body->ext.case_list; cp; cp = cp->next)
3428 /* Count the number of cases in the whole construct. */
3431 /* Intercept the DEFAULT case. */
3432 if (cp->low == NULL && cp->high == NULL)
3434 if (default_case != NULL)
3436 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3437 "by a second DEFAULT CASE at %L",
3438 &default_case->where, &cp->where);
3449 /* Deal with single value cases and case ranges. Errors are
3450 issued from the validation function. */
3451 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3452 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3458 if (type == BT_LOGICAL
3459 && ((cp->low == NULL || cp->high == NULL)
3460 || cp->low != cp->high))
3463 ("Logical range in CASE statement at %L is not allowed",
3469 if (cp->low != NULL && cp->high != NULL
3470 && cp->low != cp->high
3471 && gfc_compare_expr (cp->low, cp->high) > 0)
3473 if (gfc_option.warn_surprising)
3474 gfc_warning ("Range specification at %L can never "
3475 "be matched", &cp->where);
3477 cp->unreachable = 1;
3478 seen_unreachable = 1;
3482 /* If the case range can be matched, it can also overlap with
3483 other cases. To make sure it does not, we put it in a
3484 double linked list here. We sort that with a merge sort
3485 later on to detect any overlapping cases. */
3489 head->right = head->left = NULL;
3494 tail->right->left = tail;
3501 /* It there was a failure in the previous case label, give up
3502 for this case label list. Continue with the next block. */
3506 /* See if any case labels that are unreachable have been seen.
3507 If so, we eliminate them. This is a bit of a kludge because
3508 the case lists for a single case statement (label) is a
3509 single forward linked lists. */
3510 if (seen_unreachable)
3512 /* Advance until the first case in the list is reachable. */
3513 while (body->ext.case_list != NULL
3514 && body->ext.case_list->unreachable)
3516 gfc_case *n = body->ext.case_list;
3517 body->ext.case_list = body->ext.case_list->next;
3519 gfc_free_case_list (n);
3522 /* Strip all other unreachable cases. */
3523 if (body->ext.case_list)
3525 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3527 if (cp->next->unreachable)
3529 gfc_case *n = cp->next;
3530 cp->next = cp->next->next;
3532 gfc_free_case_list (n);
3539 /* See if there were overlapping cases. If the check returns NULL,
3540 there was overlap. In that case we don't do anything. If head
3541 is non-NULL, we prepend the DEFAULT case. The sorted list can
3542 then used during code generation for SELECT CASE constructs with
3543 a case expression of a CHARACTER type. */
3546 head = check_case_overlap (head);
3548 /* Prepend the default_case if it is there. */
3549 if (head != NULL && default_case)
3551 default_case->left = NULL;
3552 default_case->right = head;
3553 head->left = default_case;
3557 /* Eliminate dead blocks that may be the result if we've seen
3558 unreachable case labels for a block. */
3559 for (body = code; body && body->block; body = body->block)
3561 if (body->block->ext.case_list == NULL)
3563 /* Cut the unreachable block from the code chain. */
3564 gfc_code *c = body->block;
3565 body->block = c->block;
3567 /* Kill the dead block, but not the blocks below it. */
3569 gfc_free_statements (c);
3573 /* More than two cases is legal but insane for logical selects.
3574 Issue a warning for it. */
3575 if (gfc_option.warn_surprising && type == BT_LOGICAL
3577 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3582 /* Resolve a transfer statement. This is making sure that:
3583 -- a derived type being transferred has only non-pointer components
3584 -- a derived type being transferred doesn't have private components, unless
3585 it's being transferred from the module where the type was defined
3586 -- we're not trying to transfer a whole assumed size array. */
3589 resolve_transfer (gfc_code * code)
3598 if (exp->expr_type != EXPR_VARIABLE)
3601 sym = exp->symtree->n.sym;
3604 /* Go to actual component transferred. */
3605 for (ref = code->expr->ref; ref; ref = ref->next)
3606 if (ref->type == REF_COMPONENT)
3607 ts = &ref->u.c.component->ts;
3609 if (ts->type == BT_DERIVED)
3611 /* Check that transferred derived type doesn't contain POINTER
3613 if (derived_pointer (ts->derived))
3615 gfc_error ("Data transfer element at %L cannot have "
3616 "POINTER components", &code->loc);
3620 if (derived_inaccessible (ts->derived))
3622 gfc_error ("Data transfer element at %L cannot have "
3623 "PRIVATE components",&code->loc);
3628 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3629 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3631 gfc_error ("Data transfer element at %L cannot be a full reference to "
3632 "an assumed-size array", &code->loc);
3638 /*********** Toplevel code resolution subroutines ***********/
3640 /* Given a branch to a label and a namespace, if the branch is conforming.
3641 The code node described where the branch is located. */
3644 resolve_branch (gfc_st_label * label, gfc_code * code)
3646 gfc_code *block, *found;
3654 /* Step one: is this a valid branching target? */
3656 if (lp->defined == ST_LABEL_UNKNOWN)
3658 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3663 if (lp->defined != ST_LABEL_TARGET)
3665 gfc_error ("Statement at %L is not a valid branch target statement "
3666 "for the branch statement at %L", &lp->where, &code->loc);
3670 /* Step two: make sure this branch is not a branch to itself ;-) */
3672 if (code->here == label)
3674 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3678 /* Step three: Try to find the label in the parse tree. To do this,
3679 we traverse the tree block-by-block: first the block that
3680 contains this GOTO, then the block that it is nested in, etc. We
3681 can ignore other blocks because branching into another block is
3686 for (stack = cs_base; stack; stack = stack->prev)
3688 for (block = stack->head; block; block = block->next)
3690 if (block->here == label)
3703 /* The label is not in an enclosing block, so illegal. This was
3704 allowed in Fortran 66, so we allow it as extension. We also
3705 forego further checks if we run into this. */
3706 gfc_notify_std (GFC_STD_LEGACY,
3707 "Label at %L is not in the same block as the "
3708 "GOTO statement at %L", &lp->where, &code->loc);
3712 /* Step four: Make sure that the branching target is legal if
3713 the statement is an END {SELECT,DO,IF}. */
3715 if (found->op == EXEC_NOP)
3717 for (stack = cs_base; stack; stack = stack->prev)
3718 if (stack->current->next == found)
3722 gfc_notify_std (GFC_STD_F95_DEL,
3723 "Obsolete: GOTO at %L jumps to END of construct at %L",
3724 &code->loc, &found->loc);
3729 /* Check whether EXPR1 has the same shape as EXPR2. */
3732 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3734 mpz_t shape[GFC_MAX_DIMENSIONS];
3735 mpz_t shape2[GFC_MAX_DIMENSIONS];
3736 try result = FAILURE;
3739 /* Compare the rank. */
3740 if (expr1->rank != expr2->rank)
3743 /* Compare the size of each dimension. */
3744 for (i=0; i<expr1->rank; i++)
3746 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3749 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3752 if (mpz_cmp (shape[i], shape2[i]))
3756 /* When either of the two expression is an assumed size array, we
3757 ignore the comparison of dimension sizes. */
3762 for (i--; i>=0; i--)
3764 mpz_clear (shape[i]);
3765 mpz_clear (shape2[i]);
3771 /* Check whether a WHERE assignment target or a WHERE mask expression
3772 has the same shape as the outmost WHERE mask expression. */
3775 resolve_where (gfc_code *code, gfc_expr *mask)
3781 cblock = code->block;
3783 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3784 In case of nested WHERE, only the outmost one is stored. */
3785 if (mask == NULL) /* outmost WHERE */
3787 else /* inner WHERE */
3794 /* Check if the mask-expr has a consistent shape with the
3795 outmost WHERE mask-expr. */
3796 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3797 gfc_error ("WHERE mask at %L has inconsistent shape",
3798 &cblock->expr->where);
3801 /* the assignment statement of a WHERE statement, or the first
3802 statement in where-body-construct of a WHERE construct */
3803 cnext = cblock->next;
3808 /* WHERE assignment statement */
3811 /* Check shape consistent for WHERE assignment target. */
3812 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3813 gfc_error ("WHERE assignment target at %L has "
3814 "inconsistent shape", &cnext->expr->where);
3817 /* WHERE or WHERE construct is part of a where-body-construct */
3819 resolve_where (cnext, e);
3823 gfc_error ("Unsupported statement inside WHERE at %L",
3826 /* the next statement within the same where-body-construct */
3827 cnext = cnext->next;
3829 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3830 cblock = cblock->block;
3835 /* Check whether the FORALL index appears in the expression or not. */
3838 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3842 gfc_actual_arglist *args;
3845 switch (expr->expr_type)
3848 gcc_assert (expr->symtree->n.sym);
3850 /* A scalar assignment */
3853 if (expr->symtree->n.sym == symbol)
3859 /* the expr is array ref, substring or struct component. */
3866 /* Check if the symbol appears in the array subscript. */
3868 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3871 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3875 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3879 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3885 if (expr->symtree->n.sym == symbol)
3888 /* Check if the symbol appears in the substring section. */
3889 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3891 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3899 gfc_error("expresion reference type error at %L", &expr->where);
3905 /* If the expression is a function call, then check if the symbol
3906 appears in the actual arglist of the function. */
3908 for (args = expr->value.function.actual; args; args = args->next)
3910 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3915 /* It seems not to happen. */
3916 case EXPR_SUBSTRING:
3920 gcc_assert (expr->ref->type == REF_SUBSTRING);
3921 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3923 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3928 /* It seems not to happen. */
3929 case EXPR_STRUCTURE:
3931 gfc_error ("Unsupported statement while finding forall index in "
3936 /* Find the FORALL index in the first operand. */
3937 if (expr->value.op.op1)
3939 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3943 /* Find the FORALL index in the second operand. */
3944 if (expr->value.op.op2)
3946 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3959 /* Resolve assignment in FORALL construct.
3960 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3961 FORALL index variables. */
3964 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3968 for (n = 0; n < nvar; n++)
3970 gfc_symbol *forall_index;
3972 forall_index = var_expr[n]->symtree->n.sym;
3974 /* Check whether the assignment target is one of the FORALL index
3976 if ((code->expr->expr_type == EXPR_VARIABLE)
3977 && (code->expr->symtree->n.sym == forall_index))
3978 gfc_error ("Assignment to a FORALL index variable at %L",
3979 &code->expr->where);
3982 /* If one of the FORALL index variables doesn't appear in the
3983 assignment target, then there will be a many-to-one
3985 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3986 gfc_error ("The FORALL with index '%s' cause more than one "
3987 "assignment to this object at %L",
3988 var_expr[n]->symtree->name, &code->expr->where);
3994 /* Resolve WHERE statement in FORALL construct. */
3997 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4001 cblock = code->block;
4004 /* the assignment statement of a WHERE statement, or the first
4005 statement in where-body-construct of a WHERE construct */
4006 cnext = cblock->next;
4011 /* WHERE assignment statement */
4013 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4016 /* WHERE or WHERE construct is part of a where-body-construct */
4018 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4022 gfc_error ("Unsupported statement inside WHERE at %L",
4025 /* the next statement within the same where-body-construct */
4026 cnext = cnext->next;
4028 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4029 cblock = cblock->block;
4034 /* Traverse the FORALL body to check whether the following errors exist:
4035 1. For assignment, check if a many-to-one assignment happens.
4036 2. For WHERE statement, check the WHERE body to see if there is any
4037 many-to-one assignment. */
4040 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4044 c = code->block->next;
4050 case EXEC_POINTER_ASSIGN:
4051 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4054 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4055 there is no need to handle it here. */
4059 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4064 /* The next statement in the FORALL body. */
4070 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4071 gfc_resolve_forall_body to resolve the FORALL body. */
4074 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4076 static gfc_expr **var_expr;
4077 static int total_var = 0;
4078 static int nvar = 0;
4079 gfc_forall_iterator *fa;
4080 gfc_symbol *forall_index;
4084 /* Start to resolve a FORALL construct */
4085 if (forall_save == 0)
4087 /* Count the total number of FORALL index in the nested FORALL
4088 construct in order to allocate the VAR_EXPR with proper size. */
4090 while ((next != NULL) && (next->op == EXEC_FORALL))
4092 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4094 next = next->block->next;
4097 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4098 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4101 /* The information about FORALL iterator, including FORALL index start, end
4102 and stride. The FORALL index can not appear in start, end or stride. */
4103 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4105 /* Check if any outer FORALL index name is the same as the current
4107 for (i = 0; i < nvar; i++)
4109 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4111 gfc_error ("An outer FORALL construct already has an index "
4112 "with this name %L", &fa->var->where);
4116 /* Record the current FORALL index. */
4117 var_expr[nvar] = gfc_copy_expr (fa->var);
4119 forall_index = fa->var->symtree->n.sym;
4121 /* Check if the FORALL index appears in start, end or stride. */
4122 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4123 gfc_error ("A FORALL index must not appear in a limit or stride "
4124 "expression in the same FORALL at %L", &fa->start->where);
4125 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4126 gfc_error ("A FORALL index must not appear in a limit or stride "
4127 "expression in the same FORALL at %L", &fa->end->where);
4128 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4129 gfc_error ("A FORALL index must not appear in a limit or stride "
4130 "expression in the same FORALL at %L", &fa->stride->where);
4134 /* Resolve the FORALL body. */
4135 gfc_resolve_forall_body (code, nvar, var_expr);
4137 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4138 gfc_resolve_blocks (code->block, ns);
4140 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4141 for (i = 0; i < total_var; i++)
4142 gfc_free_expr (var_expr[i]);
4144 /* Reset the counters. */
4150 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4153 static void resolve_code (gfc_code *, gfc_namespace *);
4156 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4160 for (; b; b = b->block)
4162 t = gfc_resolve_expr (b->expr);
4163 if (gfc_resolve_expr (b->expr2) == FAILURE)
4169 if (t == SUCCESS && b->expr != NULL
4170 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4172 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4179 && (b->expr->ts.type != BT_LOGICAL
4180 || b->expr->rank == 0))
4182 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4187 resolve_branch (b->label, b);
4199 case EXEC_OMP_ATOMIC:
4200 case EXEC_OMP_CRITICAL:
4202 case EXEC_OMP_MASTER:
4203 case EXEC_OMP_ORDERED:
4204 case EXEC_OMP_PARALLEL:
4205 case EXEC_OMP_PARALLEL_DO:
4206 case EXEC_OMP_PARALLEL_SECTIONS:
4207 case EXEC_OMP_PARALLEL_WORKSHARE:
4208 case EXEC_OMP_SECTIONS:
4209 case EXEC_OMP_SINGLE:
4210 case EXEC_OMP_WORKSHARE:
4214 gfc_internal_error ("resolve_block(): Bad block type");
4217 resolve_code (b->next, ns);
4222 /* Given a block of code, recursively resolve everything pointed to by this
4226 resolve_code (gfc_code * code, gfc_namespace * ns)
4228 int omp_workshare_save;
4233 frame.prev = cs_base;
4237 for (; code; code = code->next)
4239 frame.current = code;
4241 if (code->op == EXEC_FORALL)
4243 int forall_save = forall_flag;
4246 gfc_resolve_forall (code, ns, forall_save);
4247 forall_flag = forall_save;
4249 else if (code->block)
4251 omp_workshare_save = -1;
4254 case EXEC_OMP_PARALLEL_WORKSHARE:
4255 omp_workshare_save = omp_workshare_flag;
4256 omp_workshare_flag = 1;
4257 gfc_resolve_omp_parallel_blocks (code, ns);
4259 case EXEC_OMP_PARALLEL:
4260 case EXEC_OMP_PARALLEL_DO:
4261 case EXEC_OMP_PARALLEL_SECTIONS:
4262 omp_workshare_save = omp_workshare_flag;
4263 omp_workshare_flag = 0;
4264 gfc_resolve_omp_parallel_blocks (code, ns);
4267 gfc_resolve_omp_do_blocks (code, ns);
4269 case EXEC_OMP_WORKSHARE:
4270 omp_workshare_save = omp_workshare_flag;
4271 omp_workshare_flag = 1;
4274 gfc_resolve_blocks (code->block, ns);
4278 if (omp_workshare_save != -1)
4279 omp_workshare_flag = omp_workshare_save;
4282 t = gfc_resolve_expr (code->expr);
4283 if (gfc_resolve_expr (code->expr2) == FAILURE)
4299 resolve_where (code, NULL);
4303 if (code->expr != NULL)
4305 if (code->expr->ts.type != BT_INTEGER)
4306 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4307 "variable", &code->expr->where);
4308 else if (code->expr->symtree->n.sym->attr.assign != 1)
4309 gfc_error ("Variable '%s' has not been assigned a target label "
4310 "at %L", code->expr->symtree->n.sym->name,
4311 &code->expr->where);
4314 resolve_branch (code->label, code);
4318 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4319 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4320 "return specifier", &code->expr->where);
4327 if (gfc_extend_assign (code, ns) == SUCCESS)
4329 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4331 gfc_error ("Subroutine '%s' called instead of assignment at "
4332 "%L must be PURE", code->symtree->n.sym->name,
4339 if (gfc_pure (NULL))
4341 if (gfc_impure_variable (code->expr->symtree->n.sym))
4344 ("Cannot assign to variable '%s' in PURE procedure at %L",
4345 code->expr->symtree->n.sym->name, &code->expr->where);
4349 if (code->expr2->ts.type == BT_DERIVED
4350 && derived_pointer (code->expr2->ts.derived))
4353 ("Right side of assignment at %L is a derived type "
4354 "containing a POINTER in a PURE procedure",
4355 &code->expr2->where);
4360 gfc_check_assign (code->expr, code->expr2, 1);
4363 case EXEC_LABEL_ASSIGN:
4364 if (code->label->defined == ST_LABEL_UNKNOWN)
4365 gfc_error ("Label %d referenced at %L is never defined",
4366 code->label->value, &code->label->where);
4368 && (code->expr->expr_type != EXPR_VARIABLE
4369 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4370 || code->expr->symtree->n.sym->ts.kind
4371 != gfc_default_integer_kind
4372 || code->expr->symtree->n.sym->as != NULL))
4373 gfc_error ("ASSIGN statement at %L requires a scalar "
4374 "default INTEGER variable", &code->expr->where);
4377 case EXEC_POINTER_ASSIGN:
4381 gfc_check_pointer_assign (code->expr, code->expr2);
4384 case EXEC_ARITHMETIC_IF:
4386 && code->expr->ts.type != BT_INTEGER
4387 && code->expr->ts.type != BT_REAL)
4388 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4389 "expression", &code->expr->where);
4391 resolve_branch (code->label, code);
4392 resolve_branch (code->label2, code);
4393 resolve_branch (code->label3, code);
4397 if (t == SUCCESS && code->expr != NULL
4398 && (code->expr->ts.type != BT_LOGICAL
4399 || code->expr->rank != 0))
4400 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4401 &code->expr->where);
4406 resolve_call (code);
4410 /* Select is complicated. Also, a SELECT construct could be
4411 a transformed computed GOTO. */
4412 resolve_select (code);
4416 if (code->ext.iterator != NULL)
4418 gfc_iterator *iter = code->ext.iterator;
4419 if (gfc_resolve_iterator (iter, true) != FAILURE)
4420 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4425 if (code->expr == NULL)
4426 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4428 && (code->expr->rank != 0
4429 || code->expr->ts.type != BT_LOGICAL))
4430 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4431 "a scalar LOGICAL expression", &code->expr->where);
4435 if (t == SUCCESS && code->expr != NULL
4436 && code->expr->ts.type != BT_INTEGER)
4437 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4438 "of type INTEGER", &code->expr->where);
4440 for (a = code->ext.alloc_list; a; a = a->next)
4441 resolve_allocate_expr (a->expr, code);
4445 case EXEC_DEALLOCATE:
4446 if (t == SUCCESS && code->expr != NULL
4447 && code->expr->ts.type != BT_INTEGER)
4449 ("STAT tag in DEALLOCATE statement at %L must be of type "
4450 "INTEGER", &code->expr->where);
4452 for (a = code->ext.alloc_list; a; a = a->next)
4453 resolve_deallocate_expr (a->expr);
4458 if (gfc_resolve_open (code->ext.open) == FAILURE)
4461 resolve_branch (code->ext.open->err, code);
4465 if (gfc_resolve_close (code->ext.close) == FAILURE)
4468 resolve_branch (code->ext.close->err, code);
4471 case EXEC_BACKSPACE:
4475 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4478 resolve_branch (code->ext.filepos->err, code);
4482 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4485 resolve_branch (code->ext.inquire->err, code);
4489 gcc_assert (code->ext.inquire != NULL);
4490 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4493 resolve_branch (code->ext.inquire->err, code);
4498 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4501 resolve_branch (code->ext.dt->err, code);
4502 resolve_branch (code->ext.dt->end, code);
4503 resolve_branch (code->ext.dt->eor, code);
4507 resolve_transfer (code);
4511 resolve_forall_iterators (code->ext.forall_iterator);
4513 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4515 ("FORALL mask clause at %L requires a LOGICAL expression",
4516 &code->expr->where);
4519 case EXEC_OMP_ATOMIC:
4520 case EXEC_OMP_BARRIER:
4521 case EXEC_OMP_CRITICAL:
4522 case EXEC_OMP_FLUSH:
4524 case EXEC_OMP_MASTER:
4525 case EXEC_OMP_ORDERED:
4526 case EXEC_OMP_SECTIONS:
4527 case EXEC_OMP_SINGLE:
4528 case EXEC_OMP_WORKSHARE:
4529 gfc_resolve_omp_directive (code, ns);
4532 case EXEC_OMP_PARALLEL:
4533 case EXEC_OMP_PARALLEL_DO:
4534 case EXEC_OMP_PARALLEL_SECTIONS:
4535 case EXEC_OMP_PARALLEL_WORKSHARE:
4536 omp_workshare_save = omp_workshare_flag;
4537 omp_workshare_flag = 0;
4538 gfc_resolve_omp_directive (code, ns);
4539 omp_workshare_flag = omp_workshare_save;
4543 gfc_internal_error ("resolve_code(): Bad statement code");
4547 cs_base = frame.prev;
4551 /* Resolve initial values and make sure they are compatible with
4555 resolve_values (gfc_symbol * sym)
4558 if (sym->value == NULL)
4561 if (gfc_resolve_expr (sym->value) == FAILURE)
4564 gfc_check_assign_symbol (sym, sym->value);
4568 /* Resolve an index expression. */
4571 resolve_index_expr (gfc_expr * e)
4574 if (gfc_resolve_expr (e) == FAILURE)
4577 if (gfc_simplify_expr (e, 0) == FAILURE)
4580 if (gfc_specification_expr (e) == FAILURE)
4586 /* Resolve a charlen structure. */
4589 resolve_charlen (gfc_charlen *cl)
4596 if (resolve_index_expr (cl->length) == FAILURE)
4603 /* Test for non-constant shape arrays. */
4606 is_non_constant_shape_array (gfc_symbol *sym)
4611 if (sym->as != NULL)
4613 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
4614 has not been simplified; parameter array references. Do the
4615 simplification now. */
4616 for (i = 0; i < sym->as->rank; i++)
4618 e = sym->as->lower[i];
4619 if (e && (resolve_index_expr (e) == FAILURE
4620 || !gfc_is_constant_expr (e)))
4623 e = sym->as->upper[i];
4624 if (e && (resolve_index_expr (e) == FAILURE
4625 || !gfc_is_constant_expr (e)))
4632 /* Resolution of common features of flavors variable and procedure. */
4635 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
4637 /* Constraints on deferred shape variable. */
4638 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4640 if (sym->attr.allocatable)
4642 if (sym->attr.dimension)
4643 gfc_error ("Allocatable array '%s' at %L must have "
4644 "a deferred shape", sym->name, &sym->declared_at);
4646 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4647 sym->name, &sym->declared_at);
4651 if (sym->attr.pointer && sym->attr.dimension)
4653 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4654 sym->name, &sym->declared_at);
4661 if (!mp_flag && !sym->attr.allocatable
4662 && !sym->attr.pointer && !sym->attr.dummy)
4664 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4665 sym->name, &sym->declared_at);
4672 /* Resolve symbols with flavor variable. */
4675 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
4680 gfc_expr *constructor_expr;
4682 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4685 /* The shape of a main program or module array needs to be constant. */
4686 if (sym->ns->proc_name
4687 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4688 || sym->ns->proc_name->attr.is_main_program)
4689 && !sym->attr.use_assoc
4690 && !sym->attr.allocatable
4691 && !sym->attr.pointer
4692 && is_non_constant_shape_array (sym))
4694 gfc_error ("The module or main program array '%s' at %L must "
4695 "have constant shape", sym->name, &sym->declared_at);
4699 if (sym->ts.type == BT_CHARACTER)
4701 /* Make sure that character string variables with assumed length are
4703 e = sym->ts.cl->length;
4704 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
4706 gfc_error ("Entity with assumed character length at %L must be a "
4707 "dummy argument or a PARAMETER", &sym->declared_at);
4711 if (!gfc_is_constant_expr (e)
4712 && !(e->expr_type == EXPR_VARIABLE
4713 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
4714 && sym->ns->proc_name
4715 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4716 || sym->ns->proc_name->attr.is_main_program)
4717 && !sym->attr.use_assoc)
4719 gfc_error ("'%s' at %L must have constant character length "
4720 "in this context", sym->name, &sym->declared_at);
4725 /* Can the symbol have an initializer? */
4727 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4728 || sym->attr.intrinsic || sym->attr.result)
4730 else if (sym->attr.dimension && !sym->attr.pointer)
4732 /* Don't allow initialization of automatic arrays. */
4733 for (i = 0; i < sym->as->rank; i++)
4735 if (sym->as->lower[i] == NULL
4736 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4737 || sym->as->upper[i] == NULL
4738 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4746 /* Reject illegal initializers. */
4747 if (sym->value && flag)
4749 if (sym->attr.allocatable)
4750 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4751 sym->name, &sym->declared_at);
4752 else if (sym->attr.external)
4753 gfc_error ("External '%s' at %L cannot have an initializer",
4754 sym->name, &sym->declared_at);
4755 else if (sym->attr.dummy)
4756 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4757 sym->name, &sym->declared_at);
4758 else if (sym->attr.intrinsic)
4759 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4760 sym->name, &sym->declared_at);
4761 else if (sym->attr.result)
4762 gfc_error ("Function result '%s' at %L cannot have an initializer",
4763 sym->name, &sym->declared_at);
4765 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4766 sym->name, &sym->declared_at);
4770 /* 4th constraint in section 11.3: "If an object of a type for which
4771 component-initialization is specified (R429) appears in the
4772 specification-part of a module and does not have the ALLOCATABLE
4773 or POINTER attribute, the object shall have the SAVE attribute." */
4775 constructor_expr = NULL;
4776 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
4777 constructor_expr = gfc_default_initializer (&sym->ts);
4779 if (sym->ns->proc_name
4780 && sym->ns->proc_name->attr.flavor == FL_MODULE
4782 && !sym->ns->save_all && !sym->attr.save
4783 && !sym->attr.pointer && !sym->attr.allocatable)
4785 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4786 sym->name, &sym->declared_at,
4787 "for default initialization of a component");
4791 /* Assign default initializer. */
4792 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4793 && !sym->attr.pointer)
4794 sym->value = gfc_default_initializer (&sym->ts);
4800 /* Resolve a procedure. */
4803 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
4805 gfc_formal_arglist *arg;
4807 if (sym->attr.function
4808 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4811 if (sym->attr.proc == PROC_ST_FUNCTION)
4813 if (sym->ts.type == BT_CHARACTER)
4815 gfc_charlen *cl = sym->ts.cl;
4816 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4818 gfc_error ("Character-valued statement function '%s' at %L must "
4819 "have constant length", sym->name, &sym->declared_at);
4825 /* Ensure that derived type formal arguments of a public procedure
4826 are not of a private type. */
4827 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4829 for (arg = sym->formal; arg; arg = arg->next)
4832 && arg->sym->ts.type == BT_DERIVED
4833 && !arg->sym->ts.derived->attr.use_assoc
4834 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4835 arg->sym->ts.derived->ns->default_access))
4837 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
4838 "a dummy argument of '%s', which is "
4839 "PUBLIC at %L", arg->sym->name, sym->name,
4841 /* Stop this message from recurring. */
4842 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4848 /* An external symbol may not have an intializer because it is taken to be
4850 if (sym->attr.external && sym->value)
4852 gfc_error ("External object '%s' at %L may not have an initializer",
4853 sym->name, &sym->declared_at);
4857 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4858 char-len-param shall not be array-valued, pointer-valued, recursive
4859 or pure. ....snip... A character value of * may only be used in the
4860 following ways: (i) Dummy arg of procedure - dummy associates with
4861 actual length; (ii) To declare a named constant; or (iii) External
4862 function - but length must be declared in calling scoping unit. */
4863 if (sym->attr.function
4864 && sym->ts.type == BT_CHARACTER
4865 && sym->ts.cl && sym->ts.cl->length == NULL)
4867 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
4868 || (sym->attr.recursive) || (sym->attr.pure))
4870 if (sym->as && sym->as->rank)
4871 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4872 "array-valued", sym->name, &sym->declared_at);
4874 if (sym->attr.pointer)
4875 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4876 "pointer-valued", sym->name, &sym->declared_at);
4879 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4880 "pure", sym->name, &sym->declared_at);
4882 if (sym->attr.recursive)
4883 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4884 "recursive", sym->name, &sym->declared_at);
4889 /* Appendix B.2 of the standard. Contained functions give an
4890 error anyway. Fixed-form is likely to be F77/legacy. */
4891 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
4892 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
4893 "'%s' at %L is obsolescent in fortran 95",
4894 sym->name, &sym->declared_at);
4900 /* Resolve the components of a derived type. */
4903 resolve_fl_derived (gfc_symbol *sym)
4906 gfc_dt_list * dt_list;
4909 for (c = sym->components; c != NULL; c = c->next)
4911 if (c->ts.type == BT_CHARACTER)
4913 if (c->ts.cl->length == NULL
4914 || (resolve_charlen (c->ts.cl) == FAILURE)
4915 || !gfc_is_constant_expr (c->ts.cl->length))
4917 gfc_error ("Character length of component '%s' needs to "
4918 "be a constant specification expression at %L.",
4920 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
4925 if (c->ts.type == BT_DERIVED
4926 && sym->component_access != ACCESS_PRIVATE
4927 && gfc_check_access(sym->attr.access, sym->ns->default_access)
4928 && !c->ts.derived->attr.use_assoc
4929 && !gfc_check_access(c->ts.derived->attr.access,
4930 c->ts.derived->ns->default_access))
4932 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4933 "a component of '%s', which is PUBLIC at %L",
4934 c->name, sym->name, &sym->declared_at);
4938 if (c->pointer || c->as == NULL)
4941 for (i = 0; i < c->as->rank; i++)
4943 if (c->as->lower[i] == NULL
4944 || !gfc_is_constant_expr (c->as->lower[i])
4945 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
4946 || c->as->upper[i] == NULL
4947 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
4948 || !gfc_is_constant_expr (c->as->upper[i]))
4950 gfc_error ("Component '%s' of '%s' at %L must have "
4951 "constant array bounds.",
4952 c->name, sym->name, &c->loc);
4958 /* Add derived type to the derived type list. */
4959 dt_list = gfc_get_dt_list ();
4960 dt_list->next = sym->ns->derived_types;
4961 dt_list->derived = sym;
4962 sym->ns->derived_types = dt_list;
4969 resolve_fl_namelist (gfc_symbol *sym)
4974 /* Reject PRIVATE objects in a PUBLIC namelist. */
4975 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4977 for (nl = sym->namelist; nl; nl = nl->next)
4979 if (!nl->sym->attr.use_assoc
4980 && !(sym->ns->parent == nl->sym->ns)
4981 && !gfc_check_access(nl->sym->attr.access,
4982 nl->sym->ns->default_access))
4984 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4985 "PUBLIC namelist at %L", nl->sym->name,
4992 /* Reject namelist arrays that are not constant shape. */
4993 for (nl = sym->namelist; nl; nl = nl->next)
4995 if (is_non_constant_shape_array (nl->sym))
4997 gfc_error ("The array '%s' must have constant shape to be "
4998 "a NAMELIST object at %L", nl->sym->name,
5004 /* 14.1.2 A module or internal procedure represent local entities
5005 of the same type as a namelist member and so are not allowed.
5006 Note that this is sometimes caught by check_conflict so the
5007 same message has been used. */
5008 for (nl = sym->namelist; nl; nl = nl->next)
5011 if (sym->ns->parent && nl->sym && nl->sym->name)
5012 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5013 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5015 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5016 "attribute in '%s' at %L", nlsym->name,
5027 resolve_fl_parameter (gfc_symbol *sym)
5029 /* A parameter array's shape needs to be constant. */
5030 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5032 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5033 "or assumed shape", sym->name, &sym->declared_at);
5037 /* Make sure a parameter that has been implicitly typed still
5038 matches the implicit type, since PARAMETER statements can precede
5039 IMPLICIT statements. */
5040 if (sym->attr.implicit_type
5041 && !gfc_compare_types (&sym->ts,
5042 gfc_get_default_type (sym, sym->ns)))
5044 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5045 "later IMPLICIT type", sym->name, &sym->declared_at);
5049 /* Make sure the types of derived parameters are consistent. This
5050 type checking is deferred until resolution because the type may
5051 refer to a derived type from the host. */
5052 if (sym->ts.type == BT_DERIVED
5053 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5055 gfc_error ("Incompatible derived type in PARAMETER at %L",
5056 &sym->value->where);
5063 /* Do anything necessary to resolve a symbol. Right now, we just
5064 assume that an otherwise unknown symbol is a variable. This sort
5065 of thing commonly happens for symbols in module. */
5068 resolve_symbol (gfc_symbol * sym)
5070 /* Zero if we are checking a formal namespace. */
5071 static int formal_ns_flag = 1;
5072 int formal_ns_save, check_constant, mp_flag;
5073 gfc_symtree *symtree;
5074 gfc_symtree *this_symtree;
5078 if (sym->attr.flavor == FL_UNKNOWN)
5081 /* If we find that a flavorless symbol is an interface in one of the
5082 parent namespaces, find its symtree in this namespace, free the
5083 symbol and set the symtree to point to the interface symbol. */
5084 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5086 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5087 if (symtree && symtree->n.sym->generic)
5089 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5093 gfc_free_symbol (sym);
5094 symtree->n.sym->refs++;
5095 this_symtree->n.sym = symtree->n.sym;
5100 /* Otherwise give it a flavor according to such attributes as
5102 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5103 sym->attr.flavor = FL_VARIABLE;
5106 sym->attr.flavor = FL_PROCEDURE;
5107 if (sym->attr.dimension)
5108 sym->attr.function = 1;
5112 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5115 /* Symbols that are module procedures with results (functions) have
5116 the types and array specification copied for type checking in
5117 procedures that call them, as well as for saving to a module
5118 file. These symbols can't stand the scrutiny that their results
5120 mp_flag = (sym->result != NULL && sym->result != sym);
5122 /* Assign default type to symbols that need one and don't have one. */
5123 if (sym->ts.type == BT_UNKNOWN)
5125 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5126 gfc_set_default_type (sym, 1, NULL);
5128 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5130 /* The specific case of an external procedure should emit an error
5131 in the case that there is no implicit type. */
5133 gfc_set_default_type (sym, sym->attr.external, NULL);
5136 /* Result may be in another namespace. */
5137 resolve_symbol (sym->result);
5139 sym->ts = sym->result->ts;
5140 sym->as = gfc_copy_array_spec (sym->result->as);
5141 sym->attr.dimension = sym->result->attr.dimension;
5142 sym->attr.pointer = sym->result->attr.pointer;
5147 /* Assumed size arrays and assumed shape arrays must be dummy
5151 && (sym->as->type == AS_ASSUMED_SIZE
5152 || sym->as->type == AS_ASSUMED_SHAPE)
5153 && sym->attr.dummy == 0)
5155 if (sym->as->type == AS_ASSUMED_SIZE)
5156 gfc_error ("Assumed size array at %L must be a dummy argument",
5159 gfc_error ("Assumed shape array at %L must be a dummy argument",
5164 /* Make sure symbols with known intent or optional are really dummy
5165 variable. Because of ENTRY statement, this has to be deferred
5166 until resolution time. */
5168 if (!sym->attr.dummy
5169 && (sym->attr.optional
5170 || sym->attr.intent != INTENT_UNKNOWN))
5172 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5176 /* If a derived type symbol has reached this point, without its
5177 type being declared, we have an error. Notice that most
5178 conditions that produce undefined derived types have already
5179 been dealt with. However, the likes of:
5180 implicit type(t) (t) ..... call foo (t) will get us here if
5181 the type is not declared in the scope of the implicit
5182 statement. Change the type to BT_UNKNOWN, both because it is so
5183 and to prevent an ICE. */
5184 if (sym->ts.type == BT_DERIVED
5185 && sym->ts.derived->components == NULL)
5187 gfc_error ("The derived type '%s' at %L is of type '%s', "
5188 "which has not been defined.", sym->name,
5189 &sym->declared_at, sym->ts.derived->name);
5190 sym->ts.type = BT_UNKNOWN;
5194 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5195 default initialization is defined (5.1.2.4.4). */
5196 if (sym->ts.type == BT_DERIVED
5198 && sym->attr.intent == INTENT_OUT
5200 && sym->as->type == AS_ASSUMED_SIZE)
5202 for (c = sym->ts.derived->components; c; c = c->next)
5206 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5207 "ASSUMED SIZE and so cannot have a default initializer",
5208 sym->name, &sym->declared_at);
5214 switch (sym->attr.flavor)
5217 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5222 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5227 if (resolve_fl_namelist (sym) == FAILURE)
5232 if (resolve_fl_parameter (sym) == FAILURE)
5242 /* Make sure that intrinsic exist */
5243 if (sym->attr.intrinsic
5244 && ! gfc_intrinsic_name(sym->name, 0)
5245 && ! gfc_intrinsic_name(sym->name, 1))
5246 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5248 /* Resolve array specifier. Check as well some constraints
5249 on COMMON blocks. */
5251 check_constant = sym->attr.in_common && !sym->attr.pointer;
5252 gfc_resolve_array_spec (sym->as, check_constant);
5254 /* Resolve formal namespaces. */
5256 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5258 formal_ns_save = formal_ns_flag;
5260 gfc_resolve (sym->formal_ns);
5261 formal_ns_flag = formal_ns_save;
5264 /* Check threadprivate restrictions. */
5265 if (sym->attr.threadprivate && !sym->attr.save
5266 && (!sym->attr.in_common
5267 && sym->module == NULL
5268 && (sym->ns->proc_name == NULL
5269 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5270 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5275 /************* Resolve DATA statements *************/
5279 gfc_data_value *vnode;
5285 /* Advance the values structure to point to the next value in the data list. */
5288 next_data_value (void)
5290 while (values.left == 0)
5292 if (values.vnode->next == NULL)
5295 values.vnode = values.vnode->next;
5296 values.left = values.vnode->repeat;
5304 check_data_variable (gfc_data_variable * var, locus * where)
5310 ar_type mark = AR_UNKNOWN;
5312 mpz_t section_index[GFC_MAX_DIMENSIONS];
5316 if (gfc_resolve_expr (var->expr) == FAILURE)
5320 mpz_init_set_si (offset, 0);
5323 if (e->expr_type != EXPR_VARIABLE)
5324 gfc_internal_error ("check_data_variable(): Bad expression");
5326 if (e->symtree->n.sym->ns->is_block_data
5327 && !e->symtree->n.sym->attr.in_common)
5329 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5330 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5335 mpz_init_set_ui (size, 1);
5342 /* Find the array section reference. */
5343 for (ref = e->ref; ref; ref = ref->next)
5345 if (ref->type != REF_ARRAY)
5347 if (ref->u.ar.type == AR_ELEMENT)
5353 /* Set marks according to the reference pattern. */
5354 switch (ref->u.ar.type)
5362 /* Get the start position of array section. */
5363 gfc_get_section_index (ar, section_index, &offset);
5371 if (gfc_array_size (e, &size) == FAILURE)
5373 gfc_error ("Nonconstant array section at %L in DATA statement",
5382 while (mpz_cmp_ui (size, 0) > 0)
5384 if (next_data_value () == FAILURE)
5386 gfc_error ("DATA statement at %L has more variables than values",
5392 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5396 /* If we have more than one element left in the repeat count,
5397 and we have more than one element left in the target variable,
5398 then create a range assignment. */
5399 /* ??? Only done for full arrays for now, since array sections
5401 if (mark == AR_FULL && ref && ref->next == NULL
5402 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5406 if (mpz_cmp_ui (size, values.left) >= 0)
5408 mpz_init_set_ui (range, values.left);
5409 mpz_sub_ui (size, size, values.left);
5414 mpz_init_set (range, size);
5415 values.left -= mpz_get_ui (size);
5416 mpz_set_ui (size, 0);
5419 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5422 mpz_add (offset, offset, range);
5426 /* Assign initial value to symbol. */
5430 mpz_sub_ui (size, size, 1);
5432 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5434 if (mark == AR_FULL)
5435 mpz_add_ui (offset, offset, 1);
5437 /* Modify the array section indexes and recalculate the offset
5438 for next element. */
5439 else if (mark == AR_SECTION)
5440 gfc_advance_section (section_index, ar, &offset);
5444 if (mark == AR_SECTION)
5446 for (i = 0; i < ar->dimen; i++)
5447 mpz_clear (section_index[i]);
5457 static try traverse_data_var (gfc_data_variable *, locus *);
5459 /* Iterate over a list of elements in a DATA statement. */
5462 traverse_data_list (gfc_data_variable * var, locus * where)
5465 iterator_stack frame;
5468 mpz_init (frame.value);
5470 mpz_init_set (trip, var->iter.end->value.integer);
5471 mpz_sub (trip, trip, var->iter.start->value.integer);
5472 mpz_add (trip, trip, var->iter.step->value.integer);
5474 mpz_div (trip, trip, var->iter.step->value.integer);
5476 mpz_set (frame.value, var->iter.start->value.integer);
5478 frame.prev = iter_stack;
5479 frame.variable = var->iter.var->symtree;
5480 iter_stack = &frame;
5482 while (mpz_cmp_ui (trip, 0) > 0)
5484 if (traverse_data_var (var->list, where) == FAILURE)
5490 e = gfc_copy_expr (var->expr);
5491 if (gfc_simplify_expr (e, 1) == FAILURE)
5497 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5499 mpz_sub_ui (trip, trip, 1);
5503 mpz_clear (frame.value);
5505 iter_stack = frame.prev;
5510 /* Type resolve variables in the variable list of a DATA statement. */
5513 traverse_data_var (gfc_data_variable * var, locus * where)
5517 for (; var; var = var->next)
5519 if (var->expr == NULL)
5520 t = traverse_data_list (var, where);
5522 t = check_data_variable (var, where);
5532 /* Resolve the expressions and iterators associated with a data statement.
5533 This is separate from the assignment checking because data lists should
5534 only be resolved once. */
5537 resolve_data_variables (gfc_data_variable * d)
5539 for (; d; d = d->next)
5541 if (d->list == NULL)
5543 if (gfc_resolve_expr (d->expr) == FAILURE)
5548 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5551 if (d->iter.start->expr_type != EXPR_CONSTANT
5552 || d->iter.end->expr_type != EXPR_CONSTANT
5553 || d->iter.step->expr_type != EXPR_CONSTANT)
5554 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5556 if (resolve_data_variables (d->list) == FAILURE)
5565 /* Resolve a single DATA statement. We implement this by storing a pointer to
5566 the value list into static variables, and then recursively traversing the
5567 variables list, expanding iterators and such. */
5570 resolve_data (gfc_data * d)
5572 if (resolve_data_variables (d->var) == FAILURE)
5575 values.vnode = d->value;
5576 values.left = (d->value == NULL) ? 0 : d->value->repeat;
5578 if (traverse_data_var (d->var, &d->where) == FAILURE)
5581 /* At this point, we better not have any values left. */
5583 if (next_data_value () == SUCCESS)
5584 gfc_error ("DATA statement at %L has more values than variables",
5589 /* Determines if a variable is not 'pure', ie not assignable within a pure
5590 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5594 gfc_impure_variable (gfc_symbol * sym)
5596 if (sym->attr.use_assoc || sym->attr.in_common)
5599 if (sym->ns != gfc_current_ns)
5600 return !sym->attr.function;
5602 /* TODO: Check storage association through EQUIVALENCE statements */
5608 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5609 symbol of the current procedure. */
5612 gfc_pure (gfc_symbol * sym)
5614 symbol_attribute attr;
5617 sym = gfc_current_ns->proc_name;
5623 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5627 /* Test whether the current procedure is elemental or not. */
5630 gfc_elemental (gfc_symbol * sym)
5632 symbol_attribute attr;
5635 sym = gfc_current_ns->proc_name;
5640 return attr.flavor == FL_PROCEDURE && attr.elemental;
5644 /* Warn about unused labels. */
5647 warn_unused_label (gfc_st_label * label)
5652 warn_unused_label (label->left);
5654 if (label->defined == ST_LABEL_UNKNOWN)
5657 switch (label->referenced)
5659 case ST_LABEL_UNKNOWN:
5660 gfc_warning ("Label %d at %L defined but not used", label->value,
5664 case ST_LABEL_BAD_TARGET:
5665 gfc_warning ("Label %d at %L defined but cannot be used",
5666 label->value, &label->where);
5673 warn_unused_label (label->right);
5677 /* Returns the sequence type of a symbol or sequence. */
5680 sequence_type (gfc_typespec ts)
5689 if (ts.derived->components == NULL)
5690 return SEQ_NONDEFAULT;
5692 result = sequence_type (ts.derived->components->ts);
5693 for (c = ts.derived->components->next; c; c = c->next)
5694 if (sequence_type (c->ts) != result)
5700 if (ts.kind != gfc_default_character_kind)
5701 return SEQ_NONDEFAULT;
5703 return SEQ_CHARACTER;
5706 if (ts.kind != gfc_default_integer_kind)
5707 return SEQ_NONDEFAULT;
5712 if (!(ts.kind == gfc_default_real_kind
5713 || ts.kind == gfc_default_double_kind))
5714 return SEQ_NONDEFAULT;
5719 if (ts.kind != gfc_default_complex_kind)
5720 return SEQ_NONDEFAULT;
5725 if (ts.kind != gfc_default_logical_kind)
5726 return SEQ_NONDEFAULT;
5731 return SEQ_NONDEFAULT;
5736 /* Resolve derived type EQUIVALENCE object. */
5739 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5742 gfc_component *c = derived->components;
5747 /* Shall not be an object of nonsequence derived type. */
5748 if (!derived->attr.sequence)
5750 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5751 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5755 for (; c ; c = c->next)
5758 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5761 /* Shall not be an object of sequence derived type containing a pointer
5762 in the structure. */
5765 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5766 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5772 gfc_error ("Derived type variable '%s' at %L with default initializer "
5773 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5781 /* Resolve equivalence object.
5782 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5783 an allocatable array, an object of nonsequence derived type, an object of
5784 sequence derived type containing a pointer at any level of component
5785 selection, an automatic object, a function name, an entry name, a result
5786 name, a named constant, a structure component, or a subobject of any of
5787 the preceding objects. A substring shall not have length zero. A
5788 derived type shall not have components with default initialization nor
5789 shall two objects of an equivalence group be initialized.
5790 The simple constraints are done in symbol.c(check_conflict) and the rest
5791 are implemented here. */
5794 resolve_equivalence (gfc_equiv *eq)
5797 gfc_symbol *derived;
5798 gfc_symbol *first_sym;
5801 locus *last_where = NULL;
5802 seq_type eq_type, last_eq_type;
5803 gfc_typespec *last_ts;
5805 const char *value_name;
5809 last_ts = &eq->expr->symtree->n.sym->ts;
5811 first_sym = eq->expr->symtree->n.sym;
5813 for (object = 1; eq; eq = eq->eq, object++)
5817 e->ts = e->symtree->n.sym->ts;
5818 /* match_varspec might not know yet if it is seeing
5819 array reference or substring reference, as it doesn't
5821 if (e->ref && e->ref->type == REF_ARRAY)
5823 gfc_ref *ref = e->ref;
5824 sym = e->symtree->n.sym;
5826 if (sym->attr.dimension)
5828 ref->u.ar.as = sym->as;
5832 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5833 if (e->ts.type == BT_CHARACTER
5835 && ref->type == REF_ARRAY
5836 && ref->u.ar.dimen == 1
5837 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5838 && ref->u.ar.stride[0] == NULL)
5840 gfc_expr *start = ref->u.ar.start[0];
5841 gfc_expr *end = ref->u.ar.end[0];
5844 /* Optimize away the (:) reference. */
5845 if (start == NULL && end == NULL)
5850 e->ref->next = ref->next;
5855 ref->type = REF_SUBSTRING;
5857 start = gfc_int_expr (1);
5858 ref->u.ss.start = start;
5859 if (end == NULL && e->ts.cl)
5860 end = gfc_copy_expr (e->ts.cl->length);
5861 ref->u.ss.end = end;
5862 ref->u.ss.length = e->ts.cl;
5869 /* Any further ref is an error. */
5872 gcc_assert (ref->type == REF_ARRAY);
5873 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5879 if (gfc_resolve_expr (e) == FAILURE)
5882 sym = e->symtree->n.sym;
5884 /* An equivalence statement cannot have more than one initialized
5888 if (value_name != NULL)
5890 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5891 "be in the EQUIVALENCE statement at %L",
5892 value_name, sym->name, &e->where);
5896 value_name = sym->name;
5899 /* Shall not equivalence common block variables in a PURE procedure. */
5900 if (sym->ns->proc_name
5901 && sym->ns->proc_name->attr.pure
5902 && sym->attr.in_common)
5904 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5905 "object in the pure procedure '%s'",
5906 sym->name, &e->where, sym->ns->proc_name->name);
5910 /* Shall not be a named constant. */
5911 if (e->expr_type == EXPR_CONSTANT)
5913 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5914 "object", sym->name, &e->where);
5918 derived = e->ts.derived;
5919 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5922 /* Check that the types correspond correctly:
5924 A numeric sequence structure may be equivalenced to another sequence
5925 structure, an object of default integer type, default real type, double
5926 precision real type, default logical type such that components of the
5927 structure ultimately only become associated to objects of the same
5928 kind. A character sequence structure may be equivalenced to an object
5929 of default character kind or another character sequence structure.
5930 Other objects may be equivalenced only to objects of the same type and
5933 /* Identical types are unconditionally OK. */
5934 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5935 goto identical_types;
5937 last_eq_type = sequence_type (*last_ts);
5938 eq_type = sequence_type (sym->ts);
5940 /* Since the pair of objects is not of the same type, mixed or
5941 non-default sequences can be rejected. */
5943 msg = "Sequence %s with mixed components in EQUIVALENCE "
5944 "statement at %L with different type objects";
5946 && last_eq_type == SEQ_MIXED
5947 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5948 last_where) == FAILURE)
5949 || (eq_type == SEQ_MIXED
5950 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5951 &e->where) == FAILURE))
5954 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5955 "statement at %L with objects of different type";
5957 && last_eq_type == SEQ_NONDEFAULT
5958 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5959 last_where) == FAILURE)
5960 || (eq_type == SEQ_NONDEFAULT
5961 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5962 &e->where) == FAILURE))
5965 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5966 "EQUIVALENCE statement at %L";
5967 if (last_eq_type == SEQ_CHARACTER
5968 && eq_type != SEQ_CHARACTER
5969 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5970 &e->where) == FAILURE)
5973 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5974 "EQUIVALENCE statement at %L";
5975 if (last_eq_type == SEQ_NUMERIC
5976 && eq_type != SEQ_NUMERIC
5977 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5978 &e->where) == FAILURE)
5983 last_where = &e->where;
5988 /* Shall not be an automatic array. */
5989 if (e->ref->type == REF_ARRAY
5990 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5992 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5993 "an EQUIVALENCE object", sym->name, &e->where);
6000 /* Shall not be a structure component. */
6001 if (r->type == REF_COMPONENT)
6003 gfc_error ("Structure component '%s' at %L cannot be an "
6004 "EQUIVALENCE object",
6005 r->u.c.component->name, &e->where);
6009 /* A substring shall not have length zero. */
6010 if (r->type == REF_SUBSTRING)
6012 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6014 gfc_error ("Substring at %L has length zero",
6015 &r->u.ss.start->where);
6025 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6028 resolve_fntype (gfc_namespace * ns)
6033 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6036 /* If there are any entries, ns->proc_name is the entry master
6037 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6039 sym = ns->entries->sym;
6041 sym = ns->proc_name;
6042 if (sym->result == sym
6043 && sym->ts.type == BT_UNKNOWN
6044 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6045 && !sym->attr.untyped)
6047 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6048 sym->name, &sym->declared_at);
6049 sym->attr.untyped = 1;
6052 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6053 && !gfc_check_access (sym->ts.derived->attr.access,
6054 sym->ts.derived->ns->default_access)
6055 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6057 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6058 sym->name, &sym->declared_at, sym->ts.derived->name);
6062 for (el = ns->entries->next; el; el = el->next)
6064 if (el->sym->result == el->sym
6065 && el->sym->ts.type == BT_UNKNOWN
6066 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6067 && !el->sym->attr.untyped)
6069 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6070 el->sym->name, &el->sym->declared_at);
6071 el->sym->attr.untyped = 1;
6077 /* Examine all of the expressions associated with a program unit,
6078 assign types to all intermediate expressions, make sure that all
6079 assignments are to compatible types and figure out which names
6080 refer to which functions or subroutines. It doesn't check code
6081 block, which is handled by resolve_code. */
6084 resolve_types (gfc_namespace * ns)
6091 gfc_current_ns = ns;
6093 gfc_traverse_ns (ns, resolve_symbol);
6095 resolve_fntype (ns);
6097 for (n = ns->contained; n; n = n->sibling)
6099 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6100 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6101 "also be PURE", n->proc_name->name,
6102 &n->proc_name->declared_at);
6108 gfc_check_interfaces (ns);
6110 for (cl = ns->cl_list; cl; cl = cl->next)
6111 resolve_charlen (cl);
6113 gfc_traverse_ns (ns, resolve_values);
6119 for (d = ns->data; d; d = d->next)
6123 gfc_traverse_ns (ns, gfc_formalize_init_value);
6125 for (eq = ns->equiv; eq; eq = eq->next)
6126 resolve_equivalence (eq);
6128 /* Warn about unused labels. */
6129 if (gfc_option.warn_unused_labels)
6130 warn_unused_label (ns->st_labels);
6134 /* Call resolve_code recursively. */
6137 resolve_codes (gfc_namespace * ns)
6141 for (n = ns->contained; n; n = n->sibling)
6144 gfc_current_ns = ns;
6146 resolve_code (ns->code, ns);
6150 /* This function is called after a complete program unit has been compiled.
6151 Its purpose is to examine all of the expressions associated with a program
6152 unit, assign types to all intermediate expressions, make sure that all
6153 assignments are to compatible types and figure out which names refer to
6154 which functions or subroutines. */
6157 gfc_resolve (gfc_namespace * ns)
6159 gfc_namespace *old_ns;
6161 old_ns = gfc_current_ns;
6163 resolve_contained_functions (ns);
6167 gfc_current_ns = old_ns;