1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code *head, *current;
44 struct code_stack *prev;
48 static code_stack *cs_base = NULL;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag = 0;
64 gfc_is_formal_arg (void)
66 return formal_arg_flag;
69 /* Resolve types of formal argument lists. These have to be done early so that
70 the formal argument lists of module procedures can be copied to the
71 containing module before the individual procedures are resolved
72 individually. We also resolve argument lists of procedures in interface
73 blocks because they are self-contained scoping units.
75 Since a dummy argument cannot be a non-dummy procedure, the only
76 resort left for untyped names are the IMPLICIT types. */
79 resolve_formal_arglist (gfc_symbol * proc)
81 gfc_formal_arglist *f;
85 /* TODO: Procedures whose return character length parameter is not constant
86 or assumed must also have explicit interfaces. */
87 if (proc->result != NULL)
92 if (gfc_elemental (proc)
93 || sym->attr.pointer || sym->attr.allocatable
94 || (sym->as && sym->as->rank > 0))
95 proc->attr.always_explicit = 1;
99 for (f = proc->formal; f; f = f->next)
105 /* Alternate return placeholder. */
106 if (gfc_elemental (proc))
107 gfc_error ("Alternate return specifier in elemental subroutine "
108 "'%s' at %L is not allowed", proc->name,
110 if (proc->attr.function)
111 gfc_error ("Alternate return specifier in function "
112 "'%s' at %L is not allowed", proc->name,
117 if (sym->attr.if_source != IFSRC_UNKNOWN)
118 resolve_formal_arglist (sym);
120 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
122 if (gfc_pure (proc) && !gfc_pure (sym))
125 ("Dummy procedure '%s' of PURE procedure at %L must also "
126 "be PURE", sym->name, &sym->declared_at);
130 if (gfc_elemental (proc))
133 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
141 if (sym->ts.type == BT_UNKNOWN)
143 if (!sym->attr.function || sym->result == sym)
144 gfc_set_default_type (sym, 1, sym->ns);
147 gfc_resolve_array_spec (sym->as, 0);
149 /* We can't tell if an array with dimension (:) is assumed or deferred
150 shape until we know if it has the pointer or allocatable attributes.
152 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
153 && !(sym->attr.pointer || sym->attr.allocatable))
155 sym->as->type = AS_ASSUMED_SHAPE;
156 for (i = 0; i < sym->as->rank; i++)
157 sym->as->lower[i] = gfc_int_expr (1);
160 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
161 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
162 || sym->attr.optional)
163 proc->attr.always_explicit = 1;
165 /* If the flavor is unknown at this point, it has to be a variable.
166 A procedure specification would have already set the type. */
168 if (sym->attr.flavor == FL_UNKNOWN)
169 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
173 if (proc->attr.function && !sym->attr.pointer
174 && sym->attr.flavor != FL_PROCEDURE
175 && sym->attr.intent != INTENT_IN)
177 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
178 "INTENT(IN)", sym->name, proc->name,
181 if (proc->attr.subroutine && !sym->attr.pointer
182 && sym->attr.intent == INTENT_UNKNOWN)
185 ("Argument '%s' of pure subroutine '%s' at %L must have "
186 "its INTENT specified", sym->name, proc->name,
191 if (gfc_elemental (proc))
196 ("Argument '%s' of elemental procedure at %L must be scalar",
197 sym->name, &sym->declared_at);
201 if (sym->attr.pointer)
204 ("Argument '%s' of elemental procedure at %L cannot have "
205 "the POINTER attribute", sym->name, &sym->declared_at);
210 /* Each dummy shall be specified to be scalar. */
211 if (proc->attr.proc == PROC_ST_FUNCTION)
216 ("Argument '%s' of statement function at %L must be scalar",
217 sym->name, &sym->declared_at);
221 if (sym->ts.type == BT_CHARACTER)
223 gfc_charlen *cl = sym->ts.cl;
224 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
227 ("Character-valued argument '%s' of statement function at "
228 "%L must has constant length",
229 sym->name, &sym->declared_at);
239 /* Work function called when searching for symbols that have argument lists
240 associated with them. */
243 find_arglists (gfc_symbol * sym)
246 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
249 resolve_formal_arglist (sym);
253 /* Given a namespace, resolve all formal argument lists within the namespace.
257 resolve_formal_arglists (gfc_namespace * ns)
263 gfc_traverse_ns (ns, find_arglists);
268 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
272 /* If this namespace is not a function, ignore it. */
274 || !(sym->attr.function
275 || sym->attr.flavor == FL_VARIABLE))
278 /* Try to find out of what the return type is. */
279 if (sym->result != NULL)
282 if (sym->ts.type == BT_UNKNOWN)
284 t = gfc_set_default_type (sym, 0, ns);
286 if (t == FAILURE && !sym->attr.untyped)
288 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
289 sym->name, &sym->declared_at); /* FIXME */
290 sym->attr.untyped = 1;
294 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
295 lists the only ways a character length value of * can be used: dummy arguments
296 of procedures, named constants, and function results in external functions.
297 Internal function results are not on that list; ergo, not permitted. */
299 if (sym->ts.type == BT_CHARACTER)
301 gfc_charlen *cl = sym->ts.cl;
302 if (!cl || !cl->length)
303 gfc_error ("Character-valued internal function '%s' at %L must "
304 "not be assumed length", sym->name, &sym->declared_at);
309 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
310 introduce duplicates. */
313 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
315 gfc_formal_arglist *f, *new_arglist;
318 for (; new_args != NULL; new_args = new_args->next)
320 new_sym = new_args->sym;
321 /* See if ths arg is already in the formal argument list. */
322 for (f = proc->formal; f; f = f->next)
324 if (new_sym == f->sym)
331 /* Add a new argument. Argument order is not important. */
332 new_arglist = gfc_get_formal_arglist ();
333 new_arglist->sym = new_sym;
334 new_arglist->next = proc->formal;
335 proc->formal = new_arglist;
340 /* Resolve alternate entry points. If a symbol has multiple entry points we
341 create a new master symbol for the main routine, and turn the existing
342 symbol into an entry point. */
345 resolve_entries (gfc_namespace * ns)
347 gfc_namespace *old_ns;
351 char name[GFC_MAX_SYMBOL_LEN + 1];
352 static int master_count = 0;
354 if (ns->proc_name == NULL)
357 /* No need to do anything if this procedure doesn't have alternate entry
362 /* We may already have resolved alternate entry points. */
363 if (ns->proc_name->attr.entry_master)
366 /* If this isn't a procedure something has gone horribly wrong. */
367 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
369 /* Remember the current namespace. */
370 old_ns = gfc_current_ns;
374 /* Add the main entry point to the list of entry points. */
375 el = gfc_get_entry_list ();
376 el->sym = ns->proc_name;
378 el->next = ns->entries;
380 ns->proc_name->attr.entry = 1;
382 /* Add an entry statement for it. */
389 /* Create a new symbol for the master function. */
390 /* Give the internal function a unique name (within this file).
391 Also include the function name so the user has some hope of figuring
392 out what is going on. */
393 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
394 master_count++, ns->proc_name->name);
395 gfc_get_ha_symbol (name, &proc);
396 gcc_assert (proc != NULL);
398 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
399 if (ns->proc_name->attr.subroutine)
400 gfc_add_subroutine (&proc->attr, proc->name, NULL);
404 gfc_typespec *ts, *fts;
406 gfc_add_function (&proc->attr, proc->name, NULL);
408 fts = &ns->entries->sym->result->ts;
409 if (fts->type == BT_UNKNOWN)
410 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
411 for (el = ns->entries->next; el; el = el->next)
413 ts = &el->sym->result->ts;
414 if (ts->type == BT_UNKNOWN)
415 ts = gfc_get_default_type (el->sym->result, NULL);
416 if (! gfc_compare_types (ts, fts)
417 || (el->sym->result->attr.dimension
418 != ns->entries->sym->result->attr.dimension)
419 || (el->sym->result->attr.pointer
420 != ns->entries->sym->result->attr.pointer))
426 sym = ns->entries->sym->result;
427 /* All result types the same. */
429 if (sym->attr.dimension)
430 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
431 if (sym->attr.pointer)
432 gfc_add_pointer (&proc->attr, NULL);
436 /* Otherwise the result will be passed through a union by
438 proc->attr.mixed_entry_master = 1;
439 for (el = ns->entries; el; el = el->next)
441 sym = el->sym->result;
442 if (sym->attr.dimension)
444 if (el == ns->entries)
446 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
447 sym->name, ns->entries->sym->name, &sym->declared_at);
450 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
451 sym->name, ns->entries->sym->name, &sym->declared_at);
453 else if (sym->attr.pointer)
455 if (el == ns->entries)
457 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
458 sym->name, ns->entries->sym->name, &sym->declared_at);
461 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
462 sym->name, ns->entries->sym->name, &sym->declared_at);
467 if (ts->type == BT_UNKNOWN)
468 ts = gfc_get_default_type (sym, NULL);
472 if (ts->kind == gfc_default_integer_kind)
476 if (ts->kind == gfc_default_real_kind
477 || ts->kind == gfc_default_double_kind)
481 if (ts->kind == gfc_default_complex_kind)
485 if (ts->kind == gfc_default_logical_kind)
489 /* We will issue error elsewhere. */
497 if (el == ns->entries)
499 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
500 sym->name, gfc_typename (ts), ns->entries->sym->name,
504 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
505 sym->name, gfc_typename (ts), ns->entries->sym->name,
512 proc->attr.access = ACCESS_PRIVATE;
513 proc->attr.entry_master = 1;
515 /* Merge all the entry point arguments. */
516 for (el = ns->entries; el; el = el->next)
517 merge_argument_lists (proc, el->sym->formal);
519 /* Use the master function for the function body. */
520 ns->proc_name = proc;
522 /* Finalize the new symbols. */
523 gfc_commit_symbols ();
525 /* Restore the original namespace. */
526 gfc_current_ns = old_ns;
530 /* Resolve contained function types. Because contained functions can call one
531 another, they have to be worked out before any of the contained procedures
534 The good news is that if a function doesn't already have a type, the only
535 way it can get one is through an IMPLICIT type or a RESULT variable, because
536 by definition contained functions are contained namespace they're contained
537 in, not in a sibling or parent namespace. */
540 resolve_contained_functions (gfc_namespace * ns)
542 gfc_namespace *child;
545 resolve_formal_arglists (ns);
547 for (child = ns->contained; child; child = child->sibling)
549 /* Resolve alternate entry points first. */
550 resolve_entries (child);
552 /* Then check function return types. */
553 resolve_contained_fntype (child->proc_name, child);
554 for (el = child->entries; el; el = el->next)
555 resolve_contained_fntype (el->sym, child);
560 /* Resolve all of the elements of a structure constructor and make sure that
561 the types are correct. */
564 resolve_structure_cons (gfc_expr * expr)
566 gfc_constructor *cons;
571 cons = expr->value.constructor;
572 /* A constructor may have references if it is the result of substituting a
573 parameter variable. In this case we just pull out the component we
576 comp = expr->ref->u.c.sym->components;
578 comp = expr->ts.derived->components;
580 for (; comp; comp = comp->next, cons = cons->next)
588 if (gfc_resolve_expr (cons->expr) == FAILURE)
594 /* If we don't have the right type, try to convert it. */
596 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
599 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
600 gfc_error ("The element in the derived type constructor at %L, "
601 "for pointer component '%s', is %s but should be %s",
602 &cons->expr->where, comp->name,
603 gfc_basic_typename (cons->expr->ts.type),
604 gfc_basic_typename (comp->ts.type));
606 t = gfc_convert_type (cons->expr, &comp->ts, 1);
615 /****************** Expression name resolution ******************/
617 /* Returns 0 if a symbol was not declared with a type or
618 attribute declaration statement, nonzero otherwise. */
621 was_declared (gfc_symbol * sym)
627 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
630 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
631 || a.optional || a.pointer || a.save || a.target
632 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
639 /* Determine if a symbol is generic or not. */
642 generic_sym (gfc_symbol * sym)
646 if (sym->attr.generic ||
647 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
650 if (was_declared (sym) || sym->ns->parent == NULL)
653 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
655 return (s == NULL) ? 0 : generic_sym (s);
659 /* Determine if a symbol is specific or not. */
662 specific_sym (gfc_symbol * sym)
666 if (sym->attr.if_source == IFSRC_IFBODY
667 || sym->attr.proc == PROC_MODULE
668 || sym->attr.proc == PROC_INTERNAL
669 || sym->attr.proc == PROC_ST_FUNCTION
670 || (sym->attr.intrinsic &&
671 gfc_specific_intrinsic (sym->name))
672 || sym->attr.external)
675 if (was_declared (sym) || sym->ns->parent == NULL)
678 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
680 return (s == NULL) ? 0 : specific_sym (s);
684 /* Figure out if the procedure is specific, generic or unknown. */
687 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
691 procedure_kind (gfc_symbol * sym)
694 if (generic_sym (sym))
695 return PTYPE_GENERIC;
697 if (specific_sym (sym))
698 return PTYPE_SPECIFIC;
700 return PTYPE_UNKNOWN;
703 /* Check references to assumed size arrays. The flag need_full_assumed_size
704 is nonzero when matching actual arguments. */
706 static int need_full_assumed_size = 0;
709 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
715 if (need_full_assumed_size
716 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
719 for (ref = e->ref; ref; ref = ref->next)
720 if (ref->type == REF_ARRAY)
721 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
722 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
726 gfc_error ("The upper bound in the last dimension must "
727 "appear in the reference to the assumed size "
728 "array '%s' at %L.", sym->name, &e->where);
735 /* Look for bad assumed size array references in argument expressions
736 of elemental and array valued intrinsic procedures. Since this is
737 called from procedure resolution functions, it only recurses at
741 resolve_assumed_size_actual (gfc_expr *e)
746 switch (e->expr_type)
750 && check_assumed_size_reference (e->symtree->n.sym, e))
755 if (resolve_assumed_size_actual (e->value.op.op1)
756 || resolve_assumed_size_actual (e->value.op.op2))
767 /* Resolve an actual argument list. Most of the time, this is just
768 resolving the expressions in the list.
769 The exception is that we sometimes have to decide whether arguments
770 that look like procedure arguments are really simple variable
774 resolve_actual_arglist (gfc_actual_arglist * arg)
777 gfc_symtree *parent_st;
780 for (; arg; arg = arg->next)
786 /* Check the label is a valid branching target. */
789 if (arg->label->defined == ST_LABEL_UNKNOWN)
791 gfc_error ("Label %d referenced at %L is never defined",
792 arg->label->value, &arg->label->where);
799 if (e->ts.type != BT_PROCEDURE)
801 if (gfc_resolve_expr (e) != SUCCESS)
806 /* See if the expression node should really be a variable
809 sym = e->symtree->n.sym;
811 if (sym->attr.flavor == FL_PROCEDURE
812 || sym->attr.intrinsic
813 || sym->attr.external)
816 if (sym->attr.proc == PROC_ST_FUNCTION)
818 gfc_error ("Statement function '%s' at %L is not allowed as an "
819 "actual argument", sym->name, &e->where);
822 if (sym->attr.contained && !sym->attr.use_assoc
823 && sym->ns->proc_name->attr.flavor != FL_MODULE)
825 gfc_error ("Internal procedure '%s' is not allowed as an "
826 "actual argument at %L", sym->name, &e->where);
829 if (sym->attr.elemental && !sym->attr.intrinsic)
831 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
832 "allowed as an actual argument at %L", sym->name,
836 /* If the symbol is the function that names the current (or
837 parent) scope, then we really have a variable reference. */
839 if (sym->attr.function && sym->result == sym
840 && (sym->ns->proc_name == sym
841 || (sym->ns->parent != NULL
842 && sym->ns->parent->proc_name == sym)))
848 /* See if the name is a module procedure in a parent unit. */
850 if (was_declared (sym) || sym->ns->parent == NULL)
853 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
855 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
859 if (parent_st == NULL)
862 sym = parent_st->n.sym;
863 e->symtree = parent_st; /* Point to the right thing. */
865 if (sym->attr.flavor == FL_PROCEDURE
866 || sym->attr.intrinsic
867 || sym->attr.external)
873 e->expr_type = EXPR_VARIABLE;
877 e->rank = sym->as->rank;
878 e->ref = gfc_get_ref ();
879 e->ref->type = REF_ARRAY;
880 e->ref->u.ar.type = AR_FULL;
881 e->ref->u.ar.as = sym->as;
889 /* Go through each actual argument in ACTUAL and see if it can be
890 implemented as an inlined, non-copying intrinsic. FNSYM is the
891 function being called, or NULL if not known. */
894 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
896 gfc_actual_arglist *ap;
899 for (ap = actual; ap; ap = ap->next)
901 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
902 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
903 ap->expr->inline_noncopying_intrinsic = 1;
906 /* This function does the checking of references to global procedures
907 as defined in sections 18.1 and 14.1, respectively, of the Fortran
908 77 and 95 standards. It checks for a gsymbol for the name, making
909 one if it does not already exist. If it already exists, then the
910 reference being resolved must correspond to the type of gsymbol.
911 Otherwise, the new symbol is equipped with the attributes of the
912 reference. The corresponding code that is called in creating
913 global entities is parse.c. */
916 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
921 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
923 gsym = gfc_get_gsymbol (sym->name);
925 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
926 global_used (gsym, where);
928 if (gsym->type == GSYM_UNKNOWN)
931 gsym->where = *where;
937 /************* Function resolution *************/
939 /* Resolve a function call known to be generic.
940 Section 14.1.2.4.1. */
943 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
947 if (sym->attr.generic)
950 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
953 expr->value.function.name = s->name;
954 expr->value.function.esym = s;
956 if (s->ts.type != BT_UNKNOWN)
958 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
959 expr->ts = s->result->ts;
962 expr->rank = s->as->rank;
963 else if (s->result != NULL && s->result->as != NULL)
964 expr->rank = s->result->as->rank;
969 /* TODO: Need to search for elemental references in generic interface */
972 if (sym->attr.intrinsic)
973 return gfc_intrinsic_func_interface (expr, 0);
980 resolve_generic_f (gfc_expr * expr)
985 sym = expr->symtree->n.sym;
989 m = resolve_generic_f0 (expr, sym);
992 else if (m == MATCH_ERROR)
996 if (sym->ns->parent == NULL)
998 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1002 if (!generic_sym (sym))
1006 /* Last ditch attempt. */
1008 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1010 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1011 expr->symtree->n.sym->name, &expr->where);
1015 m = gfc_intrinsic_func_interface (expr, 0);
1020 ("Generic function '%s' at %L is not consistent with a specific "
1021 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1027 /* Resolve a function call known to be specific. */
1030 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1034 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1036 if (sym->attr.dummy)
1038 sym->attr.proc = PROC_DUMMY;
1042 sym->attr.proc = PROC_EXTERNAL;
1046 if (sym->attr.proc == PROC_MODULE
1047 || sym->attr.proc == PROC_ST_FUNCTION
1048 || sym->attr.proc == PROC_INTERNAL)
1051 if (sym->attr.intrinsic)
1053 m = gfc_intrinsic_func_interface (expr, 1);
1058 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1059 "an intrinsic", sym->name, &expr->where);
1067 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1070 expr->value.function.name = sym->name;
1071 expr->value.function.esym = sym;
1072 if (sym->as != NULL)
1073 expr->rank = sym->as->rank;
1080 resolve_specific_f (gfc_expr * expr)
1085 sym = expr->symtree->n.sym;
1089 m = resolve_specific_f0 (sym, expr);
1092 if (m == MATCH_ERROR)
1095 if (sym->ns->parent == NULL)
1098 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1104 gfc_error ("Unable to resolve the specific function '%s' at %L",
1105 expr->symtree->n.sym->name, &expr->where);
1111 /* Resolve a procedure call not known to be generic nor specific. */
1114 resolve_unknown_f (gfc_expr * expr)
1119 sym = expr->symtree->n.sym;
1121 if (sym->attr.dummy)
1123 sym->attr.proc = PROC_DUMMY;
1124 expr->value.function.name = sym->name;
1128 /* See if we have an intrinsic function reference. */
1130 if (gfc_intrinsic_name (sym->name, 0))
1132 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1137 /* The reference is to an external name. */
1139 sym->attr.proc = PROC_EXTERNAL;
1140 expr->value.function.name = sym->name;
1141 expr->value.function.esym = expr->symtree->n.sym;
1143 if (sym->as != NULL)
1144 expr->rank = sym->as->rank;
1146 /* Type of the expression is either the type of the symbol or the
1147 default type of the symbol. */
1150 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1152 if (sym->ts.type != BT_UNKNOWN)
1156 ts = gfc_get_default_type (sym, sym->ns);
1158 if (ts->type == BT_UNKNOWN)
1160 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1161 sym->name, &expr->where);
1172 /* Figure out if a function reference is pure or not. Also set the name
1173 of the function for a potential error message. Return nonzero if the
1174 function is PURE, zero if not. */
1177 pure_function (gfc_expr * e, const char **name)
1181 if (e->value.function.esym)
1183 pure = gfc_pure (e->value.function.esym);
1184 *name = e->value.function.esym->name;
1186 else if (e->value.function.isym)
1188 pure = e->value.function.isym->pure
1189 || e->value.function.isym->elemental;
1190 *name = e->value.function.isym->name;
1194 /* Implicit functions are not pure. */
1196 *name = e->value.function.name;
1203 /* Resolve a function call, which means resolving the arguments, then figuring
1204 out which entity the name refers to. */
1205 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1206 to INTENT(OUT) or INTENT(INOUT). */
1209 resolve_function (gfc_expr * expr)
1211 gfc_actual_arglist *arg;
1220 sym = expr->symtree->n.sym;
1222 /* If the procedure is not internal, a statement function or a module
1223 procedure,it must be external and should be checked for usage. */
1224 if (sym && !sym->attr.dummy && !sym->attr.contained
1225 && sym->attr.proc != PROC_ST_FUNCTION
1226 && !sym->attr.use_assoc)
1227 resolve_global_procedure (sym, &expr->where, 0);
1229 /* Switch off assumed size checking and do this again for certain kinds
1230 of procedure, once the procedure itself is resolved. */
1231 need_full_assumed_size++;
1233 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1236 /* Resume assumed_size checking. */
1237 need_full_assumed_size--;
1239 if (sym && sym->ts.type == BT_CHARACTER
1241 && sym->ts.cl->length == NULL
1243 && !sym->attr.contained)
1245 /* Internal procedures are taken care of in resolve_contained_fntype. */
1246 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1247 "be used at %L since it is not a dummy argument",
1248 sym->name, &expr->where);
1252 /* See if function is already resolved. */
1254 if (expr->value.function.name != NULL)
1256 if (expr->ts.type == BT_UNKNOWN)
1262 /* Apply the rules of section 14.1.2. */
1264 switch (procedure_kind (sym))
1267 t = resolve_generic_f (expr);
1270 case PTYPE_SPECIFIC:
1271 t = resolve_specific_f (expr);
1275 t = resolve_unknown_f (expr);
1279 gfc_internal_error ("resolve_function(): bad function type");
1283 /* If the expression is still a function (it might have simplified),
1284 then we check to see if we are calling an elemental function. */
1286 if (expr->expr_type != EXPR_FUNCTION)
1289 temp = need_full_assumed_size;
1290 need_full_assumed_size = 0;
1292 if (expr->value.function.actual != NULL
1293 && ((expr->value.function.esym != NULL
1294 && expr->value.function.esym->attr.elemental)
1295 || (expr->value.function.isym != NULL
1296 && expr->value.function.isym->elemental)))
1298 /* The rank of an elemental is the rank of its array argument(s). */
1299 for (arg = expr->value.function.actual; arg; arg = arg->next)
1301 if (arg->expr != NULL && arg->expr->rank > 0)
1303 expr->rank = arg->expr->rank;
1304 if (!expr->shape && arg->expr->shape)
1306 expr->shape = gfc_get_shape (expr->rank);
1307 for (i = 0; i < expr->rank; i++)
1308 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1314 /* Being elemental, the last upper bound of an assumed size array
1315 argument must be present. */
1316 for (arg = expr->value.function.actual; arg; arg = arg->next)
1318 if (arg->expr != NULL
1319 && arg->expr->rank > 0
1320 && resolve_assumed_size_actual (arg->expr))
1324 if (omp_workshare_flag
1325 && expr->value.function.esym
1326 && ! gfc_elemental (expr->value.function.esym))
1328 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1329 " in WORKSHARE construct", expr->value.function.esym->name,
1334 else if (expr->value.function.actual != NULL
1335 && expr->value.function.isym != NULL
1336 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1337 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1338 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1340 /* Array instrinsics must also have the last upper bound of an
1341 assumed size array argument. UBOUND and SIZE have to be
1342 excluded from the check if the second argument is anything
1345 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1346 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1348 for (arg = expr->value.function.actual; arg; arg = arg->next)
1350 if (inquiry && arg->next != NULL && arg->next->expr
1351 && arg->next->expr->expr_type != EXPR_CONSTANT)
1354 if (arg->expr != NULL
1355 && arg->expr->rank > 0
1356 && resolve_assumed_size_actual (arg->expr))
1361 need_full_assumed_size = temp;
1363 if (!pure_function (expr, &name) && name)
1368 ("Function reference to '%s' at %L is inside a FORALL block",
1369 name, &expr->where);
1372 else if (gfc_pure (NULL))
1374 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1375 "procedure within a PURE procedure", name, &expr->where);
1380 /* Functions without the RECURSIVE attribution are not allowed to
1381 * call themselves. */
1382 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1384 gfc_symbol *esym, *proc;
1385 esym = expr->value.function.esym;
1386 proc = gfc_current_ns->proc_name;
1389 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1390 "RECURSIVE", name, &expr->where);
1394 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1395 && esym->ns->entries->sym == proc->ns->entries->sym)
1397 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1398 "'%s' is not declared as RECURSIVE",
1399 esym->name, &expr->where, esym->ns->entries->sym->name);
1404 /* Character lengths of use associated functions may contains references to
1405 symbols not referenced from the current program unit otherwise. Make sure
1406 those symbols are marked as referenced. */
1408 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1409 && expr->value.function.esym->attr.use_assoc)
1411 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1415 find_noncopying_intrinsics (expr->value.function.esym,
1416 expr->value.function.actual);
1421 /************* Subroutine resolution *************/
1424 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1431 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1432 sym->name, &c->loc);
1433 else if (gfc_pure (NULL))
1434 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1440 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1444 if (sym->attr.generic)
1446 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1449 c->resolved_sym = s;
1450 pure_subroutine (c, s);
1454 /* TODO: Need to search for elemental references in generic interface. */
1457 if (sym->attr.intrinsic)
1458 return gfc_intrinsic_sub_interface (c, 0);
1465 resolve_generic_s (gfc_code * c)
1470 sym = c->symtree->n.sym;
1472 m = resolve_generic_s0 (c, sym);
1475 if (m == MATCH_ERROR)
1478 if (sym->ns->parent != NULL)
1480 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1483 m = resolve_generic_s0 (c, sym);
1486 if (m == MATCH_ERROR)
1491 /* Last ditch attempt. */
1493 if (!gfc_generic_intrinsic (sym->name))
1496 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1497 sym->name, &c->loc);
1501 m = gfc_intrinsic_sub_interface (c, 0);
1505 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1506 "intrinsic subroutine interface", sym->name, &c->loc);
1512 /* Resolve a subroutine call known to be specific. */
1515 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1519 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1521 if (sym->attr.dummy)
1523 sym->attr.proc = PROC_DUMMY;
1527 sym->attr.proc = PROC_EXTERNAL;
1531 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1534 if (sym->attr.intrinsic)
1536 m = gfc_intrinsic_sub_interface (c, 1);
1540 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1541 "with an intrinsic", sym->name, &c->loc);
1549 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1551 c->resolved_sym = sym;
1552 pure_subroutine (c, sym);
1559 resolve_specific_s (gfc_code * c)
1564 sym = c->symtree->n.sym;
1566 m = resolve_specific_s0 (c, sym);
1569 if (m == MATCH_ERROR)
1572 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1576 m = resolve_specific_s0 (c, sym);
1579 if (m == MATCH_ERROR)
1583 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1584 sym->name, &c->loc);
1590 /* Resolve a subroutine call not known to be generic nor specific. */
1593 resolve_unknown_s (gfc_code * c)
1597 sym = c->symtree->n.sym;
1599 if (sym->attr.dummy)
1601 sym->attr.proc = PROC_DUMMY;
1605 /* See if we have an intrinsic function reference. */
1607 if (gfc_intrinsic_name (sym->name, 1))
1609 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1614 /* The reference is to an external name. */
1617 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1619 c->resolved_sym = sym;
1621 pure_subroutine (c, sym);
1627 /* Resolve a subroutine call. Although it was tempting to use the same code
1628 for functions, subroutines and functions are stored differently and this
1629 makes things awkward. */
1632 resolve_call (gfc_code * c)
1636 if (c->symtree && c->symtree->n.sym
1637 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1639 gfc_error ("'%s' at %L has a type, which is not consistent with "
1640 "the CALL at %L", c->symtree->n.sym->name,
1641 &c->symtree->n.sym->declared_at, &c->loc);
1645 /* If the procedure is not internal or module, it must be external and
1646 should be checked for usage. */
1647 if (c->symtree && c->symtree->n.sym
1648 && !c->symtree->n.sym->attr.dummy
1649 && !c->symtree->n.sym->attr.contained
1650 && !c->symtree->n.sym->attr.use_assoc)
1651 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1653 /* Subroutines without the RECURSIVE attribution are not allowed to
1654 * call themselves. */
1655 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1657 gfc_symbol *csym, *proc;
1658 csym = c->symtree->n.sym;
1659 proc = gfc_current_ns->proc_name;
1662 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1663 "RECURSIVE", csym->name, &c->loc);
1667 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1668 && csym->ns->entries->sym == proc->ns->entries->sym)
1670 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1671 "'%s' is not declared as RECURSIVE",
1672 csym->name, &c->loc, csym->ns->entries->sym->name);
1677 /* Switch off assumed size checking and do this again for certain kinds
1678 of procedure, once the procedure itself is resolved. */
1679 need_full_assumed_size++;
1681 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1684 /* Resume assumed_size checking. */
1685 need_full_assumed_size--;
1689 if (c->resolved_sym == NULL)
1690 switch (procedure_kind (c->symtree->n.sym))
1693 t = resolve_generic_s (c);
1696 case PTYPE_SPECIFIC:
1697 t = resolve_specific_s (c);
1701 t = resolve_unknown_s (c);
1705 gfc_internal_error ("resolve_subroutine(): bad function type");
1708 /* Some checks of elemental subroutines. */
1709 if (c->ext.actual != NULL
1710 && c->symtree->n.sym->attr.elemental)
1712 gfc_actual_arglist * a;
1716 for (a = c->ext.actual; a; a = a->next)
1718 if (a->expr == NULL || a->expr->rank == 0)
1721 /* The last upper bound of an assumed size array argument must
1723 if (resolve_assumed_size_actual (a->expr))
1726 /* Array actual arguments must conform. */
1729 if (gfc_check_conformance ("elemental subroutine", a->expr, e)
1739 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1743 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1744 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1745 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1746 if their shapes do not match. If either op1->shape or op2->shape is
1747 NULL, return SUCCESS. */
1750 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1757 if (op1->shape != NULL && op2->shape != NULL)
1759 for (i = 0; i < op1->rank; i++)
1761 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1763 gfc_error ("Shapes for operands at %L and %L are not conformable",
1764 &op1->where, &op2->where);
1774 /* Resolve an operator expression node. This can involve replacing the
1775 operation with a user defined function call. */
1778 resolve_operator (gfc_expr * e)
1780 gfc_expr *op1, *op2;
1784 /* Resolve all subnodes-- give them types. */
1786 switch (e->value.op.operator)
1789 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1792 /* Fall through... */
1795 case INTRINSIC_UPLUS:
1796 case INTRINSIC_UMINUS:
1797 case INTRINSIC_PARENTHESES:
1798 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1803 /* Typecheck the new node. */
1805 op1 = e->value.op.op1;
1806 op2 = e->value.op.op2;
1808 switch (e->value.op.operator)
1810 case INTRINSIC_UPLUS:
1811 case INTRINSIC_UMINUS:
1812 if (op1->ts.type == BT_INTEGER
1813 || op1->ts.type == BT_REAL
1814 || op1->ts.type == BT_COMPLEX)
1820 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1821 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1824 case INTRINSIC_PLUS:
1825 case INTRINSIC_MINUS:
1826 case INTRINSIC_TIMES:
1827 case INTRINSIC_DIVIDE:
1828 case INTRINSIC_POWER:
1829 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1831 gfc_type_convert_binary (e);
1836 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1837 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1838 gfc_typename (&op2->ts));
1841 case INTRINSIC_CONCAT:
1842 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1844 e->ts.type = BT_CHARACTER;
1845 e->ts.kind = op1->ts.kind;
1850 _("Operands of string concatenation operator at %%L are %s/%s"),
1851 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1857 case INTRINSIC_NEQV:
1858 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1860 e->ts.type = BT_LOGICAL;
1861 e->ts.kind = gfc_kind_max (op1, op2);
1862 if (op1->ts.kind < e->ts.kind)
1863 gfc_convert_type (op1, &e->ts, 2);
1864 else if (op2->ts.kind < e->ts.kind)
1865 gfc_convert_type (op2, &e->ts, 2);
1869 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1870 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1871 gfc_typename (&op2->ts));
1876 if (op1->ts.type == BT_LOGICAL)
1878 e->ts.type = BT_LOGICAL;
1879 e->ts.kind = op1->ts.kind;
1883 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1884 gfc_typename (&op1->ts));
1891 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1893 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1897 /* Fall through... */
1901 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1903 e->ts.type = BT_LOGICAL;
1904 e->ts.kind = gfc_default_logical_kind;
1908 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1910 gfc_type_convert_binary (e);
1912 e->ts.type = BT_LOGICAL;
1913 e->ts.kind = gfc_default_logical_kind;
1917 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1919 _("Logicals at %%L must be compared with %s instead of %s"),
1920 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1921 gfc_op2string (e->value.op.operator));
1924 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1925 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1926 gfc_typename (&op2->ts));
1930 case INTRINSIC_USER:
1932 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1933 e->value.op.uop->name, gfc_typename (&op1->ts));
1935 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1936 e->value.op.uop->name, gfc_typename (&op1->ts),
1937 gfc_typename (&op2->ts));
1941 case INTRINSIC_PARENTHESES:
1945 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1948 /* Deal with arrayness of an operand through an operator. */
1952 switch (e->value.op.operator)
1954 case INTRINSIC_PLUS:
1955 case INTRINSIC_MINUS:
1956 case INTRINSIC_TIMES:
1957 case INTRINSIC_DIVIDE:
1958 case INTRINSIC_POWER:
1959 case INTRINSIC_CONCAT:
1963 case INTRINSIC_NEQV:
1971 if (op1->rank == 0 && op2->rank == 0)
1974 if (op1->rank == 0 && op2->rank != 0)
1976 e->rank = op2->rank;
1978 if (e->shape == NULL)
1979 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1982 if (op1->rank != 0 && op2->rank == 0)
1984 e->rank = op1->rank;
1986 if (e->shape == NULL)
1987 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1990 if (op1->rank != 0 && op2->rank != 0)
1992 if (op1->rank == op2->rank)
1994 e->rank = op1->rank;
1995 if (e->shape == NULL)
1997 t = compare_shapes(op1, op2);
2001 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2006 gfc_error ("Inconsistent ranks for operator at %L and %L",
2007 &op1->where, &op2->where);
2010 /* Allow higher level expressions to work. */
2018 case INTRINSIC_UPLUS:
2019 case INTRINSIC_UMINUS:
2020 case INTRINSIC_PARENTHESES:
2021 e->rank = op1->rank;
2023 if (e->shape == NULL)
2024 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2026 /* Simply copy arrayness attribute */
2033 /* Attempt to simplify the expression. */
2035 t = gfc_simplify_expr (e, 0);
2040 if (gfc_extend_expr (e) == SUCCESS)
2043 gfc_error (msg, &e->where);
2049 /************** Array resolution subroutines **************/
2053 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2056 /* Compare two integer expressions. */
2059 compare_bound (gfc_expr * a, gfc_expr * b)
2063 if (a == NULL || a->expr_type != EXPR_CONSTANT
2064 || b == NULL || b->expr_type != EXPR_CONSTANT)
2067 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2068 gfc_internal_error ("compare_bound(): Bad expression");
2070 i = mpz_cmp (a->value.integer, b->value.integer);
2080 /* Compare an integer expression with an integer. */
2083 compare_bound_int (gfc_expr * a, int b)
2087 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2090 if (a->ts.type != BT_INTEGER)
2091 gfc_internal_error ("compare_bound_int(): Bad expression");
2093 i = mpz_cmp_si (a->value.integer, b);
2103 /* Compare a single dimension of an array reference to the array
2107 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2110 /* Given start, end and stride values, calculate the minimum and
2111 maximum referenced indexes. */
2119 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2121 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2127 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2129 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2133 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2135 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2138 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2139 it is legal (see 6.2.2.3.1). */
2144 gfc_internal_error ("check_dimension(): Bad array reference");
2150 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2155 /* Compare an array reference with an array specification. */
2158 compare_spec_to_ref (gfc_array_ref * ar)
2165 /* TODO: Full array sections are only allowed as actual parameters. */
2166 if (as->type == AS_ASSUMED_SIZE
2167 && (/*ar->type == AR_FULL
2168 ||*/ (ar->type == AR_SECTION
2169 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2171 gfc_error ("Rightmost upper bound of assumed size array section"
2172 " not specified at %L", &ar->where);
2176 if (ar->type == AR_FULL)
2179 if (as->rank != ar->dimen)
2181 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2182 &ar->where, ar->dimen, as->rank);
2186 for (i = 0; i < as->rank; i++)
2187 if (check_dimension (i, ar, as) == FAILURE)
2194 /* Resolve one part of an array index. */
2197 gfc_resolve_index (gfc_expr * index, int check_scalar)
2204 if (gfc_resolve_expr (index) == FAILURE)
2207 if (check_scalar && index->rank != 0)
2209 gfc_error ("Array index at %L must be scalar", &index->where);
2213 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2215 gfc_error ("Array index at %L must be of INTEGER type",
2220 if (index->ts.type == BT_REAL)
2221 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2222 &index->where) == FAILURE)
2225 if (index->ts.kind != gfc_index_integer_kind
2226 || index->ts.type != BT_INTEGER)
2229 ts.type = BT_INTEGER;
2230 ts.kind = gfc_index_integer_kind;
2232 gfc_convert_type_warn (index, &ts, 2, 0);
2238 /* Resolve a dim argument to an intrinsic function. */
2241 gfc_resolve_dim_arg (gfc_expr *dim)
2246 if (gfc_resolve_expr (dim) == FAILURE)
2251 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2255 if (dim->ts.type != BT_INTEGER)
2257 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2260 if (dim->ts.kind != gfc_index_integer_kind)
2264 ts.type = BT_INTEGER;
2265 ts.kind = gfc_index_integer_kind;
2267 gfc_convert_type_warn (dim, &ts, 2, 0);
2273 /* Given an expression that contains array references, update those array
2274 references to point to the right array specifications. While this is
2275 filled in during matching, this information is difficult to save and load
2276 in a module, so we take care of it here.
2278 The idea here is that the original array reference comes from the
2279 base symbol. We traverse the list of reference structures, setting
2280 the stored reference to references. Component references can
2281 provide an additional array specification. */
2284 find_array_spec (gfc_expr * e)
2288 gfc_symbol *derived;
2291 as = e->symtree->n.sym->as;
2294 for (ref = e->ref; ref; ref = ref->next)
2299 gfc_internal_error ("find_array_spec(): Missing spec");
2306 if (derived == NULL)
2307 derived = e->symtree->n.sym->ts.derived;
2309 c = derived->components;
2311 for (; c; c = c->next)
2312 if (c == ref->u.c.component)
2314 /* Track the sequence of component references. */
2315 if (c->ts.type == BT_DERIVED)
2316 derived = c->ts.derived;
2321 gfc_internal_error ("find_array_spec(): Component not found");
2326 gfc_internal_error ("find_array_spec(): unused as(1)");
2337 gfc_internal_error ("find_array_spec(): unused as(2)");
2341 /* Resolve an array reference. */
2344 resolve_array_ref (gfc_array_ref * ar)
2346 int i, check_scalar;
2349 for (i = 0; i < ar->dimen; i++)
2351 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2353 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2355 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2357 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2362 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2366 ar->dimen_type[i] = DIMEN_ELEMENT;
2370 ar->dimen_type[i] = DIMEN_VECTOR;
2371 if (e->expr_type == EXPR_VARIABLE
2372 && e->symtree->n.sym->ts.type == BT_DERIVED)
2373 ar->start[i] = gfc_get_parentheses (e);
2377 gfc_error ("Array index at %L is an array of rank %d",
2378 &ar->c_where[i], e->rank);
2383 /* If the reference type is unknown, figure out what kind it is. */
2385 if (ar->type == AR_UNKNOWN)
2387 ar->type = AR_ELEMENT;
2388 for (i = 0; i < ar->dimen; i++)
2389 if (ar->dimen_type[i] == DIMEN_RANGE
2390 || ar->dimen_type[i] == DIMEN_VECTOR)
2392 ar->type = AR_SECTION;
2397 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2405 resolve_substring (gfc_ref * ref)
2408 if (ref->u.ss.start != NULL)
2410 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2413 if (ref->u.ss.start->ts.type != BT_INTEGER)
2415 gfc_error ("Substring start index at %L must be of type INTEGER",
2416 &ref->u.ss.start->where);
2420 if (ref->u.ss.start->rank != 0)
2422 gfc_error ("Substring start index at %L must be scalar",
2423 &ref->u.ss.start->where);
2427 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2429 gfc_error ("Substring start index at %L is less than one",
2430 &ref->u.ss.start->where);
2435 if (ref->u.ss.end != NULL)
2437 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2440 if (ref->u.ss.end->ts.type != BT_INTEGER)
2442 gfc_error ("Substring end index at %L must be of type INTEGER",
2443 &ref->u.ss.end->where);
2447 if (ref->u.ss.end->rank != 0)
2449 gfc_error ("Substring end index at %L must be scalar",
2450 &ref->u.ss.end->where);
2454 if (ref->u.ss.length != NULL
2455 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2457 gfc_error ("Substring end index at %L is out of bounds",
2458 &ref->u.ss.start->where);
2467 /* Resolve subtype references. */
2470 resolve_ref (gfc_expr * expr)
2472 int current_part_dimension, n_components, seen_part_dimension;
2475 for (ref = expr->ref; ref; ref = ref->next)
2476 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2478 find_array_spec (expr);
2482 for (ref = expr->ref; ref; ref = ref->next)
2486 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2494 resolve_substring (ref);
2498 /* Check constraints on part references. */
2500 current_part_dimension = 0;
2501 seen_part_dimension = 0;
2504 for (ref = expr->ref; ref; ref = ref->next)
2509 switch (ref->u.ar.type)
2513 current_part_dimension = 1;
2517 current_part_dimension = 0;
2521 gfc_internal_error ("resolve_ref(): Bad array reference");
2527 if ((current_part_dimension || seen_part_dimension)
2528 && ref->u.c.component->pointer)
2531 ("Component to the right of a part reference with nonzero "
2532 "rank must not have the POINTER attribute at %L",
2544 if (((ref->type == REF_COMPONENT && n_components > 1)
2545 || ref->next == NULL)
2546 && current_part_dimension
2547 && seen_part_dimension)
2550 gfc_error ("Two or more part references with nonzero rank must "
2551 "not be specified at %L", &expr->where);
2555 if (ref->type == REF_COMPONENT)
2557 if (current_part_dimension)
2558 seen_part_dimension = 1;
2560 /* reset to make sure */
2561 current_part_dimension = 0;
2569 /* Given an expression, determine its shape. This is easier than it sounds.
2570 Leaves the shape array NULL if it is not possible to determine the shape. */
2573 expression_shape (gfc_expr * e)
2575 mpz_t array[GFC_MAX_DIMENSIONS];
2578 if (e->rank == 0 || e->shape != NULL)
2581 for (i = 0; i < e->rank; i++)
2582 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2585 e->shape = gfc_get_shape (e->rank);
2587 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2592 for (i--; i >= 0; i--)
2593 mpz_clear (array[i]);
2597 /* Given a variable expression node, compute the rank of the expression by
2598 examining the base symbol and any reference structures it may have. */
2601 expression_rank (gfc_expr * e)
2608 if (e->expr_type == EXPR_ARRAY)
2610 /* Constructors can have a rank different from one via RESHAPE(). */
2612 if (e->symtree == NULL)
2618 e->rank = (e->symtree->n.sym->as == NULL)
2619 ? 0 : e->symtree->n.sym->as->rank;
2625 for (ref = e->ref; ref; ref = ref->next)
2627 if (ref->type != REF_ARRAY)
2630 if (ref->u.ar.type == AR_FULL)
2632 rank = ref->u.ar.as->rank;
2636 if (ref->u.ar.type == AR_SECTION)
2638 /* Figure out the rank of the section. */
2640 gfc_internal_error ("expression_rank(): Two array specs");
2642 for (i = 0; i < ref->u.ar.dimen; i++)
2643 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2644 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2654 expression_shape (e);
2658 /* Resolve a variable expression. */
2661 resolve_variable (gfc_expr * e)
2665 if (e->ref && resolve_ref (e) == FAILURE)
2668 if (e->symtree == NULL)
2671 sym = e->symtree->n.sym;
2672 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2674 e->ts.type = BT_PROCEDURE;
2678 if (sym->ts.type != BT_UNKNOWN)
2679 gfc_variable_attr (e, &e->ts);
2682 /* Must be a simple variable reference. */
2683 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2688 if (check_assumed_size_reference (sym, e))
2695 /* Resolve an expression. That is, make sure that types of operands agree
2696 with their operators, intrinsic operators are converted to function calls
2697 for overloaded types and unresolved function references are resolved. */
2700 gfc_resolve_expr (gfc_expr * e)
2707 switch (e->expr_type)
2710 t = resolve_operator (e);
2714 t = resolve_function (e);
2718 t = resolve_variable (e);
2720 expression_rank (e);
2723 case EXPR_SUBSTRING:
2724 t = resolve_ref (e);
2734 if (resolve_ref (e) == FAILURE)
2737 t = gfc_resolve_array_constructor (e);
2738 /* Also try to expand a constructor. */
2741 expression_rank (e);
2742 gfc_expand_constructor (e);
2747 case EXPR_STRUCTURE:
2748 t = resolve_ref (e);
2752 t = resolve_structure_cons (e);
2756 t = gfc_simplify_expr (e, 0);
2760 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2767 /* Resolve an expression from an iterator. They must be scalar and have
2768 INTEGER or (optionally) REAL type. */
2771 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2772 const char * name_msgid)
2774 if (gfc_resolve_expr (expr) == FAILURE)
2777 if (expr->rank != 0)
2779 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2783 if (!(expr->ts.type == BT_INTEGER
2784 || (expr->ts.type == BT_REAL && real_ok)))
2787 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2790 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2797 /* Resolve the expressions in an iterator structure. If REAL_OK is
2798 false allow only INTEGER type iterators, otherwise allow REAL types. */
2801 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2804 if (iter->var->ts.type == BT_REAL)
2805 gfc_notify_std (GFC_STD_F95_DEL,
2806 "Obsolete: REAL DO loop iterator at %L",
2809 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2813 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2815 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2820 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2821 "Start expression in DO loop") == FAILURE)
2824 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2825 "End expression in DO loop") == FAILURE)
2828 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2829 "Step expression in DO loop") == FAILURE)
2832 if (iter->step->expr_type == EXPR_CONSTANT)
2834 if ((iter->step->ts.type == BT_INTEGER
2835 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2836 || (iter->step->ts.type == BT_REAL
2837 && mpfr_sgn (iter->step->value.real) == 0))
2839 gfc_error ("Step expression in DO loop at %L cannot be zero",
2840 &iter->step->where);
2845 /* Convert start, end, and step to the same type as var. */
2846 if (iter->start->ts.kind != iter->var->ts.kind
2847 || iter->start->ts.type != iter->var->ts.type)
2848 gfc_convert_type (iter->start, &iter->var->ts, 2);
2850 if (iter->end->ts.kind != iter->var->ts.kind
2851 || iter->end->ts.type != iter->var->ts.type)
2852 gfc_convert_type (iter->end, &iter->var->ts, 2);
2854 if (iter->step->ts.kind != iter->var->ts.kind
2855 || iter->step->ts.type != iter->var->ts.type)
2856 gfc_convert_type (iter->step, &iter->var->ts, 2);
2862 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2863 to be a scalar INTEGER variable. The subscripts and stride are scalar
2864 INTEGERs, and if stride is a constant it must be nonzero. */
2867 resolve_forall_iterators (gfc_forall_iterator * iter)
2872 if (gfc_resolve_expr (iter->var) == SUCCESS
2873 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2874 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2877 if (gfc_resolve_expr (iter->start) == SUCCESS
2878 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2879 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2880 &iter->start->where);
2881 if (iter->var->ts.kind != iter->start->ts.kind)
2882 gfc_convert_type (iter->start, &iter->var->ts, 2);
2884 if (gfc_resolve_expr (iter->end) == SUCCESS
2885 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2886 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2888 if (iter->var->ts.kind != iter->end->ts.kind)
2889 gfc_convert_type (iter->end, &iter->var->ts, 2);
2891 if (gfc_resolve_expr (iter->stride) == SUCCESS)
2893 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2894 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2895 &iter->stride->where, "INTEGER");
2897 if (iter->stride->expr_type == EXPR_CONSTANT
2898 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2899 gfc_error ("FORALL stride expression at %L cannot be zero",
2900 &iter->stride->where);
2902 if (iter->var->ts.kind != iter->stride->ts.kind)
2903 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2910 /* Given a pointer to a symbol that is a derived type, see if any components
2911 have the POINTER attribute. The search is recursive if necessary.
2912 Returns zero if no pointer components are found, nonzero otherwise. */
2915 derived_pointer (gfc_symbol * sym)
2919 for (c = sym->components; c; c = c->next)
2924 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2932 /* Given a pointer to a symbol that is a derived type, see if it's
2933 inaccessible, i.e. if it's defined in another module and the components are
2934 PRIVATE. The search is recursive if necessary. Returns zero if no
2935 inaccessible components are found, nonzero otherwise. */
2938 derived_inaccessible (gfc_symbol *sym)
2942 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2945 for (c = sym->components; c; c = c->next)
2947 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2955 /* Resolve the argument of a deallocate expression. The expression must be
2956 a pointer or a full array. */
2959 resolve_deallocate_expr (gfc_expr * e)
2961 symbol_attribute attr;
2965 if (gfc_resolve_expr (e) == FAILURE)
2968 attr = gfc_expr_attr (e);
2972 if (e->expr_type != EXPR_VARIABLE)
2975 allocatable = e->symtree->n.sym->attr.allocatable;
2976 for (ref = e->ref; ref; ref = ref->next)
2980 if (ref->u.ar.type != AR_FULL)
2985 allocatable = (ref->u.c.component->as != NULL
2986 && ref->u.c.component->as->type == AS_DEFERRED);
2994 if (allocatable == 0)
2997 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2998 "ALLOCATABLE or a POINTER", &e->where);
3001 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3003 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3004 e->symtree->n.sym->name, &e->where);
3012 /* Given the expression node e for an allocatable/pointer of derived type to be
3013 allocated, get the expression node to be initialized afterwards (needed for
3014 derived types with default initializers). */
3017 expr_to_initialize (gfc_expr * e)
3023 result = gfc_copy_expr (e);
3025 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3026 for (ref = result->ref; ref; ref = ref->next)
3027 if (ref->type == REF_ARRAY && ref->next == NULL)
3029 ref->u.ar.type = AR_FULL;
3031 for (i = 0; i < ref->u.ar.dimen; i++)
3032 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3034 result->rank = ref->u.ar.dimen;
3042 /* Resolve the expression in an ALLOCATE statement, doing the additional
3043 checks to see whether the expression is OK or not. The expression must
3044 have a trailing array reference that gives the size of the array. */
3047 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3049 int i, pointer, allocatable, dimension;
3050 symbol_attribute attr;
3051 gfc_ref *ref, *ref2;
3056 if (gfc_resolve_expr (e) == FAILURE)
3059 /* Make sure the expression is allocatable or a pointer. If it is
3060 pointer, the next-to-last reference must be a pointer. */
3064 if (e->expr_type != EXPR_VARIABLE)
3068 attr = gfc_expr_attr (e);
3069 pointer = attr.pointer;
3070 dimension = attr.dimension;
3075 allocatable = e->symtree->n.sym->attr.allocatable;
3076 pointer = e->symtree->n.sym->attr.pointer;
3077 dimension = e->symtree->n.sym->attr.dimension;
3079 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3083 if (ref->next != NULL)
3088 allocatable = (ref->u.c.component->as != NULL
3089 && ref->u.c.component->as->type == AS_DEFERRED);
3091 pointer = ref->u.c.component->pointer;
3092 dimension = ref->u.c.component->dimension;
3102 if (allocatable == 0 && pointer == 0)
3104 gfc_error ("Expression in ALLOCATE statement at %L must be "
3105 "ALLOCATABLE or a POINTER", &e->where);
3109 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3111 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3112 e->symtree->n.sym->name, &e->where);
3116 /* Add default initializer for those derived types that need them. */
3117 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3119 init_st = gfc_get_code ();
3120 init_st->loc = code->loc;
3121 init_st->op = EXEC_ASSIGN;
3122 init_st->expr = expr_to_initialize (e);
3123 init_st->expr2 = init_e;
3125 init_st->next = code->next;
3126 code->next = init_st;
3129 if (pointer && dimension == 0)
3132 /* Make sure the next-to-last reference node is an array specification. */
3134 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3136 gfc_error ("Array specification required in ALLOCATE statement "
3137 "at %L", &e->where);
3141 if (ref2->u.ar.type == AR_ELEMENT)
3144 /* Make sure that the array section reference makes sense in the
3145 context of an ALLOCATE specification. */
3149 for (i = 0; i < ar->dimen; i++)
3150 switch (ar->dimen_type[i])
3156 if (ar->start[i] != NULL
3157 && ar->end[i] != NULL
3158 && ar->stride[i] == NULL)
3161 /* Fall Through... */
3165 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3174 /************ SELECT CASE resolution subroutines ************/
3176 /* Callback function for our mergesort variant. Determines interval
3177 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3178 op1 > op2. Assumes we're not dealing with the default case.
3179 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3180 There are nine situations to check. */
3183 compare_cases (const gfc_case * op1, const gfc_case * op2)
3187 if (op1->low == NULL) /* op1 = (:L) */
3189 /* op2 = (:N), so overlap. */
3191 /* op2 = (M:) or (M:N), L < M */
3192 if (op2->low != NULL
3193 && gfc_compare_expr (op1->high, op2->low) < 0)
3196 else if (op1->high == NULL) /* op1 = (K:) */
3198 /* op2 = (M:), so overlap. */
3200 /* op2 = (:N) or (M:N), K > N */
3201 if (op2->high != NULL
3202 && gfc_compare_expr (op1->low, op2->high) > 0)
3205 else /* op1 = (K:L) */
3207 if (op2->low == NULL) /* op2 = (:N), K > N */
3208 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3209 else if (op2->high == NULL) /* op2 = (M:), L < M */
3210 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3211 else /* op2 = (M:N) */
3215 if (gfc_compare_expr (op1->high, op2->low) < 0)
3218 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3227 /* Merge-sort a double linked case list, detecting overlap in the
3228 process. LIST is the head of the double linked case list before it
3229 is sorted. Returns the head of the sorted list if we don't see any
3230 overlap, or NULL otherwise. */
3233 check_case_overlap (gfc_case * list)
3235 gfc_case *p, *q, *e, *tail;
3236 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3238 /* If the passed list was empty, return immediately. */
3245 /* Loop unconditionally. The only exit from this loop is a return
3246 statement, when we've finished sorting the case list. */
3253 /* Count the number of merges we do in this pass. */
3256 /* Loop while there exists a merge to be done. */
3261 /* Count this merge. */
3264 /* Cut the list in two pieces by stepping INSIZE places
3265 forward in the list, starting from P. */
3268 for (i = 0; i < insize; i++)
3277 /* Now we have two lists. Merge them! */
3278 while (psize > 0 || (qsize > 0 && q != NULL))
3281 /* See from which the next case to merge comes from. */
3284 /* P is empty so the next case must come from Q. */
3289 else if (qsize == 0 || q == NULL)
3298 cmp = compare_cases (p, q);
3301 /* The whole case range for P is less than the
3309 /* The whole case range for Q is greater than
3310 the case range for P. */
3317 /* The cases overlap, or they are the same
3318 element in the list. Either way, we must
3319 issue an error and get the next case from P. */
3320 /* FIXME: Sort P and Q by line number. */
3321 gfc_error ("CASE label at %L overlaps with CASE "
3322 "label at %L", &p->where, &q->where);
3330 /* Add the next element to the merged list. */
3339 /* P has now stepped INSIZE places along, and so has Q. So
3340 they're the same. */
3345 /* If we have done only one merge or none at all, we've
3346 finished sorting the cases. */
3355 /* Otherwise repeat, merging lists twice the size. */
3361 /* Check to see if an expression is suitable for use in a CASE statement.
3362 Makes sure that all case expressions are scalar constants of the same
3363 type. Return FAILURE if anything is wrong. */
3366 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3368 if (e == NULL) return SUCCESS;
3370 if (e->ts.type != case_expr->ts.type)
3372 gfc_error ("Expression in CASE statement at %L must be of type %s",
3373 &e->where, gfc_basic_typename (case_expr->ts.type));
3377 /* C805 (R808) For a given case-construct, each case-value shall be of
3378 the same type as case-expr. For character type, length differences
3379 are allowed, but the kind type parameters shall be the same. */
3381 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3383 gfc_error("Expression in CASE statement at %L must be kind %d",
3384 &e->where, case_expr->ts.kind);
3388 /* Convert the case value kind to that of case expression kind, if needed.
3389 FIXME: Should a warning be issued? */
3390 if (e->ts.kind != case_expr->ts.kind)
3391 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3395 gfc_error ("Expression in CASE statement at %L must be scalar",
3404 /* Given a completely parsed select statement, we:
3406 - Validate all expressions and code within the SELECT.
3407 - Make sure that the selection expression is not of the wrong type.
3408 - Make sure that no case ranges overlap.
3409 - Eliminate unreachable cases and unreachable code resulting from
3410 removing case labels.
3412 The standard does allow unreachable cases, e.g. CASE (5:3). But
3413 they are a hassle for code generation, and to prevent that, we just
3414 cut them out here. This is not necessary for overlapping cases
3415 because they are illegal and we never even try to generate code.
3417 We have the additional caveat that a SELECT construct could have
3418 been a computed GOTO in the source code. Fortunately we can fairly
3419 easily work around that here: The case_expr for a "real" SELECT CASE
3420 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3421 we have to do is make sure that the case_expr is a scalar integer
3425 resolve_select (gfc_code * code)
3428 gfc_expr *case_expr;
3429 gfc_case *cp, *default_case, *tail, *head;
3430 int seen_unreachable;
3435 if (code->expr == NULL)
3437 /* This was actually a computed GOTO statement. */
3438 case_expr = code->expr2;
3439 if (case_expr->ts.type != BT_INTEGER
3440 || case_expr->rank != 0)
3441 gfc_error ("Selection expression in computed GOTO statement "
3442 "at %L must be a scalar integer expression",
3445 /* Further checking is not necessary because this SELECT was built
3446 by the compiler, so it should always be OK. Just move the
3447 case_expr from expr2 to expr so that we can handle computed
3448 GOTOs as normal SELECTs from here on. */
3449 code->expr = code->expr2;
3454 case_expr = code->expr;
3456 type = case_expr->ts.type;
3457 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3459 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3460 &case_expr->where, gfc_typename (&case_expr->ts));
3462 /* Punt. Going on here just produce more garbage error messages. */
3466 if (case_expr->rank != 0)
3468 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3469 "expression", &case_expr->where);
3475 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3476 of the SELECT CASE expression and its CASE values. Walk the lists
3477 of case values, and if we find a mismatch, promote case_expr to
3478 the appropriate kind. */
3480 if (type == BT_LOGICAL || type == BT_INTEGER)
3482 for (body = code->block; body; body = body->block)
3484 /* Walk the case label list. */
3485 for (cp = body->ext.case_list; cp; cp = cp->next)
3487 /* Intercept the DEFAULT case. It does not have a kind. */
3488 if (cp->low == NULL && cp->high == NULL)
3491 /* Unreachable case ranges are discarded, so ignore. */
3492 if (cp->low != NULL && cp->high != NULL
3493 && cp->low != cp->high
3494 && gfc_compare_expr (cp->low, cp->high) > 0)
3497 /* FIXME: Should a warning be issued? */
3499 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3500 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3502 if (cp->high != NULL
3503 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3504 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3509 /* Assume there is no DEFAULT case. */
3510 default_case = NULL;
3514 for (body = code->block; body; body = body->block)
3516 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3518 seen_unreachable = 0;
3520 /* Walk the case label list, making sure that all case labels
3522 for (cp = body->ext.case_list; cp; cp = cp->next)
3524 /* Count the number of cases in the whole construct. */
3527 /* Intercept the DEFAULT case. */
3528 if (cp->low == NULL && cp->high == NULL)
3530 if (default_case != NULL)
3532 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3533 "by a second DEFAULT CASE at %L",
3534 &default_case->where, &cp->where);
3545 /* Deal with single value cases and case ranges. Errors are
3546 issued from the validation function. */
3547 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3548 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3554 if (type == BT_LOGICAL
3555 && ((cp->low == NULL || cp->high == NULL)
3556 || cp->low != cp->high))
3559 ("Logical range in CASE statement at %L is not allowed",
3565 if (cp->low != NULL && cp->high != NULL
3566 && cp->low != cp->high
3567 && gfc_compare_expr (cp->low, cp->high) > 0)
3569 if (gfc_option.warn_surprising)
3570 gfc_warning ("Range specification at %L can never "
3571 "be matched", &cp->where);
3573 cp->unreachable = 1;
3574 seen_unreachable = 1;
3578 /* If the case range can be matched, it can also overlap with
3579 other cases. To make sure it does not, we put it in a
3580 double linked list here. We sort that with a merge sort
3581 later on to detect any overlapping cases. */
3585 head->right = head->left = NULL;
3590 tail->right->left = tail;
3597 /* It there was a failure in the previous case label, give up
3598 for this case label list. Continue with the next block. */
3602 /* See if any case labels that are unreachable have been seen.
3603 If so, we eliminate them. This is a bit of a kludge because
3604 the case lists for a single case statement (label) is a
3605 single forward linked lists. */
3606 if (seen_unreachable)
3608 /* Advance until the first case in the list is reachable. */
3609 while (body->ext.case_list != NULL
3610 && body->ext.case_list->unreachable)
3612 gfc_case *n = body->ext.case_list;
3613 body->ext.case_list = body->ext.case_list->next;
3615 gfc_free_case_list (n);
3618 /* Strip all other unreachable cases. */
3619 if (body->ext.case_list)
3621 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3623 if (cp->next->unreachable)
3625 gfc_case *n = cp->next;
3626 cp->next = cp->next->next;
3628 gfc_free_case_list (n);
3635 /* See if there were overlapping cases. If the check returns NULL,
3636 there was overlap. In that case we don't do anything. If head
3637 is non-NULL, we prepend the DEFAULT case. The sorted list can
3638 then used during code generation for SELECT CASE constructs with
3639 a case expression of a CHARACTER type. */
3642 head = check_case_overlap (head);
3644 /* Prepend the default_case if it is there. */
3645 if (head != NULL && default_case)
3647 default_case->left = NULL;
3648 default_case->right = head;
3649 head->left = default_case;
3653 /* Eliminate dead blocks that may be the result if we've seen
3654 unreachable case labels for a block. */
3655 for (body = code; body && body->block; body = body->block)
3657 if (body->block->ext.case_list == NULL)
3659 /* Cut the unreachable block from the code chain. */
3660 gfc_code *c = body->block;
3661 body->block = c->block;
3663 /* Kill the dead block, but not the blocks below it. */
3665 gfc_free_statements (c);
3669 /* More than two cases is legal but insane for logical selects.
3670 Issue a warning for it. */
3671 if (gfc_option.warn_surprising && type == BT_LOGICAL
3673 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3678 /* Resolve a transfer statement. This is making sure that:
3679 -- a derived type being transferred has only non-pointer components
3680 -- a derived type being transferred doesn't have private components, unless
3681 it's being transferred from the module where the type was defined
3682 -- we're not trying to transfer a whole assumed size array. */
3685 resolve_transfer (gfc_code * code)
3694 if (exp->expr_type != EXPR_VARIABLE)
3697 sym = exp->symtree->n.sym;
3700 /* Go to actual component transferred. */
3701 for (ref = code->expr->ref; ref; ref = ref->next)
3702 if (ref->type == REF_COMPONENT)
3703 ts = &ref->u.c.component->ts;
3705 if (ts->type == BT_DERIVED)
3707 /* Check that transferred derived type doesn't contain POINTER
3709 if (derived_pointer (ts->derived))
3711 gfc_error ("Data transfer element at %L cannot have "
3712 "POINTER components", &code->loc);
3716 if (derived_inaccessible (ts->derived))
3718 gfc_error ("Data transfer element at %L cannot have "
3719 "PRIVATE components",&code->loc);
3724 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3725 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3727 gfc_error ("Data transfer element at %L cannot be a full reference to "
3728 "an assumed-size array", &code->loc);
3734 /*********** Toplevel code resolution subroutines ***********/
3736 /* Given a branch to a label and a namespace, if the branch is conforming.
3737 The code node described where the branch is located. */
3740 resolve_branch (gfc_st_label * label, gfc_code * code)
3742 gfc_code *block, *found;
3750 /* Step one: is this a valid branching target? */
3752 if (lp->defined == ST_LABEL_UNKNOWN)
3754 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3759 if (lp->defined != ST_LABEL_TARGET)
3761 gfc_error ("Statement at %L is not a valid branch target statement "
3762 "for the branch statement at %L", &lp->where, &code->loc);
3766 /* Step two: make sure this branch is not a branch to itself ;-) */
3768 if (code->here == label)
3770 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3774 /* Step three: Try to find the label in the parse tree. To do this,
3775 we traverse the tree block-by-block: first the block that
3776 contains this GOTO, then the block that it is nested in, etc. We
3777 can ignore other blocks because branching into another block is
3782 for (stack = cs_base; stack; stack = stack->prev)
3784 for (block = stack->head; block; block = block->next)
3786 if (block->here == label)
3799 /* The label is not in an enclosing block, so illegal. This was
3800 allowed in Fortran 66, so we allow it as extension. We also
3801 forego further checks if we run into this. */
3802 gfc_notify_std (GFC_STD_LEGACY,
3803 "Label at %L is not in the same block as the "
3804 "GOTO statement at %L", &lp->where, &code->loc);
3808 /* Step four: Make sure that the branching target is legal if
3809 the statement is an END {SELECT,DO,IF}. */
3811 if (found->op == EXEC_NOP)
3813 for (stack = cs_base; stack; stack = stack->prev)
3814 if (stack->current->next == found)
3818 gfc_notify_std (GFC_STD_F95_DEL,
3819 "Obsolete: GOTO at %L jumps to END of construct at %L",
3820 &code->loc, &found->loc);
3825 /* Check whether EXPR1 has the same shape as EXPR2. */
3828 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3830 mpz_t shape[GFC_MAX_DIMENSIONS];
3831 mpz_t shape2[GFC_MAX_DIMENSIONS];
3832 try result = FAILURE;
3835 /* Compare the rank. */
3836 if (expr1->rank != expr2->rank)
3839 /* Compare the size of each dimension. */
3840 for (i=0; i<expr1->rank; i++)
3842 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3845 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3848 if (mpz_cmp (shape[i], shape2[i]))
3852 /* When either of the two expression is an assumed size array, we
3853 ignore the comparison of dimension sizes. */
3858 for (i--; i>=0; i--)
3860 mpz_clear (shape[i]);
3861 mpz_clear (shape2[i]);
3867 /* Check whether a WHERE assignment target or a WHERE mask expression
3868 has the same shape as the outmost WHERE mask expression. */
3871 resolve_where (gfc_code *code, gfc_expr *mask)
3877 cblock = code->block;
3879 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3880 In case of nested WHERE, only the outmost one is stored. */
3881 if (mask == NULL) /* outmost WHERE */
3883 else /* inner WHERE */
3890 /* Check if the mask-expr has a consistent shape with the
3891 outmost WHERE mask-expr. */
3892 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3893 gfc_error ("WHERE mask at %L has inconsistent shape",
3894 &cblock->expr->where);
3897 /* the assignment statement of a WHERE statement, or the first
3898 statement in where-body-construct of a WHERE construct */
3899 cnext = cblock->next;
3904 /* WHERE assignment statement */
3907 /* Check shape consistent for WHERE assignment target. */
3908 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3909 gfc_error ("WHERE assignment target at %L has "
3910 "inconsistent shape", &cnext->expr->where);
3913 /* WHERE or WHERE construct is part of a where-body-construct */
3915 resolve_where (cnext, e);
3919 gfc_error ("Unsupported statement inside WHERE at %L",
3922 /* the next statement within the same where-body-construct */
3923 cnext = cnext->next;
3925 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3926 cblock = cblock->block;
3931 /* Check whether the FORALL index appears in the expression or not. */
3934 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3938 gfc_actual_arglist *args;
3941 switch (expr->expr_type)
3944 gcc_assert (expr->symtree->n.sym);
3946 /* A scalar assignment */
3949 if (expr->symtree->n.sym == symbol)
3955 /* the expr is array ref, substring or struct component. */
3962 /* Check if the symbol appears in the array subscript. */
3964 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3967 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3971 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3975 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3981 if (expr->symtree->n.sym == symbol)
3984 /* Check if the symbol appears in the substring section. */
3985 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3987 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3995 gfc_error("expression reference type error at %L", &expr->where);
4001 /* If the expression is a function call, then check if the symbol
4002 appears in the actual arglist of the function. */
4004 for (args = expr->value.function.actual; args; args = args->next)
4006 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4011 /* It seems not to happen. */
4012 case EXPR_SUBSTRING:
4016 gcc_assert (expr->ref->type == REF_SUBSTRING);
4017 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4019 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4024 /* It seems not to happen. */
4025 case EXPR_STRUCTURE:
4027 gfc_error ("Unsupported statement while finding forall index in "
4032 /* Find the FORALL index in the first operand. */
4033 if (expr->value.op.op1)
4035 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4039 /* Find the FORALL index in the second operand. */
4040 if (expr->value.op.op2)
4042 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4055 /* Resolve assignment in FORALL construct.
4056 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4057 FORALL index variables. */
4060 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4064 for (n = 0; n < nvar; n++)
4066 gfc_symbol *forall_index;
4068 forall_index = var_expr[n]->symtree->n.sym;
4070 /* Check whether the assignment target is one of the FORALL index
4072 if ((code->expr->expr_type == EXPR_VARIABLE)
4073 && (code->expr->symtree->n.sym == forall_index))
4074 gfc_error ("Assignment to a FORALL index variable at %L",
4075 &code->expr->where);
4078 /* If one of the FORALL index variables doesn't appear in the
4079 assignment target, then there will be a many-to-one
4081 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4082 gfc_error ("The FORALL with index '%s' cause more than one "
4083 "assignment to this object at %L",
4084 var_expr[n]->symtree->name, &code->expr->where);
4090 /* Resolve WHERE statement in FORALL construct. */
4093 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4097 cblock = code->block;
4100 /* the assignment statement of a WHERE statement, or the first
4101 statement in where-body-construct of a WHERE construct */
4102 cnext = cblock->next;
4107 /* WHERE assignment statement */
4109 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4112 /* WHERE or WHERE construct is part of a where-body-construct */
4114 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4118 gfc_error ("Unsupported statement inside WHERE at %L",
4121 /* the next statement within the same where-body-construct */
4122 cnext = cnext->next;
4124 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4125 cblock = cblock->block;
4130 /* Traverse the FORALL body to check whether the following errors exist:
4131 1. For assignment, check if a many-to-one assignment happens.
4132 2. For WHERE statement, check the WHERE body to see if there is any
4133 many-to-one assignment. */
4136 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4140 c = code->block->next;
4146 case EXEC_POINTER_ASSIGN:
4147 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4150 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4151 there is no need to handle it here. */
4155 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4160 /* The next statement in the FORALL body. */
4166 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4167 gfc_resolve_forall_body to resolve the FORALL body. */
4170 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4172 static gfc_expr **var_expr;
4173 static int total_var = 0;
4174 static int nvar = 0;
4175 gfc_forall_iterator *fa;
4176 gfc_symbol *forall_index;
4180 /* Start to resolve a FORALL construct */
4181 if (forall_save == 0)
4183 /* Count the total number of FORALL index in the nested FORALL
4184 construct in order to allocate the VAR_EXPR with proper size. */
4186 while ((next != NULL) && (next->op == EXEC_FORALL))
4188 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4190 next = next->block->next;
4193 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4194 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4197 /* The information about FORALL iterator, including FORALL index start, end
4198 and stride. The FORALL index can not appear in start, end or stride. */
4199 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4201 /* Check if any outer FORALL index name is the same as the current
4203 for (i = 0; i < nvar; i++)
4205 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4207 gfc_error ("An outer FORALL construct already has an index "
4208 "with this name %L", &fa->var->where);
4212 /* Record the current FORALL index. */
4213 var_expr[nvar] = gfc_copy_expr (fa->var);
4215 forall_index = fa->var->symtree->n.sym;
4217 /* Check if the FORALL index appears in start, end or stride. */
4218 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4219 gfc_error ("A FORALL index must not appear in a limit or stride "
4220 "expression in the same FORALL at %L", &fa->start->where);
4221 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4222 gfc_error ("A FORALL index must not appear in a limit or stride "
4223 "expression in the same FORALL at %L", &fa->end->where);
4224 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4225 gfc_error ("A FORALL index must not appear in a limit or stride "
4226 "expression in the same FORALL at %L", &fa->stride->where);
4230 /* Resolve the FORALL body. */
4231 gfc_resolve_forall_body (code, nvar, var_expr);
4233 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4234 gfc_resolve_blocks (code->block, ns);
4236 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4237 for (i = 0; i < total_var; i++)
4238 gfc_free_expr (var_expr[i]);
4240 /* Reset the counters. */
4246 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4249 static void resolve_code (gfc_code *, gfc_namespace *);
4252 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4256 for (; b; b = b->block)
4258 t = gfc_resolve_expr (b->expr);
4259 if (gfc_resolve_expr (b->expr2) == FAILURE)
4265 if (t == SUCCESS && b->expr != NULL
4266 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4268 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4275 && (b->expr->ts.type != BT_LOGICAL
4276 || b->expr->rank == 0))
4278 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4283 resolve_branch (b->label, b);
4295 case EXEC_OMP_ATOMIC:
4296 case EXEC_OMP_CRITICAL:
4298 case EXEC_OMP_MASTER:
4299 case EXEC_OMP_ORDERED:
4300 case EXEC_OMP_PARALLEL:
4301 case EXEC_OMP_PARALLEL_DO:
4302 case EXEC_OMP_PARALLEL_SECTIONS:
4303 case EXEC_OMP_PARALLEL_WORKSHARE:
4304 case EXEC_OMP_SECTIONS:
4305 case EXEC_OMP_SINGLE:
4306 case EXEC_OMP_WORKSHARE:
4310 gfc_internal_error ("resolve_block(): Bad block type");
4313 resolve_code (b->next, ns);
4318 /* Given a block of code, recursively resolve everything pointed to by this
4322 resolve_code (gfc_code * code, gfc_namespace * ns)
4324 int omp_workshare_save;
4329 frame.prev = cs_base;
4333 for (; code; code = code->next)
4335 frame.current = code;
4337 if (code->op == EXEC_FORALL)
4339 int forall_save = forall_flag;
4342 gfc_resolve_forall (code, ns, forall_save);
4343 forall_flag = forall_save;
4345 else if (code->block)
4347 omp_workshare_save = -1;
4350 case EXEC_OMP_PARALLEL_WORKSHARE:
4351 omp_workshare_save = omp_workshare_flag;
4352 omp_workshare_flag = 1;
4353 gfc_resolve_omp_parallel_blocks (code, ns);
4355 case EXEC_OMP_PARALLEL:
4356 case EXEC_OMP_PARALLEL_DO:
4357 case EXEC_OMP_PARALLEL_SECTIONS:
4358 omp_workshare_save = omp_workshare_flag;
4359 omp_workshare_flag = 0;
4360 gfc_resolve_omp_parallel_blocks (code, ns);
4363 gfc_resolve_omp_do_blocks (code, ns);
4365 case EXEC_OMP_WORKSHARE:
4366 omp_workshare_save = omp_workshare_flag;
4367 omp_workshare_flag = 1;
4370 gfc_resolve_blocks (code->block, ns);
4374 if (omp_workshare_save != -1)
4375 omp_workshare_flag = omp_workshare_save;
4378 t = gfc_resolve_expr (code->expr);
4379 if (gfc_resolve_expr (code->expr2) == FAILURE)
4395 resolve_where (code, NULL);
4399 if (code->expr != NULL)
4401 if (code->expr->ts.type != BT_INTEGER)
4402 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4403 "variable", &code->expr->where);
4404 else if (code->expr->symtree->n.sym->attr.assign != 1)
4405 gfc_error ("Variable '%s' has not been assigned a target label "
4406 "at %L", code->expr->symtree->n.sym->name,
4407 &code->expr->where);
4410 resolve_branch (code->label, code);
4414 if (code->expr != NULL
4415 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4416 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4417 "INTEGER return specifier", &code->expr->where);
4424 if (gfc_extend_assign (code, ns) == SUCCESS)
4426 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4428 gfc_error ("Subroutine '%s' called instead of assignment at "
4429 "%L must be PURE", code->symtree->n.sym->name,
4436 if (gfc_pure (NULL))
4438 if (gfc_impure_variable (code->expr->symtree->n.sym))
4441 ("Cannot assign to variable '%s' in PURE procedure at %L",
4442 code->expr->symtree->n.sym->name, &code->expr->where);
4446 if (code->expr2->ts.type == BT_DERIVED
4447 && derived_pointer (code->expr2->ts.derived))
4450 ("Right side of assignment at %L is a derived type "
4451 "containing a POINTER in a PURE procedure",
4452 &code->expr2->where);
4457 gfc_check_assign (code->expr, code->expr2, 1);
4460 case EXEC_LABEL_ASSIGN:
4461 if (code->label->defined == ST_LABEL_UNKNOWN)
4462 gfc_error ("Label %d referenced at %L is never defined",
4463 code->label->value, &code->label->where);
4465 && (code->expr->expr_type != EXPR_VARIABLE
4466 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4467 || code->expr->symtree->n.sym->ts.kind
4468 != gfc_default_integer_kind
4469 || code->expr->symtree->n.sym->as != NULL))
4470 gfc_error ("ASSIGN statement at %L requires a scalar "
4471 "default INTEGER variable", &code->expr->where);
4474 case EXEC_POINTER_ASSIGN:
4478 gfc_check_pointer_assign (code->expr, code->expr2);
4481 case EXEC_ARITHMETIC_IF:
4483 && code->expr->ts.type != BT_INTEGER
4484 && code->expr->ts.type != BT_REAL)
4485 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4486 "expression", &code->expr->where);
4488 resolve_branch (code->label, code);
4489 resolve_branch (code->label2, code);
4490 resolve_branch (code->label3, code);
4494 if (t == SUCCESS && code->expr != NULL
4495 && (code->expr->ts.type != BT_LOGICAL
4496 || code->expr->rank != 0))
4497 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4498 &code->expr->where);
4503 resolve_call (code);
4507 /* Select is complicated. Also, a SELECT construct could be
4508 a transformed computed GOTO. */
4509 resolve_select (code);
4513 if (code->ext.iterator != NULL)
4515 gfc_iterator *iter = code->ext.iterator;
4516 if (gfc_resolve_iterator (iter, true) != FAILURE)
4517 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4522 if (code->expr == NULL)
4523 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4525 && (code->expr->rank != 0
4526 || code->expr->ts.type != BT_LOGICAL))
4527 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4528 "a scalar LOGICAL expression", &code->expr->where);
4532 if (t == SUCCESS && code->expr != NULL
4533 && code->expr->ts.type != BT_INTEGER)
4534 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4535 "of type INTEGER", &code->expr->where);
4537 for (a = code->ext.alloc_list; a; a = a->next)
4538 resolve_allocate_expr (a->expr, code);
4542 case EXEC_DEALLOCATE:
4543 if (t == SUCCESS && code->expr != NULL
4544 && code->expr->ts.type != BT_INTEGER)
4546 ("STAT tag in DEALLOCATE statement at %L must be of type "
4547 "INTEGER", &code->expr->where);
4549 for (a = code->ext.alloc_list; a; a = a->next)
4550 resolve_deallocate_expr (a->expr);
4555 if (gfc_resolve_open (code->ext.open) == FAILURE)
4558 resolve_branch (code->ext.open->err, code);
4562 if (gfc_resolve_close (code->ext.close) == FAILURE)
4565 resolve_branch (code->ext.close->err, code);
4568 case EXEC_BACKSPACE:
4572 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4575 resolve_branch (code->ext.filepos->err, code);
4579 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4582 resolve_branch (code->ext.inquire->err, code);
4586 gcc_assert (code->ext.inquire != NULL);
4587 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4590 resolve_branch (code->ext.inquire->err, code);
4595 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4598 resolve_branch (code->ext.dt->err, code);
4599 resolve_branch (code->ext.dt->end, code);
4600 resolve_branch (code->ext.dt->eor, code);
4604 resolve_transfer (code);
4608 resolve_forall_iterators (code->ext.forall_iterator);
4610 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4612 ("FORALL mask clause at %L requires a LOGICAL expression",
4613 &code->expr->where);
4616 case EXEC_OMP_ATOMIC:
4617 case EXEC_OMP_BARRIER:
4618 case EXEC_OMP_CRITICAL:
4619 case EXEC_OMP_FLUSH:
4621 case EXEC_OMP_MASTER:
4622 case EXEC_OMP_ORDERED:
4623 case EXEC_OMP_SECTIONS:
4624 case EXEC_OMP_SINGLE:
4625 case EXEC_OMP_WORKSHARE:
4626 gfc_resolve_omp_directive (code, ns);
4629 case EXEC_OMP_PARALLEL:
4630 case EXEC_OMP_PARALLEL_DO:
4631 case EXEC_OMP_PARALLEL_SECTIONS:
4632 case EXEC_OMP_PARALLEL_WORKSHARE:
4633 omp_workshare_save = omp_workshare_flag;
4634 omp_workshare_flag = 0;
4635 gfc_resolve_omp_directive (code, ns);
4636 omp_workshare_flag = omp_workshare_save;
4640 gfc_internal_error ("resolve_code(): Bad statement code");
4644 cs_base = frame.prev;
4648 /* Resolve initial values and make sure they are compatible with
4652 resolve_values (gfc_symbol * sym)
4655 if (sym->value == NULL)
4658 if (gfc_resolve_expr (sym->value) == FAILURE)
4661 gfc_check_assign_symbol (sym, sym->value);
4665 /* Resolve an index expression. */
4668 resolve_index_expr (gfc_expr * e)
4671 if (gfc_resolve_expr (e) == FAILURE)
4674 if (gfc_simplify_expr (e, 0) == FAILURE)
4677 if (gfc_specification_expr (e) == FAILURE)
4683 /* Resolve a charlen structure. */
4686 resolve_charlen (gfc_charlen *cl)
4693 if (resolve_index_expr (cl->length) == FAILURE)
4700 /* Test for non-constant shape arrays. */
4703 is_non_constant_shape_array (gfc_symbol *sym)
4708 if (sym->as != NULL)
4710 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
4711 has not been simplified; parameter array references. Do the
4712 simplification now. */
4713 for (i = 0; i < sym->as->rank; i++)
4715 e = sym->as->lower[i];
4716 if (e && (resolve_index_expr (e) == FAILURE
4717 || !gfc_is_constant_expr (e)))
4720 e = sym->as->upper[i];
4721 if (e && (resolve_index_expr (e) == FAILURE
4722 || !gfc_is_constant_expr (e)))
4729 /* Resolution of common features of flavors variable and procedure. */
4732 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
4734 /* Constraints on deferred shape variable. */
4735 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4737 if (sym->attr.allocatable)
4739 if (sym->attr.dimension)
4740 gfc_error ("Allocatable array '%s' at %L must have "
4741 "a deferred shape", sym->name, &sym->declared_at);
4743 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4744 sym->name, &sym->declared_at);
4748 if (sym->attr.pointer && sym->attr.dimension)
4750 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4751 sym->name, &sym->declared_at);
4758 if (!mp_flag && !sym->attr.allocatable
4759 && !sym->attr.pointer && !sym->attr.dummy)
4761 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4762 sym->name, &sym->declared_at);
4769 /* Resolve symbols with flavor variable. */
4772 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
4777 gfc_expr *constructor_expr;
4779 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4782 /* The shape of a main program or module array needs to be constant. */
4783 if (sym->ns->proc_name
4784 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4785 || sym->ns->proc_name->attr.is_main_program)
4786 && !sym->attr.use_assoc
4787 && !sym->attr.allocatable
4788 && !sym->attr.pointer
4789 && is_non_constant_shape_array (sym))
4791 gfc_error ("The module or main program array '%s' at %L must "
4792 "have constant shape", sym->name, &sym->declared_at);
4796 if (sym->ts.type == BT_CHARACTER)
4798 /* Make sure that character string variables with assumed length are
4800 e = sym->ts.cl->length;
4801 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
4803 gfc_error ("Entity with assumed character length at %L must be a "
4804 "dummy argument or a PARAMETER", &sym->declared_at);
4808 if (!gfc_is_constant_expr (e)
4809 && !(e->expr_type == EXPR_VARIABLE
4810 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
4811 && sym->ns->proc_name
4812 && (sym->ns->proc_name->attr.flavor == FL_MODULE
4813 || sym->ns->proc_name->attr.is_main_program)
4814 && !sym->attr.use_assoc)
4816 gfc_error ("'%s' at %L must have constant character length "
4817 "in this context", sym->name, &sym->declared_at);
4822 /* Can the symbol have an initializer? */
4824 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4825 || sym->attr.intrinsic || sym->attr.result)
4827 else if (sym->attr.dimension && !sym->attr.pointer)
4829 /* Don't allow initialization of automatic arrays. */
4830 for (i = 0; i < sym->as->rank; i++)
4832 if (sym->as->lower[i] == NULL
4833 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4834 || sym->as->upper[i] == NULL
4835 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4843 /* Reject illegal initializers. */
4844 if (sym->value && flag)
4846 if (sym->attr.allocatable)
4847 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4848 sym->name, &sym->declared_at);
4849 else if (sym->attr.external)
4850 gfc_error ("External '%s' at %L cannot have an initializer",
4851 sym->name, &sym->declared_at);
4852 else if (sym->attr.dummy)
4853 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4854 sym->name, &sym->declared_at);
4855 else if (sym->attr.intrinsic)
4856 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4857 sym->name, &sym->declared_at);
4858 else if (sym->attr.result)
4859 gfc_error ("Function result '%s' at %L cannot have an initializer",
4860 sym->name, &sym->declared_at);
4862 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4863 sym->name, &sym->declared_at);
4867 /* 4th constraint in section 11.3: "If an object of a type for which
4868 component-initialization is specified (R429) appears in the
4869 specification-part of a module and does not have the ALLOCATABLE
4870 or POINTER attribute, the object shall have the SAVE attribute." */
4872 constructor_expr = NULL;
4873 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
4874 constructor_expr = gfc_default_initializer (&sym->ts);
4876 if (sym->ns->proc_name
4877 && sym->ns->proc_name->attr.flavor == FL_MODULE
4879 && !sym->ns->save_all && !sym->attr.save
4880 && !sym->attr.pointer && !sym->attr.allocatable)
4882 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4883 sym->name, &sym->declared_at,
4884 "for default initialization of a component");
4888 /* Assign default initializer. */
4889 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4890 && !sym->attr.pointer)
4891 sym->value = gfc_default_initializer (&sym->ts);
4897 /* Resolve a procedure. */
4900 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
4902 gfc_formal_arglist *arg;
4904 if (sym->attr.function
4905 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
4908 if (sym->attr.proc == PROC_ST_FUNCTION)
4910 if (sym->ts.type == BT_CHARACTER)
4912 gfc_charlen *cl = sym->ts.cl;
4913 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4915 gfc_error ("Character-valued statement function '%s' at %L must "
4916 "have constant length", sym->name, &sym->declared_at);
4922 /* Ensure that derived type for are not of a private type. Internal
4923 module procedures are excluded by 2.2.3.3 - ie. they are not
4924 externally accessible and can access all the objects accessible in
4926 if (!(sym->ns->parent
4927 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
4928 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4930 for (arg = sym->formal; arg; arg = arg->next)
4933 && arg->sym->ts.type == BT_DERIVED
4934 && !arg->sym->ts.derived->attr.use_assoc
4935 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4936 arg->sym->ts.derived->ns->default_access))
4938 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
4939 "a dummy argument of '%s', which is "
4940 "PUBLIC at %L", arg->sym->name, sym->name,
4942 /* Stop this message from recurring. */
4943 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4949 /* An external symbol may not have an initializer because it is taken to be
4951 if (sym->attr.external && sym->value)
4953 gfc_error ("External object '%s' at %L may not have an initializer",
4954 sym->name, &sym->declared_at);
4958 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4959 char-len-param shall not be array-valued, pointer-valued, recursive
4960 or pure. ....snip... A character value of * may only be used in the
4961 following ways: (i) Dummy arg of procedure - dummy associates with
4962 actual length; (ii) To declare a named constant; or (iii) External
4963 function - but length must be declared in calling scoping unit. */
4964 if (sym->attr.function
4965 && sym->ts.type == BT_CHARACTER
4966 && sym->ts.cl && sym->ts.cl->length == NULL)
4968 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
4969 || (sym->attr.recursive) || (sym->attr.pure))
4971 if (sym->as && sym->as->rank)
4972 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4973 "array-valued", sym->name, &sym->declared_at);
4975 if (sym->attr.pointer)
4976 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4977 "pointer-valued", sym->name, &sym->declared_at);
4980 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4981 "pure", sym->name, &sym->declared_at);
4983 if (sym->attr.recursive)
4984 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4985 "recursive", sym->name, &sym->declared_at);
4990 /* Appendix B.2 of the standard. Contained functions give an
4991 error anyway. Fixed-form is likely to be F77/legacy. */
4992 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
4993 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
4994 "'%s' at %L is obsolescent in fortran 95",
4995 sym->name, &sym->declared_at);
5001 /* Resolve the components of a derived type. */
5004 resolve_fl_derived (gfc_symbol *sym)
5007 gfc_dt_list * dt_list;
5010 for (c = sym->components; c != NULL; c = c->next)
5012 if (c->ts.type == BT_CHARACTER)
5014 if (c->ts.cl->length == NULL
5015 || (resolve_charlen (c->ts.cl) == FAILURE)
5016 || !gfc_is_constant_expr (c->ts.cl->length))
5018 gfc_error ("Character length of component '%s' needs to "
5019 "be a constant specification expression at %L.",
5021 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5026 if (c->ts.type == BT_DERIVED
5027 && sym->component_access != ACCESS_PRIVATE
5028 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5029 && !c->ts.derived->attr.use_assoc
5030 && !gfc_check_access(c->ts.derived->attr.access,
5031 c->ts.derived->ns->default_access))
5033 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5034 "a component of '%s', which is PUBLIC at %L",
5035 c->name, sym->name, &sym->declared_at);
5039 if (c->pointer || c->as == NULL)
5042 for (i = 0; i < c->as->rank; i++)
5044 if (c->as->lower[i] == NULL
5045 || !gfc_is_constant_expr (c->as->lower[i])
5046 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5047 || c->as->upper[i] == NULL
5048 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5049 || !gfc_is_constant_expr (c->as->upper[i]))
5051 gfc_error ("Component '%s' of '%s' at %L must have "
5052 "constant array bounds.",
5053 c->name, sym->name, &c->loc);
5059 /* Add derived type to the derived type list. */
5060 dt_list = gfc_get_dt_list ();
5061 dt_list->next = sym->ns->derived_types;
5062 dt_list->derived = sym;
5063 sym->ns->derived_types = dt_list;
5070 resolve_fl_namelist (gfc_symbol *sym)
5075 /* Reject PRIVATE objects in a PUBLIC namelist. */
5076 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5078 for (nl = sym->namelist; nl; nl = nl->next)
5080 if (!nl->sym->attr.use_assoc
5081 && !(sym->ns->parent == nl->sym->ns)
5082 && !gfc_check_access(nl->sym->attr.access,
5083 nl->sym->ns->default_access))
5085 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5086 "PUBLIC namelist at %L", nl->sym->name,
5093 /* Reject namelist arrays that are not constant shape. */
5094 for (nl = sym->namelist; nl; nl = nl->next)
5096 if (is_non_constant_shape_array (nl->sym))
5098 gfc_error ("The array '%s' must have constant shape to be "
5099 "a NAMELIST object at %L", nl->sym->name,
5105 /* 14.1.2 A module or internal procedure represent local entities
5106 of the same type as a namelist member and so are not allowed.
5107 Note that this is sometimes caught by check_conflict so the
5108 same message has been used. */
5109 for (nl = sym->namelist; nl; nl = nl->next)
5112 if (sym->ns->parent && nl->sym && nl->sym->name)
5113 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5114 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5116 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5117 "attribute in '%s' at %L", nlsym->name,
5128 resolve_fl_parameter (gfc_symbol *sym)
5130 /* A parameter array's shape needs to be constant. */
5131 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5133 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5134 "or assumed shape", sym->name, &sym->declared_at);
5138 /* Make sure a parameter that has been implicitly typed still
5139 matches the implicit type, since PARAMETER statements can precede
5140 IMPLICIT statements. */
5141 if (sym->attr.implicit_type
5142 && !gfc_compare_types (&sym->ts,
5143 gfc_get_default_type (sym, sym->ns)))
5145 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5146 "later IMPLICIT type", sym->name, &sym->declared_at);
5150 /* Make sure the types of derived parameters are consistent. This
5151 type checking is deferred until resolution because the type may
5152 refer to a derived type from the host. */
5153 if (sym->ts.type == BT_DERIVED
5154 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5156 gfc_error ("Incompatible derived type in PARAMETER at %L",
5157 &sym->value->where);
5164 /* Do anything necessary to resolve a symbol. Right now, we just
5165 assume that an otherwise unknown symbol is a variable. This sort
5166 of thing commonly happens for symbols in module. */
5169 resolve_symbol (gfc_symbol * sym)
5171 /* Zero if we are checking a formal namespace. */
5172 static int formal_ns_flag = 1;
5173 int formal_ns_save, check_constant, mp_flag;
5174 gfc_symtree *symtree;
5175 gfc_symtree *this_symtree;
5179 if (sym->attr.flavor == FL_UNKNOWN)
5182 /* If we find that a flavorless symbol is an interface in one of the
5183 parent namespaces, find its symtree in this namespace, free the
5184 symbol and set the symtree to point to the interface symbol. */
5185 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5187 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5188 if (symtree && symtree->n.sym->generic)
5190 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5194 gfc_free_symbol (sym);
5195 symtree->n.sym->refs++;
5196 this_symtree->n.sym = symtree->n.sym;
5201 /* Otherwise give it a flavor according to such attributes as
5203 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5204 sym->attr.flavor = FL_VARIABLE;
5207 sym->attr.flavor = FL_PROCEDURE;
5208 if (sym->attr.dimension)
5209 sym->attr.function = 1;
5213 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5216 /* Symbols that are module procedures with results (functions) have
5217 the types and array specification copied for type checking in
5218 procedures that call them, as well as for saving to a module
5219 file. These symbols can't stand the scrutiny that their results
5221 mp_flag = (sym->result != NULL && sym->result != sym);
5223 /* Assign default type to symbols that need one and don't have one. */
5224 if (sym->ts.type == BT_UNKNOWN)
5226 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5227 gfc_set_default_type (sym, 1, NULL);
5229 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5231 /* The specific case of an external procedure should emit an error
5232 in the case that there is no implicit type. */
5234 gfc_set_default_type (sym, sym->attr.external, NULL);
5237 /* Result may be in another namespace. */
5238 resolve_symbol (sym->result);
5240 sym->ts = sym->result->ts;
5241 sym->as = gfc_copy_array_spec (sym->result->as);
5242 sym->attr.dimension = sym->result->attr.dimension;
5243 sym->attr.pointer = sym->result->attr.pointer;
5244 sym->attr.allocatable = sym->result->attr.allocatable;
5249 /* Assumed size arrays and assumed shape arrays must be dummy
5253 && (sym->as->type == AS_ASSUMED_SIZE
5254 || sym->as->type == AS_ASSUMED_SHAPE)
5255 && sym->attr.dummy == 0)
5257 if (sym->as->type == AS_ASSUMED_SIZE)
5258 gfc_error ("Assumed size array at %L must be a dummy argument",
5261 gfc_error ("Assumed shape array at %L must be a dummy argument",
5266 /* Make sure symbols with known intent or optional are really dummy
5267 variable. Because of ENTRY statement, this has to be deferred
5268 until resolution time. */
5270 if (!sym->attr.dummy
5271 && (sym->attr.optional
5272 || sym->attr.intent != INTENT_UNKNOWN))
5274 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5278 /* If a derived type symbol has reached this point, without its
5279 type being declared, we have an error. Notice that most
5280 conditions that produce undefined derived types have already
5281 been dealt with. However, the likes of:
5282 implicit type(t) (t) ..... call foo (t) will get us here if
5283 the type is not declared in the scope of the implicit
5284 statement. Change the type to BT_UNKNOWN, both because it is so
5285 and to prevent an ICE. */
5286 if (sym->ts.type == BT_DERIVED
5287 && sym->ts.derived->components == NULL)
5289 gfc_error ("The derived type '%s' at %L is of type '%s', "
5290 "which has not been defined.", sym->name,
5291 &sym->declared_at, sym->ts.derived->name);
5292 sym->ts.type = BT_UNKNOWN;
5296 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5297 default initialization is defined (5.1.2.4.4). */
5298 if (sym->ts.type == BT_DERIVED
5300 && sym->attr.intent == INTENT_OUT
5302 && sym->as->type == AS_ASSUMED_SIZE)
5304 for (c = sym->ts.derived->components; c; c = c->next)
5308 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5309 "ASSUMED SIZE and so cannot have a default initializer",
5310 sym->name, &sym->declared_at);
5316 switch (sym->attr.flavor)
5319 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5324 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5329 if (resolve_fl_namelist (sym) == FAILURE)
5334 if (resolve_fl_parameter (sym) == FAILURE)
5344 /* Make sure that intrinsic exist */
5345 if (sym->attr.intrinsic
5346 && ! gfc_intrinsic_name(sym->name, 0)
5347 && ! gfc_intrinsic_name(sym->name, 1))
5348 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5350 /* Resolve array specifier. Check as well some constraints
5351 on COMMON blocks. */
5353 check_constant = sym->attr.in_common && !sym->attr.pointer;
5354 gfc_resolve_array_spec (sym->as, check_constant);
5356 /* Resolve formal namespaces. */
5358 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5360 formal_ns_save = formal_ns_flag;
5362 gfc_resolve (sym->formal_ns);
5363 formal_ns_flag = formal_ns_save;
5366 /* Check threadprivate restrictions. */
5367 if (sym->attr.threadprivate && !sym->attr.save
5368 && (!sym->attr.in_common
5369 && sym->module == NULL
5370 && (sym->ns->proc_name == NULL
5371 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5372 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5377 /************* Resolve DATA statements *************/
5381 gfc_data_value *vnode;
5387 /* Advance the values structure to point to the next value in the data list. */
5390 next_data_value (void)
5392 while (values.left == 0)
5394 if (values.vnode->next == NULL)
5397 values.vnode = values.vnode->next;
5398 values.left = values.vnode->repeat;
5406 check_data_variable (gfc_data_variable * var, locus * where)
5412 ar_type mark = AR_UNKNOWN;
5414 mpz_t section_index[GFC_MAX_DIMENSIONS];
5418 if (gfc_resolve_expr (var->expr) == FAILURE)
5422 mpz_init_set_si (offset, 0);
5425 if (e->expr_type != EXPR_VARIABLE)
5426 gfc_internal_error ("check_data_variable(): Bad expression");
5428 if (e->symtree->n.sym->ns->is_block_data
5429 && !e->symtree->n.sym->attr.in_common)
5431 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5432 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5437 mpz_init_set_ui (size, 1);
5444 /* Find the array section reference. */
5445 for (ref = e->ref; ref; ref = ref->next)
5447 if (ref->type != REF_ARRAY)
5449 if (ref->u.ar.type == AR_ELEMENT)
5455 /* Set marks according to the reference pattern. */
5456 switch (ref->u.ar.type)
5464 /* Get the start position of array section. */
5465 gfc_get_section_index (ar, section_index, &offset);
5473 if (gfc_array_size (e, &size) == FAILURE)
5475 gfc_error ("Nonconstant array section at %L in DATA statement",
5484 while (mpz_cmp_ui (size, 0) > 0)
5486 if (next_data_value () == FAILURE)
5488 gfc_error ("DATA statement at %L has more variables than values",
5494 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5498 /* If we have more than one element left in the repeat count,
5499 and we have more than one element left in the target variable,
5500 then create a range assignment. */
5501 /* ??? Only done for full arrays for now, since array sections
5503 if (mark == AR_FULL && ref && ref->next == NULL
5504 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5508 if (mpz_cmp_ui (size, values.left) >= 0)
5510 mpz_init_set_ui (range, values.left);
5511 mpz_sub_ui (size, size, values.left);
5516 mpz_init_set (range, size);
5517 values.left -= mpz_get_ui (size);
5518 mpz_set_ui (size, 0);
5521 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5524 mpz_add (offset, offset, range);
5528 /* Assign initial value to symbol. */
5532 mpz_sub_ui (size, size, 1);
5534 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5536 if (mark == AR_FULL)
5537 mpz_add_ui (offset, offset, 1);
5539 /* Modify the array section indexes and recalculate the offset
5540 for next element. */
5541 else if (mark == AR_SECTION)
5542 gfc_advance_section (section_index, ar, &offset);
5546 if (mark == AR_SECTION)
5548 for (i = 0; i < ar->dimen; i++)
5549 mpz_clear (section_index[i]);
5559 static try traverse_data_var (gfc_data_variable *, locus *);
5561 /* Iterate over a list of elements in a DATA statement. */
5564 traverse_data_list (gfc_data_variable * var, locus * where)
5567 iterator_stack frame;
5570 mpz_init (frame.value);
5572 mpz_init_set (trip, var->iter.end->value.integer);
5573 mpz_sub (trip, trip, var->iter.start->value.integer);
5574 mpz_add (trip, trip, var->iter.step->value.integer);
5576 mpz_div (trip, trip, var->iter.step->value.integer);
5578 mpz_set (frame.value, var->iter.start->value.integer);
5580 frame.prev = iter_stack;
5581 frame.variable = var->iter.var->symtree;
5582 iter_stack = &frame;
5584 while (mpz_cmp_ui (trip, 0) > 0)
5586 if (traverse_data_var (var->list, where) == FAILURE)
5592 e = gfc_copy_expr (var->expr);
5593 if (gfc_simplify_expr (e, 1) == FAILURE)
5599 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5601 mpz_sub_ui (trip, trip, 1);
5605 mpz_clear (frame.value);
5607 iter_stack = frame.prev;
5612 /* Type resolve variables in the variable list of a DATA statement. */
5615 traverse_data_var (gfc_data_variable * var, locus * where)
5619 for (; var; var = var->next)
5621 if (var->expr == NULL)
5622 t = traverse_data_list (var, where);
5624 t = check_data_variable (var, where);
5634 /* Resolve the expressions and iterators associated with a data statement.
5635 This is separate from the assignment checking because data lists should
5636 only be resolved once. */
5639 resolve_data_variables (gfc_data_variable * d)
5641 for (; d; d = d->next)
5643 if (d->list == NULL)
5645 if (gfc_resolve_expr (d->expr) == FAILURE)
5650 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5653 if (d->iter.start->expr_type != EXPR_CONSTANT
5654 || d->iter.end->expr_type != EXPR_CONSTANT
5655 || d->iter.step->expr_type != EXPR_CONSTANT)
5656 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5658 if (resolve_data_variables (d->list) == FAILURE)
5667 /* Resolve a single DATA statement. We implement this by storing a pointer to
5668 the value list into static variables, and then recursively traversing the
5669 variables list, expanding iterators and such. */
5672 resolve_data (gfc_data * d)
5674 if (resolve_data_variables (d->var) == FAILURE)
5677 values.vnode = d->value;
5678 values.left = (d->value == NULL) ? 0 : d->value->repeat;
5680 if (traverse_data_var (d->var, &d->where) == FAILURE)
5683 /* At this point, we better not have any values left. */
5685 if (next_data_value () == SUCCESS)
5686 gfc_error ("DATA statement at %L has more values than variables",
5691 /* Determines if a variable is not 'pure', ie not assignable within a pure
5692 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5696 gfc_impure_variable (gfc_symbol * sym)
5698 if (sym->attr.use_assoc || sym->attr.in_common)
5701 if (sym->ns != gfc_current_ns)
5702 return !sym->attr.function;
5704 /* TODO: Check storage association through EQUIVALENCE statements */
5710 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5711 symbol of the current procedure. */
5714 gfc_pure (gfc_symbol * sym)
5716 symbol_attribute attr;
5719 sym = gfc_current_ns->proc_name;
5725 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5729 /* Test whether the current procedure is elemental or not. */
5732 gfc_elemental (gfc_symbol * sym)
5734 symbol_attribute attr;
5737 sym = gfc_current_ns->proc_name;
5742 return attr.flavor == FL_PROCEDURE && attr.elemental;
5746 /* Warn about unused labels. */
5749 warn_unused_label (gfc_st_label * label)
5754 warn_unused_label (label->left);
5756 if (label->defined == ST_LABEL_UNKNOWN)
5759 switch (label->referenced)
5761 case ST_LABEL_UNKNOWN:
5762 gfc_warning ("Label %d at %L defined but not used", label->value,
5766 case ST_LABEL_BAD_TARGET:
5767 gfc_warning ("Label %d at %L defined but cannot be used",
5768 label->value, &label->where);
5775 warn_unused_label (label->right);
5779 /* Returns the sequence type of a symbol or sequence. */
5782 sequence_type (gfc_typespec ts)
5791 if (ts.derived->components == NULL)
5792 return SEQ_NONDEFAULT;
5794 result = sequence_type (ts.derived->components->ts);
5795 for (c = ts.derived->components->next; c; c = c->next)
5796 if (sequence_type (c->ts) != result)
5802 if (ts.kind != gfc_default_character_kind)
5803 return SEQ_NONDEFAULT;
5805 return SEQ_CHARACTER;
5808 if (ts.kind != gfc_default_integer_kind)
5809 return SEQ_NONDEFAULT;
5814 if (!(ts.kind == gfc_default_real_kind
5815 || ts.kind == gfc_default_double_kind))
5816 return SEQ_NONDEFAULT;
5821 if (ts.kind != gfc_default_complex_kind)
5822 return SEQ_NONDEFAULT;
5827 if (ts.kind != gfc_default_logical_kind)
5828 return SEQ_NONDEFAULT;
5833 return SEQ_NONDEFAULT;
5838 /* Resolve derived type EQUIVALENCE object. */
5841 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5844 gfc_component *c = derived->components;
5849 /* Shall not be an object of nonsequence derived type. */
5850 if (!derived->attr.sequence)
5852 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5853 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5857 for (; c ; c = c->next)
5860 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5863 /* Shall not be an object of sequence derived type containing a pointer
5864 in the structure. */
5867 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5868 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5874 gfc_error ("Derived type variable '%s' at %L with default initializer "
5875 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5883 /* Resolve equivalence object.
5884 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5885 an allocatable array, an object of nonsequence derived type, an object of
5886 sequence derived type containing a pointer at any level of component
5887 selection, an automatic object, a function name, an entry name, a result
5888 name, a named constant, a structure component, or a subobject of any of
5889 the preceding objects. A substring shall not have length zero. A
5890 derived type shall not have components with default initialization nor
5891 shall two objects of an equivalence group be initialized.
5892 The simple constraints are done in symbol.c(check_conflict) and the rest
5893 are implemented here. */
5896 resolve_equivalence (gfc_equiv *eq)
5899 gfc_symbol *derived;
5900 gfc_symbol *first_sym;
5903 locus *last_where = NULL;
5904 seq_type eq_type, last_eq_type;
5905 gfc_typespec *last_ts;
5907 const char *value_name;
5911 last_ts = &eq->expr->symtree->n.sym->ts;
5913 first_sym = eq->expr->symtree->n.sym;
5915 for (object = 1; eq; eq = eq->eq, object++)
5919 e->ts = e->symtree->n.sym->ts;
5920 /* match_varspec might not know yet if it is seeing
5921 array reference or substring reference, as it doesn't
5923 if (e->ref && e->ref->type == REF_ARRAY)
5925 gfc_ref *ref = e->ref;
5926 sym = e->symtree->n.sym;
5928 if (sym->attr.dimension)
5930 ref->u.ar.as = sym->as;
5934 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5935 if (e->ts.type == BT_CHARACTER
5937 && ref->type == REF_ARRAY
5938 && ref->u.ar.dimen == 1
5939 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5940 && ref->u.ar.stride[0] == NULL)
5942 gfc_expr *start = ref->u.ar.start[0];
5943 gfc_expr *end = ref->u.ar.end[0];
5946 /* Optimize away the (:) reference. */
5947 if (start == NULL && end == NULL)
5952 e->ref->next = ref->next;
5957 ref->type = REF_SUBSTRING;
5959 start = gfc_int_expr (1);
5960 ref->u.ss.start = start;
5961 if (end == NULL && e->ts.cl)
5962 end = gfc_copy_expr (e->ts.cl->length);
5963 ref->u.ss.end = end;
5964 ref->u.ss.length = e->ts.cl;
5971 /* Any further ref is an error. */
5974 gcc_assert (ref->type == REF_ARRAY);
5975 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5981 if (gfc_resolve_expr (e) == FAILURE)
5984 sym = e->symtree->n.sym;
5986 /* An equivalence statement cannot have more than one initialized
5990 if (value_name != NULL)
5992 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5993 "be in the EQUIVALENCE statement at %L",
5994 value_name, sym->name, &e->where);
5998 value_name = sym->name;
6001 /* Shall not equivalence common block variables in a PURE procedure. */
6002 if (sym->ns->proc_name
6003 && sym->ns->proc_name->attr.pure
6004 && sym->attr.in_common)
6006 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6007 "object in the pure procedure '%s'",
6008 sym->name, &e->where, sym->ns->proc_name->name);
6012 /* Shall not be a named constant. */
6013 if (e->expr_type == EXPR_CONSTANT)
6015 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6016 "object", sym->name, &e->where);
6020 derived = e->ts.derived;
6021 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6024 /* Check that the types correspond correctly:
6026 A numeric sequence structure may be equivalenced to another sequence
6027 structure, an object of default integer type, default real type, double
6028 precision real type, default logical type such that components of the
6029 structure ultimately only become associated to objects of the same
6030 kind. A character sequence structure may be equivalenced to an object
6031 of default character kind or another character sequence structure.
6032 Other objects may be equivalenced only to objects of the same type and
6035 /* Identical types are unconditionally OK. */
6036 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6037 goto identical_types;
6039 last_eq_type = sequence_type (*last_ts);
6040 eq_type = sequence_type (sym->ts);
6042 /* Since the pair of objects is not of the same type, mixed or
6043 non-default sequences can be rejected. */
6045 msg = "Sequence %s with mixed components in EQUIVALENCE "
6046 "statement at %L with different type objects";
6048 && last_eq_type == SEQ_MIXED
6049 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6050 last_where) == FAILURE)
6051 || (eq_type == SEQ_MIXED
6052 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6053 &e->where) == FAILURE))
6056 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6057 "statement at %L with objects of different type";
6059 && last_eq_type == SEQ_NONDEFAULT
6060 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6061 last_where) == FAILURE)
6062 || (eq_type == SEQ_NONDEFAULT
6063 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6064 &e->where) == FAILURE))
6067 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6068 "EQUIVALENCE statement at %L";
6069 if (last_eq_type == SEQ_CHARACTER
6070 && eq_type != SEQ_CHARACTER
6071 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6072 &e->where) == FAILURE)
6075 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6076 "EQUIVALENCE statement at %L";
6077 if (last_eq_type == SEQ_NUMERIC
6078 && eq_type != SEQ_NUMERIC
6079 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6080 &e->where) == FAILURE)
6085 last_where = &e->where;
6090 /* Shall not be an automatic array. */
6091 if (e->ref->type == REF_ARRAY
6092 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6094 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6095 "an EQUIVALENCE object", sym->name, &e->where);
6102 /* Shall not be a structure component. */
6103 if (r->type == REF_COMPONENT)
6105 gfc_error ("Structure component '%s' at %L cannot be an "
6106 "EQUIVALENCE object",
6107 r->u.c.component->name, &e->where);
6111 /* A substring shall not have length zero. */
6112 if (r->type == REF_SUBSTRING)
6114 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6116 gfc_error ("Substring at %L has length zero",
6117 &r->u.ss.start->where);
6127 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6130 resolve_fntype (gfc_namespace * ns)
6135 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6138 /* If there are any entries, ns->proc_name is the entry master
6139 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6141 sym = ns->entries->sym;
6143 sym = ns->proc_name;
6144 if (sym->result == sym
6145 && sym->ts.type == BT_UNKNOWN
6146 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6147 && !sym->attr.untyped)
6149 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6150 sym->name, &sym->declared_at);
6151 sym->attr.untyped = 1;
6154 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6155 && !gfc_check_access (sym->ts.derived->attr.access,
6156 sym->ts.derived->ns->default_access)
6157 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6159 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6160 sym->name, &sym->declared_at, sym->ts.derived->name);
6164 for (el = ns->entries->next; el; el = el->next)
6166 if (el->sym->result == el->sym
6167 && el->sym->ts.type == BT_UNKNOWN
6168 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6169 && !el->sym->attr.untyped)
6171 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6172 el->sym->name, &el->sym->declared_at);
6173 el->sym->attr.untyped = 1;
6178 /* 12.3.2.1.1 Defined operators. */
6181 gfc_resolve_uops(gfc_symtree *symtree)
6185 gfc_formal_arglist *formal;
6187 if (symtree == NULL)
6190 gfc_resolve_uops (symtree->left);
6191 gfc_resolve_uops (symtree->right);
6193 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6196 if (!sym->attr.function)
6197 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6198 sym->name, &sym->declared_at);
6200 if (sym->ts.type == BT_CHARACTER
6201 && !(sym->ts.cl && sym->ts.cl->length)
6202 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6203 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6204 "length", sym->name, &sym->declared_at);
6206 formal = sym->formal;
6207 if (!formal || !formal->sym)
6209 gfc_error("User operator procedure '%s' at %L must have at least "
6210 "one argument", sym->name, &sym->declared_at);
6214 if (formal->sym->attr.intent != INTENT_IN)
6215 gfc_error ("First argument of operator interface at %L must be "
6216 "INTENT(IN)", &sym->declared_at);
6218 if (formal->sym->attr.optional)
6219 gfc_error ("First argument of operator interface at %L cannot be "
6220 "optional", &sym->declared_at);
6222 formal = formal->next;
6223 if (!formal || !formal->sym)
6226 if (formal->sym->attr.intent != INTENT_IN)
6227 gfc_error ("Second argument of operator interface at %L must be "
6228 "INTENT(IN)", &sym->declared_at);
6230 if (formal->sym->attr.optional)
6231 gfc_error ("Second argument of operator interface at %L cannot be "
6232 "optional", &sym->declared_at);
6235 gfc_error ("Operator interface at %L must have, at most, two "
6236 "arguments", &sym->declared_at);
6241 /* Examine all of the expressions associated with a program unit,
6242 assign types to all intermediate expressions, make sure that all
6243 assignments are to compatible types and figure out which names
6244 refer to which functions or subroutines. It doesn't check code
6245 block, which is handled by resolve_code. */
6248 resolve_types (gfc_namespace * ns)
6255 gfc_current_ns = ns;
6257 resolve_entries (ns);
6259 resolve_contained_functions (ns);
6261 gfc_traverse_ns (ns, resolve_symbol);
6263 resolve_fntype (ns);
6265 for (n = ns->contained; n; n = n->sibling)
6267 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6268 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6269 "also be PURE", n->proc_name->name,
6270 &n->proc_name->declared_at);
6276 gfc_check_interfaces (ns);
6278 for (cl = ns->cl_list; cl; cl = cl->next)
6279 resolve_charlen (cl);
6281 gfc_traverse_ns (ns, resolve_values);
6287 for (d = ns->data; d; d = d->next)
6291 gfc_traverse_ns (ns, gfc_formalize_init_value);
6293 for (eq = ns->equiv; eq; eq = eq->next)
6294 resolve_equivalence (eq);
6296 /* Warn about unused labels. */
6297 if (gfc_option.warn_unused_labels)
6298 warn_unused_label (ns->st_labels);
6300 gfc_resolve_uops (ns->uop_root);
6305 /* Call resolve_code recursively. */
6308 resolve_codes (gfc_namespace * ns)
6312 for (n = ns->contained; n; n = n->sibling)
6315 gfc_current_ns = ns;
6317 resolve_code (ns->code, ns);
6321 /* This function is called after a complete program unit has been compiled.
6322 Its purpose is to examine all of the expressions associated with a program
6323 unit, assign types to all intermediate expressions, make sure that all
6324 assignments are to compatible types and figure out which names refer to
6325 which functions or subroutines. */
6328 gfc_resolve (gfc_namespace * ns)
6330 gfc_namespace *old_ns;
6332 old_ns = gfc_current_ns;
6337 gfc_current_ns = old_ns;