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_c_interop != 1)
1909 gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
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;
2285 sprintf (name, "%s_%c%d", sym->name, type, kind);
2286 /* Set up the binding label as the given symbol's label plus
2287 the type and kind. */
2288 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2292 /* If the second arg is missing, set the name and label as
2293 was, cause it should at least be found, and the missing
2294 arg error will be caught by compare_parameters(). */
2295 sprintf (name, "%s", sym->name);
2296 sprintf (binding_label, "%s", sym->binding_label);
2303 /* Resolve a generic version of the iso_c_binding procedure given
2304 (sym) to the specific one based on the type and kind of the
2305 argument(s). Currently, this function resolves c_f_pointer() and
2306 c_f_procpointer based on the type and kind of the second argument
2307 (FPTR). Other iso_c_binding procedures aren't specially handled.
2308 Upon successfully exiting, c->resolved_sym will hold the resolved
2309 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2313 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2315 gfc_symbol *new_sym;
2316 /* this is fine, since we know the names won't use the max */
2317 char name[GFC_MAX_SYMBOL_LEN + 1];
2318 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2319 /* default to success; will override if find error */
2320 match m = MATCH_YES;
2321 gfc_symbol *tmp_sym;
2323 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2324 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2326 set_name_and_label (c, sym, name, binding_label);
2328 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2330 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2332 /* Make sure we got a third arg. The type/rank of it will
2333 be checked later if it's there (gfc_procedure_use()). */
2334 if (c->ext.actual->next->expr->rank != 0 &&
2335 c->ext.actual->next->next == NULL)
2338 gfc_error ("Missing SHAPE parameter for call to %s "
2339 "at %L", sym->name, &(c->loc));
2341 /* Make sure the param is a POINTER. No need to make sure
2342 it does not have INTENT(IN) since it is a POINTER. */
2343 tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
2344 if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
2346 gfc_error ("Argument '%s' to '%s' at %L "
2347 "must have the POINTER attribute",
2348 tmp_sym->name, sym->name, &(c->loc));
2354 if (m != MATCH_ERROR)
2356 /* the 1 means to add the optional arg to formal list */
2357 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2359 /* for error reporting, say it's declared where the original was */
2360 new_sym->declared_at = sym->declared_at;
2363 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2365 /* TODO: Figure out if this is even reacable; this part of the
2366 conditional may not be necessary. */
2368 if (c->ext.actual->next == NULL)
2370 /* The user did not give two args, so resolve to the version
2371 of c_associated expecting one arg. */
2373 /* get rid of the second arg */
2374 /* TODO!! Should free up the memory here! */
2375 sym->formal->next = NULL;
2383 sprintf (name, "%s_%d", sym->name, num_args);
2384 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2385 sym->name = gfc_get_string (name);
2386 strcpy (sym->binding_label, binding_label);
2390 /* no differences for c_loc or c_funloc */
2394 /* set the resolved symbol */
2395 if (m != MATCH_ERROR)
2397 gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
2398 c->resolved_sym = new_sym;
2401 c->resolved_sym = sym;
2407 /* Resolve a subroutine call known to be specific. */
2410 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2414 if(sym->attr.is_iso_c)
2416 m = gfc_iso_c_sub_interface (c,sym);
2420 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2422 if (sym->attr.dummy)
2424 sym->attr.proc = PROC_DUMMY;
2428 sym->attr.proc = PROC_EXTERNAL;
2432 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2435 if (sym->attr.intrinsic)
2437 m = gfc_intrinsic_sub_interface (c, 1);
2441 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2442 "with an intrinsic", sym->name, &c->loc);
2450 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2452 c->resolved_sym = sym;
2453 pure_subroutine (c, sym);
2460 resolve_specific_s (gfc_code *c)
2465 sym = c->symtree->n.sym;
2469 m = resolve_specific_s0 (c, sym);
2472 if (m == MATCH_ERROR)
2475 if (sym->ns->parent == NULL)
2478 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2484 sym = c->symtree->n.sym;
2485 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2486 sym->name, &c->loc);
2492 /* Resolve a subroutine call not known to be generic nor specific. */
2495 resolve_unknown_s (gfc_code *c)
2499 sym = c->symtree->n.sym;
2501 if (sym->attr.dummy)
2503 sym->attr.proc = PROC_DUMMY;
2507 /* See if we have an intrinsic function reference. */
2509 if (gfc_intrinsic_name (sym->name, 1))
2511 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2516 /* The reference is to an external name. */
2519 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2521 c->resolved_sym = sym;
2523 pure_subroutine (c, sym);
2529 /* Resolve a subroutine call. Although it was tempting to use the same code
2530 for functions, subroutines and functions are stored differently and this
2531 makes things awkward. */
2534 resolve_call (gfc_code *c)
2537 procedure_type ptype = PROC_INTRINSIC;
2539 if (c->symtree && c->symtree->n.sym
2540 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2542 gfc_error ("'%s' at %L has a type, which is not consistent with "
2543 "the CALL at %L", c->symtree->n.sym->name,
2544 &c->symtree->n.sym->declared_at, &c->loc);
2548 /* If external, check for usage. */
2549 if (c->symtree && is_external_proc (c->symtree->n.sym))
2550 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2552 /* Subroutines without the RECURSIVE attribution are not allowed to
2553 * call themselves. */
2554 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2556 gfc_symbol *csym, *proc;
2557 csym = c->symtree->n.sym;
2558 proc = gfc_current_ns->proc_name;
2561 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2562 "RECURSIVE", csym->name, &c->loc);
2566 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2567 && csym->ns->entries->sym == proc->ns->entries->sym)
2569 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2570 "'%s' is not declared as RECURSIVE",
2571 csym->name, &c->loc, csym->ns->entries->sym->name);
2576 /* Switch off assumed size checking and do this again for certain kinds
2577 of procedure, once the procedure itself is resolved. */
2578 need_full_assumed_size++;
2580 if (c->symtree && c->symtree->n.sym)
2581 ptype = c->symtree->n.sym->attr.proc;
2583 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2586 /* Resume assumed_size checking. */
2587 need_full_assumed_size--;
2590 if (c->resolved_sym == NULL)
2591 switch (procedure_kind (c->symtree->n.sym))
2594 t = resolve_generic_s (c);
2597 case PTYPE_SPECIFIC:
2598 t = resolve_specific_s (c);
2602 t = resolve_unknown_s (c);
2606 gfc_internal_error ("resolve_subroutine(): bad function type");
2609 /* Some checks of elemental subroutine actual arguments. */
2610 if (resolve_elemental_actual (NULL, c) == FAILURE)
2614 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2619 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2620 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2621 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2622 if their shapes do not match. If either op1->shape or op2->shape is
2623 NULL, return SUCCESS. */
2626 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2633 if (op1->shape != NULL && op2->shape != NULL)
2635 for (i = 0; i < op1->rank; i++)
2637 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2639 gfc_error ("Shapes for operands at %L and %L are not conformable",
2640 &op1->where, &op2->where);
2651 /* Resolve an operator expression node. This can involve replacing the
2652 operation with a user defined function call. */
2655 resolve_operator (gfc_expr *e)
2657 gfc_expr *op1, *op2;
2659 bool dual_locus_error;
2662 /* Resolve all subnodes-- give them types. */
2664 switch (e->value.op.operator)
2667 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2670 /* Fall through... */
2673 case INTRINSIC_UPLUS:
2674 case INTRINSIC_UMINUS:
2675 case INTRINSIC_PARENTHESES:
2676 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2681 /* Typecheck the new node. */
2683 op1 = e->value.op.op1;
2684 op2 = e->value.op.op2;
2685 dual_locus_error = false;
2687 if ((op1 && op1->expr_type == EXPR_NULL)
2688 || (op2 && op2->expr_type == EXPR_NULL))
2690 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2694 switch (e->value.op.operator)
2696 case INTRINSIC_UPLUS:
2697 case INTRINSIC_UMINUS:
2698 if (op1->ts.type == BT_INTEGER
2699 || op1->ts.type == BT_REAL
2700 || op1->ts.type == BT_COMPLEX)
2706 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2707 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2710 case INTRINSIC_PLUS:
2711 case INTRINSIC_MINUS:
2712 case INTRINSIC_TIMES:
2713 case INTRINSIC_DIVIDE:
2714 case INTRINSIC_POWER:
2715 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2717 gfc_type_convert_binary (e);
2722 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2723 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2724 gfc_typename (&op2->ts));
2727 case INTRINSIC_CONCAT:
2728 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2730 e->ts.type = BT_CHARACTER;
2731 e->ts.kind = op1->ts.kind;
2736 _("Operands of string concatenation operator at %%L are %s/%s"),
2737 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2743 case INTRINSIC_NEQV:
2744 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2746 e->ts.type = BT_LOGICAL;
2747 e->ts.kind = gfc_kind_max (op1, op2);
2748 if (op1->ts.kind < e->ts.kind)
2749 gfc_convert_type (op1, &e->ts, 2);
2750 else if (op2->ts.kind < e->ts.kind)
2751 gfc_convert_type (op2, &e->ts, 2);
2755 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2756 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2757 gfc_typename (&op2->ts));
2762 if (op1->ts.type == BT_LOGICAL)
2764 e->ts.type = BT_LOGICAL;
2765 e->ts.kind = op1->ts.kind;
2769 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2770 gfc_typename (&op1->ts));
2774 case INTRINSIC_GT_OS:
2776 case INTRINSIC_GE_OS:
2778 case INTRINSIC_LT_OS:
2780 case INTRINSIC_LE_OS:
2781 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2783 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2787 /* Fall through... */
2790 case INTRINSIC_EQ_OS:
2792 case INTRINSIC_NE_OS:
2793 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2795 e->ts.type = BT_LOGICAL;
2796 e->ts.kind = gfc_default_logical_kind;
2800 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2802 gfc_type_convert_binary (e);
2804 e->ts.type = BT_LOGICAL;
2805 e->ts.kind = gfc_default_logical_kind;
2809 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2811 _("Logicals at %%L must be compared with %s instead of %s"),
2812 e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
2813 gfc_op2string (e->value.op.operator));
2816 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2817 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2818 gfc_typename (&op2->ts));
2822 case INTRINSIC_USER:
2823 if (e->value.op.uop->operator == NULL)
2824 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2825 else if (op2 == NULL)
2826 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2827 e->value.op.uop->name, gfc_typename (&op1->ts));
2829 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2830 e->value.op.uop->name, gfc_typename (&op1->ts),
2831 gfc_typename (&op2->ts));
2835 case INTRINSIC_PARENTHESES:
2839 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2842 /* Deal with arrayness of an operand through an operator. */
2846 switch (e->value.op.operator)
2848 case INTRINSIC_PLUS:
2849 case INTRINSIC_MINUS:
2850 case INTRINSIC_TIMES:
2851 case INTRINSIC_DIVIDE:
2852 case INTRINSIC_POWER:
2853 case INTRINSIC_CONCAT:
2857 case INTRINSIC_NEQV:
2859 case INTRINSIC_EQ_OS:
2861 case INTRINSIC_NE_OS:
2863 case INTRINSIC_GT_OS:
2865 case INTRINSIC_GE_OS:
2867 case INTRINSIC_LT_OS:
2869 case INTRINSIC_LE_OS:
2871 if (op1->rank == 0 && op2->rank == 0)
2874 if (op1->rank == 0 && op2->rank != 0)
2876 e->rank = op2->rank;
2878 if (e->shape == NULL)
2879 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2882 if (op1->rank != 0 && op2->rank == 0)
2884 e->rank = op1->rank;
2886 if (e->shape == NULL)
2887 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2890 if (op1->rank != 0 && op2->rank != 0)
2892 if (op1->rank == op2->rank)
2894 e->rank = op1->rank;
2895 if (e->shape == NULL)
2897 t = compare_shapes(op1, op2);
2901 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2906 /* Allow higher level expressions to work. */
2909 /* Try user-defined operators, and otherwise throw an error. */
2910 dual_locus_error = true;
2912 _("Inconsistent ranks for operator at %%L and %%L"));
2920 case INTRINSIC_UPLUS:
2921 case INTRINSIC_UMINUS:
2922 case INTRINSIC_PARENTHESES:
2923 e->rank = op1->rank;
2925 if (e->shape == NULL)
2926 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2928 /* Simply copy arrayness attribute */
2935 /* Attempt to simplify the expression. */
2938 t = gfc_simplify_expr (e, 0);
2939 /* Some calls do not succeed in simplification and return FAILURE
2940 even though there is no error; eg. variable references to
2941 PARAMETER arrays. */
2942 if (!gfc_is_constant_expr (e))
2949 if (gfc_extend_expr (e) == SUCCESS)
2952 if (dual_locus_error)
2953 gfc_error (msg, &op1->where, &op2->where);
2955 gfc_error (msg, &e->where);
2961 /************** Array resolution subroutines **************/
2964 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2967 /* Compare two integer expressions. */
2970 compare_bound (gfc_expr *a, gfc_expr *b)
2974 if (a == NULL || a->expr_type != EXPR_CONSTANT
2975 || b == NULL || b->expr_type != EXPR_CONSTANT)
2978 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2979 gfc_internal_error ("compare_bound(): Bad expression");
2981 i = mpz_cmp (a->value.integer, b->value.integer);
2991 /* Compare an integer expression with an integer. */
2994 compare_bound_int (gfc_expr *a, int b)
2998 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3001 if (a->ts.type != BT_INTEGER)
3002 gfc_internal_error ("compare_bound_int(): Bad expression");
3004 i = mpz_cmp_si (a->value.integer, b);
3014 /* Compare an integer expression with a mpz_t. */
3017 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3021 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3024 if (a->ts.type != BT_INTEGER)
3025 gfc_internal_error ("compare_bound_int(): Bad expression");
3027 i = mpz_cmp (a->value.integer, b);
3037 /* Compute the last value of a sequence given by a triplet.
3038 Return 0 if it wasn't able to compute the last value, or if the
3039 sequence if empty, and 1 otherwise. */
3042 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3043 gfc_expr *stride, mpz_t last)
3047 if (start == NULL || start->expr_type != EXPR_CONSTANT
3048 || end == NULL || end->expr_type != EXPR_CONSTANT
3049 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3052 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3053 || (stride != NULL && stride->ts.type != BT_INTEGER))
3056 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3058 if (compare_bound (start, end) == CMP_GT)
3060 mpz_set (last, end->value.integer);
3064 if (compare_bound_int (stride, 0) == CMP_GT)
3066 /* Stride is positive */
3067 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3072 /* Stride is negative */
3073 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3078 mpz_sub (rem, end->value.integer, start->value.integer);
3079 mpz_tdiv_r (rem, rem, stride->value.integer);
3080 mpz_sub (last, end->value.integer, rem);
3087 /* Compare a single dimension of an array reference to the array
3091 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3095 /* Given start, end and stride values, calculate the minimum and
3096 maximum referenced indexes. */
3104 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3106 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3113 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3114 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3116 comparison comp_start_end = compare_bound (AR_START, AR_END);
3118 /* Check for zero stride, which is not allowed. */
3119 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3121 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3125 /* if start == len || (stride > 0 && start < len)
3126 || (stride < 0 && start > len),
3127 then the array section contains at least one element. In this
3128 case, there is an out-of-bounds access if
3129 (start < lower || start > upper). */
3130 if (compare_bound (AR_START, AR_END) == CMP_EQ
3131 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3132 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3133 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3134 && comp_start_end == CMP_GT))
3136 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3137 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3141 /* If we can compute the highest index of the array section,
3142 then it also has to be between lower and upper. */
3143 mpz_init (last_value);
3144 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3147 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3148 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3150 mpz_clear (last_value);
3154 mpz_clear (last_value);
3162 gfc_internal_error ("check_dimension(): Bad array reference");
3168 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3173 /* Compare an array reference with an array specification. */
3176 compare_spec_to_ref (gfc_array_ref *ar)
3183 /* TODO: Full array sections are only allowed as actual parameters. */
3184 if (as->type == AS_ASSUMED_SIZE
3185 && (/*ar->type == AR_FULL
3186 ||*/ (ar->type == AR_SECTION
3187 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3189 gfc_error ("Rightmost upper bound of assumed size array section "
3190 "not specified at %L", &ar->where);
3194 if (ar->type == AR_FULL)
3197 if (as->rank != ar->dimen)
3199 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3200 &ar->where, ar->dimen, as->rank);
3204 for (i = 0; i < as->rank; i++)
3205 if (check_dimension (i, ar, as) == FAILURE)
3212 /* Resolve one part of an array index. */
3215 gfc_resolve_index (gfc_expr *index, int check_scalar)
3222 if (gfc_resolve_expr (index) == FAILURE)
3225 if (check_scalar && index->rank != 0)
3227 gfc_error ("Array index at %L must be scalar", &index->where);
3231 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3233 gfc_error ("Array index at %L must be of INTEGER type",
3238 if (index->ts.type == BT_REAL)
3239 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3240 &index->where) == FAILURE)
3243 if (index->ts.kind != gfc_index_integer_kind
3244 || index->ts.type != BT_INTEGER)
3247 ts.type = BT_INTEGER;
3248 ts.kind = gfc_index_integer_kind;
3250 gfc_convert_type_warn (index, &ts, 2, 0);
3256 /* Resolve a dim argument to an intrinsic function. */
3259 gfc_resolve_dim_arg (gfc_expr *dim)
3264 if (gfc_resolve_expr (dim) == FAILURE)
3269 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3273 if (dim->ts.type != BT_INTEGER)
3275 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3278 if (dim->ts.kind != gfc_index_integer_kind)
3282 ts.type = BT_INTEGER;
3283 ts.kind = gfc_index_integer_kind;
3285 gfc_convert_type_warn (dim, &ts, 2, 0);
3291 /* Given an expression that contains array references, update those array
3292 references to point to the right array specifications. While this is
3293 filled in during matching, this information is difficult to save and load
3294 in a module, so we take care of it here.
3296 The idea here is that the original array reference comes from the
3297 base symbol. We traverse the list of reference structures, setting
3298 the stored reference to references. Component references can
3299 provide an additional array specification. */
3302 find_array_spec (gfc_expr *e)
3306 gfc_symbol *derived;
3309 as = e->symtree->n.sym->as;
3312 for (ref = e->ref; ref; ref = ref->next)
3317 gfc_internal_error ("find_array_spec(): Missing spec");
3324 if (derived == NULL)
3325 derived = e->symtree->n.sym->ts.derived;
3327 c = derived->components;
3329 for (; c; c = c->next)
3330 if (c == ref->u.c.component)
3332 /* Track the sequence of component references. */
3333 if (c->ts.type == BT_DERIVED)
3334 derived = c->ts.derived;
3339 gfc_internal_error ("find_array_spec(): Component not found");
3344 gfc_internal_error ("find_array_spec(): unused as(1)");
3355 gfc_internal_error ("find_array_spec(): unused as(2)");
3359 /* Resolve an array reference. */
3362 resolve_array_ref (gfc_array_ref *ar)
3364 int i, check_scalar;
3367 for (i = 0; i < ar->dimen; i++)
3369 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3371 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3373 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3375 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3380 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3384 ar->dimen_type[i] = DIMEN_ELEMENT;
3388 ar->dimen_type[i] = DIMEN_VECTOR;
3389 if (e->expr_type == EXPR_VARIABLE
3390 && e->symtree->n.sym->ts.type == BT_DERIVED)
3391 ar->start[i] = gfc_get_parentheses (e);
3395 gfc_error ("Array index at %L is an array of rank %d",
3396 &ar->c_where[i], e->rank);
3401 /* If the reference type is unknown, figure out what kind it is. */
3403 if (ar->type == AR_UNKNOWN)
3405 ar->type = AR_ELEMENT;
3406 for (i = 0; i < ar->dimen; i++)
3407 if (ar->dimen_type[i] == DIMEN_RANGE
3408 || ar->dimen_type[i] == DIMEN_VECTOR)
3410 ar->type = AR_SECTION;
3415 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3423 resolve_substring (gfc_ref *ref)
3425 if (ref->u.ss.start != NULL)
3427 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3430 if (ref->u.ss.start->ts.type != BT_INTEGER)
3432 gfc_error ("Substring start index at %L must be of type INTEGER",
3433 &ref->u.ss.start->where);
3437 if (ref->u.ss.start->rank != 0)
3439 gfc_error ("Substring start index at %L must be scalar",
3440 &ref->u.ss.start->where);
3444 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3445 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3446 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3448 gfc_error ("Substring start index at %L is less than one",
3449 &ref->u.ss.start->where);
3454 if (ref->u.ss.end != NULL)
3456 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3459 if (ref->u.ss.end->ts.type != BT_INTEGER)
3461 gfc_error ("Substring end index at %L must be of type INTEGER",
3462 &ref->u.ss.end->where);
3466 if (ref->u.ss.end->rank != 0)
3468 gfc_error ("Substring end index at %L must be scalar",
3469 &ref->u.ss.end->where);
3473 if (ref->u.ss.length != NULL
3474 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3475 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3476 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3478 gfc_error ("Substring end index at %L exceeds the string length",
3479 &ref->u.ss.start->where);
3488 /* Resolve subtype references. */
3491 resolve_ref (gfc_expr *expr)
3493 int current_part_dimension, n_components, seen_part_dimension;
3496 for (ref = expr->ref; ref; ref = ref->next)
3497 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3499 find_array_spec (expr);
3503 for (ref = expr->ref; ref; ref = ref->next)
3507 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3515 resolve_substring (ref);
3519 /* Check constraints on part references. */
3521 current_part_dimension = 0;
3522 seen_part_dimension = 0;
3525 for (ref = expr->ref; ref; ref = ref->next)
3530 switch (ref->u.ar.type)
3534 current_part_dimension = 1;
3538 current_part_dimension = 0;
3542 gfc_internal_error ("resolve_ref(): Bad array reference");
3548 if (current_part_dimension || seen_part_dimension)
3550 if (ref->u.c.component->pointer)
3552 gfc_error ("Component to the right of a part reference "
3553 "with nonzero rank must not have the POINTER "
3554 "attribute at %L", &expr->where);
3557 else if (ref->u.c.component->allocatable)
3559 gfc_error ("Component to the right of a part reference "
3560 "with nonzero rank must not have the ALLOCATABLE "
3561 "attribute at %L", &expr->where);
3573 if (((ref->type == REF_COMPONENT && n_components > 1)
3574 || ref->next == NULL)
3575 && current_part_dimension
3576 && seen_part_dimension)
3578 gfc_error ("Two or more part references with nonzero rank must "
3579 "not be specified at %L", &expr->where);
3583 if (ref->type == REF_COMPONENT)
3585 if (current_part_dimension)
3586 seen_part_dimension = 1;
3588 /* reset to make sure */
3589 current_part_dimension = 0;
3597 /* Given an expression, determine its shape. This is easier than it sounds.
3598 Leaves the shape array NULL if it is not possible to determine the shape. */
3601 expression_shape (gfc_expr *e)
3603 mpz_t array[GFC_MAX_DIMENSIONS];
3606 if (e->rank == 0 || e->shape != NULL)
3609 for (i = 0; i < e->rank; i++)
3610 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3613 e->shape = gfc_get_shape (e->rank);
3615 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3620 for (i--; i >= 0; i--)
3621 mpz_clear (array[i]);
3625 /* Given a variable expression node, compute the rank of the expression by
3626 examining the base symbol and any reference structures it may have. */
3629 expression_rank (gfc_expr *e)
3636 if (e->expr_type == EXPR_ARRAY)
3638 /* Constructors can have a rank different from one via RESHAPE(). */
3640 if (e->symtree == NULL)
3646 e->rank = (e->symtree->n.sym->as == NULL)
3647 ? 0 : e->symtree->n.sym->as->rank;
3653 for (ref = e->ref; ref; ref = ref->next)
3655 if (ref->type != REF_ARRAY)
3658 if (ref->u.ar.type == AR_FULL)
3660 rank = ref->u.ar.as->rank;
3664 if (ref->u.ar.type == AR_SECTION)
3666 /* Figure out the rank of the section. */
3668 gfc_internal_error ("expression_rank(): Two array specs");
3670 for (i = 0; i < ref->u.ar.dimen; i++)
3671 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3672 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3682 expression_shape (e);
3686 /* Resolve a variable expression. */
3689 resolve_variable (gfc_expr *e)
3696 if (e->symtree == NULL)
3699 if (e->ref && resolve_ref (e) == FAILURE)
3702 sym = e->symtree->n.sym;
3703 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3705 e->ts.type = BT_PROCEDURE;
3709 if (sym->ts.type != BT_UNKNOWN)
3710 gfc_variable_attr (e, &e->ts);
3713 /* Must be a simple variable reference. */
3714 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3719 if (check_assumed_size_reference (sym, e))
3722 /* Deal with forward references to entries during resolve_code, to
3723 satisfy, at least partially, 12.5.2.5. */
3724 if (gfc_current_ns->entries
3725 && current_entry_id == sym->entry_id
3728 && cs_base->current->op != EXEC_ENTRY)
3730 gfc_entry_list *entry;
3731 gfc_formal_arglist *formal;
3735 /* If the symbol is a dummy... */
3736 if (sym->attr.dummy)
3738 entry = gfc_current_ns->entries;
3741 /* ...test if the symbol is a parameter of previous entries. */
3742 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3743 for (formal = entry->sym->formal; formal; formal = formal->next)
3745 if (formal->sym && sym->name == formal->sym->name)
3749 /* If it has not been seen as a dummy, this is an error. */
3752 if (specification_expr)
3753 gfc_error ("Variable '%s',used in a specification expression, "
3754 "is referenced at %L before the ENTRY statement "
3755 "in which it is a parameter",
3756 sym->name, &cs_base->current->loc);
3758 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3759 "statement in which it is a parameter",
3760 sym->name, &cs_base->current->loc);
3765 /* Now do the same check on the specification expressions. */
3766 specification_expr = 1;
3767 if (sym->ts.type == BT_CHARACTER
3768 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3772 for (n = 0; n < sym->as->rank; n++)
3774 specification_expr = 1;
3775 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3777 specification_expr = 1;
3778 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3781 specification_expr = 0;
3784 /* Update the symbol's entry level. */
3785 sym->entry_id = current_entry_id + 1;
3792 /* Checks to see that the correct symbol has been host associated.
3793 The only situation where this arises is that in which a twice
3794 contained function is parsed after the host association is made.
3795 Therefore, on detecting this, the line is rematched, having got
3796 rid of the existing references and actual_arg_list. */
3798 check_host_association (gfc_expr *e)
3800 gfc_symbol *sym, *old_sym;
3804 bool retval = e->expr_type == EXPR_FUNCTION;
3806 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3809 old_sym = e->symtree->n.sym;
3811 if (old_sym->attr.use_assoc)
3814 if (gfc_current_ns->parent
3815 && gfc_current_ns->parent->parent
3816 && old_sym->ns != gfc_current_ns)
3818 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3819 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3821 temp_locus = gfc_current_locus;
3822 gfc_current_locus = e->where;
3824 gfc_buffer_error (1);
3826 gfc_free_ref_list (e->ref);
3831 gfc_free_actual_arglist (e->value.function.actual);
3832 e->value.function.actual = NULL;
3835 if (e->shape != NULL)
3837 for (n = 0; n < e->rank; n++)
3838 mpz_clear (e->shape[n]);
3840 gfc_free (e->shape);
3843 gfc_match_rvalue (&expr);
3845 gfc_buffer_error (0);
3847 gcc_assert (expr && sym == expr->symtree->n.sym);
3853 gfc_current_locus = temp_locus;
3856 /* This might have changed! */
3857 return e->expr_type == EXPR_FUNCTION;
3861 /* Resolve an expression. That is, make sure that types of operands agree
3862 with their operators, intrinsic operators are converted to function calls
3863 for overloaded types and unresolved function references are resolved. */
3866 gfc_resolve_expr (gfc_expr *e)
3873 switch (e->expr_type)
3876 t = resolve_operator (e);
3882 if (check_host_association (e))
3883 t = resolve_function (e);
3886 t = resolve_variable (e);
3888 expression_rank (e);
3892 case EXPR_SUBSTRING:
3893 t = resolve_ref (e);
3903 if (resolve_ref (e) == FAILURE)
3906 t = gfc_resolve_array_constructor (e);
3907 /* Also try to expand a constructor. */
3910 expression_rank (e);
3911 gfc_expand_constructor (e);
3914 /* This provides the opportunity for the length of constructors with
3915 character valued function elements to propagate the string length
3916 to the expression. */
3917 if (e->ts.type == BT_CHARACTER)
3918 gfc_resolve_character_array_constructor (e);
3922 case EXPR_STRUCTURE:
3923 t = resolve_ref (e);
3927 t = resolve_structure_cons (e);
3931 t = gfc_simplify_expr (e, 0);
3935 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3942 /* Resolve an expression from an iterator. They must be scalar and have
3943 INTEGER or (optionally) REAL type. */
3946 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3947 const char *name_msgid)
3949 if (gfc_resolve_expr (expr) == FAILURE)
3952 if (expr->rank != 0)
3954 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3958 if (expr->ts.type != BT_INTEGER)
3960 if (expr->ts.type == BT_REAL)
3963 return gfc_notify_std (GFC_STD_F95_DEL,
3964 "Deleted feature: %s at %L must be integer",
3965 _(name_msgid), &expr->where);
3968 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
3975 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3983 /* Resolve the expressions in an iterator structure. If REAL_OK is
3984 false allow only INTEGER type iterators, otherwise allow REAL types. */
3987 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
3989 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3993 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3995 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4000 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4001 "Start expression in DO loop") == FAILURE)
4004 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4005 "End expression in DO loop") == FAILURE)
4008 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4009 "Step expression in DO loop") == FAILURE)
4012 if (iter->step->expr_type == EXPR_CONSTANT)
4014 if ((iter->step->ts.type == BT_INTEGER
4015 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4016 || (iter->step->ts.type == BT_REAL
4017 && mpfr_sgn (iter->step->value.real) == 0))
4019 gfc_error ("Step expression in DO loop at %L cannot be zero",
4020 &iter->step->where);
4025 /* Convert start, end, and step to the same type as var. */
4026 if (iter->start->ts.kind != iter->var->ts.kind
4027 || iter->start->ts.type != iter->var->ts.type)
4028 gfc_convert_type (iter->start, &iter->var->ts, 2);
4030 if (iter->end->ts.kind != iter->var->ts.kind
4031 || iter->end->ts.type != iter->var->ts.type)
4032 gfc_convert_type (iter->end, &iter->var->ts, 2);
4034 if (iter->step->ts.kind != iter->var->ts.kind
4035 || iter->step->ts.type != iter->var->ts.type)
4036 gfc_convert_type (iter->step, &iter->var->ts, 2);
4042 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4043 to be a scalar INTEGER variable. The subscripts and stride are scalar
4044 INTEGERs, and if stride is a constant it must be nonzero. */
4047 resolve_forall_iterators (gfc_forall_iterator *iter)
4051 if (gfc_resolve_expr (iter->var) == SUCCESS
4052 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4053 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4056 if (gfc_resolve_expr (iter->start) == SUCCESS
4057 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4058 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4059 &iter->start->where);
4060 if (iter->var->ts.kind != iter->start->ts.kind)
4061 gfc_convert_type (iter->start, &iter->var->ts, 2);
4063 if (gfc_resolve_expr (iter->end) == SUCCESS
4064 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4065 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4067 if (iter->var->ts.kind != iter->end->ts.kind)
4068 gfc_convert_type (iter->end, &iter->var->ts, 2);
4070 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4072 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4073 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4074 &iter->stride->where, "INTEGER");
4076 if (iter->stride->expr_type == EXPR_CONSTANT
4077 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4078 gfc_error ("FORALL stride expression at %L cannot be zero",
4079 &iter->stride->where);
4081 if (iter->var->ts.kind != iter->stride->ts.kind)
4082 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4089 /* Given a pointer to a symbol that is a derived type, see if any components
4090 have the POINTER attribute. The search is recursive if necessary.
4091 Returns zero if no pointer components are found, nonzero otherwise. */
4094 derived_pointer (gfc_symbol *sym)
4098 for (c = sym->components; c; c = c->next)
4103 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
4111 /* Given a pointer to a symbol that is a derived type, see if it's
4112 inaccessible, i.e. if it's defined in another module and the components are
4113 PRIVATE. The search is recursive if necessary. Returns zero if no
4114 inaccessible components are found, nonzero otherwise. */
4117 derived_inaccessible (gfc_symbol *sym)
4121 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
4124 for (c = sym->components; c; c = c->next)
4126 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4134 /* Resolve the argument of a deallocate expression. The expression must be
4135 a pointer or a full array. */
4138 resolve_deallocate_expr (gfc_expr *e)
4140 symbol_attribute attr;
4141 int allocatable, pointer, check_intent_in;
4144 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4145 check_intent_in = 1;
4147 if (gfc_resolve_expr (e) == FAILURE)
4150 if (e->expr_type != EXPR_VARIABLE)
4153 allocatable = e->symtree->n.sym->attr.allocatable;
4154 pointer = e->symtree->n.sym->attr.pointer;
4155 for (ref = e->ref; ref; ref = ref->next)
4158 check_intent_in = 0;
4163 if (ref->u.ar.type != AR_FULL)
4168 allocatable = (ref->u.c.component->as != NULL
4169 && ref->u.c.component->as->type == AS_DEFERRED);
4170 pointer = ref->u.c.component->pointer;
4179 attr = gfc_expr_attr (e);
4181 if (allocatable == 0 && attr.pointer == 0)
4184 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4185 "ALLOCATABLE or a POINTER", &e->where);
4189 && e->symtree->n.sym->attr.intent == INTENT_IN)
4191 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4192 e->symtree->n.sym->name, &e->where);
4200 /* Returns true if the expression e contains a reference the symbol sym. */
4202 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4204 gfc_actual_arglist *arg;
4212 switch (e->expr_type)
4215 for (arg = e->value.function.actual; arg; arg = arg->next)
4216 rv = rv || find_sym_in_expr (sym, arg->expr);
4219 /* If the variable is not the same as the dependent, 'sym', and
4220 it is not marked as being declared and it is in the same
4221 namespace as 'sym', add it to the local declarations. */
4223 if (sym == e->symtree->n.sym)
4228 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4229 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4238 for (ref = e->ref; ref; ref = ref->next)
4243 for (i = 0; i < ref->u.ar.dimen; i++)
4245 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4246 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4247 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4252 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4253 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4257 if (ref->u.c.component->ts.type == BT_CHARACTER
4258 && ref->u.c.component->ts.cl->length->expr_type
4261 || find_sym_in_expr (sym,
4262 ref->u.c.component->ts.cl->length);
4264 if (ref->u.c.component->as)
4265 for (i = 0; i < ref->u.c.component->as->rank; i++)
4268 || find_sym_in_expr (sym,
4269 ref->u.c.component->as->lower[i]);
4271 || find_sym_in_expr (sym,
4272 ref->u.c.component->as->upper[i]);
4282 /* Given the expression node e for an allocatable/pointer of derived type to be
4283 allocated, get the expression node to be initialized afterwards (needed for
4284 derived types with default initializers, and derived types with allocatable
4285 components that need nullification.) */
4288 expr_to_initialize (gfc_expr *e)
4294 result = gfc_copy_expr (e);
4296 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4297 for (ref = result->ref; ref; ref = ref->next)
4298 if (ref->type == REF_ARRAY && ref->next == NULL)
4300 ref->u.ar.type = AR_FULL;
4302 for (i = 0; i < ref->u.ar.dimen; i++)
4303 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4305 result->rank = ref->u.ar.dimen;
4313 /* Resolve the expression in an ALLOCATE statement, doing the additional
4314 checks to see whether the expression is OK or not. The expression must
4315 have a trailing array reference that gives the size of the array. */
4318 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4320 int i, pointer, allocatable, dimension, check_intent_in;
4321 symbol_attribute attr;
4322 gfc_ref *ref, *ref2;
4329 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4330 check_intent_in = 1;
4332 if (gfc_resolve_expr (e) == FAILURE)
4335 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4336 sym = code->expr->symtree->n.sym;
4340 /* Make sure the expression is allocatable or a pointer. If it is
4341 pointer, the next-to-last reference must be a pointer. */
4345 if (e->expr_type != EXPR_VARIABLE)
4348 attr = gfc_expr_attr (e);
4349 pointer = attr.pointer;
4350 dimension = attr.dimension;
4354 allocatable = e->symtree->n.sym->attr.allocatable;
4355 pointer = e->symtree->n.sym->attr.pointer;
4356 dimension = e->symtree->n.sym->attr.dimension;
4358 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4360 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4361 "not be allocated in the same statement at %L",
4362 sym->name, &e->where);
4366 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4369 check_intent_in = 0;
4374 if (ref->next != NULL)
4379 allocatable = (ref->u.c.component->as != NULL
4380 && ref->u.c.component->as->type == AS_DEFERRED);
4382 pointer = ref->u.c.component->pointer;
4383 dimension = ref->u.c.component->dimension;
4394 if (allocatable == 0 && pointer == 0)
4396 gfc_error ("Expression in ALLOCATE statement at %L must be "
4397 "ALLOCATABLE or a POINTER", &e->where);
4402 && e->symtree->n.sym->attr.intent == INTENT_IN)
4404 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4405 e->symtree->n.sym->name, &e->where);
4409 /* Add default initializer for those derived types that need them. */
4410 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4412 init_st = gfc_get_code ();
4413 init_st->loc = code->loc;
4414 init_st->op = EXEC_INIT_ASSIGN;
4415 init_st->expr = expr_to_initialize (e);
4416 init_st->expr2 = init_e;
4417 init_st->next = code->next;
4418 code->next = init_st;
4421 if (pointer && dimension == 0)
4424 /* Make sure the next-to-last reference node is an array specification. */
4426 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4428 gfc_error ("Array specification required in ALLOCATE statement "
4429 "at %L", &e->where);
4433 /* Make sure that the array section reference makes sense in the
4434 context of an ALLOCATE specification. */
4438 for (i = 0; i < ar->dimen; i++)
4440 if (ref2->u.ar.type == AR_ELEMENT)
4443 switch (ar->dimen_type[i])
4449 if (ar->start[i] != NULL
4450 && ar->end[i] != NULL
4451 && ar->stride[i] == NULL)
4454 /* Fall Through... */
4458 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4465 for (a = code->ext.alloc_list; a; a = a->next)
4467 sym = a->expr->symtree->n.sym;
4469 /* TODO - check derived type components. */
4470 if (sym->ts.type == BT_DERIVED)
4473 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4474 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4476 gfc_error ("'%s' must not appear an the array specification at "
4477 "%L in the same ALLOCATE statement where it is "
4478 "itself allocated", sym->name, &ar->where);
4488 /************ SELECT CASE resolution subroutines ************/
4490 /* Callback function for our mergesort variant. Determines interval
4491 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4492 op1 > op2. Assumes we're not dealing with the default case.
4493 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4494 There are nine situations to check. */
4497 compare_cases (const gfc_case *op1, const gfc_case *op2)
4501 if (op1->low == NULL) /* op1 = (:L) */
4503 /* op2 = (:N), so overlap. */
4505 /* op2 = (M:) or (M:N), L < M */
4506 if (op2->low != NULL
4507 && gfc_compare_expr (op1->high, op2->low) < 0)
4510 else if (op1->high == NULL) /* op1 = (K:) */
4512 /* op2 = (M:), so overlap. */
4514 /* op2 = (:N) or (M:N), K > N */
4515 if (op2->high != NULL
4516 && gfc_compare_expr (op1->low, op2->high) > 0)
4519 else /* op1 = (K:L) */
4521 if (op2->low == NULL) /* op2 = (:N), K > N */
4522 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4523 else if (op2->high == NULL) /* op2 = (M:), L < M */
4524 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4525 else /* op2 = (M:N) */
4529 if (gfc_compare_expr (op1->high, op2->low) < 0)
4532 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4541 /* Merge-sort a double linked case list, detecting overlap in the
4542 process. LIST is the head of the double linked case list before it
4543 is sorted. Returns the head of the sorted list if we don't see any
4544 overlap, or NULL otherwise. */
4547 check_case_overlap (gfc_case *list)
4549 gfc_case *p, *q, *e, *tail;
4550 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4552 /* If the passed list was empty, return immediately. */
4559 /* Loop unconditionally. The only exit from this loop is a return
4560 statement, when we've finished sorting the case list. */
4567 /* Count the number of merges we do in this pass. */
4570 /* Loop while there exists a merge to be done. */
4575 /* Count this merge. */
4578 /* Cut the list in two pieces by stepping INSIZE places
4579 forward in the list, starting from P. */
4582 for (i = 0; i < insize; i++)
4591 /* Now we have two lists. Merge them! */
4592 while (psize > 0 || (qsize > 0 && q != NULL))
4594 /* See from which the next case to merge comes from. */
4597 /* P is empty so the next case must come from Q. */
4602 else if (qsize == 0 || q == NULL)
4611 cmp = compare_cases (p, q);
4614 /* The whole case range for P is less than the
4622 /* The whole case range for Q is greater than
4623 the case range for P. */
4630 /* The cases overlap, or they are the same
4631 element in the list. Either way, we must
4632 issue an error and get the next case from P. */
4633 /* FIXME: Sort P and Q by line number. */
4634 gfc_error ("CASE label at %L overlaps with CASE "
4635 "label at %L", &p->where, &q->where);
4643 /* Add the next element to the merged list. */
4652 /* P has now stepped INSIZE places along, and so has Q. So
4653 they're the same. */
4658 /* If we have done only one merge or none at all, we've
4659 finished sorting the cases. */
4668 /* Otherwise repeat, merging lists twice the size. */
4674 /* Check to see if an expression is suitable for use in a CASE statement.
4675 Makes sure that all case expressions are scalar constants of the same
4676 type. Return FAILURE if anything is wrong. */
4679 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4681 if (e == NULL) return SUCCESS;
4683 if (e->ts.type != case_expr->ts.type)
4685 gfc_error ("Expression in CASE statement at %L must be of type %s",
4686 &e->where, gfc_basic_typename (case_expr->ts.type));
4690 /* C805 (R808) For a given case-construct, each case-value shall be of
4691 the same type as case-expr. For character type, length differences
4692 are allowed, but the kind type parameters shall be the same. */
4694 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4696 gfc_error("Expression in CASE statement at %L must be kind %d",
4697 &e->where, case_expr->ts.kind);
4701 /* Convert the case value kind to that of case expression kind, if needed.
4702 FIXME: Should a warning be issued? */
4703 if (e->ts.kind != case_expr->ts.kind)
4704 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4708 gfc_error ("Expression in CASE statement at %L must be scalar",
4717 /* Given a completely parsed select statement, we:
4719 - Validate all expressions and code within the SELECT.
4720 - Make sure that the selection expression is not of the wrong type.
4721 - Make sure that no case ranges overlap.
4722 - Eliminate unreachable cases and unreachable code resulting from
4723 removing case labels.
4725 The standard does allow unreachable cases, e.g. CASE (5:3). But
4726 they are a hassle for code generation, and to prevent that, we just
4727 cut them out here. This is not necessary for overlapping cases
4728 because they are illegal and we never even try to generate code.
4730 We have the additional caveat that a SELECT construct could have
4731 been a computed GOTO in the source code. Fortunately we can fairly
4732 easily work around that here: The case_expr for a "real" SELECT CASE
4733 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4734 we have to do is make sure that the case_expr is a scalar integer
4738 resolve_select (gfc_code *code)
4741 gfc_expr *case_expr;
4742 gfc_case *cp, *default_case, *tail, *head;
4743 int seen_unreachable;
4749 if (code->expr == NULL)
4751 /* This was actually a computed GOTO statement. */
4752 case_expr = code->expr2;
4753 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4754 gfc_error ("Selection expression in computed GOTO statement "
4755 "at %L must be a scalar integer expression",
4758 /* Further checking is not necessary because this SELECT was built
4759 by the compiler, so it should always be OK. Just move the
4760 case_expr from expr2 to expr so that we can handle computed
4761 GOTOs as normal SELECTs from here on. */
4762 code->expr = code->expr2;
4767 case_expr = code->expr;
4769 type = case_expr->ts.type;
4770 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4772 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4773 &case_expr->where, gfc_typename (&case_expr->ts));
4775 /* Punt. Going on here just produce more garbage error messages. */
4779 if (case_expr->rank != 0)
4781 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4782 "expression", &case_expr->where);
4788 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4789 of the SELECT CASE expression and its CASE values. Walk the lists
4790 of case values, and if we find a mismatch, promote case_expr to
4791 the appropriate kind. */
4793 if (type == BT_LOGICAL || type == BT_INTEGER)
4795 for (body = code->block; body; body = body->block)
4797 /* Walk the case label list. */
4798 for (cp = body->ext.case_list; cp; cp = cp->next)
4800 /* Intercept the DEFAULT case. It does not have a kind. */
4801 if (cp->low == NULL && cp->high == NULL)
4804 /* Unreachable case ranges are discarded, so ignore. */
4805 if (cp->low != NULL && cp->high != NULL
4806 && cp->low != cp->high
4807 && gfc_compare_expr (cp->low, cp->high) > 0)
4810 /* FIXME: Should a warning be issued? */
4812 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4813 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4815 if (cp->high != NULL
4816 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4817 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4822 /* Assume there is no DEFAULT case. */
4823 default_case = NULL;
4828 for (body = code->block; body; body = body->block)
4830 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4832 seen_unreachable = 0;
4834 /* Walk the case label list, making sure that all case labels
4836 for (cp = body->ext.case_list; cp; cp = cp->next)
4838 /* Count the number of cases in the whole construct. */
4841 /* Intercept the DEFAULT case. */
4842 if (cp->low == NULL && cp->high == NULL)
4844 if (default_case != NULL)
4846 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4847 "by a second DEFAULT CASE at %L",
4848 &default_case->where, &cp->where);
4859 /* Deal with single value cases and case ranges. Errors are
4860 issued from the validation function. */
4861 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4862 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4868 if (type == BT_LOGICAL
4869 && ((cp->low == NULL || cp->high == NULL)
4870 || cp->low != cp->high))
4872 gfc_error ("Logical range in CASE statement at %L is not "
4873 "allowed", &cp->low->where);
4878 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4881 value = cp->low->value.logical == 0 ? 2 : 1;
4882 if (value & seen_logical)
4884 gfc_error ("constant logical value in CASE statement "
4885 "is repeated at %L",
4890 seen_logical |= value;
4893 if (cp->low != NULL && cp->high != NULL
4894 && cp->low != cp->high
4895 && gfc_compare_expr (cp->low, cp->high) > 0)
4897 if (gfc_option.warn_surprising)
4898 gfc_warning ("Range specification at %L can never "
4899 "be matched", &cp->where);
4901 cp->unreachable = 1;
4902 seen_unreachable = 1;
4906 /* If the case range can be matched, it can also overlap with
4907 other cases. To make sure it does not, we put it in a
4908 double linked list here. We sort that with a merge sort
4909 later on to detect any overlapping cases. */
4913 head->right = head->left = NULL;
4918 tail->right->left = tail;
4925 /* It there was a failure in the previous case label, give up
4926 for this case label list. Continue with the next block. */
4930 /* See if any case labels that are unreachable have been seen.
4931 If so, we eliminate them. This is a bit of a kludge because
4932 the case lists for a single case statement (label) is a
4933 single forward linked lists. */
4934 if (seen_unreachable)
4936 /* Advance until the first case in the list is reachable. */
4937 while (body->ext.case_list != NULL
4938 && body->ext.case_list->unreachable)
4940 gfc_case *n = body->ext.case_list;
4941 body->ext.case_list = body->ext.case_list->next;
4943 gfc_free_case_list (n);
4946 /* Strip all other unreachable cases. */
4947 if (body->ext.case_list)
4949 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4951 if (cp->next->unreachable)
4953 gfc_case *n = cp->next;
4954 cp->next = cp->next->next;
4956 gfc_free_case_list (n);
4963 /* See if there were overlapping cases. If the check returns NULL,
4964 there was overlap. In that case we don't do anything. If head
4965 is non-NULL, we prepend the DEFAULT case. The sorted list can
4966 then used during code generation for SELECT CASE constructs with
4967 a case expression of a CHARACTER type. */
4970 head = check_case_overlap (head);
4972 /* Prepend the default_case if it is there. */
4973 if (head != NULL && default_case)
4975 default_case->left = NULL;
4976 default_case->right = head;
4977 head->left = default_case;
4981 /* Eliminate dead blocks that may be the result if we've seen
4982 unreachable case labels for a block. */
4983 for (body = code; body && body->block; body = body->block)
4985 if (body->block->ext.case_list == NULL)
4987 /* Cut the unreachable block from the code chain. */
4988 gfc_code *c = body->block;
4989 body->block = c->block;
4991 /* Kill the dead block, but not the blocks below it. */
4993 gfc_free_statements (c);
4997 /* More than two cases is legal but insane for logical selects.
4998 Issue a warning for it. */
4999 if (gfc_option.warn_surprising && type == BT_LOGICAL
5001 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5006 /* Resolve a transfer statement. This is making sure that:
5007 -- a derived type being transferred has only non-pointer components
5008 -- a derived type being transferred doesn't have private components, unless
5009 it's being transferred from the module where the type was defined
5010 -- we're not trying to transfer a whole assumed size array. */
5013 resolve_transfer (gfc_code *code)
5022 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5025 sym = exp->symtree->n.sym;
5028 /* Go to actual component transferred. */
5029 for (ref = code->expr->ref; ref; ref = ref->next)
5030 if (ref->type == REF_COMPONENT)
5031 ts = &ref->u.c.component->ts;
5033 if (ts->type == BT_DERIVED)
5035 /* Check that transferred derived type doesn't contain POINTER
5037 if (derived_pointer (ts->derived))
5039 gfc_error ("Data transfer element at %L cannot have "
5040 "POINTER components", &code->loc);
5044 if (ts->derived->attr.alloc_comp)
5046 gfc_error ("Data transfer element at %L cannot have "
5047 "ALLOCATABLE components", &code->loc);
5051 if (derived_inaccessible (ts->derived))
5053 gfc_error ("Data transfer element at %L cannot have "
5054 "PRIVATE components",&code->loc);
5059 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5060 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5062 gfc_error ("Data transfer element at %L cannot be a full reference to "
5063 "an assumed-size array", &code->loc);
5069 /*********** Toplevel code resolution subroutines ***********/
5071 /* Find the set of labels that are reachable from this block. We also
5072 record the last statement in each block so that we don't have to do
5073 a linear search to find the END DO statements of the blocks. */
5076 reachable_labels (gfc_code *block)
5083 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5085 /* Collect labels in this block. */
5086 for (c = block; c; c = c->next)
5089 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5091 if (!c->next && cs_base->prev)
5092 cs_base->prev->tail = c;
5095 /* Merge with labels from parent block. */
5098 gcc_assert (cs_base->prev->reachable_labels);
5099 bitmap_ior_into (cs_base->reachable_labels,
5100 cs_base->prev->reachable_labels);
5104 /* Given a branch to a label and a namespace, if the branch is conforming.
5105 The code node describes where the branch is located. */
5108 resolve_branch (gfc_st_label *label, gfc_code *code)
5115 /* Step one: is this a valid branching target? */
5117 if (label->defined == ST_LABEL_UNKNOWN)
5119 gfc_error ("Label %d referenced at %L is never defined", label->value,
5124 if (label->defined != ST_LABEL_TARGET)
5126 gfc_error ("Statement at %L is not a valid branch target statement "
5127 "for the branch statement at %L", &label->where, &code->loc);
5131 /* Step two: make sure this branch is not a branch to itself ;-) */
5133 if (code->here == label)
5135 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5139 /* Step three: See if the label is in the same block as the
5140 branching statement. The hard work has been done by setting up
5141 the bitmap reachable_labels. */
5143 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5145 /* The label is not in an enclosing block, so illegal. This was
5146 allowed in Fortran 66, so we allow it as extension. No
5147 further checks are necessary in this case. */
5148 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5149 "as the GOTO statement at %L", &label->where,
5154 /* Step four: Make sure that the branching target is legal if
5155 the statement is an END {SELECT,IF}. */
5157 for (stack = cs_base; stack; stack = stack->prev)
5158 if (stack->current->next && stack->current->next->here == label)
5161 if (stack && stack->current->next->op == EXEC_NOP)
5163 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5164 "END of construct at %L", &code->loc,
5165 &stack->current->next->loc);
5166 return; /* We know this is not an END DO. */
5169 /* Step five: Make sure that we're not jumping to the end of a DO
5170 loop from within the loop. */
5172 for (stack = cs_base; stack; stack = stack->prev)
5173 if ((stack->current->op == EXEC_DO
5174 || stack->current->op == EXEC_DO_WHILE)
5175 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5177 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5178 "to END of construct at %L", &code->loc,
5186 /* Check whether EXPR1 has the same shape as EXPR2. */
5189 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5191 mpz_t shape[GFC_MAX_DIMENSIONS];
5192 mpz_t shape2[GFC_MAX_DIMENSIONS];
5193 try result = FAILURE;
5196 /* Compare the rank. */
5197 if (expr1->rank != expr2->rank)
5200 /* Compare the size of each dimension. */
5201 for (i=0; i<expr1->rank; i++)
5203 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5206 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5209 if (mpz_cmp (shape[i], shape2[i]))
5213 /* When either of the two expression is an assumed size array, we
5214 ignore the comparison of dimension sizes. */
5219 for (i--; i >= 0; i--)
5221 mpz_clear (shape[i]);
5222 mpz_clear (shape2[i]);
5228 /* Check whether a WHERE assignment target or a WHERE mask expression
5229 has the same shape as the outmost WHERE mask expression. */
5232 resolve_where (gfc_code *code, gfc_expr *mask)
5238 cblock = code->block;
5240 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5241 In case of nested WHERE, only the outmost one is stored. */
5242 if (mask == NULL) /* outmost WHERE */
5244 else /* inner WHERE */
5251 /* Check if the mask-expr has a consistent shape with the
5252 outmost WHERE mask-expr. */
5253 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5254 gfc_error ("WHERE mask at %L has inconsistent shape",
5255 &cblock->expr->where);
5258 /* the assignment statement of a WHERE statement, or the first
5259 statement in where-body-construct of a WHERE construct */
5260 cnext = cblock->next;
5265 /* WHERE assignment statement */
5268 /* Check shape consistent for WHERE assignment target. */
5269 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5270 gfc_error ("WHERE assignment target at %L has "
5271 "inconsistent shape", &cnext->expr->where);
5275 case EXEC_ASSIGN_CALL:
5276 resolve_call (cnext);
5279 /* WHERE or WHERE construct is part of a where-body-construct */
5281 resolve_where (cnext, e);
5285 gfc_error ("Unsupported statement inside WHERE at %L",
5288 /* the next statement within the same where-body-construct */
5289 cnext = cnext->next;
5291 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5292 cblock = cblock->block;
5297 /* Check whether the FORALL index appears in the expression or not. */
5300 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5304 gfc_actual_arglist *args;
5307 switch (expr->expr_type)
5310 gcc_assert (expr->symtree->n.sym);
5312 /* A scalar assignment */
5315 if (expr->symtree->n.sym == symbol)
5321 /* the expr is array ref, substring or struct component. */
5328 /* Check if the symbol appears in the array subscript. */
5330 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5333 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5337 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5341 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5347 if (expr->symtree->n.sym == symbol)
5350 /* Check if the symbol appears in the substring section. */
5351 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5353 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5361 gfc_error("expression reference type error at %L", &expr->where);
5367 /* If the expression is a function call, then check if the symbol
5368 appears in the actual arglist of the function. */
5370 for (args = expr->value.function.actual; args; args = args->next)
5372 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5377 /* It seems not to happen. */
5378 case EXPR_SUBSTRING:
5382 gcc_assert (expr->ref->type == REF_SUBSTRING);
5383 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5385 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5390 /* It seems not to happen. */
5391 case EXPR_STRUCTURE:
5393 gfc_error ("Unsupported statement while finding forall index in "
5398 /* Find the FORALL index in the first operand. */
5399 if (expr->value.op.op1)
5401 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5405 /* Find the FORALL index in the second operand. */
5406 if (expr->value.op.op2)
5408 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5421 /* Resolve assignment in FORALL construct.
5422 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5423 FORALL index variables. */
5426 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5430 for (n = 0; n < nvar; n++)
5432 gfc_symbol *forall_index;
5434 forall_index = var_expr[n]->symtree->n.sym;
5436 /* Check whether the assignment target is one of the FORALL index
5438 if ((code->expr->expr_type == EXPR_VARIABLE)
5439 && (code->expr->symtree->n.sym == forall_index))
5440 gfc_error ("Assignment to a FORALL index variable at %L",
5441 &code->expr->where);
5444 /* If one of the FORALL index variables doesn't appear in the
5445 assignment target, then there will be a many-to-one
5447 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5448 gfc_error ("The FORALL with index '%s' cause more than one "
5449 "assignment to this object at %L",
5450 var_expr[n]->symtree->name, &code->expr->where);
5456 /* Resolve WHERE statement in FORALL construct. */
5459 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5460 gfc_expr **var_expr)
5465 cblock = code->block;
5468 /* the assignment statement of a WHERE statement, or the first
5469 statement in where-body-construct of a WHERE construct */
5470 cnext = cblock->next;
5475 /* WHERE assignment statement */
5477 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5480 /* WHERE operator assignment statement */
5481 case EXEC_ASSIGN_CALL:
5482 resolve_call (cnext);
5485 /* WHERE or WHERE construct is part of a where-body-construct */
5487 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5491 gfc_error ("Unsupported statement inside WHERE at %L",
5494 /* the next statement within the same where-body-construct */
5495 cnext = cnext->next;
5497 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5498 cblock = cblock->block;
5503 /* Traverse the FORALL body to check whether the following errors exist:
5504 1. For assignment, check if a many-to-one assignment happens.
5505 2. For WHERE statement, check the WHERE body to see if there is any
5506 many-to-one assignment. */
5509 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5513 c = code->block->next;
5519 case EXEC_POINTER_ASSIGN:
5520 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5523 case EXEC_ASSIGN_CALL:
5527 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5528 there is no need to handle it here. */
5532 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5537 /* The next statement in the FORALL body. */
5543 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5544 gfc_resolve_forall_body to resolve the FORALL body. */
5547 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5549 static gfc_expr **var_expr;
5550 static int total_var = 0;
5551 static int nvar = 0;
5552 gfc_forall_iterator *fa;
5553 gfc_symbol *forall_index;
5557 /* Start to resolve a FORALL construct */
5558 if (forall_save == 0)
5560 /* Count the total number of FORALL index in the nested FORALL
5561 construct in order to allocate the VAR_EXPR with proper size. */
5563 while ((next != NULL) && (next->op == EXEC_FORALL))
5565 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5567 next = next->block->next;
5570 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5571 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5574 /* The information about FORALL iterator, including FORALL index start, end
5575 and stride. The FORALL index can not appear in start, end or stride. */
5576 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5578 /* Check if any outer FORALL index name is the same as the current
5580 for (i = 0; i < nvar; i++)
5582 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5584 gfc_error ("An outer FORALL construct already has an index "
5585 "with this name %L", &fa->var->where);
5589 /* Record the current FORALL index. */
5590 var_expr[nvar] = gfc_copy_expr (fa->var);
5592 forall_index = fa->var->symtree->n.sym;
5594 /* Check if the FORALL index appears in start, end or stride. */
5595 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5596 gfc_error ("A FORALL index must not appear in a limit or stride "
5597 "expression in the same FORALL at %L", &fa->start->where);
5598 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5599 gfc_error ("A FORALL index must not appear in a limit or stride "
5600 "expression in the same FORALL at %L", &fa->end->where);
5601 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5602 gfc_error ("A FORALL index must not appear in a limit or stride "
5603 "expression in the same FORALL at %L", &fa->stride->where);
5607 /* Resolve the FORALL body. */
5608 gfc_resolve_forall_body (code, nvar, var_expr);
5610 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5611 gfc_resolve_blocks (code->block, ns);
5613 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5614 for (i = 0; i < total_var; i++)
5615 gfc_free_expr (var_expr[i]);
5617 /* Reset the counters. */
5623 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5626 static void resolve_code (gfc_code *, gfc_namespace *);
5629 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5633 for (; b; b = b->block)
5635 t = gfc_resolve_expr (b->expr);
5636 if (gfc_resolve_expr (b->expr2) == FAILURE)
5642 if (t == SUCCESS && b->expr != NULL
5643 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5644 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5651 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5652 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5657 resolve_branch (b->label, b);
5669 case EXEC_OMP_ATOMIC:
5670 case EXEC_OMP_CRITICAL:
5672 case EXEC_OMP_MASTER:
5673 case EXEC_OMP_ORDERED:
5674 case EXEC_OMP_PARALLEL:
5675 case EXEC_OMP_PARALLEL_DO:
5676 case EXEC_OMP_PARALLEL_SECTIONS:
5677 case EXEC_OMP_PARALLEL_WORKSHARE:
5678 case EXEC_OMP_SECTIONS:
5679 case EXEC_OMP_SINGLE:
5680 case EXEC_OMP_WORKSHARE:
5684 gfc_internal_error ("resolve_block(): Bad block type");
5687 resolve_code (b->next, ns);
5692 /* Given a block of code, recursively resolve everything pointed to by this
5696 resolve_code (gfc_code *code, gfc_namespace *ns)
5698 int omp_workshare_save;
5704 frame.prev = cs_base;
5708 reachable_labels (code);
5710 for (; code; code = code->next)
5712 frame.current = code;
5713 forall_save = forall_flag;
5715 if (code->op == EXEC_FORALL)
5718 gfc_resolve_forall (code, ns, forall_save);
5721 else if (code->block)
5723 omp_workshare_save = -1;
5726 case EXEC_OMP_PARALLEL_WORKSHARE:
5727 omp_workshare_save = omp_workshare_flag;
5728 omp_workshare_flag = 1;
5729 gfc_resolve_omp_parallel_blocks (code, ns);
5731 case EXEC_OMP_PARALLEL:
5732 case EXEC_OMP_PARALLEL_DO:
5733 case EXEC_OMP_PARALLEL_SECTIONS:
5734 omp_workshare_save = omp_workshare_flag;
5735 omp_workshare_flag = 0;
5736 gfc_resolve_omp_parallel_blocks (code, ns);
5739 gfc_resolve_omp_do_blocks (code, ns);
5741 case EXEC_OMP_WORKSHARE:
5742 omp_workshare_save = omp_workshare_flag;
5743 omp_workshare_flag = 1;
5746 gfc_resolve_blocks (code->block, ns);
5750 if (omp_workshare_save != -1)
5751 omp_workshare_flag = omp_workshare_save;
5754 t = gfc_resolve_expr (code->expr);
5755 forall_flag = forall_save;
5757 if (gfc_resolve_expr (code->expr2) == FAILURE)
5772 /* Keep track of which entry we are up to. */
5773 current_entry_id = code->ext.entry->id;
5777 resolve_where (code, NULL);
5781 if (code->expr != NULL)
5783 if (code->expr->ts.type != BT_INTEGER)
5784 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5785 "INTEGER variable", &code->expr->where);
5786 else if (code->expr->symtree->n.sym->attr.assign != 1)
5787 gfc_error ("Variable '%s' has not been assigned a target "
5788 "label at %L", code->expr->symtree->n.sym->name,
5789 &code->expr->where);
5792 resolve_branch (code->label, code);
5796 if (code->expr != NULL
5797 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5798 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5799 "INTEGER return specifier", &code->expr->where);
5802 case EXEC_INIT_ASSIGN:
5809 if (gfc_extend_assign (code, ns) == SUCCESS)
5811 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5813 gfc_error ("Subroutine '%s' called instead of assignment at "
5814 "%L must be PURE", code->symtree->n.sym->name,
5821 if (code->expr->ts.type == BT_CHARACTER
5822 && gfc_option.warn_character_truncation)
5824 int llen = 0, rlen = 0;
5826 if (code->expr->ts.cl != NULL
5827 && code->expr->ts.cl->length != NULL
5828 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5829 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5831 if (code->expr2->expr_type == EXPR_CONSTANT)
5832 rlen = code->expr2->value.character.length;
5834 else if (code->expr2->ts.cl != NULL
5835 && code->expr2->ts.cl->length != NULL
5836 && code->expr2->ts.cl->length->expr_type
5838 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5840 if (rlen && llen && rlen > llen)
5841 gfc_warning_now ("CHARACTER expression will be truncated "
5842 "in assignment (%d/%d) at %L",
5843 llen, rlen, &code->loc);
5846 if (gfc_pure (NULL))
5848 if (gfc_impure_variable (code->expr->symtree->n.sym))
5850 gfc_error ("Cannot assign to variable '%s' in PURE "
5852 code->expr->symtree->n.sym->name,
5853 &code->expr->where);
5857 if (code->expr->ts.type == BT_DERIVED
5858 && code->expr->expr_type == EXPR_VARIABLE
5859 && derived_pointer (code->expr->ts.derived)
5860 && gfc_impure_variable (code->expr2->symtree->n.sym))
5862 gfc_error ("The impure variable at %L is assigned to "
5863 "a derived type variable with a POINTER "
5864 "component in a PURE procedure (12.6)",
5865 &code->expr2->where);
5870 gfc_check_assign (code->expr, code->expr2, 1);
5873 case EXEC_LABEL_ASSIGN:
5874 if (code->label->defined == ST_LABEL_UNKNOWN)
5875 gfc_error ("Label %d referenced at %L is never defined",
5876 code->label->value, &code->label->where);
5878 && (code->expr->expr_type != EXPR_VARIABLE
5879 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5880 || code->expr->symtree->n.sym->ts.kind
5881 != gfc_default_integer_kind
5882 || code->expr->symtree->n.sym->as != NULL))
5883 gfc_error ("ASSIGN statement at %L requires a scalar "
5884 "default INTEGER variable", &code->expr->where);
5887 case EXEC_POINTER_ASSIGN:
5891 gfc_check_pointer_assign (code->expr, code->expr2);
5894 case EXEC_ARITHMETIC_IF:
5896 && code->expr->ts.type != BT_INTEGER
5897 && code->expr->ts.type != BT_REAL)
5898 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5899 "expression", &code->expr->where);
5901 resolve_branch (code->label, code);
5902 resolve_branch (code->label2, code);
5903 resolve_branch (code->label3, code);
5907 if (t == SUCCESS && code->expr != NULL
5908 && (code->expr->ts.type != BT_LOGICAL
5909 || code->expr->rank != 0))
5910 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5911 &code->expr->where);
5916 resolve_call (code);
5920 /* Select is complicated. Also, a SELECT construct could be
5921 a transformed computed GOTO. */
5922 resolve_select (code);
5926 if (code->ext.iterator != NULL)
5928 gfc_iterator *iter = code->ext.iterator;
5929 if (gfc_resolve_iterator (iter, true) != FAILURE)
5930 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5935 if (code->expr == NULL)
5936 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5938 && (code->expr->rank != 0
5939 || code->expr->ts.type != BT_LOGICAL))
5940 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5941 "a scalar LOGICAL expression", &code->expr->where);
5945 if (t == SUCCESS && code->expr != NULL
5946 && code->expr->ts.type != BT_INTEGER)
5947 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5948 "of type INTEGER", &code->expr->where);
5950 for (a = code->ext.alloc_list; a; a = a->next)
5951 resolve_allocate_expr (a->expr, code);
5955 case EXEC_DEALLOCATE:
5956 if (t == SUCCESS && code->expr != NULL
5957 && code->expr->ts.type != BT_INTEGER)
5959 ("STAT tag in DEALLOCATE statement at %L must be of type "
5960 "INTEGER", &code->expr->where);
5962 for (a = code->ext.alloc_list; a; a = a->next)
5963 resolve_deallocate_expr (a->expr);
5968 if (gfc_resolve_open (code->ext.open) == FAILURE)
5971 resolve_branch (code->ext.open->err, code);
5975 if (gfc_resolve_close (code->ext.close) == FAILURE)
5978 resolve_branch (code->ext.close->err, code);
5981 case EXEC_BACKSPACE:
5985 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5988 resolve_branch (code->ext.filepos->err, code);
5992 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5995 resolve_branch (code->ext.inquire->err, code);
5999 gcc_assert (code->ext.inquire != NULL);
6000 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6003 resolve_branch (code->ext.inquire->err, code);
6008 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6011 resolve_branch (code->ext.dt->err, code);
6012 resolve_branch (code->ext.dt->end, code);
6013 resolve_branch (code->ext.dt->eor, code);
6017 resolve_transfer (code);
6021 resolve_forall_iterators (code->ext.forall_iterator);
6023 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6024 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6025 "expression", &code->expr->where);
6028 case EXEC_OMP_ATOMIC:
6029 case EXEC_OMP_BARRIER:
6030 case EXEC_OMP_CRITICAL:
6031 case EXEC_OMP_FLUSH:
6033 case EXEC_OMP_MASTER:
6034 case EXEC_OMP_ORDERED:
6035 case EXEC_OMP_SECTIONS:
6036 case EXEC_OMP_SINGLE:
6037 case EXEC_OMP_WORKSHARE:
6038 gfc_resolve_omp_directive (code, ns);
6041 case EXEC_OMP_PARALLEL:
6042 case EXEC_OMP_PARALLEL_DO:
6043 case EXEC_OMP_PARALLEL_SECTIONS:
6044 case EXEC_OMP_PARALLEL_WORKSHARE:
6045 omp_workshare_save = omp_workshare_flag;
6046 omp_workshare_flag = 0;
6047 gfc_resolve_omp_directive (code, ns);
6048 omp_workshare_flag = omp_workshare_save;
6052 gfc_internal_error ("resolve_code(): Bad statement code");
6056 cs_base = frame.prev;
6060 /* Resolve initial values and make sure they are compatible with
6064 resolve_values (gfc_symbol *sym)
6066 if (sym->value == NULL)
6069 if (gfc_resolve_expr (sym->value) == FAILURE)
6072 gfc_check_assign_symbol (sym, sym->value);
6076 /* Verify the binding labels for common blocks that are BIND(C). The label
6077 for a BIND(C) common block must be identical in all scoping units in which
6078 the common block is declared. Further, the binding label can not collide
6079 with any other global entity in the program. */
6082 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6084 if (comm_block_tree->n.common->is_bind_c == 1)
6086 gfc_gsymbol *binding_label_gsym;
6087 gfc_gsymbol *comm_name_gsym;
6089 /* See if a global symbol exists by the common block's name. It may
6090 be NULL if the common block is use-associated. */
6091 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6092 comm_block_tree->n.common->name);
6093 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6094 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6095 "with the global entity '%s' at %L",
6096 comm_block_tree->n.common->binding_label,
6097 comm_block_tree->n.common->name,
6098 &(comm_block_tree->n.common->where),
6099 comm_name_gsym->name, &(comm_name_gsym->where));
6100 else if (comm_name_gsym != NULL
6101 && strcmp (comm_name_gsym->name,
6102 comm_block_tree->n.common->name) == 0)
6104 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6106 if (comm_name_gsym->binding_label == NULL)
6107 /* No binding label for common block stored yet; save this one. */
6108 comm_name_gsym->binding_label =
6109 comm_block_tree->n.common->binding_label;
6111 if (strcmp (comm_name_gsym->binding_label,
6112 comm_block_tree->n.common->binding_label) != 0)
6114 /* Common block names match but binding labels do not. */
6115 gfc_error ("Binding label '%s' for common block '%s' at %L "
6116 "does not match the binding label '%s' for common "
6118 comm_block_tree->n.common->binding_label,
6119 comm_block_tree->n.common->name,
6120 &(comm_block_tree->n.common->where),
6121 comm_name_gsym->binding_label,
6122 comm_name_gsym->name,
6123 &(comm_name_gsym->where));
6128 /* There is no binding label (NAME="") so we have nothing further to
6129 check and nothing to add as a global symbol for the label. */
6130 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6133 binding_label_gsym =
6134 gfc_find_gsymbol (gfc_gsym_root,
6135 comm_block_tree->n.common->binding_label);
6136 if (binding_label_gsym == NULL)
6138 /* Need to make a global symbol for the binding label to prevent
6139 it from colliding with another. */
6140 binding_label_gsym =
6141 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6142 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6143 binding_label_gsym->type = GSYM_COMMON;
6147 /* If comm_name_gsym is NULL, the name common block is use
6148 associated and the name could be colliding. */
6149 if (binding_label_gsym->type != GSYM_COMMON)
6150 gfc_error ("Binding label '%s' for common block '%s' at %L "
6151 "collides with the global entity '%s' at %L",
6152 comm_block_tree->n.common->binding_label,
6153 comm_block_tree->n.common->name,
6154 &(comm_block_tree->n.common->where),
6155 binding_label_gsym->name,
6156 &(binding_label_gsym->where));
6157 else if (comm_name_gsym != NULL
6158 && (strcmp (binding_label_gsym->name,
6159 comm_name_gsym->binding_label) != 0)
6160 && (strcmp (binding_label_gsym->sym_name,
6161 comm_name_gsym->name) != 0))
6162 gfc_error ("Binding label '%s' for common block '%s' at %L "
6163 "collides with global entity '%s' at %L",
6164 binding_label_gsym->name, binding_label_gsym->sym_name,
6165 &(comm_block_tree->n.common->where),
6166 comm_name_gsym->name, &(comm_name_gsym->where));
6174 /* Verify any BIND(C) derived types in the namespace so we can report errors
6175 for them once, rather than for each variable declared of that type. */
6178 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6180 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6181 && derived_sym->attr.is_bind_c == 1)
6182 verify_bind_c_derived_type (derived_sym);
6188 /* Verify that any binding labels used in a given namespace do not collide
6189 with the names or binding labels of any global symbols. */
6192 gfc_verify_binding_labels (gfc_symbol *sym)
6196 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6197 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6199 gfc_gsymbol *bind_c_sym;
6201 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6202 if (bind_c_sym != NULL
6203 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6205 if (sym->attr.if_source == IFSRC_DECL
6206 && (bind_c_sym->type != GSYM_SUBROUTINE
6207 && bind_c_sym->type != GSYM_FUNCTION)
6208 && ((sym->attr.contained == 1
6209 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6210 || (sym->attr.use_assoc == 1
6211 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6213 /* Make sure global procedures don't collide with anything. */
6214 gfc_error ("Binding label '%s' at %L collides with the global "
6215 "entity '%s' at %L", sym->binding_label,
6216 &(sym->declared_at), bind_c_sym->name,
6217 &(bind_c_sym->where));
6220 else if (sym->attr.contained == 0
6221 && (sym->attr.if_source == IFSRC_IFBODY
6222 && sym->attr.flavor == FL_PROCEDURE)
6223 && (bind_c_sym->sym_name != NULL
6224 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6226 /* Make sure procedures in interface bodies don't collide. */
6227 gfc_error ("Binding label '%s' in interface body at %L collides "
6228 "with the global entity '%s' at %L",
6230 &(sym->declared_at), bind_c_sym->name,
6231 &(bind_c_sym->where));
6234 else if (sym->attr.contained == 0
6235 && (sym->attr.if_source == IFSRC_UNKNOWN))
6236 if ((sym->attr.use_assoc
6237 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6238 || sym->attr.use_assoc == 0)
6240 gfc_error ("Binding label '%s' at %L collides with global "
6241 "entity '%s' at %L", sym->binding_label,
6242 &(sym->declared_at), bind_c_sym->name,
6243 &(bind_c_sym->where));
6248 /* Clear the binding label to prevent checking multiple times. */
6249 sym->binding_label[0] = '\0';
6251 else if (bind_c_sym == NULL)
6253 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6254 bind_c_sym->where = sym->declared_at;
6255 bind_c_sym->sym_name = sym->name;
6257 if (sym->attr.use_assoc == 1)
6258 bind_c_sym->mod_name = sym->module;
6260 if (sym->ns->proc_name != NULL)
6261 bind_c_sym->mod_name = sym->ns->proc_name->name;
6263 if (sym->attr.contained == 0)
6265 if (sym->attr.subroutine)
6266 bind_c_sym->type = GSYM_SUBROUTINE;
6267 else if (sym->attr.function)
6268 bind_c_sym->type = GSYM_FUNCTION;
6276 /* Resolve an index expression. */
6279 resolve_index_expr (gfc_expr *e)
6281 if (gfc_resolve_expr (e) == FAILURE)
6284 if (gfc_simplify_expr (e, 0) == FAILURE)
6287 if (gfc_specification_expr (e) == FAILURE)
6293 /* Resolve a charlen structure. */
6296 resolve_charlen (gfc_charlen *cl)
6305 specification_expr = 1;
6307 if (resolve_index_expr (cl->length) == FAILURE)
6309 specification_expr = 0;
6313 /* "If the character length parameter value evaluates to a negative
6314 value, the length of character entities declared is zero." */
6315 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6317 gfc_warning_now ("CHARACTER variable has zero length at %L",
6318 &cl->length->where);
6319 gfc_replace_expr (cl->length, gfc_int_expr (0));
6326 /* Test for non-constant shape arrays. */
6329 is_non_constant_shape_array (gfc_symbol *sym)
6335 not_constant = false;
6336 if (sym->as != NULL)
6338 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6339 has not been simplified; parameter array references. Do the
6340 simplification now. */
6341 for (i = 0; i < sym->as->rank; i++)
6343 e = sym->as->lower[i];
6344 if (e && (resolve_index_expr (e) == FAILURE
6345 || !gfc_is_constant_expr (e)))
6346 not_constant = true;
6348 e = sym->as->upper[i];
6349 if (e && (resolve_index_expr (e) == FAILURE
6350 || !gfc_is_constant_expr (e)))
6351 not_constant = true;
6354 return not_constant;
6358 /* Assign the default initializer to a derived type variable or result. */
6361 apply_default_init (gfc_symbol *sym)
6364 gfc_expr *init = NULL;
6366 gfc_namespace *ns = sym->ns;
6368 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6371 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6372 init = gfc_default_initializer (&sym->ts);
6377 /* Search for the function namespace if this is a contained
6378 function without an explicit result. */
6379 if (sym->attr.function && sym == sym->result
6380 && sym->name != sym->ns->proc_name->name)
6383 for (;ns; ns = ns->sibling)
6384 if (strcmp (ns->proc_name->name, sym->name) == 0)
6390 gfc_free_expr (init);
6394 /* Build an l-value expression for the result. */
6395 lval = gfc_get_expr ();
6396 lval->expr_type = EXPR_VARIABLE;
6397 lval->where = sym->declared_at;
6399 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
6401 /* It will always be a full array. */
6402 lval->rank = sym->as ? sym->as->rank : 0;
6405 lval->ref = gfc_get_ref ();
6406 lval->ref->type = REF_ARRAY;
6407 lval->ref->u.ar.type = AR_FULL;
6408 lval->ref->u.ar.dimen = lval->rank;
6409 lval->ref->u.ar.where = sym->declared_at;
6410 lval->ref->u.ar.as = sym->as;
6413 /* Add the code at scope entry. */
6414 init_st = gfc_get_code ();
6415 init_st->next = ns->code;
6418 /* Assign the default initializer to the l-value. */
6419 init_st->loc = sym->declared_at;
6420 init_st->op = EXEC_INIT_ASSIGN;
6421 init_st->expr = lval;
6422 init_st->expr2 = init;
6426 /* Resolution of common features of flavors variable and procedure. */
6429 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6431 /* Constraints on deferred shape variable. */
6432 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6434 if (sym->attr.allocatable)
6436 if (sym->attr.dimension)
6437 gfc_error ("Allocatable array '%s' at %L must have "
6438 "a deferred shape", sym->name, &sym->declared_at);
6440 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6441 sym->name, &sym->declared_at);
6445 if (sym->attr.pointer && sym->attr.dimension)
6447 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6448 sym->name, &sym->declared_at);
6455 if (!mp_flag && !sym->attr.allocatable
6456 && !sym->attr.pointer && !sym->attr.dummy)
6458 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6459 sym->name, &sym->declared_at);
6467 static gfc_component *
6468 has_default_initializer (gfc_symbol *der)
6471 for (c = der->components; c; c = c->next)
6472 if ((c->ts.type != BT_DERIVED && c->initializer)
6473 || (c->ts.type == BT_DERIVED
6475 && has_default_initializer (c->ts.derived)))
6482 /* Resolve symbols with flavor variable. */
6485 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6491 const char *auto_save_msg;
6493 auto_save_msg = "automatic object '%s' at %L cannot have the "
6496 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6499 /* Set this flag to check that variables are parameters of all entries.
6500 This check is effected by the call to gfc_resolve_expr through
6501 is_non_constant_shape_array. */
6502 specification_expr = 1;
6504 if (!sym->attr.use_assoc
6505 && !sym->attr.allocatable
6506 && !sym->attr.pointer
6507 && is_non_constant_shape_array (sym))
6509 /* The shape of a main program or module array needs to be
6511 if (sym->ns->proc_name
6512 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6513 || sym->ns->proc_name->attr.is_main_program))
6515 gfc_error ("The module or main program array '%s' at %L must "
6516 "have constant shape", sym->name, &sym->declared_at);
6517 specification_expr = 0;
6522 if (sym->ts.type == BT_CHARACTER)
6524 /* Make sure that character string variables with assumed length are
6526 e = sym->ts.cl->length;
6527 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6529 gfc_error ("Entity with assumed character length at %L must be a "
6530 "dummy argument or a PARAMETER", &sym->declared_at);
6534 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6536 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6540 if (!gfc_is_constant_expr (e)
6541 && !(e->expr_type == EXPR_VARIABLE
6542 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6543 && sym->ns->proc_name
6544 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6545 || sym->ns->proc_name->attr.is_main_program)
6546 && !sym->attr.use_assoc)
6548 gfc_error ("'%s' at %L must have constant character length "
6549 "in this context", sym->name, &sym->declared_at);
6554 /* Can the symbol have an initializer? */
6556 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6557 || sym->attr.intrinsic || sym->attr.result)
6559 else if (sym->attr.dimension && !sym->attr.pointer)
6561 /* Don't allow initialization of automatic arrays. */
6562 for (i = 0; i < sym->as->rank; i++)
6564 if (sym->as->lower[i] == NULL
6565 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6566 || sym->as->upper[i] == NULL
6567 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6574 /* Also, they must not have the SAVE attribute.
6575 SAVE_IMPLICIT is checked below. */
6576 if (flag && sym->attr.save == SAVE_EXPLICIT)
6578 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6583 /* Reject illegal initializers. */
6584 if (!sym->mark && sym->value && flag)
6586 if (sym->attr.allocatable)
6587 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6588 sym->name, &sym->declared_at);
6589 else if (sym->attr.external)
6590 gfc_error ("External '%s' at %L cannot have an initializer",
6591 sym->name, &sym->declared_at);
6592 else if (sym->attr.dummy
6593 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6594 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6595 sym->name, &sym->declared_at);
6596 else if (sym->attr.intrinsic)
6597 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6598 sym->name, &sym->declared_at);
6599 else if (sym->attr.result)
6600 gfc_error ("Function result '%s' at %L cannot have an initializer",
6601 sym->name, &sym->declared_at);
6603 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6604 sym->name, &sym->declared_at);
6611 /* Check to see if a derived type is blocked from being host associated
6612 by the presence of another class I symbol in the same namespace.
6613 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6614 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6615 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6618 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6619 if (s && (s->attr.flavor != FL_DERIVED
6620 || !gfc_compare_derived_types (s, sym->ts.derived)))
6622 gfc_error ("The type %s cannot be host associated at %L because "
6623 "it is blocked by an incompatible object of the same "
6624 "name at %L", sym->ts.derived->name, &sym->declared_at,
6630 /* Do not use gfc_default_initializer to test for a default initializer
6631 in the fortran because it generates a hidden default for allocatable
6634 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6635 c = has_default_initializer (sym->ts.derived);
6637 /* 4th constraint in section 11.3: "If an object of a type for which
6638 component-initialization is specified (R429) appears in the
6639 specification-part of a module and does not have the ALLOCATABLE
6640 or POINTER attribute, the object shall have the SAVE attribute." */
6641 if (c && sym->ns->proc_name
6642 && sym->ns->proc_name->attr.flavor == FL_MODULE
6643 && !sym->ns->save_all && !sym->attr.save
6644 && !sym->attr.pointer && !sym->attr.allocatable)
6646 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6647 sym->name, &sym->declared_at,
6648 "for default initialization of a component");
6652 /* Assign default initializer. */
6653 if (sym->ts.type == BT_DERIVED
6655 && !sym->attr.pointer
6656 && !sym->attr.allocatable
6657 && (!flag || sym->attr.intent == INTENT_OUT))
6658 sym->value = gfc_default_initializer (&sym->ts);
6664 /* Resolve a procedure. */
6667 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6669 gfc_formal_arglist *arg;
6671 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6672 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6673 "interfaces", sym->name, &sym->declared_at);
6675 if (sym->attr.function
6676 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6679 if (sym->ts.type == BT_CHARACTER)
6681 gfc_charlen *cl = sym->ts.cl;
6683 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6684 && resolve_charlen (cl) == FAILURE)
6687 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6689 if (sym->attr.proc == PROC_ST_FUNCTION)
6691 gfc_error ("Character-valued statement function '%s' at %L must "
6692 "have constant length", sym->name, &sym->declared_at);
6696 if (sym->attr.external && sym->formal == NULL
6697 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6699 gfc_error ("Automatic character length function '%s' at %L must "
6700 "have an explicit interface", sym->name,
6707 /* Ensure that derived type for are not of a private type. Internal
6708 module procedures are excluded by 2.2.3.3 - ie. they are not
6709 externally accessible and can access all the objects accessible in
6711 if (!(sym->ns->parent
6712 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6713 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6715 gfc_interface *iface;
6717 for (arg = sym->formal; arg; arg = arg->next)
6720 && arg->sym->ts.type == BT_DERIVED
6721 && !arg->sym->ts.derived->attr.use_assoc
6722 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6723 arg->sym->ts.derived->ns->default_access))
6725 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6726 "a dummy argument of '%s', which is "
6727 "PUBLIC at %L", arg->sym->name, sym->name,
6729 /* Stop this message from recurring. */
6730 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6735 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6736 PRIVATE to the containing module. */
6737 for (iface = sym->generic; iface; iface = iface->next)
6739 for (arg = iface->sym->formal; arg; arg = arg->next)
6742 && arg->sym->ts.type == BT_DERIVED
6743 && !arg->sym->ts.derived->attr.use_assoc
6744 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6745 arg->sym->ts.derived->ns->default_access))
6747 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6748 "dummy arguments of '%s' which is PRIVATE",
6749 iface->sym->name, sym->name, &iface->sym->declared_at,
6750 gfc_typename(&arg->sym->ts));
6751 /* Stop this message from recurring. */
6752 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6758 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6759 PRIVATE to the containing module. */
6760 for (iface = sym->generic; iface; iface = iface->next)
6762 for (arg = iface->sym->formal; arg; arg = arg->next)
6765 && arg->sym->ts.type == BT_DERIVED
6766 && !arg->sym->ts.derived->attr.use_assoc
6767 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6768 arg->sym->ts.derived->ns->default_access))
6770 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6771 "dummy arguments of '%s' which is PRIVATE",
6772 iface->sym->name, sym->name, &iface->sym->declared_at,
6773 gfc_typename(&arg->sym->ts));
6774 /* Stop this message from recurring. */
6775 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6782 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
6784 gfc_error ("Function '%s' at %L cannot have an initializer",
6785 sym->name, &sym->declared_at);
6789 /* An external symbol may not have an initializer because it is taken to be
6791 if (sym->attr.external && sym->value)
6793 gfc_error ("External object '%s' at %L may not have an initializer",
6794 sym->name, &sym->declared_at);
6798 /* An elemental function is required to return a scalar 12.7.1 */
6799 if (sym->attr.elemental && sym->attr.function && sym->as)
6801 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6802 "result", sym->name, &sym->declared_at);
6803 /* Reset so that the error only occurs once. */
6804 sym->attr.elemental = 0;
6808 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6809 char-len-param shall not be array-valued, pointer-valued, recursive
6810 or pure. ....snip... A character value of * may only be used in the
6811 following ways: (i) Dummy arg of procedure - dummy associates with
6812 actual length; (ii) To declare a named constant; or (iii) External
6813 function - but length must be declared in calling scoping unit. */
6814 if (sym->attr.function
6815 && sym->ts.type == BT_CHARACTER
6816 && sym->ts.cl && sym->ts.cl->length == NULL)
6818 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6819 || (sym->attr.recursive) || (sym->attr.pure))
6821 if (sym->as && sym->as->rank)
6822 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6823 "array-valued", sym->name, &sym->declared_at);
6825 if (sym->attr.pointer)
6826 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6827 "pointer-valued", sym->name, &sym->declared_at);
6830 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6831 "pure", sym->name, &sym->declared_at);
6833 if (sym->attr.recursive)
6834 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6835 "recursive", sym->name, &sym->declared_at);
6840 /* Appendix B.2 of the standard. Contained functions give an
6841 error anyway. Fixed-form is likely to be F77/legacy. */
6842 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6843 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6844 "'%s' at %L is obsolescent in fortran 95",
6845 sym->name, &sym->declared_at);
6848 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6850 gfc_formal_arglist *curr_arg;
6851 int has_non_interop_arg = 0;
6853 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6854 sym->common_block) == FAILURE)
6856 /* Clear these to prevent looking at them again if there was an
6858 sym->attr.is_bind_c = 0;
6859 sym->attr.is_c_interop = 0;
6860 sym->ts.is_c_interop = 0;
6864 /* So far, no errors have been found. */
6865 sym->attr.is_c_interop = 1;
6866 sym->ts.is_c_interop = 1;
6869 curr_arg = sym->formal;
6870 while (curr_arg != NULL)
6872 /* Skip implicitly typed dummy args here. */
6873 if (curr_arg->sym->attr.implicit_type == 0)
6874 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
6875 /* If something is found to fail, record the fact so we
6876 can mark the symbol for the procedure as not being
6877 BIND(C) to try and prevent multiple errors being
6879 has_non_interop_arg = 1;
6881 curr_arg = curr_arg->next;
6884 /* See if any of the arguments were not interoperable and if so, clear
6885 the procedure symbol to prevent duplicate error messages. */
6886 if (has_non_interop_arg != 0)
6888 sym->attr.is_c_interop = 0;
6889 sym->ts.is_c_interop = 0;
6890 sym->attr.is_bind_c = 0;
6898 /* Resolve the components of a derived type. */
6901 resolve_fl_derived (gfc_symbol *sym)
6904 gfc_dt_list * dt_list;
6907 for (c = sym->components; c != NULL; c = c->next)
6909 if (c->ts.type == BT_CHARACTER)
6911 if (c->ts.cl->length == NULL
6912 || (resolve_charlen (c->ts.cl) == FAILURE)
6913 || !gfc_is_constant_expr (c->ts.cl->length))
6915 gfc_error ("Character length of component '%s' needs to "
6916 "be a constant specification expression at %L",
6918 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6923 if (c->ts.type == BT_DERIVED
6924 && sym->component_access != ACCESS_PRIVATE
6925 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6926 && !c->ts.derived->attr.use_assoc
6927 && !gfc_check_access (c->ts.derived->attr.access,
6928 c->ts.derived->ns->default_access))
6930 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6931 "a component of '%s', which is PUBLIC at %L",
6932 c->name, sym->name, &sym->declared_at);
6936 if (sym->attr.sequence)
6938 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6940 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6941 "not have the SEQUENCE attribute",
6942 c->ts.derived->name, &sym->declared_at);
6947 if (c->ts.type == BT_DERIVED && c->pointer
6948 && c->ts.derived->components == NULL)
6950 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6951 "that has not been declared", c->name, sym->name,
6956 if (c->pointer || c->allocatable || c->as == NULL)
6959 for (i = 0; i < c->as->rank; i++)
6961 if (c->as->lower[i] == NULL
6962 || !gfc_is_constant_expr (c->as->lower[i])
6963 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6964 || c->as->upper[i] == NULL
6965 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6966 || !gfc_is_constant_expr (c->as->upper[i]))
6968 gfc_error ("Component '%s' of '%s' at %L must have "
6969 "constant array bounds",
6970 c->name, sym->name, &c->loc);
6976 /* Add derived type to the derived type list. */
6977 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
6978 if (sym == dt_list->derived)
6981 if (dt_list == NULL)
6983 dt_list = gfc_get_dt_list ();
6984 dt_list->next = gfc_derived_types;
6985 dt_list->derived = sym;
6986 gfc_derived_types = dt_list;
6994 resolve_fl_namelist (gfc_symbol *sym)
6999 /* Reject PRIVATE objects in a PUBLIC namelist. */
7000 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7002 for (nl = sym->namelist; nl; nl = nl->next)
7004 if (!nl->sym->attr.use_assoc
7005 && !(sym->ns->parent == nl->sym->ns)
7006 && !(sym->ns->parent
7007 && sym->ns->parent->parent == nl->sym->ns)
7008 && !gfc_check_access(nl->sym->attr.access,
7009 nl->sym->ns->default_access))
7011 gfc_error ("PRIVATE symbol '%s' cannot be member of "
7012 "PUBLIC namelist at %L", nl->sym->name,
7019 /* Reject namelist arrays that are not constant shape. */
7020 for (nl = sym->namelist; nl; nl = nl->next)
7022 if (is_non_constant_shape_array (nl->sym))
7024 gfc_error ("The array '%s' must have constant shape to be "
7025 "a NAMELIST object at %L", nl->sym->name,
7031 /* Namelist objects cannot have allocatable components. */
7032 for (nl = sym->namelist; nl; nl = nl->next)
7034 if (nl->sym->ts.type == BT_DERIVED
7035 && nl->sym->ts.derived->attr.alloc_comp)
7037 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
7038 "components", nl->sym->name, &sym->declared_at);
7043 /* 14.1.2 A module or internal procedure represent local entities
7044 of the same type as a namelist member and so are not allowed. */
7045 for (nl = sym->namelist; nl; nl = nl->next)
7047 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7050 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7051 if ((nl->sym == sym->ns->proc_name)
7053 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7057 if (nl->sym && nl->sym->name)
7058 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7059 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7061 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7062 "attribute in '%s' at %L", nlsym->name,
7073 resolve_fl_parameter (gfc_symbol *sym)
7075 /* A parameter array's shape needs to be constant. */
7076 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
7078 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7079 "or assumed shape", sym->name, &sym->declared_at);
7083 /* Make sure a parameter that has been implicitly typed still
7084 matches the implicit type, since PARAMETER statements can precede
7085 IMPLICIT statements. */
7086 if (sym->attr.implicit_type
7087 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7089 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7090 "later IMPLICIT type", sym->name, &sym->declared_at);
7094 /* Make sure the types of derived parameters are consistent. This
7095 type checking is deferred until resolution because the type may
7096 refer to a derived type from the host. */
7097 if (sym->ts.type == BT_DERIVED
7098 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7100 gfc_error ("Incompatible derived type in PARAMETER at %L",
7101 &sym->value->where);
7108 /* Do anything necessary to resolve a symbol. Right now, we just
7109 assume that an otherwise unknown symbol is a variable. This sort
7110 of thing commonly happens for symbols in module. */
7113 resolve_symbol (gfc_symbol *sym)
7115 int check_constant, mp_flag;
7116 gfc_symtree *symtree;
7117 gfc_symtree *this_symtree;
7121 if (sym->attr.flavor == FL_UNKNOWN)
7124 /* If we find that a flavorless symbol is an interface in one of the
7125 parent namespaces, find its symtree in this namespace, free the
7126 symbol and set the symtree to point to the interface symbol. */
7127 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7129 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7130 if (symtree && symtree->n.sym->generic)
7132 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7136 gfc_free_symbol (sym);
7137 symtree->n.sym->refs++;
7138 this_symtree->n.sym = symtree->n.sym;
7143 /* Otherwise give it a flavor according to such attributes as
7145 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7146 sym->attr.flavor = FL_VARIABLE;
7149 sym->attr.flavor = FL_PROCEDURE;
7150 if (sym->attr.dimension)
7151 sym->attr.function = 1;
7155 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7158 /* Symbols that are module procedures with results (functions) have
7159 the types and array specification copied for type checking in
7160 procedures that call them, as well as for saving to a module
7161 file. These symbols can't stand the scrutiny that their results
7163 mp_flag = (sym->result != NULL && sym->result != sym);
7166 /* Make sure that the intrinsic is consistent with its internal
7167 representation. This needs to be done before assigning a default
7168 type to avoid spurious warnings. */
7169 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7171 if (gfc_intrinsic_name (sym->name, 0))
7173 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7174 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7175 sym->name, &sym->declared_at);
7177 else if (gfc_intrinsic_name (sym->name, 1))
7179 if (sym->ts.type != BT_UNKNOWN)
7181 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7182 sym->name, &sym->declared_at);
7188 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7193 /* Assign default type to symbols that need one and don't have one. */
7194 if (sym->ts.type == BT_UNKNOWN)
7196 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7197 gfc_set_default_type (sym, 1, NULL);
7199 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7201 /* The specific case of an external procedure should emit an error
7202 in the case that there is no implicit type. */
7204 gfc_set_default_type (sym, sym->attr.external, NULL);
7207 /* Result may be in another namespace. */
7208 resolve_symbol (sym->result);
7210 sym->ts = sym->result->ts;
7211 sym->as = gfc_copy_array_spec (sym->result->as);
7212 sym->attr.dimension = sym->result->attr.dimension;
7213 sym->attr.pointer = sym->result->attr.pointer;
7214 sym->attr.allocatable = sym->result->attr.allocatable;
7219 /* Assumed size arrays and assumed shape arrays must be dummy
7223 && (sym->as->type == AS_ASSUMED_SIZE
7224 || sym->as->type == AS_ASSUMED_SHAPE)
7225 && sym->attr.dummy == 0)
7227 if (sym->as->type == AS_ASSUMED_SIZE)
7228 gfc_error ("Assumed size array at %L must be a dummy argument",
7231 gfc_error ("Assumed shape array at %L must be a dummy argument",
7236 /* Make sure symbols with known intent or optional are really dummy
7237 variable. Because of ENTRY statement, this has to be deferred
7238 until resolution time. */
7240 if (!sym->attr.dummy
7241 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7243 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7247 if (sym->attr.value && !sym->attr.dummy)
7249 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7250 "it is not a dummy argument", sym->name, &sym->declared_at);
7254 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7256 gfc_charlen *cl = sym->ts.cl;
7257 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7259 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7260 "attribute must have constant length",
7261 sym->name, &sym->declared_at);
7265 if (sym->ts.is_c_interop
7266 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7268 gfc_error ("C interoperable character dummy variable '%s' at %L "
7269 "with VALUE attribute must have length one",
7270 sym->name, &sym->declared_at);
7275 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7276 do this for something that was implicitly typed because that is handled
7277 in gfc_set_default_type. Handle dummy arguments and procedure
7278 definitions separately. Also, anything that is use associated is not
7279 handled here but instead is handled in the module it is declared in.
7280 Finally, derived type definitions are allowed to be BIND(C) since that
7281 only implies that they're interoperable, and they are checked fully for
7282 interoperability when a variable is declared of that type. */
7283 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7284 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7285 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7289 /* First, make sure the variable is declared at the
7290 module-level scope (J3/04-007, Section 15.3). */
7291 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7292 sym->attr.in_common == 0)
7294 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7295 "is neither a COMMON block nor declared at the "
7296 "module level scope", sym->name, &(sym->declared_at));
7299 else if (sym->common_head != NULL)
7301 t = verify_com_block_vars_c_interop (sym->common_head);
7305 /* If type() declaration, we need to verify that the components
7306 of the given type are all C interoperable, etc. */
7307 if (sym->ts.type == BT_DERIVED &&
7308 sym->ts.derived->attr.is_c_interop != 1)
7310 /* Make sure the user marked the derived type as BIND(C). If
7311 not, call the verify routine. This could print an error
7312 for the derived type more than once if multiple variables
7313 of that type are declared. */
7314 if (sym->ts.derived->attr.is_bind_c != 1)
7315 verify_bind_c_derived_type (sym->ts.derived);
7319 /* Verify the variable itself as C interoperable if it
7320 is BIND(C). It is not possible for this to succeed if
7321 the verify_bind_c_derived_type failed, so don't have to handle
7322 any error returned by verify_bind_c_derived_type. */
7323 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7329 /* clear the is_bind_c flag to prevent reporting errors more than
7330 once if something failed. */
7331 sym->attr.is_bind_c = 0;
7336 /* If a derived type symbol has reached this point, without its
7337 type being declared, we have an error. Notice that most
7338 conditions that produce undefined derived types have already
7339 been dealt with. However, the likes of:
7340 implicit type(t) (t) ..... call foo (t) will get us here if
7341 the type is not declared in the scope of the implicit
7342 statement. Change the type to BT_UNKNOWN, both because it is so
7343 and to prevent an ICE. */
7344 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7346 gfc_error ("The derived type '%s' at %L is of type '%s', "
7347 "which has not been defined", sym->name,
7348 &sym->declared_at, sym->ts.derived->name);
7349 sym->ts.type = BT_UNKNOWN;
7353 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7354 default initialization is defined (5.1.2.4.4). */
7355 if (sym->ts.type == BT_DERIVED
7357 && sym->attr.intent == INTENT_OUT
7359 && sym->as->type == AS_ASSUMED_SIZE)
7361 for (c = sym->ts.derived->components; c; c = c->next)
7365 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7366 "ASSUMED SIZE and so cannot have a default initializer",
7367 sym->name, &sym->declared_at);
7373 switch (sym->attr.flavor)
7376 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7381 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7386 if (resolve_fl_namelist (sym) == FAILURE)
7391 if (resolve_fl_parameter (sym) == FAILURE)
7399 /* Resolve array specifier. Check as well some constraints
7400 on COMMON blocks. */
7402 check_constant = sym->attr.in_common && !sym->attr.pointer;
7404 /* Set the formal_arg_flag so that check_conflict will not throw
7405 an error for host associated variables in the specification
7406 expression for an array_valued function. */
7407 if (sym->attr.function && sym->as)
7408 formal_arg_flag = 1;
7410 gfc_resolve_array_spec (sym->as, check_constant);
7412 formal_arg_flag = 0;
7414 /* Resolve formal namespaces. */
7415 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7416 gfc_resolve (sym->formal_ns);
7418 /* Check threadprivate restrictions. */
7419 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7420 && (!sym->attr.in_common
7421 && sym->module == NULL
7422 && (sym->ns->proc_name == NULL
7423 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7424 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7426 /* If we have come this far we can apply default-initializers, as
7427 described in 14.7.5, to those variables that have not already
7428 been assigned one. */
7429 if (sym->ts.type == BT_DERIVED
7430 && sym->attr.referenced
7431 && sym->ns == gfc_current_ns
7433 && !sym->attr.allocatable
7434 && !sym->attr.alloc_comp)
7436 symbol_attribute *a = &sym->attr;
7438 if ((!a->save && !a->dummy && !a->pointer
7439 && !a->in_common && !a->use_assoc
7440 && !(a->function && sym != sym->result))
7441 || (a->dummy && a->intent == INTENT_OUT))
7442 apply_default_init (sym);
7447 /************* Resolve DATA statements *************/
7451 gfc_data_value *vnode;
7457 /* Advance the values structure to point to the next value in the data list. */
7460 next_data_value (void)
7462 while (values.left == 0)
7464 if (values.vnode->next == NULL)
7467 values.vnode = values.vnode->next;
7468 values.left = values.vnode->repeat;
7476 check_data_variable (gfc_data_variable *var, locus *where)
7482 ar_type mark = AR_UNKNOWN;
7484 mpz_t section_index[GFC_MAX_DIMENSIONS];
7488 if (gfc_resolve_expr (var->expr) == FAILURE)
7492 mpz_init_set_si (offset, 0);
7495 if (e->expr_type != EXPR_VARIABLE)
7496 gfc_internal_error ("check_data_variable(): Bad expression");
7498 if (e->symtree->n.sym->ns->is_block_data
7499 && !e->symtree->n.sym->attr.in_common)
7501 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7502 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7507 mpz_init_set_ui (size, 1);
7514 /* Find the array section reference. */
7515 for (ref = e->ref; ref; ref = ref->next)
7517 if (ref->type != REF_ARRAY)
7519 if (ref->u.ar.type == AR_ELEMENT)
7525 /* Set marks according to the reference pattern. */
7526 switch (ref->u.ar.type)
7534 /* Get the start position of array section. */
7535 gfc_get_section_index (ar, section_index, &offset);
7543 if (gfc_array_size (e, &size) == FAILURE)
7545 gfc_error ("Nonconstant array section at %L in DATA statement",
7554 while (mpz_cmp_ui (size, 0) > 0)
7556 if (next_data_value () == FAILURE)
7558 gfc_error ("DATA statement at %L has more variables than values",
7564 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7568 /* If we have more than one element left in the repeat count,
7569 and we have more than one element left in the target variable,
7570 then create a range assignment. */
7571 /* ??? Only done for full arrays for now, since array sections
7573 if (mark == AR_FULL && ref && ref->next == NULL
7574 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7578 if (mpz_cmp_ui (size, values.left) >= 0)
7580 mpz_init_set_ui (range, values.left);
7581 mpz_sub_ui (size, size, values.left);
7586 mpz_init_set (range, size);
7587 values.left -= mpz_get_ui (size);
7588 mpz_set_ui (size, 0);
7591 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7594 mpz_add (offset, offset, range);
7598 /* Assign initial value to symbol. */
7602 mpz_sub_ui (size, size, 1);
7604 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7608 if (mark == AR_FULL)
7609 mpz_add_ui (offset, offset, 1);
7611 /* Modify the array section indexes and recalculate the offset
7612 for next element. */
7613 else if (mark == AR_SECTION)
7614 gfc_advance_section (section_index, ar, &offset);
7618 if (mark == AR_SECTION)
7620 for (i = 0; i < ar->dimen; i++)
7621 mpz_clear (section_index[i]);
7631 static try traverse_data_var (gfc_data_variable *, locus *);
7633 /* Iterate over a list of elements in a DATA statement. */
7636 traverse_data_list (gfc_data_variable *var, locus *where)
7639 iterator_stack frame;
7640 gfc_expr *e, *start, *end, *step;
7641 try retval = SUCCESS;
7643 mpz_init (frame.value);
7645 start = gfc_copy_expr (var->iter.start);
7646 end = gfc_copy_expr (var->iter.end);
7647 step = gfc_copy_expr (var->iter.step);
7649 if (gfc_simplify_expr (start, 1) == FAILURE
7650 || start->expr_type != EXPR_CONSTANT)
7652 gfc_error ("iterator start at %L does not simplify", &start->where);
7656 if (gfc_simplify_expr (end, 1) == FAILURE
7657 || end->expr_type != EXPR_CONSTANT)
7659 gfc_error ("iterator end at %L does not simplify", &end->where);
7663 if (gfc_simplify_expr (step, 1) == FAILURE
7664 || step->expr_type != EXPR_CONSTANT)
7666 gfc_error ("iterator step at %L does not simplify", &step->where);
7671 mpz_init_set (trip, end->value.integer);
7672 mpz_sub (trip, trip, start->value.integer);
7673 mpz_add (trip, trip, step->value.integer);
7675 mpz_div (trip, trip, step->value.integer);
7677 mpz_set (frame.value, start->value.integer);
7679 frame.prev = iter_stack;
7680 frame.variable = var->iter.var->symtree;
7681 iter_stack = &frame;
7683 while (mpz_cmp_ui (trip, 0) > 0)
7685 if (traverse_data_var (var->list, where) == FAILURE)
7692 e = gfc_copy_expr (var->expr);
7693 if (gfc_simplify_expr (e, 1) == FAILURE)
7701 mpz_add (frame.value, frame.value, step->value.integer);
7703 mpz_sub_ui (trip, trip, 1);
7708 mpz_clear (frame.value);
7710 gfc_free_expr (start);
7711 gfc_free_expr (end);
7712 gfc_free_expr (step);
7714 iter_stack = frame.prev;
7719 /* Type resolve variables in the variable list of a DATA statement. */
7722 traverse_data_var (gfc_data_variable *var, locus *where)
7726 for (; var; var = var->next)
7728 if (var->expr == NULL)
7729 t = traverse_data_list (var, where);
7731 t = check_data_variable (var, where);
7741 /* Resolve the expressions and iterators associated with a data statement.
7742 This is separate from the assignment checking because data lists should
7743 only be resolved once. */
7746 resolve_data_variables (gfc_data_variable *d)
7748 for (; d; d = d->next)
7750 if (d->list == NULL)
7752 if (gfc_resolve_expr (d->expr) == FAILURE)
7757 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7760 if (resolve_data_variables (d->list) == FAILURE)
7769 /* Resolve a single DATA statement. We implement this by storing a pointer to
7770 the value list into static variables, and then recursively traversing the
7771 variables list, expanding iterators and such. */
7774 resolve_data (gfc_data * d)
7776 if (resolve_data_variables (d->var) == FAILURE)
7779 values.vnode = d->value;
7780 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7782 if (traverse_data_var (d->var, &d->where) == FAILURE)
7785 /* At this point, we better not have any values left. */
7787 if (next_data_value () == SUCCESS)
7788 gfc_error ("DATA statement at %L has more values than variables",
7793 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7794 accessed by host or use association, is a dummy argument to a pure function,
7795 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7796 is storage associated with any such variable, shall not be used in the
7797 following contexts: (clients of this function). */
7799 /* Determines if a variable is not 'pure', ie not assignable within a pure
7800 procedure. Returns zero if assignment is OK, nonzero if there is a
7803 gfc_impure_variable (gfc_symbol *sym)
7807 if (sym->attr.use_assoc || sym->attr.in_common)
7810 if (sym->ns != gfc_current_ns)
7811 return !sym->attr.function;
7813 proc = sym->ns->proc_name;
7814 if (sym->attr.dummy && gfc_pure (proc)
7815 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7817 proc->attr.function))
7820 /* TODO: Sort out what can be storage associated, if anything, and include
7821 it here. In principle equivalences should be scanned but it does not
7822 seem to be possible to storage associate an impure variable this way. */
7827 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7828 symbol of the current procedure. */
7831 gfc_pure (gfc_symbol *sym)
7833 symbol_attribute attr;
7836 sym = gfc_current_ns->proc_name;
7842 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7846 /* Test whether the current procedure is elemental or not. */
7849 gfc_elemental (gfc_symbol *sym)
7851 symbol_attribute attr;
7854 sym = gfc_current_ns->proc_name;
7859 return attr.flavor == FL_PROCEDURE && attr.elemental;
7863 /* Warn about unused labels. */
7866 warn_unused_fortran_label (gfc_st_label *label)
7871 warn_unused_fortran_label (label->left);
7873 if (label->defined == ST_LABEL_UNKNOWN)
7876 switch (label->referenced)
7878 case ST_LABEL_UNKNOWN:
7879 gfc_warning ("Label %d at %L defined but not used", label->value,
7883 case ST_LABEL_BAD_TARGET:
7884 gfc_warning ("Label %d at %L defined but cannot be used",
7885 label->value, &label->where);
7892 warn_unused_fortran_label (label->right);
7896 /* Returns the sequence type of a symbol or sequence. */
7899 sequence_type (gfc_typespec ts)
7908 if (ts.derived->components == NULL)
7909 return SEQ_NONDEFAULT;
7911 result = sequence_type (ts.derived->components->ts);
7912 for (c = ts.derived->components->next; c; c = c->next)
7913 if (sequence_type (c->ts) != result)
7919 if (ts.kind != gfc_default_character_kind)
7920 return SEQ_NONDEFAULT;
7922 return SEQ_CHARACTER;
7925 if (ts.kind != gfc_default_integer_kind)
7926 return SEQ_NONDEFAULT;
7931 if (!(ts.kind == gfc_default_real_kind
7932 || ts.kind == gfc_default_double_kind))
7933 return SEQ_NONDEFAULT;
7938 if (ts.kind != gfc_default_complex_kind)
7939 return SEQ_NONDEFAULT;
7944 if (ts.kind != gfc_default_logical_kind)
7945 return SEQ_NONDEFAULT;
7950 return SEQ_NONDEFAULT;
7955 /* Resolve derived type EQUIVALENCE object. */
7958 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
7961 gfc_component *c = derived->components;
7966 /* Shall not be an object of nonsequence derived type. */
7967 if (!derived->attr.sequence)
7969 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
7970 "attribute to be an EQUIVALENCE object", sym->name,
7975 /* Shall not have allocatable components. */
7976 if (derived->attr.alloc_comp)
7978 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
7979 "components to be an EQUIVALENCE object",sym->name,
7984 for (; c ; c = c->next)
7988 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
7991 /* Shall not be an object of sequence derived type containing a pointer
7992 in the structure. */
7995 gfc_error ("Derived type variable '%s' at %L with pointer "
7996 "component(s) cannot be an EQUIVALENCE object",
7997 sym->name, &e->where);
8005 /* Resolve equivalence object.
8006 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8007 an allocatable array, an object of nonsequence derived type, an object of
8008 sequence derived type containing a pointer at any level of component
8009 selection, an automatic object, a function name, an entry name, a result
8010 name, a named constant, a structure component, or a subobject of any of
8011 the preceding objects. A substring shall not have length zero. A
8012 derived type shall not have components with default initialization nor
8013 shall two objects of an equivalence group be initialized.
8014 Either all or none of the objects shall have an protected attribute.
8015 The simple constraints are done in symbol.c(check_conflict) and the rest
8016 are implemented here. */
8019 resolve_equivalence (gfc_equiv *eq)
8022 gfc_symbol *derived;
8023 gfc_symbol *first_sym;
8026 locus *last_where = NULL;
8027 seq_type eq_type, last_eq_type;
8028 gfc_typespec *last_ts;
8029 int object, cnt_protected;
8030 const char *value_name;
8034 last_ts = &eq->expr->symtree->n.sym->ts;
8036 first_sym = eq->expr->symtree->n.sym;
8040 for (object = 1; eq; eq = eq->eq, object++)
8044 e->ts = e->symtree->n.sym->ts;
8045 /* match_varspec might not know yet if it is seeing
8046 array reference or substring reference, as it doesn't
8048 if (e->ref && e->ref->type == REF_ARRAY)
8050 gfc_ref *ref = e->ref;
8051 sym = e->symtree->n.sym;
8053 if (sym->attr.dimension)
8055 ref->u.ar.as = sym->as;
8059 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8060 if (e->ts.type == BT_CHARACTER
8062 && ref->type == REF_ARRAY
8063 && ref->u.ar.dimen == 1
8064 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8065 && ref->u.ar.stride[0] == NULL)
8067 gfc_expr *start = ref->u.ar.start[0];
8068 gfc_expr *end = ref->u.ar.end[0];
8071 /* Optimize away the (:) reference. */
8072 if (start == NULL && end == NULL)
8077 e->ref->next = ref->next;
8082 ref->type = REF_SUBSTRING;
8084 start = gfc_int_expr (1);
8085 ref->u.ss.start = start;
8086 if (end == NULL && e->ts.cl)
8087 end = gfc_copy_expr (e->ts.cl->length);
8088 ref->u.ss.end = end;
8089 ref->u.ss.length = e->ts.cl;
8096 /* Any further ref is an error. */
8099 gcc_assert (ref->type == REF_ARRAY);
8100 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8106 if (gfc_resolve_expr (e) == FAILURE)
8109 sym = e->symtree->n.sym;
8111 if (sym->attr.protected)
8113 if (cnt_protected > 0 && cnt_protected != object)
8115 gfc_error ("Either all or none of the objects in the "
8116 "EQUIVALENCE set at %L shall have the "
8117 "PROTECTED attribute",
8122 /* Shall not equivalence common block variables in a PURE procedure. */
8123 if (sym->ns->proc_name
8124 && sym->ns->proc_name->attr.pure
8125 && sym->attr.in_common)
8127 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8128 "object in the pure procedure '%s'",
8129 sym->name, &e->where, sym->ns->proc_name->name);
8133 /* Shall not be a named constant. */
8134 if (e->expr_type == EXPR_CONSTANT)
8136 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8137 "object", sym->name, &e->where);
8141 derived = e->ts.derived;
8142 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8145 /* Check that the types correspond correctly:
8147 A numeric sequence structure may be equivalenced to another sequence
8148 structure, an object of default integer type, default real type, double
8149 precision real type, default logical type such that components of the
8150 structure ultimately only become associated to objects of the same
8151 kind. A character sequence structure may be equivalenced to an object
8152 of default character kind or another character sequence structure.
8153 Other objects may be equivalenced only to objects of the same type and
8156 /* Identical types are unconditionally OK. */
8157 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8158 goto identical_types;
8160 last_eq_type = sequence_type (*last_ts);
8161 eq_type = sequence_type (sym->ts);
8163 /* Since the pair of objects is not of the same type, mixed or
8164 non-default sequences can be rejected. */
8166 msg = "Sequence %s with mixed components in EQUIVALENCE "
8167 "statement at %L with different type objects";
8169 && last_eq_type == SEQ_MIXED
8170 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8172 || (eq_type == SEQ_MIXED
8173 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8174 &e->where) == FAILURE))
8177 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8178 "statement at %L with objects of different type";
8180 && last_eq_type == SEQ_NONDEFAULT
8181 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8182 last_where) == FAILURE)
8183 || (eq_type == SEQ_NONDEFAULT
8184 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8185 &e->where) == FAILURE))
8188 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8189 "EQUIVALENCE statement at %L";
8190 if (last_eq_type == SEQ_CHARACTER
8191 && eq_type != SEQ_CHARACTER
8192 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8193 &e->where) == FAILURE)
8196 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8197 "EQUIVALENCE statement at %L";
8198 if (last_eq_type == SEQ_NUMERIC
8199 && eq_type != SEQ_NUMERIC
8200 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8201 &e->where) == FAILURE)
8206 last_where = &e->where;
8211 /* Shall not be an automatic array. */
8212 if (e->ref->type == REF_ARRAY
8213 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8215 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8216 "an EQUIVALENCE object", sym->name, &e->where);
8223 /* Shall not be a structure component. */
8224 if (r->type == REF_COMPONENT)
8226 gfc_error ("Structure component '%s' at %L cannot be an "
8227 "EQUIVALENCE object",
8228 r->u.c.component->name, &e->where);
8232 /* A substring shall not have length zero. */
8233 if (r->type == REF_SUBSTRING)
8235 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8237 gfc_error ("Substring at %L has length zero",
8238 &r->u.ss.start->where);
8248 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8251 resolve_fntype (gfc_namespace *ns)
8256 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8259 /* If there are any entries, ns->proc_name is the entry master
8260 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8262 sym = ns->entries->sym;
8264 sym = ns->proc_name;
8265 if (sym->result == sym
8266 && sym->ts.type == BT_UNKNOWN
8267 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8268 && !sym->attr.untyped)
8270 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8271 sym->name, &sym->declared_at);
8272 sym->attr.untyped = 1;
8275 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8276 && !gfc_check_access (sym->ts.derived->attr.access,
8277 sym->ts.derived->ns->default_access)
8278 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8280 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8281 sym->name, &sym->declared_at, sym->ts.derived->name);
8285 for (el = ns->entries->next; el; el = el->next)
8287 if (el->sym->result == el->sym
8288 && el->sym->ts.type == BT_UNKNOWN
8289 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8290 && !el->sym->attr.untyped)
8292 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8293 el->sym->name, &el->sym->declared_at);
8294 el->sym->attr.untyped = 1;
8299 /* 12.3.2.1.1 Defined operators. */
8302 gfc_resolve_uops (gfc_symtree *symtree)
8306 gfc_formal_arglist *formal;
8308 if (symtree == NULL)
8311 gfc_resolve_uops (symtree->left);
8312 gfc_resolve_uops (symtree->right);
8314 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8317 if (!sym->attr.function)
8318 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8319 sym->name, &sym->declared_at);
8321 if (sym->ts.type == BT_CHARACTER
8322 && !(sym->ts.cl && sym->ts.cl->length)
8323 && !(sym->result && sym->result->ts.cl
8324 && sym->result->ts.cl->length))
8325 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8326 "character length", sym->name, &sym->declared_at);
8328 formal = sym->formal;
8329 if (!formal || !formal->sym)
8331 gfc_error ("User operator procedure '%s' at %L must have at least "
8332 "one argument", sym->name, &sym->declared_at);
8336 if (formal->sym->attr.intent != INTENT_IN)
8337 gfc_error ("First argument of operator interface at %L must be "
8338 "INTENT(IN)", &sym->declared_at);
8340 if (formal->sym->attr.optional)
8341 gfc_error ("First argument of operator interface at %L cannot be "
8342 "optional", &sym->declared_at);
8344 formal = formal->next;
8345 if (!formal || !formal->sym)
8348 if (formal->sym->attr.intent != INTENT_IN)
8349 gfc_error ("Second argument of operator interface at %L must be "
8350 "INTENT(IN)", &sym->declared_at);
8352 if (formal->sym->attr.optional)
8353 gfc_error ("Second argument of operator interface at %L cannot be "
8354 "optional", &sym->declared_at);
8357 gfc_error ("Operator interface at %L must have, at most, two "
8358 "arguments", &sym->declared_at);
8363 /* Examine all of the expressions associated with a program unit,
8364 assign types to all intermediate expressions, make sure that all
8365 assignments are to compatible types and figure out which names
8366 refer to which functions or subroutines. It doesn't check code
8367 block, which is handled by resolve_code. */
8370 resolve_types (gfc_namespace *ns)
8377 gfc_current_ns = ns;
8379 resolve_entries (ns);
8381 resolve_common_blocks (ns->common_root);
8383 resolve_contained_functions (ns);
8385 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8387 for (cl = ns->cl_list; cl; cl = cl->next)
8388 resolve_charlen (cl);
8390 gfc_traverse_ns (ns, resolve_symbol);
8392 resolve_fntype (ns);
8394 for (n = ns->contained; n; n = n->sibling)
8396 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8397 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8398 "also be PURE", n->proc_name->name,
8399 &n->proc_name->declared_at);
8405 gfc_check_interfaces (ns);
8407 gfc_traverse_ns (ns, resolve_values);
8413 for (d = ns->data; d; d = d->next)
8417 gfc_traverse_ns (ns, gfc_formalize_init_value);
8419 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8421 if (ns->common_root != NULL)
8422 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8424 for (eq = ns->equiv; eq; eq = eq->next)
8425 resolve_equivalence (eq);
8427 /* Warn about unused labels. */
8428 if (warn_unused_label)
8429 warn_unused_fortran_label (ns->st_labels);
8431 gfc_resolve_uops (ns->uop_root);
8435 /* Call resolve_code recursively. */
8438 resolve_codes (gfc_namespace *ns)
8442 for (n = ns->contained; n; n = n->sibling)
8445 gfc_current_ns = ns;
8447 /* Set to an out of range value. */
8448 current_entry_id = -1;
8450 bitmap_obstack_initialize (&labels_obstack);
8451 resolve_code (ns->code, ns);
8452 bitmap_obstack_release (&labels_obstack);
8456 /* This function is called after a complete program unit has been compiled.
8457 Its purpose is to examine all of the expressions associated with a program
8458 unit, assign types to all intermediate expressions, make sure that all
8459 assignments are to compatible types and figure out which names refer to
8460 which functions or subroutines. */
8463 gfc_resolve (gfc_namespace *ns)
8465 gfc_namespace *old_ns;
8467 old_ns = gfc_current_ns;
8472 gfc_current_ns = old_ns;