1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 /* Types used in equivalence statements. */
36 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code *head, *current, *tail;
46 struct code_stack *prev;
48 /* This bitmap keeps track of the targets valid for a branch from
50 bitmap reachable_labels;
54 static code_stack *cs_base = NULL;
57 /* Nonzero if we're inside a FORALL block. */
59 static int forall_flag;
61 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
63 static int omp_workshare_flag;
65 /* Nonzero if we are processing a formal arglist. The corresponding function
66 resets the flag each time that it is read. */
67 static int formal_arg_flag = 0;
69 /* True if we are resolving a specification expression. */
70 static int specification_expr = 0;
72 /* The id of the last entry seen. */
73 static int current_entry_id;
75 /* We use bitmaps to determine if a branch target is valid. */
76 static bitmap_obstack labels_obstack;
79 gfc_is_formal_arg (void)
81 return formal_arg_flag;
84 /* Resolve types of formal argument lists. These have to be done early so that
85 the formal argument lists of module procedures can be copied to the
86 containing module before the individual procedures are resolved
87 individually. We also resolve argument lists of procedures in interface
88 blocks because they are self-contained scoping units.
90 Since a dummy argument cannot be a non-dummy procedure, the only
91 resort left for untyped names are the IMPLICIT types. */
94 resolve_formal_arglist (gfc_symbol *proc)
96 gfc_formal_arglist *f;
100 if (proc->result != NULL)
105 if (gfc_elemental (proc)
106 || sym->attr.pointer || sym->attr.allocatable
107 || (sym->as && sym->as->rank > 0))
108 proc->attr.always_explicit = 1;
112 for (f = proc->formal; f; f = f->next)
118 /* Alternate return placeholder. */
119 if (gfc_elemental (proc))
120 gfc_error ("Alternate return specifier in elemental subroutine "
121 "'%s' at %L is not allowed", proc->name,
123 if (proc->attr.function)
124 gfc_error ("Alternate return specifier in function "
125 "'%s' at %L is not allowed", proc->name,
130 if (sym->attr.if_source != IFSRC_UNKNOWN)
131 resolve_formal_arglist (sym);
133 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
135 if (gfc_pure (proc) && !gfc_pure (sym))
137 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
138 "also be PURE", sym->name, &sym->declared_at);
142 if (gfc_elemental (proc))
144 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
145 "procedure", &sym->declared_at);
149 if (sym->attr.function
150 && sym->ts.type == BT_UNKNOWN
151 && sym->attr.intrinsic)
153 gfc_intrinsic_sym *isym;
154 isym = gfc_find_function (sym->name);
155 if (isym == NULL || !isym->specific)
157 gfc_error ("Unable to find a specific INTRINSIC procedure "
158 "for the reference '%s' at %L", sym->name,
167 if (sym->ts.type == BT_UNKNOWN)
169 if (!sym->attr.function || sym->result == sym)
170 gfc_set_default_type (sym, 1, sym->ns);
173 gfc_resolve_array_spec (sym->as, 0);
175 /* We can't tell if an array with dimension (:) is assumed or deferred
176 shape until we know if it has the pointer or allocatable attributes.
178 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
179 && !(sym->attr.pointer || sym->attr.allocatable))
181 sym->as->type = AS_ASSUMED_SHAPE;
182 for (i = 0; i < sym->as->rank; i++)
183 sym->as->lower[i] = gfc_int_expr (1);
186 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
187 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
188 || sym->attr.optional)
189 proc->attr.always_explicit = 1;
191 /* If the flavor is unknown at this point, it has to be a variable.
192 A procedure specification would have already set the type. */
194 if (sym->attr.flavor == FL_UNKNOWN)
195 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
197 if (gfc_pure (proc) && !sym->attr.pointer
198 && sym->attr.flavor != FL_PROCEDURE)
200 if (proc->attr.function && sym->attr.intent != INTENT_IN)
201 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
202 "INTENT(IN)", sym->name, proc->name,
205 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
206 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
207 "have its INTENT specified", sym->name, proc->name,
211 if (gfc_elemental (proc))
215 gfc_error ("Argument '%s' of elemental procedure at %L must "
216 "be scalar", sym->name, &sym->declared_at);
220 if (sym->attr.pointer)
222 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
223 "have the POINTER attribute", sym->name,
229 /* Each dummy shall be specified to be scalar. */
230 if (proc->attr.proc == PROC_ST_FUNCTION)
234 gfc_error ("Argument '%s' of statement function at %L must "
235 "be scalar", sym->name, &sym->declared_at);
239 if (sym->ts.type == BT_CHARACTER)
241 gfc_charlen *cl = sym->ts.cl;
242 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
244 gfc_error ("Character-valued argument '%s' of statement "
245 "function at %L must have constant length",
246 sym->name, &sym->declared_at);
256 /* Work function called when searching for symbols that have argument lists
257 associated with them. */
260 find_arglists (gfc_symbol *sym)
262 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
265 resolve_formal_arglist (sym);
269 /* Given a namespace, resolve all formal argument lists within the namespace.
273 resolve_formal_arglists (gfc_namespace *ns)
278 gfc_traverse_ns (ns, find_arglists);
283 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
287 /* If this namespace is not a function, ignore it. */
288 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
291 /* Try to find out of what the return type is. */
292 if (sym->result->ts.type == BT_UNKNOWN)
294 t = gfc_set_default_type (sym->result, 0, ns);
296 if (t == FAILURE && !sym->result->attr.untyped)
298 if (sym->result == sym)
299 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
300 sym->name, &sym->declared_at);
302 gfc_error ("Result '%s' of contained function '%s' at %L has "
303 "no IMPLICIT type", sym->result->name, sym->name,
304 &sym->result->declared_at);
305 sym->result->attr.untyped = 1;
309 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
310 type, lists the only ways a character length value of * can be used:
311 dummy arguments of procedures, named constants, and function results
312 in external functions. Internal function results are not on that list;
313 ergo, not permitted. */
315 if (sym->result->ts.type == BT_CHARACTER)
317 gfc_charlen *cl = sym->result->ts.cl;
318 if (!cl || !cl->length)
319 gfc_error ("Character-valued internal function '%s' at %L must "
320 "not be assumed length", sym->name, &sym->declared_at);
325 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
326 introduce duplicates. */
329 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
331 gfc_formal_arglist *f, *new_arglist;
334 for (; new_args != NULL; new_args = new_args->next)
336 new_sym = new_args->sym;
337 /* See if this arg is already in the formal argument list. */
338 for (f = proc->formal; f; f = f->next)
340 if (new_sym == f->sym)
347 /* Add a new argument. Argument order is not important. */
348 new_arglist = gfc_get_formal_arglist ();
349 new_arglist->sym = new_sym;
350 new_arglist->next = proc->formal;
351 proc->formal = new_arglist;
356 /* Flag the arguments that are not present in all entries. */
359 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
361 gfc_formal_arglist *f, *head;
364 for (f = proc->formal; f; f = f->next)
369 for (new_args = head; new_args; new_args = new_args->next)
371 if (new_args->sym == f->sym)
378 f->sym->attr.not_always_present = 1;
383 /* Resolve alternate entry points. If a symbol has multiple entry points we
384 create a new master symbol for the main routine, and turn the existing
385 symbol into an entry point. */
388 resolve_entries (gfc_namespace *ns)
390 gfc_namespace *old_ns;
394 char name[GFC_MAX_SYMBOL_LEN + 1];
395 static int master_count = 0;
397 if (ns->proc_name == NULL)
400 /* No need to do anything if this procedure doesn't have alternate entry
405 /* We may already have resolved alternate entry points. */
406 if (ns->proc_name->attr.entry_master)
409 /* If this isn't a procedure something has gone horribly wrong. */
410 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
412 /* Remember the current namespace. */
413 old_ns = gfc_current_ns;
417 /* Add the main entry point to the list of entry points. */
418 el = gfc_get_entry_list ();
419 el->sym = ns->proc_name;
421 el->next = ns->entries;
423 ns->proc_name->attr.entry = 1;
425 /* If it is a module function, it needs to be in the right namespace
426 so that gfc_get_fake_result_decl can gather up the results. The
427 need for this arose in get_proc_name, where these beasts were
428 left in their own namespace, to keep prior references linked to
429 the entry declaration.*/
430 if (ns->proc_name->attr.function
431 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
434 /* Add an entry statement for it. */
441 /* Create a new symbol for the master function. */
442 /* Give the internal function a unique name (within this file).
443 Also include the function name so the user has some hope of figuring
444 out what is going on. */
445 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
446 master_count++, ns->proc_name->name);
447 gfc_get_ha_symbol (name, &proc);
448 gcc_assert (proc != NULL);
450 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
451 if (ns->proc_name->attr.subroutine)
452 gfc_add_subroutine (&proc->attr, proc->name, NULL);
456 gfc_typespec *ts, *fts;
457 gfc_array_spec *as, *fas;
458 gfc_add_function (&proc->attr, proc->name, NULL);
460 fas = ns->entries->sym->as;
461 fas = fas ? fas : ns->entries->sym->result->as;
462 fts = &ns->entries->sym->result->ts;
463 if (fts->type == BT_UNKNOWN)
464 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
465 for (el = ns->entries->next; el; el = el->next)
467 ts = &el->sym->result->ts;
469 as = as ? as : el->sym->result->as;
470 if (ts->type == BT_UNKNOWN)
471 ts = gfc_get_default_type (el->sym->result, NULL);
473 if (! gfc_compare_types (ts, fts)
474 || (el->sym->result->attr.dimension
475 != ns->entries->sym->result->attr.dimension)
476 || (el->sym->result->attr.pointer
477 != ns->entries->sym->result->attr.pointer))
480 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
481 gfc_error ("Procedure %s at %L has entries with mismatched "
482 "array specifications", ns->entries->sym->name,
483 &ns->entries->sym->declared_at);
488 sym = ns->entries->sym->result;
489 /* All result types the same. */
491 if (sym->attr.dimension)
492 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
493 if (sym->attr.pointer)
494 gfc_add_pointer (&proc->attr, NULL);
498 /* Otherwise the result will be passed through a union by
500 proc->attr.mixed_entry_master = 1;
501 for (el = ns->entries; el; el = el->next)
503 sym = el->sym->result;
504 if (sym->attr.dimension)
506 if (el == ns->entries)
507 gfc_error ("FUNCTION result %s can't be an array in "
508 "FUNCTION %s at %L", sym->name,
509 ns->entries->sym->name, &sym->declared_at);
511 gfc_error ("ENTRY result %s can't be an array in "
512 "FUNCTION %s at %L", sym->name,
513 ns->entries->sym->name, &sym->declared_at);
515 else if (sym->attr.pointer)
517 if (el == ns->entries)
518 gfc_error ("FUNCTION result %s can't be a POINTER in "
519 "FUNCTION %s at %L", sym->name,
520 ns->entries->sym->name, &sym->declared_at);
522 gfc_error ("ENTRY result %s can't be a POINTER in "
523 "FUNCTION %s at %L", sym->name,
524 ns->entries->sym->name, &sym->declared_at);
529 if (ts->type == BT_UNKNOWN)
530 ts = gfc_get_default_type (sym, NULL);
534 if (ts->kind == gfc_default_integer_kind)
538 if (ts->kind == gfc_default_real_kind
539 || ts->kind == gfc_default_double_kind)
543 if (ts->kind == gfc_default_complex_kind)
547 if (ts->kind == gfc_default_logical_kind)
551 /* We will issue error elsewhere. */
559 if (el == ns->entries)
560 gfc_error ("FUNCTION result %s can't be of type %s "
561 "in FUNCTION %s at %L", sym->name,
562 gfc_typename (ts), ns->entries->sym->name,
565 gfc_error ("ENTRY result %s can't be of type %s "
566 "in FUNCTION %s at %L", sym->name,
567 gfc_typename (ts), ns->entries->sym->name,
574 proc->attr.access = ACCESS_PRIVATE;
575 proc->attr.entry_master = 1;
577 /* Merge all the entry point arguments. */
578 for (el = ns->entries; el; el = el->next)
579 merge_argument_lists (proc, el->sym->formal);
581 /* Check the master formal arguments for any that are not
582 present in all entry points. */
583 for (el = ns->entries; el; el = el->next)
584 check_argument_lists (proc, el->sym->formal);
586 /* Use the master function for the function body. */
587 ns->proc_name = proc;
589 /* Finalize the new symbols. */
590 gfc_commit_symbols ();
592 /* Restore the original namespace. */
593 gfc_current_ns = old_ns;
597 /* Resolve common blocks. */
599 resolve_common_blocks (gfc_symtree *common_root)
601 gfc_symtree *symtree;
604 if (common_root == NULL)
607 for (symtree = common_root; symtree->left; symtree = symtree->left);
609 for (; symtree; symtree = symtree->right)
611 gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
615 if (sym->attr.flavor == FL_PARAMETER)
617 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
618 sym->name, &symtree->n.common->where,
622 if (sym->attr.intrinsic)
624 gfc_error ("COMMON block '%s' at %L is also an intrinsic "
625 "procedure", sym->name,
626 &symtree->n.common->where);
628 else if (sym->attr.result
629 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
631 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
632 "at %L that is also a function result", sym->name,
633 &symtree->n.common->where);
635 else if (sym->attr.flavor == FL_PROCEDURE
636 && sym->attr.proc != PROC_INTERNAL
637 && sym->attr.proc != PROC_ST_FUNCTION)
639 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
640 "at %L that is also a global procedure", sym->name,
641 &symtree->n.common->where);
647 /* Resolve contained function types. Because contained functions can call one
648 another, they have to be worked out before any of the contained procedures
651 The good news is that if a function doesn't already have a type, the only
652 way it can get one is through an IMPLICIT type or a RESULT variable, because
653 by definition contained functions are contained namespace they're contained
654 in, not in a sibling or parent namespace. */
657 resolve_contained_functions (gfc_namespace *ns)
659 gfc_namespace *child;
662 resolve_formal_arglists (ns);
664 for (child = ns->contained; child; child = child->sibling)
666 /* Resolve alternate entry points first. */
667 resolve_entries (child);
669 /* Then check function return types. */
670 resolve_contained_fntype (child->proc_name, child);
671 for (el = child->entries; el; el = el->next)
672 resolve_contained_fntype (el->sym, child);
677 /* Resolve all of the elements of a structure constructor and make sure that
678 the types are correct. */
681 resolve_structure_cons (gfc_expr *expr)
683 gfc_constructor *cons;
689 cons = expr->value.constructor;
690 /* A constructor may have references if it is the result of substituting a
691 parameter variable. In this case we just pull out the component we
694 comp = expr->ref->u.c.sym->components;
696 comp = expr->ts.derived->components;
698 for (; comp; comp = comp->next, cons = cons->next)
703 if (gfc_resolve_expr (cons->expr) == FAILURE)
709 if (cons->expr->expr_type != EXPR_NULL
710 && comp->as && comp->as->rank != cons->expr->rank
711 && (comp->allocatable || cons->expr->rank))
713 gfc_error ("The rank of the element in the derived type "
714 "constructor at %L does not match that of the "
715 "component (%d/%d)", &cons->expr->where,
716 cons->expr->rank, comp->as ? comp->as->rank : 0);
720 /* If we don't have the right type, try to convert it. */
722 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
725 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
726 gfc_error ("The element in the derived type constructor at %L, "
727 "for pointer component '%s', is %s but should be %s",
728 &cons->expr->where, comp->name,
729 gfc_basic_typename (cons->expr->ts.type),
730 gfc_basic_typename (comp->ts.type));
732 t = gfc_convert_type (cons->expr, &comp->ts, 1);
735 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
738 a = gfc_expr_attr (cons->expr);
740 if (!a.pointer && !a.target)
743 gfc_error ("The element in the derived type constructor at %L, "
744 "for pointer component '%s' should be a POINTER or "
745 "a TARGET", &cons->expr->where, comp->name);
753 /****************** Expression name resolution ******************/
755 /* Returns 0 if a symbol was not declared with a type or
756 attribute declaration statement, nonzero otherwise. */
759 was_declared (gfc_symbol *sym)
765 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
768 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
769 || a.optional || a.pointer || a.save || a.target || a.volatile_
770 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
777 /* Determine if a symbol is generic or not. */
780 generic_sym (gfc_symbol *sym)
784 if (sym->attr.generic ||
785 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
788 if (was_declared (sym) || sym->ns->parent == NULL)
791 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
793 return (s == NULL) ? 0 : generic_sym (s);
797 /* Determine if a symbol is specific or not. */
800 specific_sym (gfc_symbol *sym)
804 if (sym->attr.if_source == IFSRC_IFBODY
805 || sym->attr.proc == PROC_MODULE
806 || sym->attr.proc == PROC_INTERNAL
807 || sym->attr.proc == PROC_ST_FUNCTION
808 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
809 || sym->attr.external)
812 if (was_declared (sym) || sym->ns->parent == NULL)
815 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
817 return (s == NULL) ? 0 : specific_sym (s);
821 /* Figure out if the procedure is specific, generic or unknown. */
824 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
828 procedure_kind (gfc_symbol *sym)
830 if (generic_sym (sym))
831 return PTYPE_GENERIC;
833 if (specific_sym (sym))
834 return PTYPE_SPECIFIC;
836 return PTYPE_UNKNOWN;
839 /* Check references to assumed size arrays. The flag need_full_assumed_size
840 is nonzero when matching actual arguments. */
842 static int need_full_assumed_size = 0;
845 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
851 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
854 for (ref = e->ref; ref; ref = ref->next)
855 if (ref->type == REF_ARRAY)
856 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
857 last = (ref->u.ar.end[dim] == NULL)
858 && (ref->u.ar.type == DIMEN_ELEMENT);
862 gfc_error ("The upper bound in the last dimension must "
863 "appear in the reference to the assumed size "
864 "array '%s' at %L", sym->name, &e->where);
871 /* Look for bad assumed size array references in argument expressions
872 of elemental and array valued intrinsic procedures. Since this is
873 called from procedure resolution functions, it only recurses at
877 resolve_assumed_size_actual (gfc_expr *e)
882 switch (e->expr_type)
885 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
890 if (resolve_assumed_size_actual (e->value.op.op1)
891 || resolve_assumed_size_actual (e->value.op.op2))
902 /* Resolve an actual argument list. Most of the time, this is just
903 resolving the expressions in the list.
904 The exception is that we sometimes have to decide whether arguments
905 that look like procedure arguments are really simple variable
909 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
912 gfc_symtree *parent_st;
915 for (; arg; arg = arg->next)
920 /* Check the label is a valid branching target. */
923 if (arg->label->defined == ST_LABEL_UNKNOWN)
925 gfc_error ("Label %d referenced at %L is never defined",
926 arg->label->value, &arg->label->where);
933 if (e->ts.type != BT_PROCEDURE)
935 if (gfc_resolve_expr (e) != SUCCESS)
940 /* See if the expression node should really be a variable reference. */
942 sym = e->symtree->n.sym;
944 if (sym->attr.flavor == FL_PROCEDURE
945 || sym->attr.intrinsic
946 || sym->attr.external)
950 /* If a procedure is not already determined to be something else
951 check if it is intrinsic. */
952 if (!sym->attr.intrinsic
953 && !(sym->attr.external || sym->attr.use_assoc
954 || sym->attr.if_source == IFSRC_IFBODY)
955 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
956 sym->attr.intrinsic = 1;
958 if (sym->attr.proc == PROC_ST_FUNCTION)
960 gfc_error ("Statement function '%s' at %L is not allowed as an "
961 "actual argument", sym->name, &e->where);
964 actual_ok = gfc_intrinsic_actual_ok (sym->name,
965 sym->attr.subroutine);
966 if (sym->attr.intrinsic && actual_ok == 0)
968 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
969 "actual argument", sym->name, &e->where);
972 if (sym->attr.contained && !sym->attr.use_assoc
973 && sym->ns->proc_name->attr.flavor != FL_MODULE)
975 gfc_error ("Internal procedure '%s' is not allowed as an "
976 "actual argument at %L", sym->name, &e->where);
979 if (sym->attr.elemental && !sym->attr.intrinsic)
981 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
982 "allowed as an actual argument at %L", sym->name,
986 /* Check if a generic interface has a specific procedure
987 with the same name before emitting an error. */
988 if (sym->attr.generic)
991 for (p = sym->generic; p; p = p->next)
992 if (strcmp (sym->name, p->sym->name) == 0)
994 e->symtree = gfc_find_symtree
995 (p->sym->ns->sym_root, sym->name);
1000 if (p == NULL || e->symtree == NULL)
1001 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1002 "allowed as an actual argument at %L", sym->name,
1006 /* If the symbol is the function that names the current (or
1007 parent) scope, then we really have a variable reference. */
1009 if (sym->attr.function && sym->result == sym
1010 && (sym->ns->proc_name == sym
1011 || (sym->ns->parent != NULL
1012 && sym->ns->parent->proc_name == sym)))
1015 /* If all else fails, see if we have a specific intrinsic. */
1016 if (sym->attr.function
1017 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1019 gfc_intrinsic_sym *isym;
1020 isym = gfc_find_function (sym->name);
1021 if (isym == NULL || !isym->specific)
1023 gfc_error ("Unable to find a specific INTRINSIC procedure "
1024 "for the reference '%s' at %L", sym->name,
1032 /* See if the name is a module procedure in a parent unit. */
1034 if (was_declared (sym) || sym->ns->parent == NULL)
1037 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1039 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1043 if (parent_st == NULL)
1046 sym = parent_st->n.sym;
1047 e->symtree = parent_st; /* Point to the right thing. */
1049 if (sym->attr.flavor == FL_PROCEDURE
1050 || sym->attr.intrinsic
1051 || sym->attr.external)
1057 e->expr_type = EXPR_VARIABLE;
1059 if (sym->as != NULL)
1061 e->rank = sym->as->rank;
1062 e->ref = gfc_get_ref ();
1063 e->ref->type = REF_ARRAY;
1064 e->ref->u.ar.type = AR_FULL;
1065 e->ref->u.ar.as = sym->as;
1068 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1069 primary.c (match_actual_arg). If above code determines that it
1070 is a variable instead, it needs to be resolved as it was not
1071 done at the beginning of this function. */
1072 if (gfc_resolve_expr (e) != SUCCESS)
1076 /* Check argument list functions %VAL, %LOC and %REF. There is
1077 nothing to do for %REF. */
1078 if (arg->name && arg->name[0] == '%')
1080 if (strncmp ("%VAL", arg->name, 4) == 0)
1082 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1084 gfc_error ("By-value argument at %L is not of numeric "
1091 gfc_error ("By-value argument at %L cannot be an array or "
1092 "an array section", &e->where);
1096 /* Intrinsics are still PROC_UNKNOWN here. However,
1097 since same file external procedures are not resolvable
1098 in gfortran, it is a good deal easier to leave them to
1100 if (ptype != PROC_UNKNOWN
1101 && ptype != PROC_DUMMY
1102 && ptype != PROC_EXTERNAL
1103 && ptype != PROC_MODULE)
1105 gfc_error ("By-value argument at %L is not allowed "
1106 "in this context", &e->where);
1111 /* Statement functions have already been excluded above. */
1112 else if (strncmp ("%LOC", arg->name, 4) == 0
1113 && e->ts.type == BT_PROCEDURE)
1115 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1117 gfc_error ("Passing internal procedure at %L by location "
1118 "not allowed", &e->where);
1129 /* Do the checks of the actual argument list that are specific to elemental
1130 procedures. If called with c == NULL, we have a function, otherwise if
1131 expr == NULL, we have a subroutine. */
1134 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1136 gfc_actual_arglist *arg0;
1137 gfc_actual_arglist *arg;
1138 gfc_symbol *esym = NULL;
1139 gfc_intrinsic_sym *isym = NULL;
1141 gfc_intrinsic_arg *iformal = NULL;
1142 gfc_formal_arglist *eformal = NULL;
1143 bool formal_optional = false;
1144 bool set_by_optional = false;
1148 /* Is this an elemental procedure? */
1149 if (expr && expr->value.function.actual != NULL)
1151 if (expr->value.function.esym != NULL
1152 && expr->value.function.esym->attr.elemental)
1154 arg0 = expr->value.function.actual;
1155 esym = expr->value.function.esym;
1157 else if (expr->value.function.isym != NULL
1158 && expr->value.function.isym->elemental)
1160 arg0 = expr->value.function.actual;
1161 isym = expr->value.function.isym;
1166 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1168 arg0 = c->ext.actual;
1169 esym = c->symtree->n.sym;
1174 /* The rank of an elemental is the rank of its array argument(s). */
1175 for (arg = arg0; arg; arg = arg->next)
1177 if (arg->expr != NULL && arg->expr->rank > 0)
1179 rank = arg->expr->rank;
1180 if (arg->expr->expr_type == EXPR_VARIABLE
1181 && arg->expr->symtree->n.sym->attr.optional)
1182 set_by_optional = true;
1184 /* Function specific; set the result rank and shape. */
1188 if (!expr->shape && arg->expr->shape)
1190 expr->shape = gfc_get_shape (rank);
1191 for (i = 0; i < rank; i++)
1192 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1199 /* If it is an array, it shall not be supplied as an actual argument
1200 to an elemental procedure unless an array of the same rank is supplied
1201 as an actual argument corresponding to a nonoptional dummy argument of
1202 that elemental procedure(12.4.1.5). */
1203 formal_optional = false;
1205 iformal = isym->formal;
1207 eformal = esym->formal;
1209 for (arg = arg0; arg; arg = arg->next)
1213 if (eformal->sym && eformal->sym->attr.optional)
1214 formal_optional = true;
1215 eformal = eformal->next;
1217 else if (isym && iformal)
1219 if (iformal->optional)
1220 formal_optional = true;
1221 iformal = iformal->next;
1224 formal_optional = true;
1226 if (pedantic && arg->expr != NULL
1227 && arg->expr->expr_type == EXPR_VARIABLE
1228 && arg->expr->symtree->n.sym->attr.optional
1231 && (set_by_optional || arg->expr->rank != rank)
1232 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1234 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1235 "MISSING, it cannot be the actual argument of an "
1236 "ELEMENTAL procedure unless there is a non-optional "
1237 "argument with the same rank (12.4.1.5)",
1238 arg->expr->symtree->n.sym->name, &arg->expr->where);
1243 for (arg = arg0; arg; arg = arg->next)
1245 if (arg->expr == NULL || arg->expr->rank == 0)
1248 /* Being elemental, the last upper bound of an assumed size array
1249 argument must be present. */
1250 if (resolve_assumed_size_actual (arg->expr))
1256 /* Elemental subroutine array actual arguments must conform. */
1259 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1271 /* Go through each actual argument in ACTUAL and see if it can be
1272 implemented as an inlined, non-copying intrinsic. FNSYM is the
1273 function being called, or NULL if not known. */
1276 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1278 gfc_actual_arglist *ap;
1281 for (ap = actual; ap; ap = ap->next)
1283 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1284 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1285 ap->expr->inline_noncopying_intrinsic = 1;
1289 /* This function does the checking of references to global procedures
1290 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1291 77 and 95 standards. It checks for a gsymbol for the name, making
1292 one if it does not already exist. If it already exists, then the
1293 reference being resolved must correspond to the type of gsymbol.
1294 Otherwise, the new symbol is equipped with the attributes of the
1295 reference. The corresponding code that is called in creating
1296 global entities is parse.c. */
1299 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1304 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1306 gsym = gfc_get_gsymbol (sym->name);
1308 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1309 global_used (gsym, where);
1311 if (gsym->type == GSYM_UNKNOWN)
1314 gsym->where = *where;
1321 /************* Function resolution *************/
1323 /* Resolve a function call known to be generic.
1324 Section 14.1.2.4.1. */
1327 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1331 if (sym->attr.generic)
1333 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1336 expr->value.function.name = s->name;
1337 expr->value.function.esym = s;
1339 if (s->ts.type != BT_UNKNOWN)
1341 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1342 expr->ts = s->result->ts;
1345 expr->rank = s->as->rank;
1346 else if (s->result != NULL && s->result->as != NULL)
1347 expr->rank = s->result->as->rank;
1352 /* TODO: Need to search for elemental references in generic
1356 if (sym->attr.intrinsic)
1357 return gfc_intrinsic_func_interface (expr, 0);
1364 resolve_generic_f (gfc_expr *expr)
1369 sym = expr->symtree->n.sym;
1373 m = resolve_generic_f0 (expr, sym);
1376 else if (m == MATCH_ERROR)
1380 if (sym->ns->parent == NULL)
1382 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1386 if (!generic_sym (sym))
1390 /* Last ditch attempt. See if the reference is to an intrinsic
1391 that possesses a matching interface. 14.1.2.4 */
1392 if (sym && !gfc_intrinsic_name (sym->name, 0))
1394 gfc_error ("There is no specific function for the generic '%s' at %L",
1395 expr->symtree->n.sym->name, &expr->where);
1399 m = gfc_intrinsic_func_interface (expr, 0);
1403 gfc_error ("Generic function '%s' at %L is not consistent with a "
1404 "specific intrinsic interface", expr->symtree->n.sym->name,
1411 /* Resolve a function call known to be specific. */
1414 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1418 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1420 if (sym->attr.dummy)
1422 sym->attr.proc = PROC_DUMMY;
1426 sym->attr.proc = PROC_EXTERNAL;
1430 if (sym->attr.proc == PROC_MODULE
1431 || sym->attr.proc == PROC_ST_FUNCTION
1432 || sym->attr.proc == PROC_INTERNAL)
1435 if (sym->attr.intrinsic)
1437 m = gfc_intrinsic_func_interface (expr, 1);
1441 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1442 "with an intrinsic", sym->name, &expr->where);
1450 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1453 expr->value.function.name = sym->name;
1454 expr->value.function.esym = sym;
1455 if (sym->as != NULL)
1456 expr->rank = sym->as->rank;
1463 resolve_specific_f (gfc_expr *expr)
1468 sym = expr->symtree->n.sym;
1472 m = resolve_specific_f0 (sym, expr);
1475 if (m == MATCH_ERROR)
1478 if (sym->ns->parent == NULL)
1481 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1487 gfc_error ("Unable to resolve the specific function '%s' at %L",
1488 expr->symtree->n.sym->name, &expr->where);
1494 /* Resolve a procedure call not known to be generic nor specific. */
1497 resolve_unknown_f (gfc_expr *expr)
1502 sym = expr->symtree->n.sym;
1504 if (sym->attr.dummy)
1506 sym->attr.proc = PROC_DUMMY;
1507 expr->value.function.name = sym->name;
1511 /* See if we have an intrinsic function reference. */
1513 if (gfc_intrinsic_name (sym->name, 0))
1515 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1520 /* The reference is to an external name. */
1522 sym->attr.proc = PROC_EXTERNAL;
1523 expr->value.function.name = sym->name;
1524 expr->value.function.esym = expr->symtree->n.sym;
1526 if (sym->as != NULL)
1527 expr->rank = sym->as->rank;
1529 /* Type of the expression is either the type of the symbol or the
1530 default type of the symbol. */
1533 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1535 if (sym->ts.type != BT_UNKNOWN)
1539 ts = gfc_get_default_type (sym, sym->ns);
1541 if (ts->type == BT_UNKNOWN)
1543 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1544 sym->name, &expr->where);
1555 /* Return true, if the symbol is an external procedure. */
1557 is_external_proc (gfc_symbol *sym)
1559 if (!sym->attr.dummy && !sym->attr.contained
1560 && !(sym->attr.intrinsic
1561 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1562 && sym->attr.proc != PROC_ST_FUNCTION
1563 && !sym->attr.use_assoc
1571 /* Figure out if a function reference is pure or not. Also set the name
1572 of the function for a potential error message. Return nonzero if the
1573 function is PURE, zero if not. */
1576 pure_function (gfc_expr *e, const char **name)
1582 if (e->symtree != NULL
1583 && e->symtree->n.sym != NULL
1584 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1587 if (e->value.function.esym)
1589 pure = gfc_pure (e->value.function.esym);
1590 *name = e->value.function.esym->name;
1592 else if (e->value.function.isym)
1594 pure = e->value.function.isym->pure
1595 || e->value.function.isym->elemental;
1596 *name = e->value.function.isym->name;
1600 /* Implicit functions are not pure. */
1602 *name = e->value.function.name;
1610 is_scalar_expr_ptr (gfc_expr *expr)
1612 try retval = SUCCESS;
1617 /* See if we have a gfc_ref, which means we have a substring, array
1618 reference, or a component. */
1619 if (expr->ref != NULL)
1622 while (ref->next != NULL)
1628 if (ref->u.ss.length != NULL
1629 && ref->u.ss.length->length != NULL
1631 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1633 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1635 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1636 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1637 if (end - start + 1 != 1)
1644 if (ref->u.ar.type == AR_ELEMENT)
1646 else if (ref->u.ar.type == AR_FULL)
1648 /* The user can give a full array if the array is of size 1. */
1649 if (ref->u.ar.as != NULL
1650 && ref->u.ar.as->rank == 1
1651 && ref->u.ar.as->type == AS_EXPLICIT
1652 && ref->u.ar.as->lower[0] != NULL
1653 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1654 && ref->u.ar.as->upper[0] != NULL
1655 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1657 /* If we have a character string, we need to check if
1658 its length is one. */
1659 if (expr->ts.type == BT_CHARACTER)
1661 if (expr->ts.cl == NULL
1662 || expr->ts.cl->length == NULL
1663 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1669 /* We have constant lower and upper bounds. If the
1670 difference between is 1, it can be considered a
1672 start = (int) mpz_get_si
1673 (ref->u.ar.as->lower[0]->value.integer);
1674 end = (int) mpz_get_si
1675 (ref->u.ar.as->upper[0]->value.integer);
1676 if (end - start + 1 != 1)
1691 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1693 /* Character string. Make sure it's of length 1. */
1694 if (expr->ts.cl == NULL
1695 || expr->ts.cl->length == NULL
1696 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1699 else if (expr->rank != 0)
1706 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1707 and, in the case of c_associated, set the binding label based on
1711 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1712 gfc_symbol **new_sym)
1714 char name[GFC_MAX_SYMBOL_LEN + 1];
1715 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1716 int optional_arg = 0;
1717 try retval = SUCCESS;
1718 gfc_symbol *args_sym;
1720 if (args->expr->expr_type == EXPR_CONSTANT
1721 || args->expr->expr_type == EXPR_OP
1722 || args->expr->expr_type == EXPR_NULL)
1724 gfc_error ("Argument to '%s' at %L is not a variable",
1725 sym->name, &(args->expr->where));
1729 args_sym = args->expr->symtree->n.sym;
1731 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1733 /* If the user gave two args then they are providing something for
1734 the optional arg (the second cptr). Therefore, set the name and
1735 binding label to the c_associated for two cptrs. Otherwise,
1736 set c_associated to expect one cptr. */
1740 sprintf (name, "%s_2", sym->name);
1741 sprintf (binding_label, "%s_2", sym->binding_label);
1747 sprintf (name, "%s_1", sym->name);
1748 sprintf (binding_label, "%s_1", sym->binding_label);
1752 /* Get a new symbol for the version of c_associated that
1754 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1756 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1757 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1759 sprintf (name, "%s", sym->name);
1760 sprintf (binding_label, "%s", sym->binding_label);
1762 /* Error check the call. */
1763 if (args->next != NULL)
1765 gfc_error_now ("More actual than formal arguments in '%s' "
1766 "call at %L", name, &(args->expr->where));
1769 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1771 /* Make sure we have either the target or pointer attribute. */
1772 if (!(args->expr->symtree->n.sym->attr.target)
1773 && !(args->expr->symtree->n.sym->attr.pointer))
1775 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1776 "a TARGET or an associated pointer",
1777 args->expr->symtree->n.sym->name,
1778 sym->name, &(args->expr->where));
1782 /* See if we have interoperable type and type param. */
1783 if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
1784 args->expr->symtree->n.sym->name,
1785 &(args->expr->where)) == SUCCESS
1786 || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
1788 if (args_sym->attr.target == 1)
1790 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1791 has the target attribute and is interoperable. */
1792 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1793 allocatable variable that has the TARGET attribute and
1794 is not an array of zero size. */
1795 if (args_sym->attr.allocatable == 1)
1797 if (args_sym->attr.dimension != 0
1798 && (args_sym->as && args_sym->as->rank == 0))
1800 gfc_error_now ("Allocatable variable '%s' used as a "
1801 "parameter to '%s' at %L must not be "
1802 "an array of zero size",
1803 args_sym->name, sym->name,
1804 &(args->expr->where));
1810 /* A non-allocatable target variable with C
1811 interoperable type and type parameters must be
1813 if (args_sym && args_sym->attr.dimension)
1815 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1817 gfc_error ("Assumed-shape array '%s' at %L "
1818 "cannot be an argument to the "
1819 "procedure '%s' because "
1820 "it is not C interoperable",
1822 &(args->expr->where), sym->name);
1825 else if (args_sym->as->type == AS_DEFERRED)
1827 gfc_error ("Deferred-shape array '%s' at %L "
1828 "cannot be an argument to the "
1829 "procedure '%s' because "
1830 "it is not C interoperable",
1832 &(args->expr->where), sym->name);
1837 /* Make sure it's not a character string. Arrays of
1838 any type should be ok if the variable is of a C
1839 interoperable type. */
1840 if (args_sym->ts.type == BT_CHARACTER)
1841 if (args_sym->ts.cl != NULL
1842 && (args_sym->ts.cl->length == NULL
1843 || args_sym->ts.cl->length->expr_type
1846 (args_sym->ts.cl->length->value.integer, 1)
1848 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1850 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1851 "at %L must have a length of 1",
1852 args_sym->name, sym->name,
1853 &(args->expr->where));
1858 else if (args_sym->attr.pointer == 1
1859 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1861 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1863 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1864 "associated scalar POINTER", args_sym->name,
1865 sym->name, &(args->expr->where));
1871 /* The parameter is not required to be C interoperable. If it
1872 is not C interoperable, it must be a nonpolymorphic scalar
1873 with no length type parameters. It still must have either
1874 the pointer or target attribute, and it can be
1875 allocatable (but must be allocated when c_loc is called). */
1876 if (args_sym->attr.dimension != 0
1877 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1879 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1880 "scalar", args_sym->name, sym->name,
1881 &(args->expr->where));
1884 else if (args_sym->ts.type == BT_CHARACTER
1885 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1887 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1888 "%L must have a length of 1",
1889 args_sym->name, sym->name,
1890 &(args->expr->where));
1895 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1897 if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1899 /* TODO: Update this error message to allow for procedure
1900 pointers once they are implemented. */
1901 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1903 args->expr->symtree->n.sym->name, sym->name,
1904 &(args->expr->where));
1907 else if (args->expr->symtree->n.sym->attr.is_bind_c != 1)
1909 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
1911 args->expr->symtree->n.sym->name, sym->name,
1912 &(args->expr->where));
1917 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1922 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1923 "iso_c_binding function: '%s'!\n", sym->name);
1930 /* Resolve a function call, which means resolving the arguments, then figuring
1931 out which entity the name refers to. */
1932 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1933 to INTENT(OUT) or INTENT(INOUT). */
1936 resolve_function (gfc_expr *expr)
1938 gfc_actual_arglist *arg;
1943 procedure_type p = PROC_INTRINSIC;
1947 sym = expr->symtree->n.sym;
1949 if (sym && sym->attr.flavor == FL_VARIABLE)
1951 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1955 /* If the procedure is external, check for usage. */
1956 if (sym && is_external_proc (sym))
1957 resolve_global_procedure (sym, &expr->where, 0);
1959 /* Switch off assumed size checking and do this again for certain kinds
1960 of procedure, once the procedure itself is resolved. */
1961 need_full_assumed_size++;
1963 if (expr->symtree && expr->symtree->n.sym)
1964 p = expr->symtree->n.sym->attr.proc;
1966 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1969 /* Need to setup the call to the correct c_associated, depending on
1970 the number of cptrs to user gives to compare. */
1971 if (sym && sym->attr.is_iso_c == 1)
1973 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
1977 /* Get the symtree for the new symbol (resolved func).
1978 the old one will be freed later, when it's no longer used. */
1979 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
1982 /* Resume assumed_size checking. */
1983 need_full_assumed_size--;
1985 if (sym && sym->ts.type == BT_CHARACTER
1987 && sym->ts.cl->length == NULL
1989 && expr->value.function.esym == NULL
1990 && !sym->attr.contained)
1992 /* Internal procedures are taken care of in resolve_contained_fntype. */
1993 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1994 "be used at %L since it is not a dummy argument",
1995 sym->name, &expr->where);
1999 /* See if function is already resolved. */
2001 if (expr->value.function.name != NULL)
2003 if (expr->ts.type == BT_UNKNOWN)
2009 /* Apply the rules of section 14.1.2. */
2011 switch (procedure_kind (sym))
2014 t = resolve_generic_f (expr);
2017 case PTYPE_SPECIFIC:
2018 t = resolve_specific_f (expr);
2022 t = resolve_unknown_f (expr);
2026 gfc_internal_error ("resolve_function(): bad function type");
2030 /* If the expression is still a function (it might have simplified),
2031 then we check to see if we are calling an elemental function. */
2033 if (expr->expr_type != EXPR_FUNCTION)
2036 temp = need_full_assumed_size;
2037 need_full_assumed_size = 0;
2039 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2042 if (omp_workshare_flag
2043 && expr->value.function.esym
2044 && ! gfc_elemental (expr->value.function.esym))
2046 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2047 "in WORKSHARE construct", expr->value.function.esym->name,
2052 #define GENERIC_ID expr->value.function.isym->id
2053 else if (expr->value.function.actual != NULL
2054 && expr->value.function.isym != NULL
2055 && GENERIC_ID != GFC_ISYM_LBOUND
2056 && GENERIC_ID != GFC_ISYM_LEN
2057 && GENERIC_ID != GFC_ISYM_LOC
2058 && GENERIC_ID != GFC_ISYM_PRESENT)
2060 /* Array intrinsics must also have the last upper bound of an
2061 assumed size array argument. UBOUND and SIZE have to be
2062 excluded from the check if the second argument is anything
2065 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2066 || GENERIC_ID == GFC_ISYM_SIZE;
2068 for (arg = expr->value.function.actual; arg; arg = arg->next)
2070 if (inquiry && arg->next != NULL && arg->next->expr)
2072 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2075 if ((int)mpz_get_si (arg->next->expr->value.integer)
2080 if (arg->expr != NULL
2081 && arg->expr->rank > 0
2082 && resolve_assumed_size_actual (arg->expr))
2088 need_full_assumed_size = temp;
2091 if (!pure_function (expr, &name) && name)
2095 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2096 "FORALL %s", name, &expr->where,
2097 forall_flag == 2 ? "mask" : "block");
2100 else if (gfc_pure (NULL))
2102 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2103 "procedure within a PURE procedure", name, &expr->where);
2108 /* Functions without the RECURSIVE attribution are not allowed to
2109 * call themselves. */
2110 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2112 gfc_symbol *esym, *proc;
2113 esym = expr->value.function.esym;
2114 proc = gfc_current_ns->proc_name;
2117 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2118 "RECURSIVE", name, &expr->where);
2122 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2123 && esym->ns->entries->sym == proc->ns->entries->sym)
2125 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2126 "'%s' is not declared as RECURSIVE",
2127 esym->name, &expr->where, esym->ns->entries->sym->name);
2132 /* Character lengths of use associated functions may contains references to
2133 symbols not referenced from the current program unit otherwise. Make sure
2134 those symbols are marked as referenced. */
2136 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2137 && expr->value.function.esym->attr.use_assoc)
2139 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2143 find_noncopying_intrinsics (expr->value.function.esym,
2144 expr->value.function.actual);
2146 /* Make sure that the expression has a typespec that works. */
2147 if (expr->ts.type == BT_UNKNOWN)
2149 if (expr->symtree->n.sym->result
2150 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2151 expr->ts = expr->symtree->n.sym->result->ts;
2158 /************* Subroutine resolution *************/
2161 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2167 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2168 sym->name, &c->loc);
2169 else if (gfc_pure (NULL))
2170 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2176 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2180 if (sym->attr.generic)
2182 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2185 c->resolved_sym = s;
2186 pure_subroutine (c, s);
2190 /* TODO: Need to search for elemental references in generic interface. */
2193 if (sym->attr.intrinsic)
2194 return gfc_intrinsic_sub_interface (c, 0);
2201 resolve_generic_s (gfc_code *c)
2206 sym = c->symtree->n.sym;
2210 m = resolve_generic_s0 (c, sym);
2213 else if (m == MATCH_ERROR)
2217 if (sym->ns->parent == NULL)
2219 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2223 if (!generic_sym (sym))
2227 /* Last ditch attempt. See if the reference is to an intrinsic
2228 that possesses a matching interface. 14.1.2.4 */
2229 sym = c->symtree->n.sym;
2231 if (!gfc_intrinsic_name (sym->name, 1))
2233 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2234 sym->name, &c->loc);
2238 m = gfc_intrinsic_sub_interface (c, 0);
2242 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2243 "intrinsic subroutine interface", sym->name, &c->loc);
2249 /* Set the name and binding label of the subroutine symbol in the call
2250 expression represented by 'c' to include the type and kind of the
2251 second parameter. This function is for resolving the appropriate
2252 version of c_f_pointer() and c_f_procpointer(). For example, a
2253 call to c_f_pointer() for a default integer pointer could have a
2254 name of c_f_pointer_i4. If no second arg exists, which is an error
2255 for these two functions, it defaults to the generic symbol's name
2256 and binding label. */
2259 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2260 char *name, char *binding_label)
2262 gfc_expr *arg = NULL;
2266 /* The second arg of c_f_pointer and c_f_procpointer determines
2267 the type and kind for the procedure name. */
2268 arg = c->ext.actual->next->expr;
2272 /* Set up the name to have the given symbol's name,
2273 plus the type and kind. */
2274 /* a derived type is marked with the type letter 'u' */
2275 if (arg->ts.type == BT_DERIVED)
2278 kind = 0; /* set the kind as 0 for now */
2282 type = gfc_type_letter (arg->ts.type);
2283 kind = arg->ts.kind;
2286 if (arg->ts.type == BT_CHARACTER)
2287 /* Kind info for character strings not needed. */
2290 sprintf (name, "%s_%c%d", sym->name, type, kind);
2291 /* Set up the binding label as the given symbol's label plus
2292 the type and kind. */
2293 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2297 /* If the second arg is missing, set the name and label as
2298 was, cause it should at least be found, and the missing
2299 arg error will be caught by compare_parameters(). */
2300 sprintf (name, "%s", sym->name);
2301 sprintf (binding_label, "%s", sym->binding_label);
2308 /* Resolve a generic version of the iso_c_binding procedure given
2309 (sym) to the specific one based on the type and kind of the
2310 argument(s). Currently, this function resolves c_f_pointer() and
2311 c_f_procpointer based on the type and kind of the second argument
2312 (FPTR). Other iso_c_binding procedures aren't specially handled.
2313 Upon successfully exiting, c->resolved_sym will hold the resolved
2314 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2318 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2320 gfc_symbol *new_sym;
2321 /* this is fine, since we know the names won't use the max */
2322 char name[GFC_MAX_SYMBOL_LEN + 1];
2323 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2324 /* default to success; will override if find error */
2325 match m = MATCH_YES;
2327 /* Make sure the actual arguments are in the necessary order (based on the
2328 formal args) before resolving. */
2329 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2331 /* Give the optional SHAPE formal arg a type now that we've done our
2332 initial checking against the actual. */
2333 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2334 sym->formal->next->next->sym->ts.type = BT_INTEGER;
2336 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2337 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2339 set_name_and_label (c, sym, name, binding_label);
2341 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2343 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2345 /* Make sure we got a third arg if the second arg has non-zero
2346 rank. We must also check that the type and rank are
2347 correct since we short-circuit this check in
2348 gfc_procedure_use() (called above to sort actual args). */
2349 if (c->ext.actual->next->expr->rank != 0)
2351 if(c->ext.actual->next->next == NULL
2352 || c->ext.actual->next->next->expr == NULL)
2355 gfc_error ("Missing SHAPE parameter for call to %s "
2356 "at %L", sym->name, &(c->loc));
2358 else if (c->ext.actual->next->next->expr->ts.type
2360 || c->ext.actual->next->next->expr->rank != 1)
2363 gfc_error ("SHAPE parameter for call to %s at %L must "
2364 "be a rank 1 INTEGER array", sym->name,
2371 if (m != MATCH_ERROR)
2373 /* the 1 means to add the optional arg to formal list */
2374 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2376 /* Set the kind for the SHAPE array to that of the actual
2378 if (c->ext.actual != NULL && c->ext.actual->next != NULL
2379 && c->ext.actual->next->expr->rank != 0)
2380 new_sym->formal->next->next->sym->ts.kind =
2381 c->ext.actual->next->next->expr->ts.kind;
2383 /* for error reporting, say it's declared where the original was */
2384 new_sym->declared_at = sym->declared_at;
2387 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2389 /* TODO: Figure out if this is even reacable; this part of the
2390 conditional may not be necessary. */
2392 if (c->ext.actual->next == NULL)
2394 /* The user did not give two args, so resolve to the version
2395 of c_associated expecting one arg. */
2397 /* get rid of the second arg */
2398 /* TODO!! Should free up the memory here! */
2399 sym->formal->next = NULL;
2407 sprintf (name, "%s_%d", sym->name, num_args);
2408 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2409 sym->name = gfc_get_string (name);
2410 strcpy (sym->binding_label, binding_label);
2414 /* no differences for c_loc or c_funloc */
2418 /* set the resolved symbol */
2419 if (m != MATCH_ERROR)
2420 c->resolved_sym = new_sym;
2422 c->resolved_sym = sym;
2428 /* Resolve a subroutine call known to be specific. */
2431 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2435 if(sym->attr.is_iso_c)
2437 m = gfc_iso_c_sub_interface (c,sym);
2441 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2443 if (sym->attr.dummy)
2445 sym->attr.proc = PROC_DUMMY;
2449 sym->attr.proc = PROC_EXTERNAL;
2453 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2456 if (sym->attr.intrinsic)
2458 m = gfc_intrinsic_sub_interface (c, 1);
2462 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2463 "with an intrinsic", sym->name, &c->loc);
2471 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2473 c->resolved_sym = sym;
2474 pure_subroutine (c, sym);
2481 resolve_specific_s (gfc_code *c)
2486 sym = c->symtree->n.sym;
2490 m = resolve_specific_s0 (c, sym);
2493 if (m == MATCH_ERROR)
2496 if (sym->ns->parent == NULL)
2499 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2505 sym = c->symtree->n.sym;
2506 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2507 sym->name, &c->loc);
2513 /* Resolve a subroutine call not known to be generic nor specific. */
2516 resolve_unknown_s (gfc_code *c)
2520 sym = c->symtree->n.sym;
2522 if (sym->attr.dummy)
2524 sym->attr.proc = PROC_DUMMY;
2528 /* See if we have an intrinsic function reference. */
2530 if (gfc_intrinsic_name (sym->name, 1))
2532 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2537 /* The reference is to an external name. */
2540 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2542 c->resolved_sym = sym;
2544 pure_subroutine (c, sym);
2550 /* Resolve a subroutine call. Although it was tempting to use the same code
2551 for functions, subroutines and functions are stored differently and this
2552 makes things awkward. */
2555 resolve_call (gfc_code *c)
2558 procedure_type ptype = PROC_INTRINSIC;
2560 if (c->symtree && c->symtree->n.sym
2561 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2563 gfc_error ("'%s' at %L has a type, which is not consistent with "
2564 "the CALL at %L", c->symtree->n.sym->name,
2565 &c->symtree->n.sym->declared_at, &c->loc);
2569 /* If external, check for usage. */
2570 if (c->symtree && is_external_proc (c->symtree->n.sym))
2571 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2573 /* Subroutines without the RECURSIVE attribution are not allowed to
2574 * call themselves. */
2575 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2577 gfc_symbol *csym, *proc;
2578 csym = c->symtree->n.sym;
2579 proc = gfc_current_ns->proc_name;
2582 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2583 "RECURSIVE", csym->name, &c->loc);
2587 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2588 && csym->ns->entries->sym == proc->ns->entries->sym)
2590 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2591 "'%s' is not declared as RECURSIVE",
2592 csym->name, &c->loc, csym->ns->entries->sym->name);
2597 /* Switch off assumed size checking and do this again for certain kinds
2598 of procedure, once the procedure itself is resolved. */
2599 need_full_assumed_size++;
2601 if (c->symtree && c->symtree->n.sym)
2602 ptype = c->symtree->n.sym->attr.proc;
2604 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2607 /* Resume assumed_size checking. */
2608 need_full_assumed_size--;
2611 if (c->resolved_sym == NULL)
2612 switch (procedure_kind (c->symtree->n.sym))
2615 t = resolve_generic_s (c);
2618 case PTYPE_SPECIFIC:
2619 t = resolve_specific_s (c);
2623 t = resolve_unknown_s (c);
2627 gfc_internal_error ("resolve_subroutine(): bad function type");
2630 /* Some checks of elemental subroutine actual arguments. */
2631 if (resolve_elemental_actual (NULL, c) == FAILURE)
2635 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2640 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2641 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2642 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2643 if their shapes do not match. If either op1->shape or op2->shape is
2644 NULL, return SUCCESS. */
2647 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2654 if (op1->shape != NULL && op2->shape != NULL)
2656 for (i = 0; i < op1->rank; i++)
2658 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2660 gfc_error ("Shapes for operands at %L and %L are not conformable",
2661 &op1->where, &op2->where);
2672 /* Resolve an operator expression node. This can involve replacing the
2673 operation with a user defined function call. */
2676 resolve_operator (gfc_expr *e)
2678 gfc_expr *op1, *op2;
2680 bool dual_locus_error;
2683 /* Resolve all subnodes-- give them types. */
2685 switch (e->value.op.operator)
2688 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2691 /* Fall through... */
2694 case INTRINSIC_UPLUS:
2695 case INTRINSIC_UMINUS:
2696 case INTRINSIC_PARENTHESES:
2697 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2702 /* Typecheck the new node. */
2704 op1 = e->value.op.op1;
2705 op2 = e->value.op.op2;
2706 dual_locus_error = false;
2708 if ((op1 && op1->expr_type == EXPR_NULL)
2709 || (op2 && op2->expr_type == EXPR_NULL))
2711 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2715 switch (e->value.op.operator)
2717 case INTRINSIC_UPLUS:
2718 case INTRINSIC_UMINUS:
2719 if (op1->ts.type == BT_INTEGER
2720 || op1->ts.type == BT_REAL
2721 || op1->ts.type == BT_COMPLEX)
2727 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2728 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2731 case INTRINSIC_PLUS:
2732 case INTRINSIC_MINUS:
2733 case INTRINSIC_TIMES:
2734 case INTRINSIC_DIVIDE:
2735 case INTRINSIC_POWER:
2736 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2738 gfc_type_convert_binary (e);
2743 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2744 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2745 gfc_typename (&op2->ts));
2748 case INTRINSIC_CONCAT:
2749 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2751 e->ts.type = BT_CHARACTER;
2752 e->ts.kind = op1->ts.kind;
2757 _("Operands of string concatenation operator at %%L are %s/%s"),
2758 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2764 case INTRINSIC_NEQV:
2765 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2767 e->ts.type = BT_LOGICAL;
2768 e->ts.kind = gfc_kind_max (op1, op2);
2769 if (op1->ts.kind < e->ts.kind)
2770 gfc_convert_type (op1, &e->ts, 2);
2771 else if (op2->ts.kind < e->ts.kind)
2772 gfc_convert_type (op2, &e->ts, 2);
2776 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2777 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2778 gfc_typename (&op2->ts));
2783 if (op1->ts.type == BT_LOGICAL)
2785 e->ts.type = BT_LOGICAL;
2786 e->ts.kind = op1->ts.kind;
2790 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2791 gfc_typename (&op1->ts));
2795 case INTRINSIC_GT_OS:
2797 case INTRINSIC_GE_OS:
2799 case INTRINSIC_LT_OS:
2801 case INTRINSIC_LE_OS:
2802 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2804 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2808 /* Fall through... */
2811 case INTRINSIC_EQ_OS:
2813 case INTRINSIC_NE_OS:
2814 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2816 e->ts.type = BT_LOGICAL;
2817 e->ts.kind = gfc_default_logical_kind;
2821 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2823 gfc_type_convert_binary (e);
2825 e->ts.type = BT_LOGICAL;
2826 e->ts.kind = gfc_default_logical_kind;
2830 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2832 _("Logicals at %%L must be compared with %s instead of %s"),
2833 e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
2834 gfc_op2string (e->value.op.operator));
2837 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2838 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2839 gfc_typename (&op2->ts));
2843 case INTRINSIC_USER:
2844 if (e->value.op.uop->operator == NULL)
2845 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2846 else if (op2 == NULL)
2847 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2848 e->value.op.uop->name, gfc_typename (&op1->ts));
2850 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2851 e->value.op.uop->name, gfc_typename (&op1->ts),
2852 gfc_typename (&op2->ts));
2856 case INTRINSIC_PARENTHESES:
2860 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2863 /* Deal with arrayness of an operand through an operator. */
2867 switch (e->value.op.operator)
2869 case INTRINSIC_PLUS:
2870 case INTRINSIC_MINUS:
2871 case INTRINSIC_TIMES:
2872 case INTRINSIC_DIVIDE:
2873 case INTRINSIC_POWER:
2874 case INTRINSIC_CONCAT:
2878 case INTRINSIC_NEQV:
2880 case INTRINSIC_EQ_OS:
2882 case INTRINSIC_NE_OS:
2884 case INTRINSIC_GT_OS:
2886 case INTRINSIC_GE_OS:
2888 case INTRINSIC_LT_OS:
2890 case INTRINSIC_LE_OS:
2892 if (op1->rank == 0 && op2->rank == 0)
2895 if (op1->rank == 0 && op2->rank != 0)
2897 e->rank = op2->rank;
2899 if (e->shape == NULL)
2900 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2903 if (op1->rank != 0 && op2->rank == 0)
2905 e->rank = op1->rank;
2907 if (e->shape == NULL)
2908 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2911 if (op1->rank != 0 && op2->rank != 0)
2913 if (op1->rank == op2->rank)
2915 e->rank = op1->rank;
2916 if (e->shape == NULL)
2918 t = compare_shapes(op1, op2);
2922 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2927 /* Allow higher level expressions to work. */
2930 /* Try user-defined operators, and otherwise throw an error. */
2931 dual_locus_error = true;
2933 _("Inconsistent ranks for operator at %%L and %%L"));
2941 case INTRINSIC_UPLUS:
2942 case INTRINSIC_UMINUS:
2943 case INTRINSIC_PARENTHESES:
2944 e->rank = op1->rank;
2946 if (e->shape == NULL)
2947 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2949 /* Simply copy arrayness attribute */
2956 /* Attempt to simplify the expression. */
2959 t = gfc_simplify_expr (e, 0);
2960 /* Some calls do not succeed in simplification and return FAILURE
2961 even though there is no error; eg. variable references to
2962 PARAMETER arrays. */
2963 if (!gfc_is_constant_expr (e))
2970 if (gfc_extend_expr (e) == SUCCESS)
2973 if (dual_locus_error)
2974 gfc_error (msg, &op1->where, &op2->where);
2976 gfc_error (msg, &e->where);
2982 /************** Array resolution subroutines **************/
2985 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2988 /* Compare two integer expressions. */
2991 compare_bound (gfc_expr *a, gfc_expr *b)
2995 if (a == NULL || a->expr_type != EXPR_CONSTANT
2996 || b == NULL || b->expr_type != EXPR_CONSTANT)
2999 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3000 gfc_internal_error ("compare_bound(): Bad expression");
3002 i = mpz_cmp (a->value.integer, b->value.integer);
3012 /* Compare an integer expression with an integer. */
3015 compare_bound_int (gfc_expr *a, int b)
3019 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3022 if (a->ts.type != BT_INTEGER)
3023 gfc_internal_error ("compare_bound_int(): Bad expression");
3025 i = mpz_cmp_si (a->value.integer, b);
3035 /* Compare an integer expression with a mpz_t. */
3038 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3042 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3045 if (a->ts.type != BT_INTEGER)
3046 gfc_internal_error ("compare_bound_int(): Bad expression");
3048 i = mpz_cmp (a->value.integer, b);
3058 /* Compute the last value of a sequence given by a triplet.
3059 Return 0 if it wasn't able to compute the last value, or if the
3060 sequence if empty, and 1 otherwise. */
3063 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3064 gfc_expr *stride, mpz_t last)
3068 if (start == NULL || start->expr_type != EXPR_CONSTANT
3069 || end == NULL || end->expr_type != EXPR_CONSTANT
3070 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3073 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3074 || (stride != NULL && stride->ts.type != BT_INTEGER))
3077 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3079 if (compare_bound (start, end) == CMP_GT)
3081 mpz_set (last, end->value.integer);
3085 if (compare_bound_int (stride, 0) == CMP_GT)
3087 /* Stride is positive */
3088 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3093 /* Stride is negative */
3094 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3099 mpz_sub (rem, end->value.integer, start->value.integer);
3100 mpz_tdiv_r (rem, rem, stride->value.integer);
3101 mpz_sub (last, end->value.integer, rem);
3108 /* Compare a single dimension of an array reference to the array
3112 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3116 /* Given start, end and stride values, calculate the minimum and
3117 maximum referenced indexes. */
3125 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3127 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3134 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3135 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3137 comparison comp_start_end = compare_bound (AR_START, AR_END);
3139 /* Check for zero stride, which is not allowed. */
3140 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3142 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3146 /* if start == len || (stride > 0 && start < len)
3147 || (stride < 0 && start > len),
3148 then the array section contains at least one element. In this
3149 case, there is an out-of-bounds access if
3150 (start < lower || start > upper). */
3151 if (compare_bound (AR_START, AR_END) == CMP_EQ
3152 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3153 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3154 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3155 && comp_start_end == CMP_GT))
3157 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3158 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3162 /* If we can compute the highest index of the array section,
3163 then it also has to be between lower and upper. */
3164 mpz_init (last_value);
3165 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3168 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3169 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3171 mpz_clear (last_value);
3175 mpz_clear (last_value);
3183 gfc_internal_error ("check_dimension(): Bad array reference");
3189 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3194 /* Compare an array reference with an array specification. */
3197 compare_spec_to_ref (gfc_array_ref *ar)
3204 /* TODO: Full array sections are only allowed as actual parameters. */
3205 if (as->type == AS_ASSUMED_SIZE
3206 && (/*ar->type == AR_FULL
3207 ||*/ (ar->type == AR_SECTION
3208 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3210 gfc_error ("Rightmost upper bound of assumed size array section "
3211 "not specified at %L", &ar->where);
3215 if (ar->type == AR_FULL)
3218 if (as->rank != ar->dimen)
3220 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3221 &ar->where, ar->dimen, as->rank);
3225 for (i = 0; i < as->rank; i++)
3226 if (check_dimension (i, ar, as) == FAILURE)
3233 /* Resolve one part of an array index. */
3236 gfc_resolve_index (gfc_expr *index, int check_scalar)
3243 if (gfc_resolve_expr (index) == FAILURE)
3246 if (check_scalar && index->rank != 0)
3248 gfc_error ("Array index at %L must be scalar", &index->where);
3252 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3254 gfc_error ("Array index at %L must be of INTEGER type",
3259 if (index->ts.type == BT_REAL)
3260 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3261 &index->where) == FAILURE)
3264 if (index->ts.kind != gfc_index_integer_kind
3265 || index->ts.type != BT_INTEGER)
3268 ts.type = BT_INTEGER;
3269 ts.kind = gfc_index_integer_kind;
3271 gfc_convert_type_warn (index, &ts, 2, 0);
3277 /* Resolve a dim argument to an intrinsic function. */
3280 gfc_resolve_dim_arg (gfc_expr *dim)
3285 if (gfc_resolve_expr (dim) == FAILURE)
3290 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3294 if (dim->ts.type != BT_INTEGER)
3296 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3299 if (dim->ts.kind != gfc_index_integer_kind)
3303 ts.type = BT_INTEGER;
3304 ts.kind = gfc_index_integer_kind;
3306 gfc_convert_type_warn (dim, &ts, 2, 0);
3312 /* Given an expression that contains array references, update those array
3313 references to point to the right array specifications. While this is
3314 filled in during matching, this information is difficult to save and load
3315 in a module, so we take care of it here.
3317 The idea here is that the original array reference comes from the
3318 base symbol. We traverse the list of reference structures, setting
3319 the stored reference to references. Component references can
3320 provide an additional array specification. */
3323 find_array_spec (gfc_expr *e)
3327 gfc_symbol *derived;
3330 as = e->symtree->n.sym->as;
3333 for (ref = e->ref; ref; ref = ref->next)
3338 gfc_internal_error ("find_array_spec(): Missing spec");
3345 if (derived == NULL)
3346 derived = e->symtree->n.sym->ts.derived;
3348 c = derived->components;
3350 for (; c; c = c->next)
3351 if (c == ref->u.c.component)
3353 /* Track the sequence of component references. */
3354 if (c->ts.type == BT_DERIVED)
3355 derived = c->ts.derived;
3360 gfc_internal_error ("find_array_spec(): Component not found");
3365 gfc_internal_error ("find_array_spec(): unused as(1)");
3376 gfc_internal_error ("find_array_spec(): unused as(2)");
3380 /* Resolve an array reference. */
3383 resolve_array_ref (gfc_array_ref *ar)
3385 int i, check_scalar;
3388 for (i = 0; i < ar->dimen; i++)
3390 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3392 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3394 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3396 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3401 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3405 ar->dimen_type[i] = DIMEN_ELEMENT;
3409 ar->dimen_type[i] = DIMEN_VECTOR;
3410 if (e->expr_type == EXPR_VARIABLE
3411 && e->symtree->n.sym->ts.type == BT_DERIVED)
3412 ar->start[i] = gfc_get_parentheses (e);
3416 gfc_error ("Array index at %L is an array of rank %d",
3417 &ar->c_where[i], e->rank);
3422 /* If the reference type is unknown, figure out what kind it is. */
3424 if (ar->type == AR_UNKNOWN)
3426 ar->type = AR_ELEMENT;
3427 for (i = 0; i < ar->dimen; i++)
3428 if (ar->dimen_type[i] == DIMEN_RANGE
3429 || ar->dimen_type[i] == DIMEN_VECTOR)
3431 ar->type = AR_SECTION;
3436 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3444 resolve_substring (gfc_ref *ref)
3446 if (ref->u.ss.start != NULL)
3448 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3451 if (ref->u.ss.start->ts.type != BT_INTEGER)
3453 gfc_error ("Substring start index at %L must be of type INTEGER",
3454 &ref->u.ss.start->where);
3458 if (ref->u.ss.start->rank != 0)
3460 gfc_error ("Substring start index at %L must be scalar",
3461 &ref->u.ss.start->where);
3465 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3466 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3467 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3469 gfc_error ("Substring start index at %L is less than one",
3470 &ref->u.ss.start->where);
3475 if (ref->u.ss.end != NULL)
3477 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3480 if (ref->u.ss.end->ts.type != BT_INTEGER)
3482 gfc_error ("Substring end index at %L must be of type INTEGER",
3483 &ref->u.ss.end->where);
3487 if (ref->u.ss.end->rank != 0)
3489 gfc_error ("Substring end index at %L must be scalar",
3490 &ref->u.ss.end->where);
3494 if (ref->u.ss.length != NULL
3495 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3496 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3497 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3499 gfc_error ("Substring end index at %L exceeds the string length",
3500 &ref->u.ss.start->where);
3509 /* Resolve subtype references. */
3512 resolve_ref (gfc_expr *expr)
3514 int current_part_dimension, n_components, seen_part_dimension;
3517 for (ref = expr->ref; ref; ref = ref->next)
3518 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3520 find_array_spec (expr);
3524 for (ref = expr->ref; ref; ref = ref->next)
3528 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3536 resolve_substring (ref);
3540 /* Check constraints on part references. */
3542 current_part_dimension = 0;
3543 seen_part_dimension = 0;
3546 for (ref = expr->ref; ref; ref = ref->next)
3551 switch (ref->u.ar.type)
3555 current_part_dimension = 1;
3559 current_part_dimension = 0;
3563 gfc_internal_error ("resolve_ref(): Bad array reference");
3569 if (current_part_dimension || seen_part_dimension)
3571 if (ref->u.c.component->pointer)
3573 gfc_error ("Component to the right of a part reference "
3574 "with nonzero rank must not have the POINTER "
3575 "attribute at %L", &expr->where);
3578 else if (ref->u.c.component->allocatable)
3580 gfc_error ("Component to the right of a part reference "
3581 "with nonzero rank must not have the ALLOCATABLE "
3582 "attribute at %L", &expr->where);
3594 if (((ref->type == REF_COMPONENT && n_components > 1)
3595 || ref->next == NULL)
3596 && current_part_dimension
3597 && seen_part_dimension)
3599 gfc_error ("Two or more part references with nonzero rank must "
3600 "not be specified at %L", &expr->where);
3604 if (ref->type == REF_COMPONENT)
3606 if (current_part_dimension)
3607 seen_part_dimension = 1;
3609 /* reset to make sure */
3610 current_part_dimension = 0;
3618 /* Given an expression, determine its shape. This is easier than it sounds.
3619 Leaves the shape array NULL if it is not possible to determine the shape. */
3622 expression_shape (gfc_expr *e)
3624 mpz_t array[GFC_MAX_DIMENSIONS];
3627 if (e->rank == 0 || e->shape != NULL)
3630 for (i = 0; i < e->rank; i++)
3631 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3634 e->shape = gfc_get_shape (e->rank);
3636 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3641 for (i--; i >= 0; i--)
3642 mpz_clear (array[i]);
3646 /* Given a variable expression node, compute the rank of the expression by
3647 examining the base symbol and any reference structures it may have. */
3650 expression_rank (gfc_expr *e)
3657 if (e->expr_type == EXPR_ARRAY)
3659 /* Constructors can have a rank different from one via RESHAPE(). */
3661 if (e->symtree == NULL)
3667 e->rank = (e->symtree->n.sym->as == NULL)
3668 ? 0 : e->symtree->n.sym->as->rank;
3674 for (ref = e->ref; ref; ref = ref->next)
3676 if (ref->type != REF_ARRAY)
3679 if (ref->u.ar.type == AR_FULL)
3681 rank = ref->u.ar.as->rank;
3685 if (ref->u.ar.type == AR_SECTION)
3687 /* Figure out the rank of the section. */
3689 gfc_internal_error ("expression_rank(): Two array specs");
3691 for (i = 0; i < ref->u.ar.dimen; i++)
3692 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3693 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3703 expression_shape (e);
3707 /* Resolve a variable expression. */
3710 resolve_variable (gfc_expr *e)
3717 if (e->symtree == NULL)
3720 if (e->ref && resolve_ref (e) == FAILURE)
3723 sym = e->symtree->n.sym;
3724 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3726 e->ts.type = BT_PROCEDURE;
3730 if (sym->ts.type != BT_UNKNOWN)
3731 gfc_variable_attr (e, &e->ts);
3734 /* Must be a simple variable reference. */
3735 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3740 if (check_assumed_size_reference (sym, e))
3743 /* Deal with forward references to entries during resolve_code, to
3744 satisfy, at least partially, 12.5.2.5. */
3745 if (gfc_current_ns->entries
3746 && current_entry_id == sym->entry_id
3749 && cs_base->current->op != EXEC_ENTRY)
3751 gfc_entry_list *entry;
3752 gfc_formal_arglist *formal;
3756 /* If the symbol is a dummy... */
3757 if (sym->attr.dummy)
3759 entry = gfc_current_ns->entries;
3762 /* ...test if the symbol is a parameter of previous entries. */
3763 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3764 for (formal = entry->sym->formal; formal; formal = formal->next)
3766 if (formal->sym && sym->name == formal->sym->name)
3770 /* If it has not been seen as a dummy, this is an error. */
3773 if (specification_expr)
3774 gfc_error ("Variable '%s',used in a specification expression, "
3775 "is referenced at %L before the ENTRY statement "
3776 "in which it is a parameter",
3777 sym->name, &cs_base->current->loc);
3779 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3780 "statement in which it is a parameter",
3781 sym->name, &cs_base->current->loc);
3786 /* Now do the same check on the specification expressions. */
3787 specification_expr = 1;
3788 if (sym->ts.type == BT_CHARACTER
3789 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3793 for (n = 0; n < sym->as->rank; n++)
3795 specification_expr = 1;
3796 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3798 specification_expr = 1;
3799 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3802 specification_expr = 0;
3805 /* Update the symbol's entry level. */
3806 sym->entry_id = current_entry_id + 1;
3813 /* Checks to see that the correct symbol has been host associated.
3814 The only situation where this arises is that in which a twice
3815 contained function is parsed after the host association is made.
3816 Therefore, on detecting this, the line is rematched, having got
3817 rid of the existing references and actual_arg_list. */
3819 check_host_association (gfc_expr *e)
3821 gfc_symbol *sym, *old_sym;
3825 bool retval = e->expr_type == EXPR_FUNCTION;
3827 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3830 old_sym = e->symtree->n.sym;
3832 if (old_sym->attr.use_assoc)
3835 if (gfc_current_ns->parent
3836 && gfc_current_ns->parent->parent
3837 && old_sym->ns != gfc_current_ns)
3839 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3840 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3842 temp_locus = gfc_current_locus;
3843 gfc_current_locus = e->where;
3845 gfc_buffer_error (1);
3847 gfc_free_ref_list (e->ref);
3852 gfc_free_actual_arglist (e->value.function.actual);
3853 e->value.function.actual = NULL;
3856 if (e->shape != NULL)
3858 for (n = 0; n < e->rank; n++)
3859 mpz_clear (e->shape[n]);
3861 gfc_free (e->shape);
3864 gfc_match_rvalue (&expr);
3866 gfc_buffer_error (0);
3868 gcc_assert (expr && sym == expr->symtree->n.sym);
3874 gfc_current_locus = temp_locus;
3877 /* This might have changed! */
3878 return e->expr_type == EXPR_FUNCTION;
3882 /* Resolve an expression. That is, make sure that types of operands agree
3883 with their operators, intrinsic operators are converted to function calls
3884 for overloaded types and unresolved function references are resolved. */
3887 gfc_resolve_expr (gfc_expr *e)
3894 switch (e->expr_type)
3897 t = resolve_operator (e);
3903 if (check_host_association (e))
3904 t = resolve_function (e);
3907 t = resolve_variable (e);
3909 expression_rank (e);
3913 case EXPR_SUBSTRING:
3914 t = resolve_ref (e);
3924 if (resolve_ref (e) == FAILURE)
3927 t = gfc_resolve_array_constructor (e);
3928 /* Also try to expand a constructor. */
3931 expression_rank (e);
3932 gfc_expand_constructor (e);
3935 /* This provides the opportunity for the length of constructors with
3936 character valued function elements to propagate the string length
3937 to the expression. */
3938 if (e->ts.type == BT_CHARACTER)
3939 gfc_resolve_character_array_constructor (e);
3943 case EXPR_STRUCTURE:
3944 t = resolve_ref (e);
3948 t = resolve_structure_cons (e);
3952 t = gfc_simplify_expr (e, 0);
3956 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3963 /* Resolve an expression from an iterator. They must be scalar and have
3964 INTEGER or (optionally) REAL type. */
3967 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3968 const char *name_msgid)
3970 if (gfc_resolve_expr (expr) == FAILURE)
3973 if (expr->rank != 0)
3975 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3979 if (expr->ts.type != BT_INTEGER)
3981 if (expr->ts.type == BT_REAL)
3984 return gfc_notify_std (GFC_STD_F95_DEL,
3985 "Deleted feature: %s at %L must be integer",
3986 _(name_msgid), &expr->where);
3989 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
3996 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4004 /* Resolve the expressions in an iterator structure. If REAL_OK is
4005 false allow only INTEGER type iterators, otherwise allow REAL types. */
4008 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4010 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4014 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4016 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4021 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4022 "Start expression in DO loop") == FAILURE)
4025 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4026 "End expression in DO loop") == FAILURE)
4029 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4030 "Step expression in DO loop") == FAILURE)
4033 if (iter->step->expr_type == EXPR_CONSTANT)
4035 if ((iter->step->ts.type == BT_INTEGER
4036 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4037 || (iter->step->ts.type == BT_REAL
4038 && mpfr_sgn (iter->step->value.real) == 0))
4040 gfc_error ("Step expression in DO loop at %L cannot be zero",
4041 &iter->step->where);
4046 /* Convert start, end, and step to the same type as var. */
4047 if (iter->start->ts.kind != iter->var->ts.kind
4048 || iter->start->ts.type != iter->var->ts.type)
4049 gfc_convert_type (iter->start, &iter->var->ts, 2);
4051 if (iter->end->ts.kind != iter->var->ts.kind
4052 || iter->end->ts.type != iter->var->ts.type)
4053 gfc_convert_type (iter->end, &iter->var->ts, 2);
4055 if (iter->step->ts.kind != iter->var->ts.kind
4056 || iter->step->ts.type != iter->var->ts.type)
4057 gfc_convert_type (iter->step, &iter->var->ts, 2);
4063 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4064 to be a scalar INTEGER variable. The subscripts and stride are scalar
4065 INTEGERs, and if stride is a constant it must be nonzero. */
4068 resolve_forall_iterators (gfc_forall_iterator *iter)
4072 if (gfc_resolve_expr (iter->var) == SUCCESS
4073 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4074 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4077 if (gfc_resolve_expr (iter->start) == SUCCESS
4078 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4079 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4080 &iter->start->where);
4081 if (iter->var->ts.kind != iter->start->ts.kind)
4082 gfc_convert_type (iter->start, &iter->var->ts, 2);
4084 if (gfc_resolve_expr (iter->end) == SUCCESS
4085 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4086 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4088 if (iter->var->ts.kind != iter->end->ts.kind)
4089 gfc_convert_type (iter->end, &iter->var->ts, 2);
4091 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4093 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4094 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4095 &iter->stride->where, "INTEGER");
4097 if (iter->stride->expr_type == EXPR_CONSTANT
4098 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4099 gfc_error ("FORALL stride expression at %L cannot be zero",
4100 &iter->stride->where);
4102 if (iter->var->ts.kind != iter->stride->ts.kind)
4103 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4110 /* Given a pointer to a symbol that is a derived type, see if any components
4111 have the POINTER attribute. The search is recursive if necessary.
4112 Returns zero if no pointer components are found, nonzero otherwise. */
4115 derived_pointer (gfc_symbol *sym)
4119 for (c = sym->components; c; c = c->next)
4124 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
4132 /* Given a pointer to a symbol that is a derived type, see if it's
4133 inaccessible, i.e. if it's defined in another module and the components are
4134 PRIVATE. The search is recursive if necessary. Returns zero if no
4135 inaccessible components are found, nonzero otherwise. */
4138 derived_inaccessible (gfc_symbol *sym)
4142 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
4145 for (c = sym->components; c; c = c->next)
4147 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4155 /* Resolve the argument of a deallocate expression. The expression must be
4156 a pointer or a full array. */
4159 resolve_deallocate_expr (gfc_expr *e)
4161 symbol_attribute attr;
4162 int allocatable, pointer, check_intent_in;
4165 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4166 check_intent_in = 1;
4168 if (gfc_resolve_expr (e) == FAILURE)
4171 if (e->expr_type != EXPR_VARIABLE)
4174 allocatable = e->symtree->n.sym->attr.allocatable;
4175 pointer = e->symtree->n.sym->attr.pointer;
4176 for (ref = e->ref; ref; ref = ref->next)
4179 check_intent_in = 0;
4184 if (ref->u.ar.type != AR_FULL)
4189 allocatable = (ref->u.c.component->as != NULL
4190 && ref->u.c.component->as->type == AS_DEFERRED);
4191 pointer = ref->u.c.component->pointer;
4200 attr = gfc_expr_attr (e);
4202 if (allocatable == 0 && attr.pointer == 0)
4205 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4206 "ALLOCATABLE or a POINTER", &e->where);
4210 && e->symtree->n.sym->attr.intent == INTENT_IN)
4212 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4213 e->symtree->n.sym->name, &e->where);
4221 /* Returns true if the expression e contains a reference the symbol sym. */
4223 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4225 gfc_actual_arglist *arg;
4233 switch (e->expr_type)
4236 for (arg = e->value.function.actual; arg; arg = arg->next)
4237 rv = rv || find_sym_in_expr (sym, arg->expr);
4240 /* If the variable is not the same as the dependent, 'sym', and
4241 it is not marked as being declared and it is in the same
4242 namespace as 'sym', add it to the local declarations. */
4244 if (sym == e->symtree->n.sym)
4249 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4250 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4259 for (ref = e->ref; ref; ref = ref->next)
4264 for (i = 0; i < ref->u.ar.dimen; i++)
4266 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4267 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4268 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4273 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4274 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4278 if (ref->u.c.component->ts.type == BT_CHARACTER
4279 && ref->u.c.component->ts.cl->length->expr_type
4282 || find_sym_in_expr (sym,
4283 ref->u.c.component->ts.cl->length);
4285 if (ref->u.c.component->as)
4286 for (i = 0; i < ref->u.c.component->as->rank; i++)
4289 || find_sym_in_expr (sym,
4290 ref->u.c.component->as->lower[i]);
4292 || find_sym_in_expr (sym,
4293 ref->u.c.component->as->upper[i]);
4303 /* Given the expression node e for an allocatable/pointer of derived type to be
4304 allocated, get the expression node to be initialized afterwards (needed for
4305 derived types with default initializers, and derived types with allocatable
4306 components that need nullification.) */
4309 expr_to_initialize (gfc_expr *e)
4315 result = gfc_copy_expr (e);
4317 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4318 for (ref = result->ref; ref; ref = ref->next)
4319 if (ref->type == REF_ARRAY && ref->next == NULL)
4321 ref->u.ar.type = AR_FULL;
4323 for (i = 0; i < ref->u.ar.dimen; i++)
4324 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4326 result->rank = ref->u.ar.dimen;
4334 /* Resolve the expression in an ALLOCATE statement, doing the additional
4335 checks to see whether the expression is OK or not. The expression must
4336 have a trailing array reference that gives the size of the array. */
4339 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4341 int i, pointer, allocatable, dimension, check_intent_in;
4342 symbol_attribute attr;
4343 gfc_ref *ref, *ref2;
4350 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4351 check_intent_in = 1;
4353 if (gfc_resolve_expr (e) == FAILURE)
4356 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4357 sym = code->expr->symtree->n.sym;
4361 /* Make sure the expression is allocatable or a pointer. If it is
4362 pointer, the next-to-last reference must be a pointer. */
4366 if (e->expr_type != EXPR_VARIABLE)
4369 attr = gfc_expr_attr (e);
4370 pointer = attr.pointer;
4371 dimension = attr.dimension;
4375 allocatable = e->symtree->n.sym->attr.allocatable;
4376 pointer = e->symtree->n.sym->attr.pointer;
4377 dimension = e->symtree->n.sym->attr.dimension;
4379 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4381 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4382 "not be allocated in the same statement at %L",
4383 sym->name, &e->where);
4387 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4390 check_intent_in = 0;
4395 if (ref->next != NULL)
4400 allocatable = (ref->u.c.component->as != NULL
4401 && ref->u.c.component->as->type == AS_DEFERRED);
4403 pointer = ref->u.c.component->pointer;
4404 dimension = ref->u.c.component->dimension;
4415 if (allocatable == 0 && pointer == 0)
4417 gfc_error ("Expression in ALLOCATE statement at %L must be "
4418 "ALLOCATABLE or a POINTER", &e->where);
4423 && e->symtree->n.sym->attr.intent == INTENT_IN)
4425 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4426 e->symtree->n.sym->name, &e->where);
4430 /* Add default initializer for those derived types that need them. */
4431 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4433 init_st = gfc_get_code ();
4434 init_st->loc = code->loc;
4435 init_st->op = EXEC_INIT_ASSIGN;
4436 init_st->expr = expr_to_initialize (e);
4437 init_st->expr2 = init_e;
4438 init_st->next = code->next;
4439 code->next = init_st;
4442 if (pointer && dimension == 0)
4445 /* Make sure the next-to-last reference node is an array specification. */
4447 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4449 gfc_error ("Array specification required in ALLOCATE statement "
4450 "at %L", &e->where);
4454 /* Make sure that the array section reference makes sense in the
4455 context of an ALLOCATE specification. */
4459 for (i = 0; i < ar->dimen; i++)
4461 if (ref2->u.ar.type == AR_ELEMENT)
4464 switch (ar->dimen_type[i])
4470 if (ar->start[i] != NULL
4471 && ar->end[i] != NULL
4472 && ar->stride[i] == NULL)
4475 /* Fall Through... */
4479 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4486 for (a = code->ext.alloc_list; a; a = a->next)
4488 sym = a->expr->symtree->n.sym;
4490 /* TODO - check derived type components. */
4491 if (sym->ts.type == BT_DERIVED)
4494 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4495 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4497 gfc_error ("'%s' must not appear an the array specification at "
4498 "%L in the same ALLOCATE statement where it is "
4499 "itself allocated", sym->name, &ar->where);
4509 /************ SELECT CASE resolution subroutines ************/
4511 /* Callback function for our mergesort variant. Determines interval
4512 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4513 op1 > op2. Assumes we're not dealing with the default case.
4514 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4515 There are nine situations to check. */
4518 compare_cases (const gfc_case *op1, const gfc_case *op2)
4522 if (op1->low == NULL) /* op1 = (:L) */
4524 /* op2 = (:N), so overlap. */
4526 /* op2 = (M:) or (M:N), L < M */
4527 if (op2->low != NULL
4528 && gfc_compare_expr (op1->high, op2->low) < 0)
4531 else if (op1->high == NULL) /* op1 = (K:) */
4533 /* op2 = (M:), so overlap. */
4535 /* op2 = (:N) or (M:N), K > N */
4536 if (op2->high != NULL
4537 && gfc_compare_expr (op1->low, op2->high) > 0)
4540 else /* op1 = (K:L) */
4542 if (op2->low == NULL) /* op2 = (:N), K > N */
4543 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4544 else if (op2->high == NULL) /* op2 = (M:), L < M */
4545 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4546 else /* op2 = (M:N) */
4550 if (gfc_compare_expr (op1->high, op2->low) < 0)
4553 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4562 /* Merge-sort a double linked case list, detecting overlap in the
4563 process. LIST is the head of the double linked case list before it
4564 is sorted. Returns the head of the sorted list if we don't see any
4565 overlap, or NULL otherwise. */
4568 check_case_overlap (gfc_case *list)
4570 gfc_case *p, *q, *e, *tail;
4571 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4573 /* If the passed list was empty, return immediately. */
4580 /* Loop unconditionally. The only exit from this loop is a return
4581 statement, when we've finished sorting the case list. */
4588 /* Count the number of merges we do in this pass. */
4591 /* Loop while there exists a merge to be done. */
4596 /* Count this merge. */
4599 /* Cut the list in two pieces by stepping INSIZE places
4600 forward in the list, starting from P. */
4603 for (i = 0; i < insize; i++)
4612 /* Now we have two lists. Merge them! */
4613 while (psize > 0 || (qsize > 0 && q != NULL))
4615 /* See from which the next case to merge comes from. */
4618 /* P is empty so the next case must come from Q. */
4623 else if (qsize == 0 || q == NULL)
4632 cmp = compare_cases (p, q);
4635 /* The whole case range for P is less than the
4643 /* The whole case range for Q is greater than
4644 the case range for P. */
4651 /* The cases overlap, or they are the same
4652 element in the list. Either way, we must
4653 issue an error and get the next case from P. */
4654 /* FIXME: Sort P and Q by line number. */
4655 gfc_error ("CASE label at %L overlaps with CASE "
4656 "label at %L", &p->where, &q->where);
4664 /* Add the next element to the merged list. */
4673 /* P has now stepped INSIZE places along, and so has Q. So
4674 they're the same. */
4679 /* If we have done only one merge or none at all, we've
4680 finished sorting the cases. */
4689 /* Otherwise repeat, merging lists twice the size. */
4695 /* Check to see if an expression is suitable for use in a CASE statement.
4696 Makes sure that all case expressions are scalar constants of the same
4697 type. Return FAILURE if anything is wrong. */
4700 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4702 if (e == NULL) return SUCCESS;
4704 if (e->ts.type != case_expr->ts.type)
4706 gfc_error ("Expression in CASE statement at %L must be of type %s",
4707 &e->where, gfc_basic_typename (case_expr->ts.type));
4711 /* C805 (R808) For a given case-construct, each case-value shall be of
4712 the same type as case-expr. For character type, length differences
4713 are allowed, but the kind type parameters shall be the same. */
4715 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4717 gfc_error("Expression in CASE statement at %L must be kind %d",
4718 &e->where, case_expr->ts.kind);
4722 /* Convert the case value kind to that of case expression kind, if needed.
4723 FIXME: Should a warning be issued? */
4724 if (e->ts.kind != case_expr->ts.kind)
4725 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4729 gfc_error ("Expression in CASE statement at %L must be scalar",
4738 /* Given a completely parsed select statement, we:
4740 - Validate all expressions and code within the SELECT.
4741 - Make sure that the selection expression is not of the wrong type.
4742 - Make sure that no case ranges overlap.
4743 - Eliminate unreachable cases and unreachable code resulting from
4744 removing case labels.
4746 The standard does allow unreachable cases, e.g. CASE (5:3). But
4747 they are a hassle for code generation, and to prevent that, we just
4748 cut them out here. This is not necessary for overlapping cases
4749 because they are illegal and we never even try to generate code.
4751 We have the additional caveat that a SELECT construct could have
4752 been a computed GOTO in the source code. Fortunately we can fairly
4753 easily work around that here: The case_expr for a "real" SELECT CASE
4754 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4755 we have to do is make sure that the case_expr is a scalar integer
4759 resolve_select (gfc_code *code)
4762 gfc_expr *case_expr;
4763 gfc_case *cp, *default_case, *tail, *head;
4764 int seen_unreachable;
4770 if (code->expr == NULL)
4772 /* This was actually a computed GOTO statement. */
4773 case_expr = code->expr2;
4774 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4775 gfc_error ("Selection expression in computed GOTO statement "
4776 "at %L must be a scalar integer expression",
4779 /* Further checking is not necessary because this SELECT was built
4780 by the compiler, so it should always be OK. Just move the
4781 case_expr from expr2 to expr so that we can handle computed
4782 GOTOs as normal SELECTs from here on. */
4783 code->expr = code->expr2;
4788 case_expr = code->expr;
4790 type = case_expr->ts.type;
4791 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4793 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4794 &case_expr->where, gfc_typename (&case_expr->ts));
4796 /* Punt. Going on here just produce more garbage error messages. */
4800 if (case_expr->rank != 0)
4802 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4803 "expression", &case_expr->where);
4809 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4810 of the SELECT CASE expression and its CASE values. Walk the lists
4811 of case values, and if we find a mismatch, promote case_expr to
4812 the appropriate kind. */
4814 if (type == BT_LOGICAL || type == BT_INTEGER)
4816 for (body = code->block; body; body = body->block)
4818 /* Walk the case label list. */
4819 for (cp = body->ext.case_list; cp; cp = cp->next)
4821 /* Intercept the DEFAULT case. It does not have a kind. */
4822 if (cp->low == NULL && cp->high == NULL)
4825 /* Unreachable case ranges are discarded, so ignore. */
4826 if (cp->low != NULL && cp->high != NULL
4827 && cp->low != cp->high
4828 && gfc_compare_expr (cp->low, cp->high) > 0)
4831 /* FIXME: Should a warning be issued? */
4833 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4834 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4836 if (cp->high != NULL
4837 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4838 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4843 /* Assume there is no DEFAULT case. */
4844 default_case = NULL;
4849 for (body = code->block; body; body = body->block)
4851 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4853 seen_unreachable = 0;
4855 /* Walk the case label list, making sure that all case labels
4857 for (cp = body->ext.case_list; cp; cp = cp->next)
4859 /* Count the number of cases in the whole construct. */
4862 /* Intercept the DEFAULT case. */
4863 if (cp->low == NULL && cp->high == NULL)
4865 if (default_case != NULL)
4867 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4868 "by a second DEFAULT CASE at %L",
4869 &default_case->where, &cp->where);
4880 /* Deal with single value cases and case ranges. Errors are
4881 issued from the validation function. */
4882 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4883 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4889 if (type == BT_LOGICAL
4890 && ((cp->low == NULL || cp->high == NULL)
4891 || cp->low != cp->high))
4893 gfc_error ("Logical range in CASE statement at %L is not "
4894 "allowed", &cp->low->where);
4899 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4902 value = cp->low->value.logical == 0 ? 2 : 1;
4903 if (value & seen_logical)
4905 gfc_error ("constant logical value in CASE statement "
4906 "is repeated at %L",
4911 seen_logical |= value;
4914 if (cp->low != NULL && cp->high != NULL
4915 && cp->low != cp->high
4916 && gfc_compare_expr (cp->low, cp->high) > 0)
4918 if (gfc_option.warn_surprising)
4919 gfc_warning ("Range specification at %L can never "
4920 "be matched", &cp->where);
4922 cp->unreachable = 1;
4923 seen_unreachable = 1;
4927 /* If the case range can be matched, it can also overlap with
4928 other cases. To make sure it does not, we put it in a
4929 double linked list here. We sort that with a merge sort
4930 later on to detect any overlapping cases. */
4934 head->right = head->left = NULL;
4939 tail->right->left = tail;
4946 /* It there was a failure in the previous case label, give up
4947 for this case label list. Continue with the next block. */
4951 /* See if any case labels that are unreachable have been seen.
4952 If so, we eliminate them. This is a bit of a kludge because
4953 the case lists for a single case statement (label) is a
4954 single forward linked lists. */
4955 if (seen_unreachable)
4957 /* Advance until the first case in the list is reachable. */
4958 while (body->ext.case_list != NULL
4959 && body->ext.case_list->unreachable)
4961 gfc_case *n = body->ext.case_list;
4962 body->ext.case_list = body->ext.case_list->next;
4964 gfc_free_case_list (n);
4967 /* Strip all other unreachable cases. */
4968 if (body->ext.case_list)
4970 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4972 if (cp->next->unreachable)
4974 gfc_case *n = cp->next;
4975 cp->next = cp->next->next;
4977 gfc_free_case_list (n);
4984 /* See if there were overlapping cases. If the check returns NULL,
4985 there was overlap. In that case we don't do anything. If head
4986 is non-NULL, we prepend the DEFAULT case. The sorted list can
4987 then used during code generation for SELECT CASE constructs with
4988 a case expression of a CHARACTER type. */
4991 head = check_case_overlap (head);
4993 /* Prepend the default_case if it is there. */
4994 if (head != NULL && default_case)
4996 default_case->left = NULL;
4997 default_case->right = head;
4998 head->left = default_case;
5002 /* Eliminate dead blocks that may be the result if we've seen
5003 unreachable case labels for a block. */
5004 for (body = code; body && body->block; body = body->block)
5006 if (body->block->ext.case_list == NULL)
5008 /* Cut the unreachable block from the code chain. */
5009 gfc_code *c = body->block;
5010 body->block = c->block;
5012 /* Kill the dead block, but not the blocks below it. */
5014 gfc_free_statements (c);
5018 /* More than two cases is legal but insane for logical selects.
5019 Issue a warning for it. */
5020 if (gfc_option.warn_surprising && type == BT_LOGICAL
5022 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5027 /* Resolve a transfer statement. This is making sure that:
5028 -- a derived type being transferred has only non-pointer components
5029 -- a derived type being transferred doesn't have private components, unless
5030 it's being transferred from the module where the type was defined
5031 -- we're not trying to transfer a whole assumed size array. */
5034 resolve_transfer (gfc_code *code)
5043 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5046 sym = exp->symtree->n.sym;
5049 /* Go to actual component transferred. */
5050 for (ref = code->expr->ref; ref; ref = ref->next)
5051 if (ref->type == REF_COMPONENT)
5052 ts = &ref->u.c.component->ts;
5054 if (ts->type == BT_DERIVED)
5056 /* Check that transferred derived type doesn't contain POINTER
5058 if (derived_pointer (ts->derived))
5060 gfc_error ("Data transfer element at %L cannot have "
5061 "POINTER components", &code->loc);
5065 if (ts->derived->attr.alloc_comp)
5067 gfc_error ("Data transfer element at %L cannot have "
5068 "ALLOCATABLE components", &code->loc);
5072 if (derived_inaccessible (ts->derived))
5074 gfc_error ("Data transfer element at %L cannot have "
5075 "PRIVATE components",&code->loc);
5080 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5081 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5083 gfc_error ("Data transfer element at %L cannot be a full reference to "
5084 "an assumed-size array", &code->loc);
5090 /*********** Toplevel code resolution subroutines ***********/
5092 /* Find the set of labels that are reachable from this block. We also
5093 record the last statement in each block so that we don't have to do
5094 a linear search to find the END DO statements of the blocks. */
5097 reachable_labels (gfc_code *block)
5104 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5106 /* Collect labels in this block. */
5107 for (c = block; c; c = c->next)
5110 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5112 if (!c->next && cs_base->prev)
5113 cs_base->prev->tail = c;
5116 /* Merge with labels from parent block. */
5119 gcc_assert (cs_base->prev->reachable_labels);
5120 bitmap_ior_into (cs_base->reachable_labels,
5121 cs_base->prev->reachable_labels);
5125 /* Given a branch to a label and a namespace, if the branch is conforming.
5126 The code node describes where the branch is located. */
5129 resolve_branch (gfc_st_label *label, gfc_code *code)
5136 /* Step one: is this a valid branching target? */
5138 if (label->defined == ST_LABEL_UNKNOWN)
5140 gfc_error ("Label %d referenced at %L is never defined", label->value,
5145 if (label->defined != ST_LABEL_TARGET)
5147 gfc_error ("Statement at %L is not a valid branch target statement "
5148 "for the branch statement at %L", &label->where, &code->loc);
5152 /* Step two: make sure this branch is not a branch to itself ;-) */
5154 if (code->here == label)
5156 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5160 /* Step three: See if the label is in the same block as the
5161 branching statement. The hard work has been done by setting up
5162 the bitmap reachable_labels. */
5164 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5166 /* The label is not in an enclosing block, so illegal. This was
5167 allowed in Fortran 66, so we allow it as extension. No
5168 further checks are necessary in this case. */
5169 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5170 "as the GOTO statement at %L", &label->where,
5175 /* Step four: Make sure that the branching target is legal if
5176 the statement is an END {SELECT,IF}. */
5178 for (stack = cs_base; stack; stack = stack->prev)
5179 if (stack->current->next && stack->current->next->here == label)
5182 if (stack && stack->current->next->op == EXEC_NOP)
5184 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5185 "END of construct at %L", &code->loc,
5186 &stack->current->next->loc);
5187 return; /* We know this is not an END DO. */
5190 /* Step five: Make sure that we're not jumping to the end of a DO
5191 loop from within the loop. */
5193 for (stack = cs_base; stack; stack = stack->prev)
5194 if ((stack->current->op == EXEC_DO
5195 || stack->current->op == EXEC_DO_WHILE)
5196 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5198 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5199 "to END of construct at %L", &code->loc,
5207 /* Check whether EXPR1 has the same shape as EXPR2. */
5210 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5212 mpz_t shape[GFC_MAX_DIMENSIONS];
5213 mpz_t shape2[GFC_MAX_DIMENSIONS];
5214 try result = FAILURE;
5217 /* Compare the rank. */
5218 if (expr1->rank != expr2->rank)
5221 /* Compare the size of each dimension. */
5222 for (i=0; i<expr1->rank; i++)
5224 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5227 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5230 if (mpz_cmp (shape[i], shape2[i]))
5234 /* When either of the two expression is an assumed size array, we
5235 ignore the comparison of dimension sizes. */
5240 for (i--; i >= 0; i--)
5242 mpz_clear (shape[i]);
5243 mpz_clear (shape2[i]);
5249 /* Check whether a WHERE assignment target or a WHERE mask expression
5250 has the same shape as the outmost WHERE mask expression. */
5253 resolve_where (gfc_code *code, gfc_expr *mask)
5259 cblock = code->block;
5261 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5262 In case of nested WHERE, only the outmost one is stored. */
5263 if (mask == NULL) /* outmost WHERE */
5265 else /* inner WHERE */
5272 /* Check if the mask-expr has a consistent shape with the
5273 outmost WHERE mask-expr. */
5274 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5275 gfc_error ("WHERE mask at %L has inconsistent shape",
5276 &cblock->expr->where);
5279 /* the assignment statement of a WHERE statement, or the first
5280 statement in where-body-construct of a WHERE construct */
5281 cnext = cblock->next;
5286 /* WHERE assignment statement */
5289 /* Check shape consistent for WHERE assignment target. */
5290 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5291 gfc_error ("WHERE assignment target at %L has "
5292 "inconsistent shape", &cnext->expr->where);
5296 case EXEC_ASSIGN_CALL:
5297 resolve_call (cnext);
5300 /* WHERE or WHERE construct is part of a where-body-construct */
5302 resolve_where (cnext, e);
5306 gfc_error ("Unsupported statement inside WHERE at %L",
5309 /* the next statement within the same where-body-construct */
5310 cnext = cnext->next;
5312 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5313 cblock = cblock->block;
5318 /* Check whether the FORALL index appears in the expression or not. */
5321 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5325 gfc_actual_arglist *args;
5328 switch (expr->expr_type)
5331 gcc_assert (expr->symtree->n.sym);
5333 /* A scalar assignment */
5336 if (expr->symtree->n.sym == symbol)
5342 /* the expr is array ref, substring or struct component. */
5349 /* Check if the symbol appears in the array subscript. */
5351 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5354 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5358 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5362 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5368 if (expr->symtree->n.sym == symbol)
5371 /* Check if the symbol appears in the substring section. */
5372 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5374 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5382 gfc_error("expression reference type error at %L", &expr->where);
5388 /* If the expression is a function call, then check if the symbol
5389 appears in the actual arglist of the function. */
5391 for (args = expr->value.function.actual; args; args = args->next)
5393 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5398 /* It seems not to happen. */
5399 case EXPR_SUBSTRING:
5403 gcc_assert (expr->ref->type == REF_SUBSTRING);
5404 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5406 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5411 /* It seems not to happen. */
5412 case EXPR_STRUCTURE:
5414 gfc_error ("Unsupported statement while finding forall index in "
5419 /* Find the FORALL index in the first operand. */
5420 if (expr->value.op.op1)
5422 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5426 /* Find the FORALL index in the second operand. */
5427 if (expr->value.op.op2)
5429 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5442 /* Resolve assignment in FORALL construct.
5443 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5444 FORALL index variables. */
5447 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5451 for (n = 0; n < nvar; n++)
5453 gfc_symbol *forall_index;
5455 forall_index = var_expr[n]->symtree->n.sym;
5457 /* Check whether the assignment target is one of the FORALL index
5459 if ((code->expr->expr_type == EXPR_VARIABLE)
5460 && (code->expr->symtree->n.sym == forall_index))
5461 gfc_error ("Assignment to a FORALL index variable at %L",
5462 &code->expr->where);
5465 /* If one of the FORALL index variables doesn't appear in the
5466 assignment target, then there will be a many-to-one
5468 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5469 gfc_error ("The FORALL with index '%s' cause more than one "
5470 "assignment to this object at %L",
5471 var_expr[n]->symtree->name, &code->expr->where);
5477 /* Resolve WHERE statement in FORALL construct. */
5480 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5481 gfc_expr **var_expr)
5486 cblock = code->block;
5489 /* the assignment statement of a WHERE statement, or the first
5490 statement in where-body-construct of a WHERE construct */
5491 cnext = cblock->next;
5496 /* WHERE assignment statement */
5498 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5501 /* WHERE operator assignment statement */
5502 case EXEC_ASSIGN_CALL:
5503 resolve_call (cnext);
5506 /* WHERE or WHERE construct is part of a where-body-construct */
5508 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5512 gfc_error ("Unsupported statement inside WHERE at %L",
5515 /* the next statement within the same where-body-construct */
5516 cnext = cnext->next;
5518 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5519 cblock = cblock->block;
5524 /* Traverse the FORALL body to check whether the following errors exist:
5525 1. For assignment, check if a many-to-one assignment happens.
5526 2. For WHERE statement, check the WHERE body to see if there is any
5527 many-to-one assignment. */
5530 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5534 c = code->block->next;
5540 case EXEC_POINTER_ASSIGN:
5541 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5544 case EXEC_ASSIGN_CALL:
5548 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5549 there is no need to handle it here. */
5553 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5558 /* The next statement in the FORALL body. */
5564 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5565 gfc_resolve_forall_body to resolve the FORALL body. */
5568 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5570 static gfc_expr **var_expr;
5571 static int total_var = 0;
5572 static int nvar = 0;
5573 gfc_forall_iterator *fa;
5574 gfc_symbol *forall_index;
5578 /* Start to resolve a FORALL construct */
5579 if (forall_save == 0)
5581 /* Count the total number of FORALL index in the nested FORALL
5582 construct in order to allocate the VAR_EXPR with proper size. */
5584 while ((next != NULL) && (next->op == EXEC_FORALL))
5586 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5588 next = next->block->next;
5591 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5592 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5595 /* The information about FORALL iterator, including FORALL index start, end
5596 and stride. The FORALL index can not appear in start, end or stride. */
5597 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5599 /* Check if any outer FORALL index name is the same as the current
5601 for (i = 0; i < nvar; i++)
5603 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5605 gfc_error ("An outer FORALL construct already has an index "
5606 "with this name %L", &fa->var->where);
5610 /* Record the current FORALL index. */
5611 var_expr[nvar] = gfc_copy_expr (fa->var);
5613 forall_index = fa->var->symtree->n.sym;
5615 /* Check if the FORALL index appears in start, end or stride. */
5616 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5617 gfc_error ("A FORALL index must not appear in a limit or stride "
5618 "expression in the same FORALL at %L", &fa->start->where);
5619 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5620 gfc_error ("A FORALL index must not appear in a limit or stride "
5621 "expression in the same FORALL at %L", &fa->end->where);
5622 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5623 gfc_error ("A FORALL index must not appear in a limit or stride "
5624 "expression in the same FORALL at %L", &fa->stride->where);
5628 /* Resolve the FORALL body. */
5629 gfc_resolve_forall_body (code, nvar, var_expr);
5631 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5632 gfc_resolve_blocks (code->block, ns);
5634 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5635 for (i = 0; i < total_var; i++)
5636 gfc_free_expr (var_expr[i]);
5638 /* Reset the counters. */
5644 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5647 static void resolve_code (gfc_code *, gfc_namespace *);
5650 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5654 for (; b; b = b->block)
5656 t = gfc_resolve_expr (b->expr);
5657 if (gfc_resolve_expr (b->expr2) == FAILURE)
5663 if (t == SUCCESS && b->expr != NULL
5664 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5665 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5672 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5673 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5678 resolve_branch (b->label, b);
5690 case EXEC_OMP_ATOMIC:
5691 case EXEC_OMP_CRITICAL:
5693 case EXEC_OMP_MASTER:
5694 case EXEC_OMP_ORDERED:
5695 case EXEC_OMP_PARALLEL:
5696 case EXEC_OMP_PARALLEL_DO:
5697 case EXEC_OMP_PARALLEL_SECTIONS:
5698 case EXEC_OMP_PARALLEL_WORKSHARE:
5699 case EXEC_OMP_SECTIONS:
5700 case EXEC_OMP_SINGLE:
5701 case EXEC_OMP_WORKSHARE:
5705 gfc_internal_error ("resolve_block(): Bad block type");
5708 resolve_code (b->next, ns);
5713 /* Given a block of code, recursively resolve everything pointed to by this
5717 resolve_code (gfc_code *code, gfc_namespace *ns)
5719 int omp_workshare_save;
5725 frame.prev = cs_base;
5729 reachable_labels (code);
5731 for (; code; code = code->next)
5733 frame.current = code;
5734 forall_save = forall_flag;
5736 if (code->op == EXEC_FORALL)
5739 gfc_resolve_forall (code, ns, forall_save);
5742 else if (code->block)
5744 omp_workshare_save = -1;
5747 case EXEC_OMP_PARALLEL_WORKSHARE:
5748 omp_workshare_save = omp_workshare_flag;
5749 omp_workshare_flag = 1;
5750 gfc_resolve_omp_parallel_blocks (code, ns);
5752 case EXEC_OMP_PARALLEL:
5753 case EXEC_OMP_PARALLEL_DO:
5754 case EXEC_OMP_PARALLEL_SECTIONS:
5755 omp_workshare_save = omp_workshare_flag;
5756 omp_workshare_flag = 0;
5757 gfc_resolve_omp_parallel_blocks (code, ns);
5760 gfc_resolve_omp_do_blocks (code, ns);
5762 case EXEC_OMP_WORKSHARE:
5763 omp_workshare_save = omp_workshare_flag;
5764 omp_workshare_flag = 1;
5767 gfc_resolve_blocks (code->block, ns);
5771 if (omp_workshare_save != -1)
5772 omp_workshare_flag = omp_workshare_save;
5775 t = gfc_resolve_expr (code->expr);
5776 forall_flag = forall_save;
5778 if (gfc_resolve_expr (code->expr2) == FAILURE)
5793 /* Keep track of which entry we are up to. */
5794 current_entry_id = code->ext.entry->id;
5798 resolve_where (code, NULL);
5802 if (code->expr != NULL)
5804 if (code->expr->ts.type != BT_INTEGER)
5805 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5806 "INTEGER variable", &code->expr->where);
5807 else if (code->expr->symtree->n.sym->attr.assign != 1)
5808 gfc_error ("Variable '%s' has not been assigned a target "
5809 "label at %L", code->expr->symtree->n.sym->name,
5810 &code->expr->where);
5813 resolve_branch (code->label, code);
5817 if (code->expr != NULL
5818 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5819 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5820 "INTEGER return specifier", &code->expr->where);
5823 case EXEC_INIT_ASSIGN:
5830 if (gfc_extend_assign (code, ns) == SUCCESS)
5832 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5834 gfc_error ("Subroutine '%s' called instead of assignment at "
5835 "%L must be PURE", code->symtree->n.sym->name,
5842 if (code->expr->ts.type == BT_CHARACTER
5843 && gfc_option.warn_character_truncation)
5845 int llen = 0, rlen = 0;
5847 if (code->expr->ts.cl != NULL
5848 && code->expr->ts.cl->length != NULL
5849 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5850 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5852 if (code->expr2->expr_type == EXPR_CONSTANT)
5853 rlen = code->expr2->value.character.length;
5855 else if (code->expr2->ts.cl != NULL
5856 && code->expr2->ts.cl->length != NULL
5857 && code->expr2->ts.cl->length->expr_type
5859 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5861 if (rlen && llen && rlen > llen)
5862 gfc_warning_now ("CHARACTER expression will be truncated "
5863 "in assignment (%d/%d) at %L",
5864 llen, rlen, &code->loc);
5867 if (gfc_pure (NULL))
5869 if (gfc_impure_variable (code->expr->symtree->n.sym))
5871 gfc_error ("Cannot assign to variable '%s' in PURE "
5873 code->expr->symtree->n.sym->name,
5874 &code->expr->where);
5878 if (code->expr->ts.type == BT_DERIVED
5879 && code->expr->expr_type == EXPR_VARIABLE
5880 && derived_pointer (code->expr->ts.derived)
5881 && gfc_impure_variable (code->expr2->symtree->n.sym))
5883 gfc_error ("The impure variable at %L is assigned to "
5884 "a derived type variable with a POINTER "
5885 "component in a PURE procedure (12.6)",
5886 &code->expr2->where);
5891 gfc_check_assign (code->expr, code->expr2, 1);
5894 case EXEC_LABEL_ASSIGN:
5895 if (code->label->defined == ST_LABEL_UNKNOWN)
5896 gfc_error ("Label %d referenced at %L is never defined",
5897 code->label->value, &code->label->where);
5899 && (code->expr->expr_type != EXPR_VARIABLE
5900 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5901 || code->expr->symtree->n.sym->ts.kind
5902 != gfc_default_integer_kind
5903 || code->expr->symtree->n.sym->as != NULL))
5904 gfc_error ("ASSIGN statement at %L requires a scalar "
5905 "default INTEGER variable", &code->expr->where);
5908 case EXEC_POINTER_ASSIGN:
5912 gfc_check_pointer_assign (code->expr, code->expr2);
5915 case EXEC_ARITHMETIC_IF:
5917 && code->expr->ts.type != BT_INTEGER
5918 && code->expr->ts.type != BT_REAL)
5919 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5920 "expression", &code->expr->where);
5922 resolve_branch (code->label, code);
5923 resolve_branch (code->label2, code);
5924 resolve_branch (code->label3, code);
5928 if (t == SUCCESS && code->expr != NULL
5929 && (code->expr->ts.type != BT_LOGICAL
5930 || code->expr->rank != 0))
5931 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5932 &code->expr->where);
5937 resolve_call (code);
5941 /* Select is complicated. Also, a SELECT construct could be
5942 a transformed computed GOTO. */
5943 resolve_select (code);
5947 if (code->ext.iterator != NULL)
5949 gfc_iterator *iter = code->ext.iterator;
5950 if (gfc_resolve_iterator (iter, true) != FAILURE)
5951 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5956 if (code->expr == NULL)
5957 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5959 && (code->expr->rank != 0
5960 || code->expr->ts.type != BT_LOGICAL))
5961 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5962 "a scalar LOGICAL expression", &code->expr->where);
5966 if (t == SUCCESS && code->expr != NULL
5967 && code->expr->ts.type != BT_INTEGER)
5968 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5969 "of type INTEGER", &code->expr->where);
5971 for (a = code->ext.alloc_list; a; a = a->next)
5972 resolve_allocate_expr (a->expr, code);
5976 case EXEC_DEALLOCATE:
5977 if (t == SUCCESS && code->expr != NULL
5978 && code->expr->ts.type != BT_INTEGER)
5980 ("STAT tag in DEALLOCATE statement at %L must be of type "
5981 "INTEGER", &code->expr->where);
5983 for (a = code->ext.alloc_list; a; a = a->next)
5984 resolve_deallocate_expr (a->expr);
5989 if (gfc_resolve_open (code->ext.open) == FAILURE)
5992 resolve_branch (code->ext.open->err, code);
5996 if (gfc_resolve_close (code->ext.close) == FAILURE)
5999 resolve_branch (code->ext.close->err, code);
6002 case EXEC_BACKSPACE:
6006 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6009 resolve_branch (code->ext.filepos->err, code);
6013 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6016 resolve_branch (code->ext.inquire->err, code);
6020 gcc_assert (code->ext.inquire != NULL);
6021 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6024 resolve_branch (code->ext.inquire->err, code);
6029 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6032 resolve_branch (code->ext.dt->err, code);
6033 resolve_branch (code->ext.dt->end, code);
6034 resolve_branch (code->ext.dt->eor, code);
6038 resolve_transfer (code);
6042 resolve_forall_iterators (code->ext.forall_iterator);
6044 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6045 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6046 "expression", &code->expr->where);
6049 case EXEC_OMP_ATOMIC:
6050 case EXEC_OMP_BARRIER:
6051 case EXEC_OMP_CRITICAL:
6052 case EXEC_OMP_FLUSH:
6054 case EXEC_OMP_MASTER:
6055 case EXEC_OMP_ORDERED:
6056 case EXEC_OMP_SECTIONS:
6057 case EXEC_OMP_SINGLE:
6058 case EXEC_OMP_WORKSHARE:
6059 gfc_resolve_omp_directive (code, ns);
6062 case EXEC_OMP_PARALLEL:
6063 case EXEC_OMP_PARALLEL_DO:
6064 case EXEC_OMP_PARALLEL_SECTIONS:
6065 case EXEC_OMP_PARALLEL_WORKSHARE:
6066 omp_workshare_save = omp_workshare_flag;
6067 omp_workshare_flag = 0;
6068 gfc_resolve_omp_directive (code, ns);
6069 omp_workshare_flag = omp_workshare_save;
6073 gfc_internal_error ("resolve_code(): Bad statement code");
6077 cs_base = frame.prev;
6081 /* Resolve initial values and make sure they are compatible with
6085 resolve_values (gfc_symbol *sym)
6087 if (sym->value == NULL)
6090 if (gfc_resolve_expr (sym->value) == FAILURE)
6093 gfc_check_assign_symbol (sym, sym->value);
6097 /* Verify the binding labels for common blocks that are BIND(C). The label
6098 for a BIND(C) common block must be identical in all scoping units in which
6099 the common block is declared. Further, the binding label can not collide
6100 with any other global entity in the program. */
6103 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6105 if (comm_block_tree->n.common->is_bind_c == 1)
6107 gfc_gsymbol *binding_label_gsym;
6108 gfc_gsymbol *comm_name_gsym;
6110 /* See if a global symbol exists by the common block's name. It may
6111 be NULL if the common block is use-associated. */
6112 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6113 comm_block_tree->n.common->name);
6114 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6115 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6116 "with the global entity '%s' at %L",
6117 comm_block_tree->n.common->binding_label,
6118 comm_block_tree->n.common->name,
6119 &(comm_block_tree->n.common->where),
6120 comm_name_gsym->name, &(comm_name_gsym->where));
6121 else if (comm_name_gsym != NULL
6122 && strcmp (comm_name_gsym->name,
6123 comm_block_tree->n.common->name) == 0)
6125 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6127 if (comm_name_gsym->binding_label == NULL)
6128 /* No binding label for common block stored yet; save this one. */
6129 comm_name_gsym->binding_label =
6130 comm_block_tree->n.common->binding_label;
6132 if (strcmp (comm_name_gsym->binding_label,
6133 comm_block_tree->n.common->binding_label) != 0)
6135 /* Common block names match but binding labels do not. */
6136 gfc_error ("Binding label '%s' for common block '%s' at %L "
6137 "does not match the binding label '%s' for common "
6139 comm_block_tree->n.common->binding_label,
6140 comm_block_tree->n.common->name,
6141 &(comm_block_tree->n.common->where),
6142 comm_name_gsym->binding_label,
6143 comm_name_gsym->name,
6144 &(comm_name_gsym->where));
6149 /* There is no binding label (NAME="") so we have nothing further to
6150 check and nothing to add as a global symbol for the label. */
6151 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6154 binding_label_gsym =
6155 gfc_find_gsymbol (gfc_gsym_root,
6156 comm_block_tree->n.common->binding_label);
6157 if (binding_label_gsym == NULL)
6159 /* Need to make a global symbol for the binding label to prevent
6160 it from colliding with another. */
6161 binding_label_gsym =
6162 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6163 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6164 binding_label_gsym->type = GSYM_COMMON;
6168 /* If comm_name_gsym is NULL, the name common block is use
6169 associated and the name could be colliding. */
6170 if (binding_label_gsym->type != GSYM_COMMON)
6171 gfc_error ("Binding label '%s' for common block '%s' at %L "
6172 "collides with the global entity '%s' at %L",
6173 comm_block_tree->n.common->binding_label,
6174 comm_block_tree->n.common->name,
6175 &(comm_block_tree->n.common->where),
6176 binding_label_gsym->name,
6177 &(binding_label_gsym->where));
6178 else if (comm_name_gsym != NULL
6179 && (strcmp (binding_label_gsym->name,
6180 comm_name_gsym->binding_label) != 0)
6181 && (strcmp (binding_label_gsym->sym_name,
6182 comm_name_gsym->name) != 0))
6183 gfc_error ("Binding label '%s' for common block '%s' at %L "
6184 "collides with global entity '%s' at %L",
6185 binding_label_gsym->name, binding_label_gsym->sym_name,
6186 &(comm_block_tree->n.common->where),
6187 comm_name_gsym->name, &(comm_name_gsym->where));
6195 /* Verify any BIND(C) derived types in the namespace so we can report errors
6196 for them once, rather than for each variable declared of that type. */
6199 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6201 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6202 && derived_sym->attr.is_bind_c == 1)
6203 verify_bind_c_derived_type (derived_sym);
6209 /* Verify that any binding labels used in a given namespace do not collide
6210 with the names or binding labels of any global symbols. */
6213 gfc_verify_binding_labels (gfc_symbol *sym)
6217 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6218 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6220 gfc_gsymbol *bind_c_sym;
6222 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6223 if (bind_c_sym != NULL
6224 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6226 if (sym->attr.if_source == IFSRC_DECL
6227 && (bind_c_sym->type != GSYM_SUBROUTINE
6228 && bind_c_sym->type != GSYM_FUNCTION)
6229 && ((sym->attr.contained == 1
6230 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6231 || (sym->attr.use_assoc == 1
6232 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6234 /* Make sure global procedures don't collide with anything. */
6235 gfc_error ("Binding label '%s' at %L collides with the global "
6236 "entity '%s' at %L", sym->binding_label,
6237 &(sym->declared_at), bind_c_sym->name,
6238 &(bind_c_sym->where));
6241 else if (sym->attr.contained == 0
6242 && (sym->attr.if_source == IFSRC_IFBODY
6243 && sym->attr.flavor == FL_PROCEDURE)
6244 && (bind_c_sym->sym_name != NULL
6245 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6247 /* Make sure procedures in interface bodies don't collide. */
6248 gfc_error ("Binding label '%s' in interface body at %L collides "
6249 "with the global entity '%s' at %L",
6251 &(sym->declared_at), bind_c_sym->name,
6252 &(bind_c_sym->where));
6255 else if (sym->attr.contained == 0
6256 && (sym->attr.if_source == IFSRC_UNKNOWN))
6257 if ((sym->attr.use_assoc
6258 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6259 || sym->attr.use_assoc == 0)
6261 gfc_error ("Binding label '%s' at %L collides with global "
6262 "entity '%s' at %L", sym->binding_label,
6263 &(sym->declared_at), bind_c_sym->name,
6264 &(bind_c_sym->where));
6269 /* Clear the binding label to prevent checking multiple times. */
6270 sym->binding_label[0] = '\0';
6272 else if (bind_c_sym == NULL)
6274 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6275 bind_c_sym->where = sym->declared_at;
6276 bind_c_sym->sym_name = sym->name;
6278 if (sym->attr.use_assoc == 1)
6279 bind_c_sym->mod_name = sym->module;
6281 if (sym->ns->proc_name != NULL)
6282 bind_c_sym->mod_name = sym->ns->proc_name->name;
6284 if (sym->attr.contained == 0)
6286 if (sym->attr.subroutine)
6287 bind_c_sym->type = GSYM_SUBROUTINE;
6288 else if (sym->attr.function)
6289 bind_c_sym->type = GSYM_FUNCTION;
6297 /* Resolve an index expression. */
6300 resolve_index_expr (gfc_expr *e)
6302 if (gfc_resolve_expr (e) == FAILURE)
6305 if (gfc_simplify_expr (e, 0) == FAILURE)
6308 if (gfc_specification_expr (e) == FAILURE)
6314 /* Resolve a charlen structure. */
6317 resolve_charlen (gfc_charlen *cl)
6326 specification_expr = 1;
6328 if (resolve_index_expr (cl->length) == FAILURE)
6330 specification_expr = 0;
6334 /* "If the character length parameter value evaluates to a negative
6335 value, the length of character entities declared is zero." */
6336 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6338 gfc_warning_now ("CHARACTER variable has zero length at %L",
6339 &cl->length->where);
6340 gfc_replace_expr (cl->length, gfc_int_expr (0));
6347 /* Test for non-constant shape arrays. */
6350 is_non_constant_shape_array (gfc_symbol *sym)
6356 not_constant = false;
6357 if (sym->as != NULL)
6359 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6360 has not been simplified; parameter array references. Do the
6361 simplification now. */
6362 for (i = 0; i < sym->as->rank; i++)
6364 e = sym->as->lower[i];
6365 if (e && (resolve_index_expr (e) == FAILURE
6366 || !gfc_is_constant_expr (e)))
6367 not_constant = true;
6369 e = sym->as->upper[i];
6370 if (e && (resolve_index_expr (e) == FAILURE
6371 || !gfc_is_constant_expr (e)))
6372 not_constant = true;
6375 return not_constant;
6379 /* Assign the default initializer to a derived type variable or result. */
6382 apply_default_init (gfc_symbol *sym)
6385 gfc_expr *init = NULL;
6387 gfc_namespace *ns = sym->ns;
6389 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6392 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6393 init = gfc_default_initializer (&sym->ts);
6398 /* Search for the function namespace if this is a contained
6399 function without an explicit result. */
6400 if (sym->attr.function && sym == sym->result
6401 && sym->name != sym->ns->proc_name->name)
6404 for (;ns; ns = ns->sibling)
6405 if (strcmp (ns->proc_name->name, sym->name) == 0)
6411 gfc_free_expr (init);
6415 /* Build an l-value expression for the result. */
6416 lval = gfc_get_expr ();
6417 lval->expr_type = EXPR_VARIABLE;
6418 lval->where = sym->declared_at;
6420 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
6422 /* It will always be a full array. */
6423 lval->rank = sym->as ? sym->as->rank : 0;
6426 lval->ref = gfc_get_ref ();
6427 lval->ref->type = REF_ARRAY;
6428 lval->ref->u.ar.type = AR_FULL;
6429 lval->ref->u.ar.dimen = lval->rank;
6430 lval->ref->u.ar.where = sym->declared_at;
6431 lval->ref->u.ar.as = sym->as;
6434 /* Add the code at scope entry. */
6435 init_st = gfc_get_code ();
6436 init_st->next = ns->code;
6439 /* Assign the default initializer to the l-value. */
6440 init_st->loc = sym->declared_at;
6441 init_st->op = EXEC_INIT_ASSIGN;
6442 init_st->expr = lval;
6443 init_st->expr2 = init;
6447 /* Resolution of common features of flavors variable and procedure. */
6450 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6452 /* Constraints on deferred shape variable. */
6453 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6455 if (sym->attr.allocatable)
6457 if (sym->attr.dimension)
6458 gfc_error ("Allocatable array '%s' at %L must have "
6459 "a deferred shape", sym->name, &sym->declared_at);
6461 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6462 sym->name, &sym->declared_at);
6466 if (sym->attr.pointer && sym->attr.dimension)
6468 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6469 sym->name, &sym->declared_at);
6476 if (!mp_flag && !sym->attr.allocatable
6477 && !sym->attr.pointer && !sym->attr.dummy)
6479 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6480 sym->name, &sym->declared_at);
6488 static gfc_component *
6489 has_default_initializer (gfc_symbol *der)
6492 for (c = der->components; c; c = c->next)
6493 if ((c->ts.type != BT_DERIVED && c->initializer)
6494 || (c->ts.type == BT_DERIVED
6496 && has_default_initializer (c->ts.derived)))
6503 /* Resolve symbols with flavor variable. */
6506 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6512 const char *auto_save_msg;
6514 auto_save_msg = "automatic object '%s' at %L cannot have the "
6517 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6520 /* Set this flag to check that variables are parameters of all entries.
6521 This check is effected by the call to gfc_resolve_expr through
6522 is_non_constant_shape_array. */
6523 specification_expr = 1;
6525 if (!sym->attr.use_assoc
6526 && !sym->attr.allocatable
6527 && !sym->attr.pointer
6528 && is_non_constant_shape_array (sym))
6530 /* The shape of a main program or module array needs to be
6532 if (sym->ns->proc_name
6533 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6534 || sym->ns->proc_name->attr.is_main_program))
6536 gfc_error ("The module or main program array '%s' at %L must "
6537 "have constant shape", sym->name, &sym->declared_at);
6538 specification_expr = 0;
6543 if (sym->ts.type == BT_CHARACTER)
6545 /* Make sure that character string variables with assumed length are
6547 e = sym->ts.cl->length;
6548 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6550 gfc_error ("Entity with assumed character length at %L must be a "
6551 "dummy argument or a PARAMETER", &sym->declared_at);
6555 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6557 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6561 if (!gfc_is_constant_expr (e)
6562 && !(e->expr_type == EXPR_VARIABLE
6563 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6564 && sym->ns->proc_name
6565 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6566 || sym->ns->proc_name->attr.is_main_program)
6567 && !sym->attr.use_assoc)
6569 gfc_error ("'%s' at %L must have constant character length "
6570 "in this context", sym->name, &sym->declared_at);
6575 /* Can the symbol have an initializer? */
6577 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6578 || sym->attr.intrinsic || sym->attr.result)
6580 else if (sym->attr.dimension && !sym->attr.pointer)
6582 /* Don't allow initialization of automatic arrays. */
6583 for (i = 0; i < sym->as->rank; i++)
6585 if (sym->as->lower[i] == NULL
6586 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6587 || sym->as->upper[i] == NULL
6588 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6595 /* Also, they must not have the SAVE attribute.
6596 SAVE_IMPLICIT is checked below. */
6597 if (flag && sym->attr.save == SAVE_EXPLICIT)
6599 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6604 /* Reject illegal initializers. */
6605 if (!sym->mark && sym->value && flag)
6607 if (sym->attr.allocatable)
6608 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6609 sym->name, &sym->declared_at);
6610 else if (sym->attr.external)
6611 gfc_error ("External '%s' at %L cannot have an initializer",
6612 sym->name, &sym->declared_at);
6613 else if (sym->attr.dummy
6614 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6615 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6616 sym->name, &sym->declared_at);
6617 else if (sym->attr.intrinsic)
6618 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6619 sym->name, &sym->declared_at);
6620 else if (sym->attr.result)
6621 gfc_error ("Function result '%s' at %L cannot have an initializer",
6622 sym->name, &sym->declared_at);
6624 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6625 sym->name, &sym->declared_at);
6632 /* Check to see if a derived type is blocked from being host associated
6633 by the presence of another class I symbol in the same namespace.
6634 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6635 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6636 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6639 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6640 if (s && (s->attr.flavor != FL_DERIVED
6641 || !gfc_compare_derived_types (s, sym->ts.derived)))
6643 gfc_error ("The type %s cannot be host associated at %L because "
6644 "it is blocked by an incompatible object of the same "
6645 "name at %L", sym->ts.derived->name, &sym->declared_at,
6651 /* Do not use gfc_default_initializer to test for a default initializer
6652 in the fortran because it generates a hidden default for allocatable
6655 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6656 c = has_default_initializer (sym->ts.derived);
6658 /* 4th constraint in section 11.3: "If an object of a type for which
6659 component-initialization is specified (R429) appears in the
6660 specification-part of a module and does not have the ALLOCATABLE
6661 or POINTER attribute, the object shall have the SAVE attribute." */
6662 if (c && sym->ns->proc_name
6663 && sym->ns->proc_name->attr.flavor == FL_MODULE
6664 && !sym->ns->save_all && !sym->attr.save
6665 && !sym->attr.pointer && !sym->attr.allocatable)
6667 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6668 sym->name, &sym->declared_at,
6669 "for default initialization of a component");
6673 /* Assign default initializer. */
6674 if (sym->ts.type == BT_DERIVED
6676 && !sym->attr.pointer
6677 && !sym->attr.allocatable
6678 && (!flag || sym->attr.intent == INTENT_OUT))
6679 sym->value = gfc_default_initializer (&sym->ts);
6685 /* Resolve a procedure. */
6688 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6690 gfc_formal_arglist *arg;
6692 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6693 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6694 "interfaces", sym->name, &sym->declared_at);
6696 if (sym->attr.function
6697 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6700 if (sym->ts.type == BT_CHARACTER)
6702 gfc_charlen *cl = sym->ts.cl;
6704 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6705 && resolve_charlen (cl) == FAILURE)
6708 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6710 if (sym->attr.proc == PROC_ST_FUNCTION)
6712 gfc_error ("Character-valued statement function '%s' at %L must "
6713 "have constant length", sym->name, &sym->declared_at);
6717 if (sym->attr.external && sym->formal == NULL
6718 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6720 gfc_error ("Automatic character length function '%s' at %L must "
6721 "have an explicit interface", sym->name,
6728 /* Ensure that derived type for are not of a private type. Internal
6729 module procedures are excluded by 2.2.3.3 - ie. they are not
6730 externally accessible and can access all the objects accessible in
6732 if (!(sym->ns->parent
6733 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6734 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6736 gfc_interface *iface;
6738 for (arg = sym->formal; arg; arg = arg->next)
6741 && arg->sym->ts.type == BT_DERIVED
6742 && !arg->sym->ts.derived->attr.use_assoc
6743 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6744 arg->sym->ts.derived->ns->default_access))
6746 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6747 "a dummy argument of '%s', which is "
6748 "PUBLIC at %L", arg->sym->name, sym->name,
6750 /* Stop this message from recurring. */
6751 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6756 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6757 PRIVATE to the containing module. */
6758 for (iface = sym->generic; iface; iface = iface->next)
6760 for (arg = iface->sym->formal; arg; arg = arg->next)
6763 && arg->sym->ts.type == BT_DERIVED
6764 && !arg->sym->ts.derived->attr.use_assoc
6765 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6766 arg->sym->ts.derived->ns->default_access))
6768 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6769 "dummy arguments of '%s' which is PRIVATE",
6770 iface->sym->name, sym->name, &iface->sym->declared_at,
6771 gfc_typename(&arg->sym->ts));
6772 /* Stop this message from recurring. */
6773 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6779 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6780 PRIVATE to the containing module. */
6781 for (iface = sym->generic; iface; iface = iface->next)
6783 for (arg = iface->sym->formal; arg; arg = arg->next)
6786 && arg->sym->ts.type == BT_DERIVED
6787 && !arg->sym->ts.derived->attr.use_assoc
6788 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6789 arg->sym->ts.derived->ns->default_access))
6791 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6792 "dummy arguments of '%s' which is PRIVATE",
6793 iface->sym->name, sym->name, &iface->sym->declared_at,
6794 gfc_typename(&arg->sym->ts));
6795 /* Stop this message from recurring. */
6796 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6803 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
6805 gfc_error ("Function '%s' at %L cannot have an initializer",
6806 sym->name, &sym->declared_at);
6810 /* An external symbol may not have an initializer because it is taken to be
6812 if (sym->attr.external && sym->value)
6814 gfc_error ("External object '%s' at %L may not have an initializer",
6815 sym->name, &sym->declared_at);
6819 /* An elemental function is required to return a scalar 12.7.1 */
6820 if (sym->attr.elemental && sym->attr.function && sym->as)
6822 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6823 "result", sym->name, &sym->declared_at);
6824 /* Reset so that the error only occurs once. */
6825 sym->attr.elemental = 0;
6829 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6830 char-len-param shall not be array-valued, pointer-valued, recursive
6831 or pure. ....snip... A character value of * may only be used in the
6832 following ways: (i) Dummy arg of procedure - dummy associates with
6833 actual length; (ii) To declare a named constant; or (iii) External
6834 function - but length must be declared in calling scoping unit. */
6835 if (sym->attr.function
6836 && sym->ts.type == BT_CHARACTER
6837 && sym->ts.cl && sym->ts.cl->length == NULL)
6839 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6840 || (sym->attr.recursive) || (sym->attr.pure))
6842 if (sym->as && sym->as->rank)
6843 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6844 "array-valued", sym->name, &sym->declared_at);
6846 if (sym->attr.pointer)
6847 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6848 "pointer-valued", sym->name, &sym->declared_at);
6851 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6852 "pure", sym->name, &sym->declared_at);
6854 if (sym->attr.recursive)
6855 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6856 "recursive", sym->name, &sym->declared_at);
6861 /* Appendix B.2 of the standard. Contained functions give an
6862 error anyway. Fixed-form is likely to be F77/legacy. */
6863 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6864 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6865 "'%s' at %L is obsolescent in fortran 95",
6866 sym->name, &sym->declared_at);
6869 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6871 gfc_formal_arglist *curr_arg;
6872 int has_non_interop_arg = 0;
6874 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6875 sym->common_block) == FAILURE)
6877 /* Clear these to prevent looking at them again if there was an
6879 sym->attr.is_bind_c = 0;
6880 sym->attr.is_c_interop = 0;
6881 sym->ts.is_c_interop = 0;
6885 /* So far, no errors have been found. */
6886 sym->attr.is_c_interop = 1;
6887 sym->ts.is_c_interop = 1;
6890 curr_arg = sym->formal;
6891 while (curr_arg != NULL)
6893 /* Skip implicitly typed dummy args here. */
6894 if (curr_arg->sym->attr.implicit_type == 0)
6895 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
6896 /* If something is found to fail, record the fact so we
6897 can mark the symbol for the procedure as not being
6898 BIND(C) to try and prevent multiple errors being
6900 has_non_interop_arg = 1;
6902 curr_arg = curr_arg->next;
6905 /* See if any of the arguments were not interoperable and if so, clear
6906 the procedure symbol to prevent duplicate error messages. */
6907 if (has_non_interop_arg != 0)
6909 sym->attr.is_c_interop = 0;
6910 sym->ts.is_c_interop = 0;
6911 sym->attr.is_bind_c = 0;
6919 /* Resolve the components of a derived type. */
6922 resolve_fl_derived (gfc_symbol *sym)
6925 gfc_dt_list * dt_list;
6928 for (c = sym->components; c != NULL; c = c->next)
6930 if (c->ts.type == BT_CHARACTER)
6932 if (c->ts.cl->length == NULL
6933 || (resolve_charlen (c->ts.cl) == FAILURE)
6934 || !gfc_is_constant_expr (c->ts.cl->length))
6936 gfc_error ("Character length of component '%s' needs to "
6937 "be a constant specification expression at %L",
6939 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6944 if (c->ts.type == BT_DERIVED
6945 && sym->component_access != ACCESS_PRIVATE
6946 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6947 && !c->ts.derived->attr.use_assoc
6948 && !gfc_check_access (c->ts.derived->attr.access,
6949 c->ts.derived->ns->default_access))
6951 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6952 "a component of '%s', which is PUBLIC at %L",
6953 c->name, sym->name, &sym->declared_at);
6957 if (sym->attr.sequence)
6959 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6961 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6962 "not have the SEQUENCE attribute",
6963 c->ts.derived->name, &sym->declared_at);
6968 if (c->ts.type == BT_DERIVED && c->pointer
6969 && c->ts.derived->components == NULL)
6971 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6972 "that has not been declared", c->name, sym->name,
6977 if (c->pointer || c->allocatable || c->as == NULL)
6980 for (i = 0; i < c->as->rank; i++)
6982 if (c->as->lower[i] == NULL
6983 || !gfc_is_constant_expr (c->as->lower[i])
6984 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6985 || c->as->upper[i] == NULL
6986 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6987 || !gfc_is_constant_expr (c->as->upper[i]))
6989 gfc_error ("Component '%s' of '%s' at %L must have "
6990 "constant array bounds",
6991 c->name, sym->name, &c->loc);
6997 /* Add derived type to the derived type list. */
6998 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
6999 if (sym == dt_list->derived)
7002 if (dt_list == NULL)
7004 dt_list = gfc_get_dt_list ();
7005 dt_list->next = gfc_derived_types;
7006 dt_list->derived = sym;
7007 gfc_derived_types = dt_list;
7015 resolve_fl_namelist (gfc_symbol *sym)
7020 /* Reject PRIVATE objects in a PUBLIC namelist. */
7021 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7023 for (nl = sym->namelist; nl; nl = nl->next)
7025 if (!nl->sym->attr.use_assoc
7026 && !(sym->ns->parent == nl->sym->ns)
7027 && !(sym->ns->parent
7028 && sym->ns->parent->parent == nl->sym->ns)
7029 && !gfc_check_access(nl->sym->attr.access,
7030 nl->sym->ns->default_access))
7032 gfc_error ("PRIVATE symbol '%s' cannot be member of "
7033 "PUBLIC namelist at %L", nl->sym->name,
7040 /* Reject namelist arrays that are not constant shape. */
7041 for (nl = sym->namelist; nl; nl = nl->next)
7043 if (is_non_constant_shape_array (nl->sym))
7045 gfc_error ("The array '%s' must have constant shape to be "
7046 "a NAMELIST object at %L", nl->sym->name,
7052 /* Namelist objects cannot have allocatable components. */
7053 for (nl = sym->namelist; nl; nl = nl->next)
7055 if (nl->sym->ts.type == BT_DERIVED
7056 && nl->sym->ts.derived->attr.alloc_comp)
7058 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
7059 "components", nl->sym->name, &sym->declared_at);
7064 /* 14.1.2 A module or internal procedure represent local entities
7065 of the same type as a namelist member and so are not allowed. */
7066 for (nl = sym->namelist; nl; nl = nl->next)
7068 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7071 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7072 if ((nl->sym == sym->ns->proc_name)
7074 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7078 if (nl->sym && nl->sym->name)
7079 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7080 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7082 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7083 "attribute in '%s' at %L", nlsym->name,
7094 resolve_fl_parameter (gfc_symbol *sym)
7096 /* A parameter array's shape needs to be constant. */
7097 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
7099 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7100 "or assumed shape", sym->name, &sym->declared_at);
7104 /* Make sure a parameter that has been implicitly typed still
7105 matches the implicit type, since PARAMETER statements can precede
7106 IMPLICIT statements. */
7107 if (sym->attr.implicit_type
7108 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7110 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7111 "later IMPLICIT type", sym->name, &sym->declared_at);
7115 /* Make sure the types of derived parameters are consistent. This
7116 type checking is deferred until resolution because the type may
7117 refer to a derived type from the host. */
7118 if (sym->ts.type == BT_DERIVED
7119 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7121 gfc_error ("Incompatible derived type in PARAMETER at %L",
7122 &sym->value->where);
7129 /* Do anything necessary to resolve a symbol. Right now, we just
7130 assume that an otherwise unknown symbol is a variable. This sort
7131 of thing commonly happens for symbols in module. */
7134 resolve_symbol (gfc_symbol *sym)
7136 int check_constant, mp_flag;
7137 gfc_symtree *symtree;
7138 gfc_symtree *this_symtree;
7142 if (sym->attr.flavor == FL_UNKNOWN)
7145 /* If we find that a flavorless symbol is an interface in one of the
7146 parent namespaces, find its symtree in this namespace, free the
7147 symbol and set the symtree to point to the interface symbol. */
7148 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7150 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7151 if (symtree && symtree->n.sym->generic)
7153 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7157 gfc_free_symbol (sym);
7158 symtree->n.sym->refs++;
7159 this_symtree->n.sym = symtree->n.sym;
7164 /* Otherwise give it a flavor according to such attributes as
7166 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7167 sym->attr.flavor = FL_VARIABLE;
7170 sym->attr.flavor = FL_PROCEDURE;
7171 if (sym->attr.dimension)
7172 sym->attr.function = 1;
7176 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7179 /* Symbols that are module procedures with results (functions) have
7180 the types and array specification copied for type checking in
7181 procedures that call them, as well as for saving to a module
7182 file. These symbols can't stand the scrutiny that their results
7184 mp_flag = (sym->result != NULL && sym->result != sym);
7187 /* Make sure that the intrinsic is consistent with its internal
7188 representation. This needs to be done before assigning a default
7189 type to avoid spurious warnings. */
7190 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7192 if (gfc_intrinsic_name (sym->name, 0))
7194 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7195 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7196 sym->name, &sym->declared_at);
7198 else if (gfc_intrinsic_name (sym->name, 1))
7200 if (sym->ts.type != BT_UNKNOWN)
7202 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7203 sym->name, &sym->declared_at);
7209 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7214 /* Assign default type to symbols that need one and don't have one. */
7215 if (sym->ts.type == BT_UNKNOWN)
7217 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7218 gfc_set_default_type (sym, 1, NULL);
7220 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7222 /* The specific case of an external procedure should emit an error
7223 in the case that there is no implicit type. */
7225 gfc_set_default_type (sym, sym->attr.external, NULL);
7228 /* Result may be in another namespace. */
7229 resolve_symbol (sym->result);
7231 sym->ts = sym->result->ts;
7232 sym->as = gfc_copy_array_spec (sym->result->as);
7233 sym->attr.dimension = sym->result->attr.dimension;
7234 sym->attr.pointer = sym->result->attr.pointer;
7235 sym->attr.allocatable = sym->result->attr.allocatable;
7240 /* Assumed size arrays and assumed shape arrays must be dummy
7244 && (sym->as->type == AS_ASSUMED_SIZE
7245 || sym->as->type == AS_ASSUMED_SHAPE)
7246 && sym->attr.dummy == 0)
7248 if (sym->as->type == AS_ASSUMED_SIZE)
7249 gfc_error ("Assumed size array at %L must be a dummy argument",
7252 gfc_error ("Assumed shape array at %L must be a dummy argument",
7257 /* Make sure symbols with known intent or optional are really dummy
7258 variable. Because of ENTRY statement, this has to be deferred
7259 until resolution time. */
7261 if (!sym->attr.dummy
7262 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7264 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7268 if (sym->attr.value && !sym->attr.dummy)
7270 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7271 "it is not a dummy argument", sym->name, &sym->declared_at);
7275 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7277 gfc_charlen *cl = sym->ts.cl;
7278 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7280 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7281 "attribute must have constant length",
7282 sym->name, &sym->declared_at);
7286 if (sym->ts.is_c_interop
7287 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7289 gfc_error ("C interoperable character dummy variable '%s' at %L "
7290 "with VALUE attribute must have length one",
7291 sym->name, &sym->declared_at);
7296 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7297 do this for something that was implicitly typed because that is handled
7298 in gfc_set_default_type. Handle dummy arguments and procedure
7299 definitions separately. Also, anything that is use associated is not
7300 handled here but instead is handled in the module it is declared in.
7301 Finally, derived type definitions are allowed to be BIND(C) since that
7302 only implies that they're interoperable, and they are checked fully for
7303 interoperability when a variable is declared of that type. */
7304 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7305 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7306 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7310 /* First, make sure the variable is declared at the
7311 module-level scope (J3/04-007, Section 15.3). */
7312 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7313 sym->attr.in_common == 0)
7315 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7316 "is neither a COMMON block nor declared at the "
7317 "module level scope", sym->name, &(sym->declared_at));
7320 else if (sym->common_head != NULL)
7322 t = verify_com_block_vars_c_interop (sym->common_head);
7326 /* If type() declaration, we need to verify that the components
7327 of the given type are all C interoperable, etc. */
7328 if (sym->ts.type == BT_DERIVED &&
7329 sym->ts.derived->attr.is_c_interop != 1)
7331 /* Make sure the user marked the derived type as BIND(C). If
7332 not, call the verify routine. This could print an error
7333 for the derived type more than once if multiple variables
7334 of that type are declared. */
7335 if (sym->ts.derived->attr.is_bind_c != 1)
7336 verify_bind_c_derived_type (sym->ts.derived);
7340 /* Verify the variable itself as C interoperable if it
7341 is BIND(C). It is not possible for this to succeed if
7342 the verify_bind_c_derived_type failed, so don't have to handle
7343 any error returned by verify_bind_c_derived_type. */
7344 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7350 /* clear the is_bind_c flag to prevent reporting errors more than
7351 once if something failed. */
7352 sym->attr.is_bind_c = 0;
7357 /* If a derived type symbol has reached this point, without its
7358 type being declared, we have an error. Notice that most
7359 conditions that produce undefined derived types have already
7360 been dealt with. However, the likes of:
7361 implicit type(t) (t) ..... call foo (t) will get us here if
7362 the type is not declared in the scope of the implicit
7363 statement. Change the type to BT_UNKNOWN, both because it is so
7364 and to prevent an ICE. */
7365 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7367 gfc_error ("The derived type '%s' at %L is of type '%s', "
7368 "which has not been defined", sym->name,
7369 &sym->declared_at, sym->ts.derived->name);
7370 sym->ts.type = BT_UNKNOWN;
7374 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7375 default initialization is defined (5.1.2.4.4). */
7376 if (sym->ts.type == BT_DERIVED
7378 && sym->attr.intent == INTENT_OUT
7380 && sym->as->type == AS_ASSUMED_SIZE)
7382 for (c = sym->ts.derived->components; c; c = c->next)
7386 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7387 "ASSUMED SIZE and so cannot have a default initializer",
7388 sym->name, &sym->declared_at);
7394 switch (sym->attr.flavor)
7397 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7402 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7407 if (resolve_fl_namelist (sym) == FAILURE)
7412 if (resolve_fl_parameter (sym) == FAILURE)
7420 /* Resolve array specifier. Check as well some constraints
7421 on COMMON blocks. */
7423 check_constant = sym->attr.in_common && !sym->attr.pointer;
7425 /* Set the formal_arg_flag so that check_conflict will not throw
7426 an error for host associated variables in the specification
7427 expression for an array_valued function. */
7428 if (sym->attr.function && sym->as)
7429 formal_arg_flag = 1;
7431 gfc_resolve_array_spec (sym->as, check_constant);
7433 formal_arg_flag = 0;
7435 /* Resolve formal namespaces. */
7436 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7437 gfc_resolve (sym->formal_ns);
7439 /* Check threadprivate restrictions. */
7440 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7441 && (!sym->attr.in_common
7442 && sym->module == NULL
7443 && (sym->ns->proc_name == NULL
7444 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7445 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7447 /* If we have come this far we can apply default-initializers, as
7448 described in 14.7.5, to those variables that have not already
7449 been assigned one. */
7450 if (sym->ts.type == BT_DERIVED
7451 && sym->attr.referenced
7452 && sym->ns == gfc_current_ns
7454 && !sym->attr.allocatable
7455 && !sym->attr.alloc_comp)
7457 symbol_attribute *a = &sym->attr;
7459 if ((!a->save && !a->dummy && !a->pointer
7460 && !a->in_common && !a->use_assoc
7461 && !(a->function && sym != sym->result))
7462 || (a->dummy && a->intent == INTENT_OUT))
7463 apply_default_init (sym);
7468 /************* Resolve DATA statements *************/
7472 gfc_data_value *vnode;
7478 /* Advance the values structure to point to the next value in the data list. */
7481 next_data_value (void)
7483 while (values.left == 0)
7485 if (values.vnode->next == NULL)
7488 values.vnode = values.vnode->next;
7489 values.left = values.vnode->repeat;
7497 check_data_variable (gfc_data_variable *var, locus *where)
7503 ar_type mark = AR_UNKNOWN;
7505 mpz_t section_index[GFC_MAX_DIMENSIONS];
7509 if (gfc_resolve_expr (var->expr) == FAILURE)
7513 mpz_init_set_si (offset, 0);
7516 if (e->expr_type != EXPR_VARIABLE)
7517 gfc_internal_error ("check_data_variable(): Bad expression");
7519 if (e->symtree->n.sym->ns->is_block_data
7520 && !e->symtree->n.sym->attr.in_common)
7522 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7523 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7528 mpz_init_set_ui (size, 1);
7535 /* Find the array section reference. */
7536 for (ref = e->ref; ref; ref = ref->next)
7538 if (ref->type != REF_ARRAY)
7540 if (ref->u.ar.type == AR_ELEMENT)
7546 /* Set marks according to the reference pattern. */
7547 switch (ref->u.ar.type)
7555 /* Get the start position of array section. */
7556 gfc_get_section_index (ar, section_index, &offset);
7564 if (gfc_array_size (e, &size) == FAILURE)
7566 gfc_error ("Nonconstant array section at %L in DATA statement",
7575 while (mpz_cmp_ui (size, 0) > 0)
7577 if (next_data_value () == FAILURE)
7579 gfc_error ("DATA statement at %L has more variables than values",
7585 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7589 /* If we have more than one element left in the repeat count,
7590 and we have more than one element left in the target variable,
7591 then create a range assignment. */
7592 /* ??? Only done for full arrays for now, since array sections
7594 if (mark == AR_FULL && ref && ref->next == NULL
7595 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7599 if (mpz_cmp_ui (size, values.left) >= 0)
7601 mpz_init_set_ui (range, values.left);
7602 mpz_sub_ui (size, size, values.left);
7607 mpz_init_set (range, size);
7608 values.left -= mpz_get_ui (size);
7609 mpz_set_ui (size, 0);
7612 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7615 mpz_add (offset, offset, range);
7619 /* Assign initial value to symbol. */
7623 mpz_sub_ui (size, size, 1);
7625 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7629 if (mark == AR_FULL)
7630 mpz_add_ui (offset, offset, 1);
7632 /* Modify the array section indexes and recalculate the offset
7633 for next element. */
7634 else if (mark == AR_SECTION)
7635 gfc_advance_section (section_index, ar, &offset);
7639 if (mark == AR_SECTION)
7641 for (i = 0; i < ar->dimen; i++)
7642 mpz_clear (section_index[i]);
7652 static try traverse_data_var (gfc_data_variable *, locus *);
7654 /* Iterate over a list of elements in a DATA statement. */
7657 traverse_data_list (gfc_data_variable *var, locus *where)
7660 iterator_stack frame;
7661 gfc_expr *e, *start, *end, *step;
7662 try retval = SUCCESS;
7664 mpz_init (frame.value);
7666 start = gfc_copy_expr (var->iter.start);
7667 end = gfc_copy_expr (var->iter.end);
7668 step = gfc_copy_expr (var->iter.step);
7670 if (gfc_simplify_expr (start, 1) == FAILURE
7671 || start->expr_type != EXPR_CONSTANT)
7673 gfc_error ("iterator start at %L does not simplify", &start->where);
7677 if (gfc_simplify_expr (end, 1) == FAILURE
7678 || end->expr_type != EXPR_CONSTANT)
7680 gfc_error ("iterator end at %L does not simplify", &end->where);
7684 if (gfc_simplify_expr (step, 1) == FAILURE
7685 || step->expr_type != EXPR_CONSTANT)
7687 gfc_error ("iterator step at %L does not simplify", &step->where);
7692 mpz_init_set (trip, end->value.integer);
7693 mpz_sub (trip, trip, start->value.integer);
7694 mpz_add (trip, trip, step->value.integer);
7696 mpz_div (trip, trip, step->value.integer);
7698 mpz_set (frame.value, start->value.integer);
7700 frame.prev = iter_stack;
7701 frame.variable = var->iter.var->symtree;
7702 iter_stack = &frame;
7704 while (mpz_cmp_ui (trip, 0) > 0)
7706 if (traverse_data_var (var->list, where) == FAILURE)
7713 e = gfc_copy_expr (var->expr);
7714 if (gfc_simplify_expr (e, 1) == FAILURE)
7722 mpz_add (frame.value, frame.value, step->value.integer);
7724 mpz_sub_ui (trip, trip, 1);
7729 mpz_clear (frame.value);
7731 gfc_free_expr (start);
7732 gfc_free_expr (end);
7733 gfc_free_expr (step);
7735 iter_stack = frame.prev;
7740 /* Type resolve variables in the variable list of a DATA statement. */
7743 traverse_data_var (gfc_data_variable *var, locus *where)
7747 for (; var; var = var->next)
7749 if (var->expr == NULL)
7750 t = traverse_data_list (var, where);
7752 t = check_data_variable (var, where);
7762 /* Resolve the expressions and iterators associated with a data statement.
7763 This is separate from the assignment checking because data lists should
7764 only be resolved once. */
7767 resolve_data_variables (gfc_data_variable *d)
7769 for (; d; d = d->next)
7771 if (d->list == NULL)
7773 if (gfc_resolve_expr (d->expr) == FAILURE)
7778 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7781 if (resolve_data_variables (d->list) == FAILURE)
7790 /* Resolve a single DATA statement. We implement this by storing a pointer to
7791 the value list into static variables, and then recursively traversing the
7792 variables list, expanding iterators and such. */
7795 resolve_data (gfc_data * d)
7797 if (resolve_data_variables (d->var) == FAILURE)
7800 values.vnode = d->value;
7801 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7803 if (traverse_data_var (d->var, &d->where) == FAILURE)
7806 /* At this point, we better not have any values left. */
7808 if (next_data_value () == SUCCESS)
7809 gfc_error ("DATA statement at %L has more values than variables",
7814 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7815 accessed by host or use association, is a dummy argument to a pure function,
7816 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7817 is storage associated with any such variable, shall not be used in the
7818 following contexts: (clients of this function). */
7820 /* Determines if a variable is not 'pure', ie not assignable within a pure
7821 procedure. Returns zero if assignment is OK, nonzero if there is a
7824 gfc_impure_variable (gfc_symbol *sym)
7828 if (sym->attr.use_assoc || sym->attr.in_common)
7831 if (sym->ns != gfc_current_ns)
7832 return !sym->attr.function;
7834 proc = sym->ns->proc_name;
7835 if (sym->attr.dummy && gfc_pure (proc)
7836 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7838 proc->attr.function))
7841 /* TODO: Sort out what can be storage associated, if anything, and include
7842 it here. In principle equivalences should be scanned but it does not
7843 seem to be possible to storage associate an impure variable this way. */
7848 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7849 symbol of the current procedure. */
7852 gfc_pure (gfc_symbol *sym)
7854 symbol_attribute attr;
7857 sym = gfc_current_ns->proc_name;
7863 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7867 /* Test whether the current procedure is elemental or not. */
7870 gfc_elemental (gfc_symbol *sym)
7872 symbol_attribute attr;
7875 sym = gfc_current_ns->proc_name;
7880 return attr.flavor == FL_PROCEDURE && attr.elemental;
7884 /* Warn about unused labels. */
7887 warn_unused_fortran_label (gfc_st_label *label)
7892 warn_unused_fortran_label (label->left);
7894 if (label->defined == ST_LABEL_UNKNOWN)
7897 switch (label->referenced)
7899 case ST_LABEL_UNKNOWN:
7900 gfc_warning ("Label %d at %L defined but not used", label->value,
7904 case ST_LABEL_BAD_TARGET:
7905 gfc_warning ("Label %d at %L defined but cannot be used",
7906 label->value, &label->where);
7913 warn_unused_fortran_label (label->right);
7917 /* Returns the sequence type of a symbol or sequence. */
7920 sequence_type (gfc_typespec ts)
7929 if (ts.derived->components == NULL)
7930 return SEQ_NONDEFAULT;
7932 result = sequence_type (ts.derived->components->ts);
7933 for (c = ts.derived->components->next; c; c = c->next)
7934 if (sequence_type (c->ts) != result)
7940 if (ts.kind != gfc_default_character_kind)
7941 return SEQ_NONDEFAULT;
7943 return SEQ_CHARACTER;
7946 if (ts.kind != gfc_default_integer_kind)
7947 return SEQ_NONDEFAULT;
7952 if (!(ts.kind == gfc_default_real_kind
7953 || ts.kind == gfc_default_double_kind))
7954 return SEQ_NONDEFAULT;
7959 if (ts.kind != gfc_default_complex_kind)
7960 return SEQ_NONDEFAULT;
7965 if (ts.kind != gfc_default_logical_kind)
7966 return SEQ_NONDEFAULT;
7971 return SEQ_NONDEFAULT;
7976 /* Resolve derived type EQUIVALENCE object. */
7979 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
7982 gfc_component *c = derived->components;
7987 /* Shall not be an object of nonsequence derived type. */
7988 if (!derived->attr.sequence)
7990 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
7991 "attribute to be an EQUIVALENCE object", sym->name,
7996 /* Shall not have allocatable components. */
7997 if (derived->attr.alloc_comp)
7999 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8000 "components to be an EQUIVALENCE object",sym->name,
8005 for (; c ; c = c->next)
8009 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8012 /* Shall not be an object of sequence derived type containing a pointer
8013 in the structure. */
8016 gfc_error ("Derived type variable '%s' at %L with pointer "
8017 "component(s) cannot be an EQUIVALENCE object",
8018 sym->name, &e->where);
8026 /* Resolve equivalence object.
8027 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8028 an allocatable array, an object of nonsequence derived type, an object of
8029 sequence derived type containing a pointer at any level of component
8030 selection, an automatic object, a function name, an entry name, a result
8031 name, a named constant, a structure component, or a subobject of any of
8032 the preceding objects. A substring shall not have length zero. A
8033 derived type shall not have components with default initialization nor
8034 shall two objects of an equivalence group be initialized.
8035 Either all or none of the objects shall have an protected attribute.
8036 The simple constraints are done in symbol.c(check_conflict) and the rest
8037 are implemented here. */
8040 resolve_equivalence (gfc_equiv *eq)
8043 gfc_symbol *derived;
8044 gfc_symbol *first_sym;
8047 locus *last_where = NULL;
8048 seq_type eq_type, last_eq_type;
8049 gfc_typespec *last_ts;
8050 int object, cnt_protected;
8051 const char *value_name;
8055 last_ts = &eq->expr->symtree->n.sym->ts;
8057 first_sym = eq->expr->symtree->n.sym;
8061 for (object = 1; eq; eq = eq->eq, object++)
8065 e->ts = e->symtree->n.sym->ts;
8066 /* match_varspec might not know yet if it is seeing
8067 array reference or substring reference, as it doesn't
8069 if (e->ref && e->ref->type == REF_ARRAY)
8071 gfc_ref *ref = e->ref;
8072 sym = e->symtree->n.sym;
8074 if (sym->attr.dimension)
8076 ref->u.ar.as = sym->as;
8080 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8081 if (e->ts.type == BT_CHARACTER
8083 && ref->type == REF_ARRAY
8084 && ref->u.ar.dimen == 1
8085 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8086 && ref->u.ar.stride[0] == NULL)
8088 gfc_expr *start = ref->u.ar.start[0];
8089 gfc_expr *end = ref->u.ar.end[0];
8092 /* Optimize away the (:) reference. */
8093 if (start == NULL && end == NULL)
8098 e->ref->next = ref->next;
8103 ref->type = REF_SUBSTRING;
8105 start = gfc_int_expr (1);
8106 ref->u.ss.start = start;
8107 if (end == NULL && e->ts.cl)
8108 end = gfc_copy_expr (e->ts.cl->length);
8109 ref->u.ss.end = end;
8110 ref->u.ss.length = e->ts.cl;
8117 /* Any further ref is an error. */
8120 gcc_assert (ref->type == REF_ARRAY);
8121 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8127 if (gfc_resolve_expr (e) == FAILURE)
8130 sym = e->symtree->n.sym;
8132 if (sym->attr.protected)
8134 if (cnt_protected > 0 && cnt_protected != object)
8136 gfc_error ("Either all or none of the objects in the "
8137 "EQUIVALENCE set at %L shall have the "
8138 "PROTECTED attribute",
8143 /* Shall not equivalence common block variables in a PURE procedure. */
8144 if (sym->ns->proc_name
8145 && sym->ns->proc_name->attr.pure
8146 && sym->attr.in_common)
8148 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8149 "object in the pure procedure '%s'",
8150 sym->name, &e->where, sym->ns->proc_name->name);
8154 /* Shall not be a named constant. */
8155 if (e->expr_type == EXPR_CONSTANT)
8157 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8158 "object", sym->name, &e->where);
8162 derived = e->ts.derived;
8163 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8166 /* Check that the types correspond correctly:
8168 A numeric sequence structure may be equivalenced to another sequence
8169 structure, an object of default integer type, default real type, double
8170 precision real type, default logical type such that components of the
8171 structure ultimately only become associated to objects of the same
8172 kind. A character sequence structure may be equivalenced to an object
8173 of default character kind or another character sequence structure.
8174 Other objects may be equivalenced only to objects of the same type and
8177 /* Identical types are unconditionally OK. */
8178 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8179 goto identical_types;
8181 last_eq_type = sequence_type (*last_ts);
8182 eq_type = sequence_type (sym->ts);
8184 /* Since the pair of objects is not of the same type, mixed or
8185 non-default sequences can be rejected. */
8187 msg = "Sequence %s with mixed components in EQUIVALENCE "
8188 "statement at %L with different type objects";
8190 && last_eq_type == SEQ_MIXED
8191 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8193 || (eq_type == SEQ_MIXED
8194 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8195 &e->where) == FAILURE))
8198 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8199 "statement at %L with objects of different type";
8201 && last_eq_type == SEQ_NONDEFAULT
8202 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8203 last_where) == FAILURE)
8204 || (eq_type == SEQ_NONDEFAULT
8205 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8206 &e->where) == FAILURE))
8209 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8210 "EQUIVALENCE statement at %L";
8211 if (last_eq_type == SEQ_CHARACTER
8212 && eq_type != SEQ_CHARACTER
8213 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8214 &e->where) == FAILURE)
8217 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8218 "EQUIVALENCE statement at %L";
8219 if (last_eq_type == SEQ_NUMERIC
8220 && eq_type != SEQ_NUMERIC
8221 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8222 &e->where) == FAILURE)
8227 last_where = &e->where;
8232 /* Shall not be an automatic array. */
8233 if (e->ref->type == REF_ARRAY
8234 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8236 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8237 "an EQUIVALENCE object", sym->name, &e->where);
8244 /* Shall not be a structure component. */
8245 if (r->type == REF_COMPONENT)
8247 gfc_error ("Structure component '%s' at %L cannot be an "
8248 "EQUIVALENCE object",
8249 r->u.c.component->name, &e->where);
8253 /* A substring shall not have length zero. */
8254 if (r->type == REF_SUBSTRING)
8256 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8258 gfc_error ("Substring at %L has length zero",
8259 &r->u.ss.start->where);
8269 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8272 resolve_fntype (gfc_namespace *ns)
8277 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8280 /* If there are any entries, ns->proc_name is the entry master
8281 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8283 sym = ns->entries->sym;
8285 sym = ns->proc_name;
8286 if (sym->result == sym
8287 && sym->ts.type == BT_UNKNOWN
8288 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8289 && !sym->attr.untyped)
8291 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8292 sym->name, &sym->declared_at);
8293 sym->attr.untyped = 1;
8296 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8297 && !gfc_check_access (sym->ts.derived->attr.access,
8298 sym->ts.derived->ns->default_access)
8299 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8301 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8302 sym->name, &sym->declared_at, sym->ts.derived->name);
8306 for (el = ns->entries->next; el; el = el->next)
8308 if (el->sym->result == el->sym
8309 && el->sym->ts.type == BT_UNKNOWN
8310 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8311 && !el->sym->attr.untyped)
8313 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8314 el->sym->name, &el->sym->declared_at);
8315 el->sym->attr.untyped = 1;
8320 /* 12.3.2.1.1 Defined operators. */
8323 gfc_resolve_uops (gfc_symtree *symtree)
8327 gfc_formal_arglist *formal;
8329 if (symtree == NULL)
8332 gfc_resolve_uops (symtree->left);
8333 gfc_resolve_uops (symtree->right);
8335 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8338 if (!sym->attr.function)
8339 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8340 sym->name, &sym->declared_at);
8342 if (sym->ts.type == BT_CHARACTER
8343 && !(sym->ts.cl && sym->ts.cl->length)
8344 && !(sym->result && sym->result->ts.cl
8345 && sym->result->ts.cl->length))
8346 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8347 "character length", sym->name, &sym->declared_at);
8349 formal = sym->formal;
8350 if (!formal || !formal->sym)
8352 gfc_error ("User operator procedure '%s' at %L must have at least "
8353 "one argument", sym->name, &sym->declared_at);
8357 if (formal->sym->attr.intent != INTENT_IN)
8358 gfc_error ("First argument of operator interface at %L must be "
8359 "INTENT(IN)", &sym->declared_at);
8361 if (formal->sym->attr.optional)
8362 gfc_error ("First argument of operator interface at %L cannot be "
8363 "optional", &sym->declared_at);
8365 formal = formal->next;
8366 if (!formal || !formal->sym)
8369 if (formal->sym->attr.intent != INTENT_IN)
8370 gfc_error ("Second argument of operator interface at %L must be "
8371 "INTENT(IN)", &sym->declared_at);
8373 if (formal->sym->attr.optional)
8374 gfc_error ("Second argument of operator interface at %L cannot be "
8375 "optional", &sym->declared_at);
8378 gfc_error ("Operator interface at %L must have, at most, two "
8379 "arguments", &sym->declared_at);
8384 /* Examine all of the expressions associated with a program unit,
8385 assign types to all intermediate expressions, make sure that all
8386 assignments are to compatible types and figure out which names
8387 refer to which functions or subroutines. It doesn't check code
8388 block, which is handled by resolve_code. */
8391 resolve_types (gfc_namespace *ns)
8398 gfc_current_ns = ns;
8400 resolve_entries (ns);
8402 resolve_common_blocks (ns->common_root);
8404 resolve_contained_functions (ns);
8406 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8408 for (cl = ns->cl_list; cl; cl = cl->next)
8409 resolve_charlen (cl);
8411 gfc_traverse_ns (ns, resolve_symbol);
8413 resolve_fntype (ns);
8415 for (n = ns->contained; n; n = n->sibling)
8417 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8418 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8419 "also be PURE", n->proc_name->name,
8420 &n->proc_name->declared_at);
8426 gfc_check_interfaces (ns);
8428 gfc_traverse_ns (ns, resolve_values);
8434 for (d = ns->data; d; d = d->next)
8438 gfc_traverse_ns (ns, gfc_formalize_init_value);
8440 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8442 if (ns->common_root != NULL)
8443 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8445 for (eq = ns->equiv; eq; eq = eq->next)
8446 resolve_equivalence (eq);
8448 /* Warn about unused labels. */
8449 if (warn_unused_label)
8450 warn_unused_fortran_label (ns->st_labels);
8452 gfc_resolve_uops (ns->uop_root);
8456 /* Call resolve_code recursively. */
8459 resolve_codes (gfc_namespace *ns)
8463 for (n = ns->contained; n; n = n->sibling)
8466 gfc_current_ns = ns;
8468 /* Set to an out of range value. */
8469 current_entry_id = -1;
8471 bitmap_obstack_initialize (&labels_obstack);
8472 resolve_code (ns->code, ns);
8473 bitmap_obstack_release (&labels_obstack);
8477 /* This function is called after a complete program unit has been compiled.
8478 Its purpose is to examine all of the expressions associated with a program
8479 unit, assign types to all intermediate expressions, make sure that all
8480 assignments are to compatible types and figure out which names refer to
8481 which functions or subroutines. */
8484 gfc_resolve (gfc_namespace *ns)
8486 gfc_namespace *old_ns;
8488 old_ns = gfc_current_ns;
8493 gfc_current_ns = old_ns;