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 /* Figure out if a function reference is pure or not. Also set the name
1556 of the function for a potential error message. Return nonzero if the
1557 function is PURE, zero if not. */
1560 pure_function (gfc_expr *e, const char **name)
1566 if (e->symtree != NULL
1567 && e->symtree->n.sym != NULL
1568 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1571 if (e->value.function.esym)
1573 pure = gfc_pure (e->value.function.esym);
1574 *name = e->value.function.esym->name;
1576 else if (e->value.function.isym)
1578 pure = e->value.function.isym->pure
1579 || e->value.function.isym->elemental;
1580 *name = e->value.function.isym->name;
1584 /* Implicit functions are not pure. */
1586 *name = e->value.function.name;
1594 is_scalar_expr_ptr (gfc_expr *expr)
1596 try retval = SUCCESS;
1601 /* See if we have a gfc_ref, which means we have a substring, array
1602 reference, or a component. */
1603 if (expr->ref != NULL)
1606 while (ref->next != NULL)
1612 if (ref->u.ss.length != NULL
1613 && ref->u.ss.length->length != NULL
1615 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1617 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1619 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1620 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1621 if (end - start + 1 != 1)
1628 if (ref->u.ar.type == AR_ELEMENT)
1630 else if (ref->u.ar.type == AR_FULL)
1632 /* The user can give a full array if the array is of size 1. */
1633 if (ref->u.ar.as != NULL
1634 && ref->u.ar.as->rank == 1
1635 && ref->u.ar.as->type == AS_EXPLICIT
1636 && ref->u.ar.as->lower[0] != NULL
1637 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1638 && ref->u.ar.as->upper[0] != NULL
1639 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1641 /* If we have a character string, we need to check if
1642 its length is one. */
1643 if (expr->ts.type == BT_CHARACTER)
1645 if (expr->ts.cl == NULL
1646 || expr->ts.cl->length == NULL
1647 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1653 /* We have constant lower and upper bounds. If the
1654 difference between is 1, it can be considered a
1656 start = (int) mpz_get_si
1657 (ref->u.ar.as->lower[0]->value.integer);
1658 end = (int) mpz_get_si
1659 (ref->u.ar.as->upper[0]->value.integer);
1660 if (end - start + 1 != 1)
1675 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1677 /* Character string. Make sure it's of length 1. */
1678 if (expr->ts.cl == NULL
1679 || expr->ts.cl->length == NULL
1680 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1683 else if (expr->rank != 0)
1690 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1691 and, in the case of c_associated, set the binding label based on
1695 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1696 gfc_symbol **new_sym)
1698 char name[GFC_MAX_SYMBOL_LEN + 1];
1699 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1700 int optional_arg = 0;
1701 try retval = SUCCESS;
1702 gfc_symbol *args_sym;
1704 args_sym = args->expr->symtree->n.sym;
1706 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1708 /* If the user gave two args then they are providing something for
1709 the optional arg (the second cptr). Therefore, set the name and
1710 binding label to the c_associated for two cptrs. Otherwise,
1711 set c_associated to expect one cptr. */
1715 sprintf (name, "%s_2", sym->name);
1716 sprintf (binding_label, "%s_2", sym->binding_label);
1722 sprintf (name, "%s_1", sym->name);
1723 sprintf (binding_label, "%s_1", sym->binding_label);
1727 /* Get a new symbol for the version of c_associated that
1729 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1731 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1732 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1734 sprintf (name, "%s", sym->name);
1735 sprintf (binding_label, "%s", sym->binding_label);
1737 /* Error check the call. */
1738 if (args->next != NULL)
1740 gfc_error_now ("More actual than formal arguments in '%s' "
1741 "call at %L", name, &(args->expr->where));
1744 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1746 /* Make sure we have either the target or pointer attribute. */
1747 if (!(args->expr->symtree->n.sym->attr.target)
1748 && !(args->expr->symtree->n.sym->attr.pointer))
1750 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1751 "a TARGET or an associated pointer",
1752 args->expr->symtree->n.sym->name,
1753 sym->name, &(args->expr->where));
1757 /* See if we have interoperable type and type param. */
1758 if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
1759 args->expr->symtree->n.sym->name,
1760 &(args->expr->where)) == SUCCESS
1761 || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
1763 if (args_sym->attr.target == 1)
1765 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1766 has the target attribute and is interoperable. */
1767 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1768 allocatable variable that has the TARGET attribute and
1769 is not an array of zero size. */
1770 if (args_sym->attr.allocatable == 1)
1772 if (args_sym->attr.dimension != 0
1773 && (args_sym->as && args_sym->as->rank == 0))
1775 gfc_error_now ("Allocatable variable '%s' used as a "
1776 "parameter to '%s' at %L must not be "
1777 "an array of zero size",
1778 args_sym->name, sym->name,
1779 &(args->expr->where));
1785 /* Make sure it's not a character string. Arrays of
1786 any type should be ok if the variable is of a C
1787 interoperable type. */
1788 if (args_sym->ts.type == BT_CHARACTER
1789 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1791 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1792 "%L must have a length of 1",
1793 args_sym->name, sym->name,
1794 &(args->expr->where));
1799 else if (args_sym->attr.pointer == 1
1800 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1802 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1804 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1805 "associated scalar POINTER", args_sym->name,
1806 sym->name, &(args->expr->where));
1812 /* The parameter is not required to be C interoperable. If it
1813 is not C interoperable, it must be a nonpolymorphic scalar
1814 with no length type parameters. It still must have either
1815 the pointer or target attribute, and it can be
1816 allocatable (but must be allocated when c_loc is called). */
1817 if (args_sym->attr.dimension != 0
1818 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1820 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1821 "scalar", args_sym->name, sym->name,
1822 &(args->expr->where));
1825 else if (args_sym->ts.type == BT_CHARACTER
1826 && args_sym->ts.cl != NULL)
1828 gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
1829 "cannot have a length type parameter",
1830 args_sym->name, sym->name,
1831 &(args->expr->where));
1836 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1838 if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1840 /* TODO: Update this error message to allow for procedure
1841 pointers once they are implemented. */
1842 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1844 args->expr->symtree->n.sym->name, sym->name,
1845 &(args->expr->where));
1848 else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
1850 gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
1852 args->expr->symtree->n.sym->name, sym->name,
1853 &(args->expr->where));
1858 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1863 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1864 "iso_c_binding function: '%s'!\n", sym->name);
1871 /* Resolve a function call, which means resolving the arguments, then figuring
1872 out which entity the name refers to. */
1873 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1874 to INTENT(OUT) or INTENT(INOUT). */
1877 resolve_function (gfc_expr *expr)
1879 gfc_actual_arglist *arg;
1884 procedure_type p = PROC_INTRINSIC;
1888 sym = expr->symtree->n.sym;
1890 if (sym && sym->attr.flavor == FL_VARIABLE)
1892 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1896 /* If the procedure is not internal, a statement function or a module
1897 procedure,it must be external and should be checked for usage. */
1898 if (sym && !sym->attr.dummy && !sym->attr.contained
1899 && sym->attr.proc != PROC_ST_FUNCTION
1900 && !sym->attr.use_assoc
1902 resolve_global_procedure (sym, &expr->where, 0);
1904 /* Switch off assumed size checking and do this again for certain kinds
1905 of procedure, once the procedure itself is resolved. */
1906 need_full_assumed_size++;
1908 if (expr->symtree && expr->symtree->n.sym)
1909 p = expr->symtree->n.sym->attr.proc;
1911 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1914 /* Need to setup the call to the correct c_associated, depending on
1915 the number of cptrs to user gives to compare. */
1916 if (sym && sym->attr.is_iso_c == 1)
1918 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
1922 /* Get the symtree for the new symbol (resolved func).
1923 the old one will be freed later, when it's no longer used. */
1924 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
1927 /* Resume assumed_size checking. */
1928 need_full_assumed_size--;
1930 if (sym && sym->ts.type == BT_CHARACTER
1932 && sym->ts.cl->length == NULL
1934 && expr->value.function.esym == NULL
1935 && !sym->attr.contained)
1937 /* Internal procedures are taken care of in resolve_contained_fntype. */
1938 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1939 "be used at %L since it is not a dummy argument",
1940 sym->name, &expr->where);
1944 /* See if function is already resolved. */
1946 if (expr->value.function.name != NULL)
1948 if (expr->ts.type == BT_UNKNOWN)
1954 /* Apply the rules of section 14.1.2. */
1956 switch (procedure_kind (sym))
1959 t = resolve_generic_f (expr);
1962 case PTYPE_SPECIFIC:
1963 t = resolve_specific_f (expr);
1967 t = resolve_unknown_f (expr);
1971 gfc_internal_error ("resolve_function(): bad function type");
1975 /* If the expression is still a function (it might have simplified),
1976 then we check to see if we are calling an elemental function. */
1978 if (expr->expr_type != EXPR_FUNCTION)
1981 temp = need_full_assumed_size;
1982 need_full_assumed_size = 0;
1984 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1987 if (omp_workshare_flag
1988 && expr->value.function.esym
1989 && ! gfc_elemental (expr->value.function.esym))
1991 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
1992 "in WORKSHARE construct", expr->value.function.esym->name,
1997 #define GENERIC_ID expr->value.function.isym->id
1998 else if (expr->value.function.actual != NULL
1999 && expr->value.function.isym != NULL
2000 && GENERIC_ID != GFC_ISYM_LBOUND
2001 && GENERIC_ID != GFC_ISYM_LEN
2002 && GENERIC_ID != GFC_ISYM_LOC
2003 && GENERIC_ID != GFC_ISYM_PRESENT)
2005 /* Array intrinsics must also have the last upper bound of an
2006 assumed size array argument. UBOUND and SIZE have to be
2007 excluded from the check if the second argument is anything
2010 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2011 || GENERIC_ID == GFC_ISYM_SIZE;
2013 for (arg = expr->value.function.actual; arg; arg = arg->next)
2015 if (inquiry && arg->next != NULL && arg->next->expr)
2017 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2020 if ((int)mpz_get_si (arg->next->expr->value.integer)
2025 if (arg->expr != NULL
2026 && arg->expr->rank > 0
2027 && resolve_assumed_size_actual (arg->expr))
2033 need_full_assumed_size = temp;
2036 if (!pure_function (expr, &name) && name)
2040 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2041 "FORALL %s", name, &expr->where,
2042 forall_flag == 2 ? "mask" : "block");
2045 else if (gfc_pure (NULL))
2047 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2048 "procedure within a PURE procedure", name, &expr->where);
2053 /* Functions without the RECURSIVE attribution are not allowed to
2054 * call themselves. */
2055 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2057 gfc_symbol *esym, *proc;
2058 esym = expr->value.function.esym;
2059 proc = gfc_current_ns->proc_name;
2062 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2063 "RECURSIVE", name, &expr->where);
2067 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2068 && esym->ns->entries->sym == proc->ns->entries->sym)
2070 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2071 "'%s' is not declared as RECURSIVE",
2072 esym->name, &expr->where, esym->ns->entries->sym->name);
2077 /* Character lengths of use associated functions may contains references to
2078 symbols not referenced from the current program unit otherwise. Make sure
2079 those symbols are marked as referenced. */
2081 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2082 && expr->value.function.esym->attr.use_assoc)
2084 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2088 find_noncopying_intrinsics (expr->value.function.esym,
2089 expr->value.function.actual);
2091 /* Make sure that the expression has a typespec that works. */
2092 if (expr->ts.type == BT_UNKNOWN)
2094 if (expr->symtree->n.sym->result
2095 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2096 expr->ts = expr->symtree->n.sym->result->ts;
2103 /************* Subroutine resolution *************/
2106 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2112 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2113 sym->name, &c->loc);
2114 else if (gfc_pure (NULL))
2115 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2121 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2125 if (sym->attr.generic)
2127 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2130 c->resolved_sym = s;
2131 pure_subroutine (c, s);
2135 /* TODO: Need to search for elemental references in generic interface. */
2138 if (sym->attr.intrinsic)
2139 return gfc_intrinsic_sub_interface (c, 0);
2146 resolve_generic_s (gfc_code *c)
2151 sym = c->symtree->n.sym;
2155 m = resolve_generic_s0 (c, sym);
2158 else if (m == MATCH_ERROR)
2162 if (sym->ns->parent == NULL)
2164 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2168 if (!generic_sym (sym))
2172 /* Last ditch attempt. See if the reference is to an intrinsic
2173 that possesses a matching interface. 14.1.2.4 */
2174 sym = c->symtree->n.sym;
2176 if (!gfc_intrinsic_name (sym->name, 1))
2178 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2179 sym->name, &c->loc);
2183 m = gfc_intrinsic_sub_interface (c, 0);
2187 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2188 "intrinsic subroutine interface", sym->name, &c->loc);
2194 /* Set the name and binding label of the subroutine symbol in the call
2195 expression represented by 'c' to include the type and kind of the
2196 second parameter. This function is for resolving the appropriate
2197 version of c_f_pointer() and c_f_procpointer(). For example, a
2198 call to c_f_pointer() for a default integer pointer could have a
2199 name of c_f_pointer_i4. If no second arg exists, which is an error
2200 for these two functions, it defaults to the generic symbol's name
2201 and binding label. */
2204 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2205 char *name, char *binding_label)
2207 gfc_expr *arg = NULL;
2211 /* The second arg of c_f_pointer and c_f_procpointer determines
2212 the type and kind for the procedure name. */
2213 arg = c->ext.actual->next->expr;
2217 /* Set up the name to have the given symbol's name,
2218 plus the type and kind. */
2219 /* a derived type is marked with the type letter 'u' */
2220 if (arg->ts.type == BT_DERIVED)
2223 kind = 0; /* set the kind as 0 for now */
2227 type = gfc_type_letter (arg->ts.type);
2228 kind = arg->ts.kind;
2230 sprintf (name, "%s_%c%d", sym->name, type, kind);
2231 /* Set up the binding label as the given symbol's label plus
2232 the type and kind. */
2233 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2237 /* If the second arg is missing, set the name and label as
2238 was, cause it should at least be found, and the missing
2239 arg error will be caught by compare_parameters(). */
2240 sprintf (name, "%s", sym->name);
2241 sprintf (binding_label, "%s", sym->binding_label);
2248 /* Resolve a generic version of the iso_c_binding procedure given
2249 (sym) to the specific one based on the type and kind of the
2250 argument(s). Currently, this function resolves c_f_pointer() and
2251 c_f_procpointer based on the type and kind of the second argument
2252 (FPTR). Other iso_c_binding procedures aren't specially handled.
2253 Upon successfully exiting, c->resolved_sym will hold the resolved
2254 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2258 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2260 gfc_symbol *new_sym;
2261 /* this is fine, since we know the names won't use the max */
2262 char name[GFC_MAX_SYMBOL_LEN + 1];
2263 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2264 /* default to success; will override if find error */
2265 match m = MATCH_YES;
2266 gfc_symbol *tmp_sym;
2268 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2269 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2271 set_name_and_label (c, sym, name, binding_label);
2273 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2275 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2277 /* Make sure we got a third arg. The type/rank of it will
2278 be checked later if it's there (gfc_procedure_use()). */
2279 if (c->ext.actual->next->expr->rank != 0 &&
2280 c->ext.actual->next->next == NULL)
2283 gfc_error ("Missing SHAPE parameter for call to %s "
2284 "at %L", sym->name, &(c->loc));
2286 /* Make sure the param is a POINTER. No need to make sure
2287 it does not have INTENT(IN) since it is a POINTER. */
2288 tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
2289 if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
2291 gfc_error ("Argument '%s' to '%s' at %L "
2292 "must have the POINTER attribute",
2293 tmp_sym->name, sym->name, &(c->loc));
2299 if (m != MATCH_ERROR)
2301 /* the 1 means to add the optional arg to formal list */
2302 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2304 /* for error reporting, say it's declared where the original was */
2305 new_sym->declared_at = sym->declared_at;
2308 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2310 /* TODO: Figure out if this is even reacable; this part of the
2311 conditional may not be necessary. */
2313 if (c->ext.actual->next == NULL)
2315 /* The user did not give two args, so resolve to the version
2316 of c_associated expecting one arg. */
2318 /* get rid of the second arg */
2319 /* TODO!! Should free up the memory here! */
2320 sym->formal->next = NULL;
2328 sprintf (name, "%s_%d", sym->name, num_args);
2329 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2330 sym->name = gfc_get_string (name);
2331 strcpy (sym->binding_label, binding_label);
2335 /* no differences for c_loc or c_funloc */
2339 /* set the resolved symbol */
2340 if (m != MATCH_ERROR)
2342 gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
2343 c->resolved_sym = new_sym;
2346 c->resolved_sym = sym;
2352 /* Resolve a subroutine call known to be specific. */
2355 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2359 if(sym->attr.is_iso_c)
2361 m = gfc_iso_c_sub_interface (c,sym);
2365 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2367 if (sym->attr.dummy)
2369 sym->attr.proc = PROC_DUMMY;
2373 sym->attr.proc = PROC_EXTERNAL;
2377 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2380 if (sym->attr.intrinsic)
2382 m = gfc_intrinsic_sub_interface (c, 1);
2386 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2387 "with an intrinsic", sym->name, &c->loc);
2395 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2397 c->resolved_sym = sym;
2398 pure_subroutine (c, sym);
2405 resolve_specific_s (gfc_code *c)
2410 sym = c->symtree->n.sym;
2414 m = resolve_specific_s0 (c, sym);
2417 if (m == MATCH_ERROR)
2420 if (sym->ns->parent == NULL)
2423 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2429 sym = c->symtree->n.sym;
2430 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2431 sym->name, &c->loc);
2437 /* Resolve a subroutine call not known to be generic nor specific. */
2440 resolve_unknown_s (gfc_code *c)
2444 sym = c->symtree->n.sym;
2446 if (sym->attr.dummy)
2448 sym->attr.proc = PROC_DUMMY;
2452 /* See if we have an intrinsic function reference. */
2454 if (gfc_intrinsic_name (sym->name, 1))
2456 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2461 /* The reference is to an external name. */
2464 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2466 c->resolved_sym = sym;
2468 pure_subroutine (c, sym);
2474 /* Resolve a subroutine call. Although it was tempting to use the same code
2475 for functions, subroutines and functions are stored differently and this
2476 makes things awkward. */
2479 resolve_call (gfc_code *c)
2482 procedure_type ptype = PROC_INTRINSIC;
2484 if (c->symtree && c->symtree->n.sym
2485 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2487 gfc_error ("'%s' at %L has a type, which is not consistent with "
2488 "the CALL at %L", c->symtree->n.sym->name,
2489 &c->symtree->n.sym->declared_at, &c->loc);
2493 /* If the procedure is not internal or module, it must be external and
2494 should be checked for usage. */
2495 if (c->symtree && c->symtree->n.sym
2496 && !c->symtree->n.sym->attr.dummy
2497 && !c->symtree->n.sym->attr.contained
2498 && !c->symtree->n.sym->attr.use_assoc)
2499 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2501 /* Subroutines without the RECURSIVE attribution are not allowed to
2502 * call themselves. */
2503 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2505 gfc_symbol *csym, *proc;
2506 csym = c->symtree->n.sym;
2507 proc = gfc_current_ns->proc_name;
2510 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2511 "RECURSIVE", csym->name, &c->loc);
2515 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2516 && csym->ns->entries->sym == proc->ns->entries->sym)
2518 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2519 "'%s' is not declared as RECURSIVE",
2520 csym->name, &c->loc, csym->ns->entries->sym->name);
2525 /* Switch off assumed size checking and do this again for certain kinds
2526 of procedure, once the procedure itself is resolved. */
2527 need_full_assumed_size++;
2529 if (c->symtree && c->symtree->n.sym)
2530 ptype = c->symtree->n.sym->attr.proc;
2532 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2535 /* Resume assumed_size checking. */
2536 need_full_assumed_size--;
2539 if (c->resolved_sym == NULL)
2540 switch (procedure_kind (c->symtree->n.sym))
2543 t = resolve_generic_s (c);
2546 case PTYPE_SPECIFIC:
2547 t = resolve_specific_s (c);
2551 t = resolve_unknown_s (c);
2555 gfc_internal_error ("resolve_subroutine(): bad function type");
2558 /* Some checks of elemental subroutine actual arguments. */
2559 if (resolve_elemental_actual (NULL, c) == FAILURE)
2563 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2568 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2569 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2570 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2571 if their shapes do not match. If either op1->shape or op2->shape is
2572 NULL, return SUCCESS. */
2575 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2582 if (op1->shape != NULL && op2->shape != NULL)
2584 for (i = 0; i < op1->rank; i++)
2586 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2588 gfc_error ("Shapes for operands at %L and %L are not conformable",
2589 &op1->where, &op2->where);
2600 /* Resolve an operator expression node. This can involve replacing the
2601 operation with a user defined function call. */
2604 resolve_operator (gfc_expr *e)
2606 gfc_expr *op1, *op2;
2608 bool dual_locus_error;
2611 /* Resolve all subnodes-- give them types. */
2613 switch (e->value.op.operator)
2616 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2619 /* Fall through... */
2622 case INTRINSIC_UPLUS:
2623 case INTRINSIC_UMINUS:
2624 case INTRINSIC_PARENTHESES:
2625 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2630 /* Typecheck the new node. */
2632 op1 = e->value.op.op1;
2633 op2 = e->value.op.op2;
2634 dual_locus_error = false;
2636 if ((op1 && op1->expr_type == EXPR_NULL)
2637 || (op2 && op2->expr_type == EXPR_NULL))
2639 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2643 switch (e->value.op.operator)
2645 case INTRINSIC_UPLUS:
2646 case INTRINSIC_UMINUS:
2647 if (op1->ts.type == BT_INTEGER
2648 || op1->ts.type == BT_REAL
2649 || op1->ts.type == BT_COMPLEX)
2655 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2656 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2659 case INTRINSIC_PLUS:
2660 case INTRINSIC_MINUS:
2661 case INTRINSIC_TIMES:
2662 case INTRINSIC_DIVIDE:
2663 case INTRINSIC_POWER:
2664 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2666 gfc_type_convert_binary (e);
2671 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2672 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2673 gfc_typename (&op2->ts));
2676 case INTRINSIC_CONCAT:
2677 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2679 e->ts.type = BT_CHARACTER;
2680 e->ts.kind = op1->ts.kind;
2685 _("Operands of string concatenation operator at %%L are %s/%s"),
2686 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2692 case INTRINSIC_NEQV:
2693 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2695 e->ts.type = BT_LOGICAL;
2696 e->ts.kind = gfc_kind_max (op1, op2);
2697 if (op1->ts.kind < e->ts.kind)
2698 gfc_convert_type (op1, &e->ts, 2);
2699 else if (op2->ts.kind < e->ts.kind)
2700 gfc_convert_type (op2, &e->ts, 2);
2704 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2705 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2706 gfc_typename (&op2->ts));
2711 if (op1->ts.type == BT_LOGICAL)
2713 e->ts.type = BT_LOGICAL;
2714 e->ts.kind = op1->ts.kind;
2718 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2719 gfc_typename (&op1->ts));
2726 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2728 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2732 /* Fall through... */
2736 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2738 e->ts.type = BT_LOGICAL;
2739 e->ts.kind = gfc_default_logical_kind;
2743 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2745 gfc_type_convert_binary (e);
2747 e->ts.type = BT_LOGICAL;
2748 e->ts.kind = gfc_default_logical_kind;
2752 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2754 _("Logicals at %%L must be compared with %s instead of %s"),
2755 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2756 gfc_op2string (e->value.op.operator));
2759 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2760 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2761 gfc_typename (&op2->ts));
2765 case INTRINSIC_USER:
2766 if (e->value.op.uop->operator == NULL)
2767 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2768 else if (op2 == NULL)
2769 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2770 e->value.op.uop->name, gfc_typename (&op1->ts));
2772 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2773 e->value.op.uop->name, gfc_typename (&op1->ts),
2774 gfc_typename (&op2->ts));
2778 case INTRINSIC_PARENTHESES:
2782 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2785 /* Deal with arrayness of an operand through an operator. */
2789 switch (e->value.op.operator)
2791 case INTRINSIC_PLUS:
2792 case INTRINSIC_MINUS:
2793 case INTRINSIC_TIMES:
2794 case INTRINSIC_DIVIDE:
2795 case INTRINSIC_POWER:
2796 case INTRINSIC_CONCAT:
2800 case INTRINSIC_NEQV:
2808 if (op1->rank == 0 && op2->rank == 0)
2811 if (op1->rank == 0 && op2->rank != 0)
2813 e->rank = op2->rank;
2815 if (e->shape == NULL)
2816 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2819 if (op1->rank != 0 && op2->rank == 0)
2821 e->rank = op1->rank;
2823 if (e->shape == NULL)
2824 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2827 if (op1->rank != 0 && op2->rank != 0)
2829 if (op1->rank == op2->rank)
2831 e->rank = op1->rank;
2832 if (e->shape == NULL)
2834 t = compare_shapes(op1, op2);
2838 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2843 /* Allow higher level expressions to work. */
2846 /* Try user-defined operators, and otherwise throw an error. */
2847 dual_locus_error = true;
2849 _("Inconsistent ranks for operator at %%L and %%L"));
2857 case INTRINSIC_UPLUS:
2858 case INTRINSIC_UMINUS:
2859 case INTRINSIC_PARENTHESES:
2860 e->rank = op1->rank;
2862 if (e->shape == NULL)
2863 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2865 /* Simply copy arrayness attribute */
2872 /* Attempt to simplify the expression. */
2875 t = gfc_simplify_expr (e, 0);
2876 /* Some calls do not succeed in simplification and return FAILURE
2877 even though there is no error; eg. variable references to
2878 PARAMETER arrays. */
2879 if (!gfc_is_constant_expr (e))
2886 if (gfc_extend_expr (e) == SUCCESS)
2889 if (dual_locus_error)
2890 gfc_error (msg, &op1->where, &op2->where);
2892 gfc_error (msg, &e->where);
2898 /************** Array resolution subroutines **************/
2901 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2904 /* Compare two integer expressions. */
2907 compare_bound (gfc_expr *a, gfc_expr *b)
2911 if (a == NULL || a->expr_type != EXPR_CONSTANT
2912 || b == NULL || b->expr_type != EXPR_CONSTANT)
2915 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2916 gfc_internal_error ("compare_bound(): Bad expression");
2918 i = mpz_cmp (a->value.integer, b->value.integer);
2928 /* Compare an integer expression with an integer. */
2931 compare_bound_int (gfc_expr *a, int b)
2935 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2938 if (a->ts.type != BT_INTEGER)
2939 gfc_internal_error ("compare_bound_int(): Bad expression");
2941 i = mpz_cmp_si (a->value.integer, b);
2951 /* Compare an integer expression with a mpz_t. */
2954 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
2958 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2961 if (a->ts.type != BT_INTEGER)
2962 gfc_internal_error ("compare_bound_int(): Bad expression");
2964 i = mpz_cmp (a->value.integer, b);
2974 /* Compute the last value of a sequence given by a triplet.
2975 Return 0 if it wasn't able to compute the last value, or if the
2976 sequence if empty, and 1 otherwise. */
2979 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
2980 gfc_expr *stride, mpz_t last)
2984 if (start == NULL || start->expr_type != EXPR_CONSTANT
2985 || end == NULL || end->expr_type != EXPR_CONSTANT
2986 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2989 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2990 || (stride != NULL && stride->ts.type != BT_INTEGER))
2993 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2995 if (compare_bound (start, end) == CMP_GT)
2997 mpz_set (last, end->value.integer);
3001 if (compare_bound_int (stride, 0) == CMP_GT)
3003 /* Stride is positive */
3004 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3009 /* Stride is negative */
3010 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3015 mpz_sub (rem, end->value.integer, start->value.integer);
3016 mpz_tdiv_r (rem, rem, stride->value.integer);
3017 mpz_sub (last, end->value.integer, rem);
3024 /* Compare a single dimension of an array reference to the array
3028 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3032 /* Given start, end and stride values, calculate the minimum and
3033 maximum referenced indexes. */
3041 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3043 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3050 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3051 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3053 comparison comp_start_end = compare_bound (AR_START, AR_END);
3055 /* Check for zero stride, which is not allowed. */
3056 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3058 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3062 /* if start == len || (stride > 0 && start < len)
3063 || (stride < 0 && start > len),
3064 then the array section contains at least one element. In this
3065 case, there is an out-of-bounds access if
3066 (start < lower || start > upper). */
3067 if (compare_bound (AR_START, AR_END) == CMP_EQ
3068 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3069 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3070 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3071 && comp_start_end == CMP_GT))
3073 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3074 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3078 /* If we can compute the highest index of the array section,
3079 then it also has to be between lower and upper. */
3080 mpz_init (last_value);
3081 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3084 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3085 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3087 mpz_clear (last_value);
3091 mpz_clear (last_value);
3099 gfc_internal_error ("check_dimension(): Bad array reference");
3105 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3110 /* Compare an array reference with an array specification. */
3113 compare_spec_to_ref (gfc_array_ref *ar)
3120 /* TODO: Full array sections are only allowed as actual parameters. */
3121 if (as->type == AS_ASSUMED_SIZE
3122 && (/*ar->type == AR_FULL
3123 ||*/ (ar->type == AR_SECTION
3124 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3126 gfc_error ("Rightmost upper bound of assumed size array section "
3127 "not specified at %L", &ar->where);
3131 if (ar->type == AR_FULL)
3134 if (as->rank != ar->dimen)
3136 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3137 &ar->where, ar->dimen, as->rank);
3141 for (i = 0; i < as->rank; i++)
3142 if (check_dimension (i, ar, as) == FAILURE)
3149 /* Resolve one part of an array index. */
3152 gfc_resolve_index (gfc_expr *index, int check_scalar)
3159 if (gfc_resolve_expr (index) == FAILURE)
3162 if (check_scalar && index->rank != 0)
3164 gfc_error ("Array index at %L must be scalar", &index->where);
3168 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3170 gfc_error ("Array index at %L must be of INTEGER type",
3175 if (index->ts.type == BT_REAL)
3176 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3177 &index->where) == FAILURE)
3180 if (index->ts.kind != gfc_index_integer_kind
3181 || index->ts.type != BT_INTEGER)
3184 ts.type = BT_INTEGER;
3185 ts.kind = gfc_index_integer_kind;
3187 gfc_convert_type_warn (index, &ts, 2, 0);
3193 /* Resolve a dim argument to an intrinsic function. */
3196 gfc_resolve_dim_arg (gfc_expr *dim)
3201 if (gfc_resolve_expr (dim) == FAILURE)
3206 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3210 if (dim->ts.type != BT_INTEGER)
3212 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3215 if (dim->ts.kind != gfc_index_integer_kind)
3219 ts.type = BT_INTEGER;
3220 ts.kind = gfc_index_integer_kind;
3222 gfc_convert_type_warn (dim, &ts, 2, 0);
3228 /* Given an expression that contains array references, update those array
3229 references to point to the right array specifications. While this is
3230 filled in during matching, this information is difficult to save and load
3231 in a module, so we take care of it here.
3233 The idea here is that the original array reference comes from the
3234 base symbol. We traverse the list of reference structures, setting
3235 the stored reference to references. Component references can
3236 provide an additional array specification. */
3239 find_array_spec (gfc_expr *e)
3243 gfc_symbol *derived;
3246 as = e->symtree->n.sym->as;
3249 for (ref = e->ref; ref; ref = ref->next)
3254 gfc_internal_error ("find_array_spec(): Missing spec");
3261 if (derived == NULL)
3262 derived = e->symtree->n.sym->ts.derived;
3264 c = derived->components;
3266 for (; c; c = c->next)
3267 if (c == ref->u.c.component)
3269 /* Track the sequence of component references. */
3270 if (c->ts.type == BT_DERIVED)
3271 derived = c->ts.derived;
3276 gfc_internal_error ("find_array_spec(): Component not found");
3281 gfc_internal_error ("find_array_spec(): unused as(1)");
3292 gfc_internal_error ("find_array_spec(): unused as(2)");
3296 /* Resolve an array reference. */
3299 resolve_array_ref (gfc_array_ref *ar)
3301 int i, check_scalar;
3304 for (i = 0; i < ar->dimen; i++)
3306 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3308 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3310 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3312 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3317 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3321 ar->dimen_type[i] = DIMEN_ELEMENT;
3325 ar->dimen_type[i] = DIMEN_VECTOR;
3326 if (e->expr_type == EXPR_VARIABLE
3327 && e->symtree->n.sym->ts.type == BT_DERIVED)
3328 ar->start[i] = gfc_get_parentheses (e);
3332 gfc_error ("Array index at %L is an array of rank %d",
3333 &ar->c_where[i], e->rank);
3338 /* If the reference type is unknown, figure out what kind it is. */
3340 if (ar->type == AR_UNKNOWN)
3342 ar->type = AR_ELEMENT;
3343 for (i = 0; i < ar->dimen; i++)
3344 if (ar->dimen_type[i] == DIMEN_RANGE
3345 || ar->dimen_type[i] == DIMEN_VECTOR)
3347 ar->type = AR_SECTION;
3352 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3360 resolve_substring (gfc_ref *ref)
3362 if (ref->u.ss.start != NULL)
3364 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3367 if (ref->u.ss.start->ts.type != BT_INTEGER)
3369 gfc_error ("Substring start index at %L must be of type INTEGER",
3370 &ref->u.ss.start->where);
3374 if (ref->u.ss.start->rank != 0)
3376 gfc_error ("Substring start index at %L must be scalar",
3377 &ref->u.ss.start->where);
3381 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3382 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3383 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3385 gfc_error ("Substring start index at %L is less than one",
3386 &ref->u.ss.start->where);
3391 if (ref->u.ss.end != NULL)
3393 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3396 if (ref->u.ss.end->ts.type != BT_INTEGER)
3398 gfc_error ("Substring end index at %L must be of type INTEGER",
3399 &ref->u.ss.end->where);
3403 if (ref->u.ss.end->rank != 0)
3405 gfc_error ("Substring end index at %L must be scalar",
3406 &ref->u.ss.end->where);
3410 if (ref->u.ss.length != NULL
3411 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3412 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3413 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3415 gfc_error ("Substring end index at %L exceeds the string length",
3416 &ref->u.ss.start->where);
3425 /* Resolve subtype references. */
3428 resolve_ref (gfc_expr *expr)
3430 int current_part_dimension, n_components, seen_part_dimension;
3433 for (ref = expr->ref; ref; ref = ref->next)
3434 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3436 find_array_spec (expr);
3440 for (ref = expr->ref; ref; ref = ref->next)
3444 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3452 resolve_substring (ref);
3456 /* Check constraints on part references. */
3458 current_part_dimension = 0;
3459 seen_part_dimension = 0;
3462 for (ref = expr->ref; ref; ref = ref->next)
3467 switch (ref->u.ar.type)
3471 current_part_dimension = 1;
3475 current_part_dimension = 0;
3479 gfc_internal_error ("resolve_ref(): Bad array reference");
3485 if (current_part_dimension || seen_part_dimension)
3487 if (ref->u.c.component->pointer)
3489 gfc_error ("Component to the right of a part reference "
3490 "with nonzero rank must not have the POINTER "
3491 "attribute at %L", &expr->where);
3494 else if (ref->u.c.component->allocatable)
3496 gfc_error ("Component to the right of a part reference "
3497 "with nonzero rank must not have the ALLOCATABLE "
3498 "attribute at %L", &expr->where);
3510 if (((ref->type == REF_COMPONENT && n_components > 1)
3511 || ref->next == NULL)
3512 && current_part_dimension
3513 && seen_part_dimension)
3515 gfc_error ("Two or more part references with nonzero rank must "
3516 "not be specified at %L", &expr->where);
3520 if (ref->type == REF_COMPONENT)
3522 if (current_part_dimension)
3523 seen_part_dimension = 1;
3525 /* reset to make sure */
3526 current_part_dimension = 0;
3534 /* Given an expression, determine its shape. This is easier than it sounds.
3535 Leaves the shape array NULL if it is not possible to determine the shape. */
3538 expression_shape (gfc_expr *e)
3540 mpz_t array[GFC_MAX_DIMENSIONS];
3543 if (e->rank == 0 || e->shape != NULL)
3546 for (i = 0; i < e->rank; i++)
3547 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3550 e->shape = gfc_get_shape (e->rank);
3552 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3557 for (i--; i >= 0; i--)
3558 mpz_clear (array[i]);
3562 /* Given a variable expression node, compute the rank of the expression by
3563 examining the base symbol and any reference structures it may have. */
3566 expression_rank (gfc_expr *e)
3573 if (e->expr_type == EXPR_ARRAY)
3575 /* Constructors can have a rank different from one via RESHAPE(). */
3577 if (e->symtree == NULL)
3583 e->rank = (e->symtree->n.sym->as == NULL)
3584 ? 0 : e->symtree->n.sym->as->rank;
3590 for (ref = e->ref; ref; ref = ref->next)
3592 if (ref->type != REF_ARRAY)
3595 if (ref->u.ar.type == AR_FULL)
3597 rank = ref->u.ar.as->rank;
3601 if (ref->u.ar.type == AR_SECTION)
3603 /* Figure out the rank of the section. */
3605 gfc_internal_error ("expression_rank(): Two array specs");
3607 for (i = 0; i < ref->u.ar.dimen; i++)
3608 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3609 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3619 expression_shape (e);
3623 /* Resolve a variable expression. */
3626 resolve_variable (gfc_expr *e)
3633 if (e->symtree == NULL)
3636 if (e->ref && resolve_ref (e) == FAILURE)
3639 sym = e->symtree->n.sym;
3640 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3642 e->ts.type = BT_PROCEDURE;
3646 if (sym->ts.type != BT_UNKNOWN)
3647 gfc_variable_attr (e, &e->ts);
3650 /* Must be a simple variable reference. */
3651 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3656 if (check_assumed_size_reference (sym, e))
3659 /* Deal with forward references to entries during resolve_code, to
3660 satisfy, at least partially, 12.5.2.5. */
3661 if (gfc_current_ns->entries
3662 && current_entry_id == sym->entry_id
3665 && cs_base->current->op != EXEC_ENTRY)
3667 gfc_entry_list *entry;
3668 gfc_formal_arglist *formal;
3672 /* If the symbol is a dummy... */
3673 if (sym->attr.dummy)
3675 entry = gfc_current_ns->entries;
3678 /* ...test if the symbol is a parameter of previous entries. */
3679 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3680 for (formal = entry->sym->formal; formal; formal = formal->next)
3682 if (formal->sym && sym->name == formal->sym->name)
3686 /* If it has not been seen as a dummy, this is an error. */
3689 if (specification_expr)
3690 gfc_error ("Variable '%s',used in a specification expression, "
3691 "is referenced at %L before the ENTRY statement "
3692 "in which it is a parameter",
3693 sym->name, &cs_base->current->loc);
3695 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3696 "statement in which it is a parameter",
3697 sym->name, &cs_base->current->loc);
3702 /* Now do the same check on the specification expressions. */
3703 specification_expr = 1;
3704 if (sym->ts.type == BT_CHARACTER
3705 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3709 for (n = 0; n < sym->as->rank; n++)
3711 specification_expr = 1;
3712 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3714 specification_expr = 1;
3715 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3718 specification_expr = 0;
3721 /* Update the symbol's entry level. */
3722 sym->entry_id = current_entry_id + 1;
3729 /* Checks to see that the correct symbol has been host associated.
3730 The only situation where this arises is that in which a twice
3731 contained function is parsed after the host association is made.
3732 Therefore, on detecting this, the line is rematched, having got
3733 rid of the existing references and actual_arg_list. */
3735 check_host_association (gfc_expr *e)
3737 gfc_symbol *sym, *old_sym;
3741 bool retval = e->expr_type == EXPR_FUNCTION;
3743 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3746 old_sym = e->symtree->n.sym;
3748 if (old_sym->attr.use_assoc)
3751 if (gfc_current_ns->parent
3752 && gfc_current_ns->parent->parent
3753 && old_sym->ns != gfc_current_ns)
3755 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3756 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3758 temp_locus = gfc_current_locus;
3759 gfc_current_locus = e->where;
3761 gfc_buffer_error (1);
3763 gfc_free_ref_list (e->ref);
3768 gfc_free_actual_arglist (e->value.function.actual);
3769 e->value.function.actual = NULL;
3772 if (e->shape != NULL)
3774 for (n = 0; n < e->rank; n++)
3775 mpz_clear (e->shape[n]);
3777 gfc_free (e->shape);
3780 gfc_match_rvalue (&expr);
3782 gfc_buffer_error (0);
3784 gcc_assert (expr && sym == expr->symtree->n.sym);
3790 gfc_current_locus = temp_locus;
3793 /* This might have changed! */
3794 return e->expr_type == EXPR_FUNCTION;
3798 /* Resolve an expression. That is, make sure that types of operands agree
3799 with their operators, intrinsic operators are converted to function calls
3800 for overloaded types and unresolved function references are resolved. */
3803 gfc_resolve_expr (gfc_expr *e)
3810 switch (e->expr_type)
3813 t = resolve_operator (e);
3819 if (check_host_association (e))
3820 t = resolve_function (e);
3823 t = resolve_variable (e);
3825 expression_rank (e);
3829 case EXPR_SUBSTRING:
3830 t = resolve_ref (e);
3840 if (resolve_ref (e) == FAILURE)
3843 t = gfc_resolve_array_constructor (e);
3844 /* Also try to expand a constructor. */
3847 expression_rank (e);
3848 gfc_expand_constructor (e);
3851 /* This provides the opportunity for the length of constructors with
3852 character valued function elements to propagate the string length
3853 to the expression. */
3854 if (e->ts.type == BT_CHARACTER)
3855 gfc_resolve_character_array_constructor (e);
3859 case EXPR_STRUCTURE:
3860 t = resolve_ref (e);
3864 t = resolve_structure_cons (e);
3868 t = gfc_simplify_expr (e, 0);
3872 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3879 /* Resolve an expression from an iterator. They must be scalar and have
3880 INTEGER or (optionally) REAL type. */
3883 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3884 const char *name_msgid)
3886 if (gfc_resolve_expr (expr) == FAILURE)
3889 if (expr->rank != 0)
3891 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3895 if (expr->ts.type != BT_INTEGER)
3897 if (expr->ts.type == BT_REAL)
3900 return gfc_notify_std (GFC_STD_F95_DEL,
3901 "Deleted feature: %s at %L must be integer",
3902 _(name_msgid), &expr->where);
3905 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
3912 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3920 /* Resolve the expressions in an iterator structure. If REAL_OK is
3921 false allow only INTEGER type iterators, otherwise allow REAL types. */
3924 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
3926 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3930 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3932 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3937 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3938 "Start expression in DO loop") == FAILURE)
3941 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3942 "End expression in DO loop") == FAILURE)
3945 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3946 "Step expression in DO loop") == FAILURE)
3949 if (iter->step->expr_type == EXPR_CONSTANT)
3951 if ((iter->step->ts.type == BT_INTEGER
3952 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3953 || (iter->step->ts.type == BT_REAL
3954 && mpfr_sgn (iter->step->value.real) == 0))
3956 gfc_error ("Step expression in DO loop at %L cannot be zero",
3957 &iter->step->where);
3962 /* Convert start, end, and step to the same type as var. */
3963 if (iter->start->ts.kind != iter->var->ts.kind
3964 || iter->start->ts.type != iter->var->ts.type)
3965 gfc_convert_type (iter->start, &iter->var->ts, 2);
3967 if (iter->end->ts.kind != iter->var->ts.kind
3968 || iter->end->ts.type != iter->var->ts.type)
3969 gfc_convert_type (iter->end, &iter->var->ts, 2);
3971 if (iter->step->ts.kind != iter->var->ts.kind
3972 || iter->step->ts.type != iter->var->ts.type)
3973 gfc_convert_type (iter->step, &iter->var->ts, 2);
3979 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3980 to be a scalar INTEGER variable. The subscripts and stride are scalar
3981 INTEGERs, and if stride is a constant it must be nonzero. */
3984 resolve_forall_iterators (gfc_forall_iterator *iter)
3988 if (gfc_resolve_expr (iter->var) == SUCCESS
3989 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3990 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3993 if (gfc_resolve_expr (iter->start) == SUCCESS
3994 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3995 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3996 &iter->start->where);
3997 if (iter->var->ts.kind != iter->start->ts.kind)
3998 gfc_convert_type (iter->start, &iter->var->ts, 2);
4000 if (gfc_resolve_expr (iter->end) == SUCCESS
4001 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4002 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4004 if (iter->var->ts.kind != iter->end->ts.kind)
4005 gfc_convert_type (iter->end, &iter->var->ts, 2);
4007 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4009 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4010 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4011 &iter->stride->where, "INTEGER");
4013 if (iter->stride->expr_type == EXPR_CONSTANT
4014 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4015 gfc_error ("FORALL stride expression at %L cannot be zero",
4016 &iter->stride->where);
4018 if (iter->var->ts.kind != iter->stride->ts.kind)
4019 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4026 /* Given a pointer to a symbol that is a derived type, see if any components
4027 have the POINTER attribute. The search is recursive if necessary.
4028 Returns zero if no pointer components are found, nonzero otherwise. */
4031 derived_pointer (gfc_symbol *sym)
4035 for (c = sym->components; c; c = c->next)
4040 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
4048 /* Given a pointer to a symbol that is a derived type, see if it's
4049 inaccessible, i.e. if it's defined in another module and the components are
4050 PRIVATE. The search is recursive if necessary. Returns zero if no
4051 inaccessible components are found, nonzero otherwise. */
4054 derived_inaccessible (gfc_symbol *sym)
4058 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
4061 for (c = sym->components; c; c = c->next)
4063 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4071 /* Resolve the argument of a deallocate expression. The expression must be
4072 a pointer or a full array. */
4075 resolve_deallocate_expr (gfc_expr *e)
4077 symbol_attribute attr;
4078 int allocatable, pointer, check_intent_in;
4081 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4082 check_intent_in = 1;
4084 if (gfc_resolve_expr (e) == FAILURE)
4087 if (e->expr_type != EXPR_VARIABLE)
4090 allocatable = e->symtree->n.sym->attr.allocatable;
4091 pointer = e->symtree->n.sym->attr.pointer;
4092 for (ref = e->ref; ref; ref = ref->next)
4095 check_intent_in = 0;
4100 if (ref->u.ar.type != AR_FULL)
4105 allocatable = (ref->u.c.component->as != NULL
4106 && ref->u.c.component->as->type == AS_DEFERRED);
4107 pointer = ref->u.c.component->pointer;
4116 attr = gfc_expr_attr (e);
4118 if (allocatable == 0 && attr.pointer == 0)
4121 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4122 "ALLOCATABLE or a POINTER", &e->where);
4126 && e->symtree->n.sym->attr.intent == INTENT_IN)
4128 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4129 e->symtree->n.sym->name, &e->where);
4137 /* Returns true if the expression e contains a reference the symbol sym. */
4139 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4141 gfc_actual_arglist *arg;
4149 switch (e->expr_type)
4152 for (arg = e->value.function.actual; arg; arg = arg->next)
4153 rv = rv || find_sym_in_expr (sym, arg->expr);
4156 /* If the variable is not the same as the dependent, 'sym', and
4157 it is not marked as being declared and it is in the same
4158 namespace as 'sym', add it to the local declarations. */
4160 if (sym == e->symtree->n.sym)
4165 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4166 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4175 for (ref = e->ref; ref; ref = ref->next)
4180 for (i = 0; i < ref->u.ar.dimen; i++)
4182 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4183 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4184 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4189 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4190 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4194 if (ref->u.c.component->ts.type == BT_CHARACTER
4195 && ref->u.c.component->ts.cl->length->expr_type
4198 || find_sym_in_expr (sym,
4199 ref->u.c.component->ts.cl->length);
4201 if (ref->u.c.component->as)
4202 for (i = 0; i < ref->u.c.component->as->rank; i++)
4205 || find_sym_in_expr (sym,
4206 ref->u.c.component->as->lower[i]);
4208 || find_sym_in_expr (sym,
4209 ref->u.c.component->as->upper[i]);
4219 /* Given the expression node e for an allocatable/pointer of derived type to be
4220 allocated, get the expression node to be initialized afterwards (needed for
4221 derived types with default initializers, and derived types with allocatable
4222 components that need nullification.) */
4225 expr_to_initialize (gfc_expr *e)
4231 result = gfc_copy_expr (e);
4233 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4234 for (ref = result->ref; ref; ref = ref->next)
4235 if (ref->type == REF_ARRAY && ref->next == NULL)
4237 ref->u.ar.type = AR_FULL;
4239 for (i = 0; i < ref->u.ar.dimen; i++)
4240 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4242 result->rank = ref->u.ar.dimen;
4250 /* Resolve the expression in an ALLOCATE statement, doing the additional
4251 checks to see whether the expression is OK or not. The expression must
4252 have a trailing array reference that gives the size of the array. */
4255 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4257 int i, pointer, allocatable, dimension, check_intent_in;
4258 symbol_attribute attr;
4259 gfc_ref *ref, *ref2;
4266 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4267 check_intent_in = 1;
4269 if (gfc_resolve_expr (e) == FAILURE)
4272 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4273 sym = code->expr->symtree->n.sym;
4277 /* Make sure the expression is allocatable or a pointer. If it is
4278 pointer, the next-to-last reference must be a pointer. */
4282 if (e->expr_type != EXPR_VARIABLE)
4285 attr = gfc_expr_attr (e);
4286 pointer = attr.pointer;
4287 dimension = attr.dimension;
4291 allocatable = e->symtree->n.sym->attr.allocatable;
4292 pointer = e->symtree->n.sym->attr.pointer;
4293 dimension = e->symtree->n.sym->attr.dimension;
4295 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4297 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4298 "not be allocated in the same statement at %L",
4299 sym->name, &e->where);
4303 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4306 check_intent_in = 0;
4311 if (ref->next != NULL)
4316 allocatable = (ref->u.c.component->as != NULL
4317 && ref->u.c.component->as->type == AS_DEFERRED);
4319 pointer = ref->u.c.component->pointer;
4320 dimension = ref->u.c.component->dimension;
4331 if (allocatable == 0 && pointer == 0)
4333 gfc_error ("Expression in ALLOCATE statement at %L must be "
4334 "ALLOCATABLE or a POINTER", &e->where);
4339 && e->symtree->n.sym->attr.intent == INTENT_IN)
4341 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4342 e->symtree->n.sym->name, &e->where);
4346 /* Add default initializer for those derived types that need them. */
4347 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4349 init_st = gfc_get_code ();
4350 init_st->loc = code->loc;
4351 init_st->op = EXEC_INIT_ASSIGN;
4352 init_st->expr = expr_to_initialize (e);
4353 init_st->expr2 = init_e;
4354 init_st->next = code->next;
4355 code->next = init_st;
4358 if (pointer && dimension == 0)
4361 /* Make sure the next-to-last reference node is an array specification. */
4363 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4365 gfc_error ("Array specification required in ALLOCATE statement "
4366 "at %L", &e->where);
4370 /* Make sure that the array section reference makes sense in the
4371 context of an ALLOCATE specification. */
4375 for (i = 0; i < ar->dimen; i++)
4377 if (ref2->u.ar.type == AR_ELEMENT)
4380 switch (ar->dimen_type[i])
4386 if (ar->start[i] != NULL
4387 && ar->end[i] != NULL
4388 && ar->stride[i] == NULL)
4391 /* Fall Through... */
4395 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4402 for (a = code->ext.alloc_list; a; a = a->next)
4404 sym = a->expr->symtree->n.sym;
4406 /* TODO - check derived type components. */
4407 if (sym->ts.type == BT_DERIVED)
4410 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4411 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4413 gfc_error ("'%s' must not appear an the array specification at "
4414 "%L in the same ALLOCATE statement where it is "
4415 "itself allocated", sym->name, &ar->where);
4425 /************ SELECT CASE resolution subroutines ************/
4427 /* Callback function for our mergesort variant. Determines interval
4428 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4429 op1 > op2. Assumes we're not dealing with the default case.
4430 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4431 There are nine situations to check. */
4434 compare_cases (const gfc_case *op1, const gfc_case *op2)
4438 if (op1->low == NULL) /* op1 = (:L) */
4440 /* op2 = (:N), so overlap. */
4442 /* op2 = (M:) or (M:N), L < M */
4443 if (op2->low != NULL
4444 && gfc_compare_expr (op1->high, op2->low) < 0)
4447 else if (op1->high == NULL) /* op1 = (K:) */
4449 /* op2 = (M:), so overlap. */
4451 /* op2 = (:N) or (M:N), K > N */
4452 if (op2->high != NULL
4453 && gfc_compare_expr (op1->low, op2->high) > 0)
4456 else /* op1 = (K:L) */
4458 if (op2->low == NULL) /* op2 = (:N), K > N */
4459 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4460 else if (op2->high == NULL) /* op2 = (M:), L < M */
4461 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4462 else /* op2 = (M:N) */
4466 if (gfc_compare_expr (op1->high, op2->low) < 0)
4469 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4478 /* Merge-sort a double linked case list, detecting overlap in the
4479 process. LIST is the head of the double linked case list before it
4480 is sorted. Returns the head of the sorted list if we don't see any
4481 overlap, or NULL otherwise. */
4484 check_case_overlap (gfc_case *list)
4486 gfc_case *p, *q, *e, *tail;
4487 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4489 /* If the passed list was empty, return immediately. */
4496 /* Loop unconditionally. The only exit from this loop is a return
4497 statement, when we've finished sorting the case list. */
4504 /* Count the number of merges we do in this pass. */
4507 /* Loop while there exists a merge to be done. */
4512 /* Count this merge. */
4515 /* Cut the list in two pieces by stepping INSIZE places
4516 forward in the list, starting from P. */
4519 for (i = 0; i < insize; i++)
4528 /* Now we have two lists. Merge them! */
4529 while (psize > 0 || (qsize > 0 && q != NULL))
4531 /* See from which the next case to merge comes from. */
4534 /* P is empty so the next case must come from Q. */
4539 else if (qsize == 0 || q == NULL)
4548 cmp = compare_cases (p, q);
4551 /* The whole case range for P is less than the
4559 /* The whole case range for Q is greater than
4560 the case range for P. */
4567 /* The cases overlap, or they are the same
4568 element in the list. Either way, we must
4569 issue an error and get the next case from P. */
4570 /* FIXME: Sort P and Q by line number. */
4571 gfc_error ("CASE label at %L overlaps with CASE "
4572 "label at %L", &p->where, &q->where);
4580 /* Add the next element to the merged list. */
4589 /* P has now stepped INSIZE places along, and so has Q. So
4590 they're the same. */
4595 /* If we have done only one merge or none at all, we've
4596 finished sorting the cases. */
4605 /* Otherwise repeat, merging lists twice the size. */
4611 /* Check to see if an expression is suitable for use in a CASE statement.
4612 Makes sure that all case expressions are scalar constants of the same
4613 type. Return FAILURE if anything is wrong. */
4616 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4618 if (e == NULL) return SUCCESS;
4620 if (e->ts.type != case_expr->ts.type)
4622 gfc_error ("Expression in CASE statement at %L must be of type %s",
4623 &e->where, gfc_basic_typename (case_expr->ts.type));
4627 /* C805 (R808) For a given case-construct, each case-value shall be of
4628 the same type as case-expr. For character type, length differences
4629 are allowed, but the kind type parameters shall be the same. */
4631 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4633 gfc_error("Expression in CASE statement at %L must be kind %d",
4634 &e->where, case_expr->ts.kind);
4638 /* Convert the case value kind to that of case expression kind, if needed.
4639 FIXME: Should a warning be issued? */
4640 if (e->ts.kind != case_expr->ts.kind)
4641 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4645 gfc_error ("Expression in CASE statement at %L must be scalar",
4654 /* Given a completely parsed select statement, we:
4656 - Validate all expressions and code within the SELECT.
4657 - Make sure that the selection expression is not of the wrong type.
4658 - Make sure that no case ranges overlap.
4659 - Eliminate unreachable cases and unreachable code resulting from
4660 removing case labels.
4662 The standard does allow unreachable cases, e.g. CASE (5:3). But
4663 they are a hassle for code generation, and to prevent that, we just
4664 cut them out here. This is not necessary for overlapping cases
4665 because they are illegal and we never even try to generate code.
4667 We have the additional caveat that a SELECT construct could have
4668 been a computed GOTO in the source code. Fortunately we can fairly
4669 easily work around that here: The case_expr for a "real" SELECT CASE
4670 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4671 we have to do is make sure that the case_expr is a scalar integer
4675 resolve_select (gfc_code *code)
4678 gfc_expr *case_expr;
4679 gfc_case *cp, *default_case, *tail, *head;
4680 int seen_unreachable;
4686 if (code->expr == NULL)
4688 /* This was actually a computed GOTO statement. */
4689 case_expr = code->expr2;
4690 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4691 gfc_error ("Selection expression in computed GOTO statement "
4692 "at %L must be a scalar integer expression",
4695 /* Further checking is not necessary because this SELECT was built
4696 by the compiler, so it should always be OK. Just move the
4697 case_expr from expr2 to expr so that we can handle computed
4698 GOTOs as normal SELECTs from here on. */
4699 code->expr = code->expr2;
4704 case_expr = code->expr;
4706 type = case_expr->ts.type;
4707 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4709 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4710 &case_expr->where, gfc_typename (&case_expr->ts));
4712 /* Punt. Going on here just produce more garbage error messages. */
4716 if (case_expr->rank != 0)
4718 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4719 "expression", &case_expr->where);
4725 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4726 of the SELECT CASE expression and its CASE values. Walk the lists
4727 of case values, and if we find a mismatch, promote case_expr to
4728 the appropriate kind. */
4730 if (type == BT_LOGICAL || type == BT_INTEGER)
4732 for (body = code->block; body; body = body->block)
4734 /* Walk the case label list. */
4735 for (cp = body->ext.case_list; cp; cp = cp->next)
4737 /* Intercept the DEFAULT case. It does not have a kind. */
4738 if (cp->low == NULL && cp->high == NULL)
4741 /* Unreachable case ranges are discarded, so ignore. */
4742 if (cp->low != NULL && cp->high != NULL
4743 && cp->low != cp->high
4744 && gfc_compare_expr (cp->low, cp->high) > 0)
4747 /* FIXME: Should a warning be issued? */
4749 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4750 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4752 if (cp->high != NULL
4753 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4754 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4759 /* Assume there is no DEFAULT case. */
4760 default_case = NULL;
4765 for (body = code->block; body; body = body->block)
4767 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4769 seen_unreachable = 0;
4771 /* Walk the case label list, making sure that all case labels
4773 for (cp = body->ext.case_list; cp; cp = cp->next)
4775 /* Count the number of cases in the whole construct. */
4778 /* Intercept the DEFAULT case. */
4779 if (cp->low == NULL && cp->high == NULL)
4781 if (default_case != NULL)
4783 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4784 "by a second DEFAULT CASE at %L",
4785 &default_case->where, &cp->where);
4796 /* Deal with single value cases and case ranges. Errors are
4797 issued from the validation function. */
4798 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4799 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4805 if (type == BT_LOGICAL
4806 && ((cp->low == NULL || cp->high == NULL)
4807 || cp->low != cp->high))
4809 gfc_error ("Logical range in CASE statement at %L is not "
4810 "allowed", &cp->low->where);
4815 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4818 value = cp->low->value.logical == 0 ? 2 : 1;
4819 if (value & seen_logical)
4821 gfc_error ("constant logical value in CASE statement "
4822 "is repeated at %L",
4827 seen_logical |= value;
4830 if (cp->low != NULL && cp->high != NULL
4831 && cp->low != cp->high
4832 && gfc_compare_expr (cp->low, cp->high) > 0)
4834 if (gfc_option.warn_surprising)
4835 gfc_warning ("Range specification at %L can never "
4836 "be matched", &cp->where);
4838 cp->unreachable = 1;
4839 seen_unreachable = 1;
4843 /* If the case range can be matched, it can also overlap with
4844 other cases. To make sure it does not, we put it in a
4845 double linked list here. We sort that with a merge sort
4846 later on to detect any overlapping cases. */
4850 head->right = head->left = NULL;
4855 tail->right->left = tail;
4862 /* It there was a failure in the previous case label, give up
4863 for this case label list. Continue with the next block. */
4867 /* See if any case labels that are unreachable have been seen.
4868 If so, we eliminate them. This is a bit of a kludge because
4869 the case lists for a single case statement (label) is a
4870 single forward linked lists. */
4871 if (seen_unreachable)
4873 /* Advance until the first case in the list is reachable. */
4874 while (body->ext.case_list != NULL
4875 && body->ext.case_list->unreachable)
4877 gfc_case *n = body->ext.case_list;
4878 body->ext.case_list = body->ext.case_list->next;
4880 gfc_free_case_list (n);
4883 /* Strip all other unreachable cases. */
4884 if (body->ext.case_list)
4886 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4888 if (cp->next->unreachable)
4890 gfc_case *n = cp->next;
4891 cp->next = cp->next->next;
4893 gfc_free_case_list (n);
4900 /* See if there were overlapping cases. If the check returns NULL,
4901 there was overlap. In that case we don't do anything. If head
4902 is non-NULL, we prepend the DEFAULT case. The sorted list can
4903 then used during code generation for SELECT CASE constructs with
4904 a case expression of a CHARACTER type. */
4907 head = check_case_overlap (head);
4909 /* Prepend the default_case if it is there. */
4910 if (head != NULL && default_case)
4912 default_case->left = NULL;
4913 default_case->right = head;
4914 head->left = default_case;
4918 /* Eliminate dead blocks that may be the result if we've seen
4919 unreachable case labels for a block. */
4920 for (body = code; body && body->block; body = body->block)
4922 if (body->block->ext.case_list == NULL)
4924 /* Cut the unreachable block from the code chain. */
4925 gfc_code *c = body->block;
4926 body->block = c->block;
4928 /* Kill the dead block, but not the blocks below it. */
4930 gfc_free_statements (c);
4934 /* More than two cases is legal but insane for logical selects.
4935 Issue a warning for it. */
4936 if (gfc_option.warn_surprising && type == BT_LOGICAL
4938 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4943 /* Resolve a transfer statement. This is making sure that:
4944 -- a derived type being transferred has only non-pointer components
4945 -- a derived type being transferred doesn't have private components, unless
4946 it's being transferred from the module where the type was defined
4947 -- we're not trying to transfer a whole assumed size array. */
4950 resolve_transfer (gfc_code *code)
4959 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
4962 sym = exp->symtree->n.sym;
4965 /* Go to actual component transferred. */
4966 for (ref = code->expr->ref; ref; ref = ref->next)
4967 if (ref->type == REF_COMPONENT)
4968 ts = &ref->u.c.component->ts;
4970 if (ts->type == BT_DERIVED)
4972 /* Check that transferred derived type doesn't contain POINTER
4974 if (derived_pointer (ts->derived))
4976 gfc_error ("Data transfer element at %L cannot have "
4977 "POINTER components", &code->loc);
4981 if (ts->derived->attr.alloc_comp)
4983 gfc_error ("Data transfer element at %L cannot have "
4984 "ALLOCATABLE components", &code->loc);
4988 if (derived_inaccessible (ts->derived))
4990 gfc_error ("Data transfer element at %L cannot have "
4991 "PRIVATE components",&code->loc);
4996 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4997 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4999 gfc_error ("Data transfer element at %L cannot be a full reference to "
5000 "an assumed-size array", &code->loc);
5006 /*********** Toplevel code resolution subroutines ***********/
5008 /* Find the set of labels that are reachable from this block. We also
5009 record the last statement in each block so that we don't have to do
5010 a linear search to find the END DO statements of the blocks. */
5013 reachable_labels (gfc_code *block)
5020 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5022 /* Collect labels in this block. */
5023 for (c = block; c; c = c->next)
5026 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5028 if (!c->next && cs_base->prev)
5029 cs_base->prev->tail = c;
5032 /* Merge with labels from parent block. */
5035 gcc_assert (cs_base->prev->reachable_labels);
5036 bitmap_ior_into (cs_base->reachable_labels,
5037 cs_base->prev->reachable_labels);
5041 /* Given a branch to a label and a namespace, if the branch is conforming.
5042 The code node describes where the branch is located. */
5045 resolve_branch (gfc_st_label *label, gfc_code *code)
5052 /* Step one: is this a valid branching target? */
5054 if (label->defined == ST_LABEL_UNKNOWN)
5056 gfc_error ("Label %d referenced at %L is never defined", label->value,
5061 if (label->defined != ST_LABEL_TARGET)
5063 gfc_error ("Statement at %L is not a valid branch target statement "
5064 "for the branch statement at %L", &label->where, &code->loc);
5068 /* Step two: make sure this branch is not a branch to itself ;-) */
5070 if (code->here == label)
5072 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5076 /* Step three: See if the label is in the same block as the
5077 branching statement. The hard work has been done by setting up
5078 the bitmap reachable_labels. */
5080 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5082 /* The label is not in an enclosing block, so illegal. This was
5083 allowed in Fortran 66, so we allow it as extension. No
5084 further checks are necessary in this case. */
5085 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5086 "as the GOTO statement at %L", &label->where,
5091 /* Step four: Make sure that the branching target is legal if
5092 the statement is an END {SELECT,IF}. */
5094 for (stack = cs_base; stack; stack = stack->prev)
5095 if (stack->current->next && stack->current->next->here == label)
5098 if (stack && stack->current->next->op == EXEC_NOP)
5100 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5101 "END of construct at %L", &code->loc,
5102 &stack->current->next->loc);
5103 return; /* We know this is not an END DO. */
5106 /* Step five: Make sure that we're not jumping to the end of a DO
5107 loop from within the loop. */
5109 for (stack = cs_base; stack; stack = stack->prev)
5110 if ((stack->current->op == EXEC_DO
5111 || stack->current->op == EXEC_DO_WHILE)
5112 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5114 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5115 "to END of construct at %L", &code->loc,
5123 /* Check whether EXPR1 has the same shape as EXPR2. */
5126 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5128 mpz_t shape[GFC_MAX_DIMENSIONS];
5129 mpz_t shape2[GFC_MAX_DIMENSIONS];
5130 try result = FAILURE;
5133 /* Compare the rank. */
5134 if (expr1->rank != expr2->rank)
5137 /* Compare the size of each dimension. */
5138 for (i=0; i<expr1->rank; i++)
5140 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5143 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5146 if (mpz_cmp (shape[i], shape2[i]))
5150 /* When either of the two expression is an assumed size array, we
5151 ignore the comparison of dimension sizes. */
5156 for (i--; i >= 0; i--)
5158 mpz_clear (shape[i]);
5159 mpz_clear (shape2[i]);
5165 /* Check whether a WHERE assignment target or a WHERE mask expression
5166 has the same shape as the outmost WHERE mask expression. */
5169 resolve_where (gfc_code *code, gfc_expr *mask)
5175 cblock = code->block;
5177 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5178 In case of nested WHERE, only the outmost one is stored. */
5179 if (mask == NULL) /* outmost WHERE */
5181 else /* inner WHERE */
5188 /* Check if the mask-expr has a consistent shape with the
5189 outmost WHERE mask-expr. */
5190 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5191 gfc_error ("WHERE mask at %L has inconsistent shape",
5192 &cblock->expr->where);
5195 /* the assignment statement of a WHERE statement, or the first
5196 statement in where-body-construct of a WHERE construct */
5197 cnext = cblock->next;
5202 /* WHERE assignment statement */
5205 /* Check shape consistent for WHERE assignment target. */
5206 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5207 gfc_error ("WHERE assignment target at %L has "
5208 "inconsistent shape", &cnext->expr->where);
5212 case EXEC_ASSIGN_CALL:
5213 resolve_call (cnext);
5216 /* WHERE or WHERE construct is part of a where-body-construct */
5218 resolve_where (cnext, e);
5222 gfc_error ("Unsupported statement inside WHERE at %L",
5225 /* the next statement within the same where-body-construct */
5226 cnext = cnext->next;
5228 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5229 cblock = cblock->block;
5234 /* Check whether the FORALL index appears in the expression or not. */
5237 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5241 gfc_actual_arglist *args;
5244 switch (expr->expr_type)
5247 gcc_assert (expr->symtree->n.sym);
5249 /* A scalar assignment */
5252 if (expr->symtree->n.sym == symbol)
5258 /* the expr is array ref, substring or struct component. */
5265 /* Check if the symbol appears in the array subscript. */
5267 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5270 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5274 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5278 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5284 if (expr->symtree->n.sym == symbol)
5287 /* Check if the symbol appears in the substring section. */
5288 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5290 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5298 gfc_error("expression reference type error at %L", &expr->where);
5304 /* If the expression is a function call, then check if the symbol
5305 appears in the actual arglist of the function. */
5307 for (args = expr->value.function.actual; args; args = args->next)
5309 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5314 /* It seems not to happen. */
5315 case EXPR_SUBSTRING:
5319 gcc_assert (expr->ref->type == REF_SUBSTRING);
5320 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5322 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5327 /* It seems not to happen. */
5328 case EXPR_STRUCTURE:
5330 gfc_error ("Unsupported statement while finding forall index in "
5335 /* Find the FORALL index in the first operand. */
5336 if (expr->value.op.op1)
5338 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5342 /* Find the FORALL index in the second operand. */
5343 if (expr->value.op.op2)
5345 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5358 /* Resolve assignment in FORALL construct.
5359 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5360 FORALL index variables. */
5363 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5367 for (n = 0; n < nvar; n++)
5369 gfc_symbol *forall_index;
5371 forall_index = var_expr[n]->symtree->n.sym;
5373 /* Check whether the assignment target is one of the FORALL index
5375 if ((code->expr->expr_type == EXPR_VARIABLE)
5376 && (code->expr->symtree->n.sym == forall_index))
5377 gfc_error ("Assignment to a FORALL index variable at %L",
5378 &code->expr->where);
5381 /* If one of the FORALL index variables doesn't appear in the
5382 assignment target, then there will be a many-to-one
5384 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5385 gfc_error ("The FORALL with index '%s' cause more than one "
5386 "assignment to this object at %L",
5387 var_expr[n]->symtree->name, &code->expr->where);
5393 /* Resolve WHERE statement in FORALL construct. */
5396 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5397 gfc_expr **var_expr)
5402 cblock = code->block;
5405 /* the assignment statement of a WHERE statement, or the first
5406 statement in where-body-construct of a WHERE construct */
5407 cnext = cblock->next;
5412 /* WHERE assignment statement */
5414 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5417 /* WHERE operator assignment statement */
5418 case EXEC_ASSIGN_CALL:
5419 resolve_call (cnext);
5422 /* WHERE or WHERE construct is part of a where-body-construct */
5424 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5428 gfc_error ("Unsupported statement inside WHERE at %L",
5431 /* the next statement within the same where-body-construct */
5432 cnext = cnext->next;
5434 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5435 cblock = cblock->block;
5440 /* Traverse the FORALL body to check whether the following errors exist:
5441 1. For assignment, check if a many-to-one assignment happens.
5442 2. For WHERE statement, check the WHERE body to see if there is any
5443 many-to-one assignment. */
5446 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5450 c = code->block->next;
5456 case EXEC_POINTER_ASSIGN:
5457 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5460 case EXEC_ASSIGN_CALL:
5464 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5465 there is no need to handle it here. */
5469 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5474 /* The next statement in the FORALL body. */
5480 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5481 gfc_resolve_forall_body to resolve the FORALL body. */
5484 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5486 static gfc_expr **var_expr;
5487 static int total_var = 0;
5488 static int nvar = 0;
5489 gfc_forall_iterator *fa;
5490 gfc_symbol *forall_index;
5494 /* Start to resolve a FORALL construct */
5495 if (forall_save == 0)
5497 /* Count the total number of FORALL index in the nested FORALL
5498 construct in order to allocate the VAR_EXPR with proper size. */
5500 while ((next != NULL) && (next->op == EXEC_FORALL))
5502 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5504 next = next->block->next;
5507 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5508 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5511 /* The information about FORALL iterator, including FORALL index start, end
5512 and stride. The FORALL index can not appear in start, end or stride. */
5513 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5515 /* Check if any outer FORALL index name is the same as the current
5517 for (i = 0; i < nvar; i++)
5519 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5521 gfc_error ("An outer FORALL construct already has an index "
5522 "with this name %L", &fa->var->where);
5526 /* Record the current FORALL index. */
5527 var_expr[nvar] = gfc_copy_expr (fa->var);
5529 forall_index = fa->var->symtree->n.sym;
5531 /* Check if the FORALL index appears in start, end or stride. */
5532 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5533 gfc_error ("A FORALL index must not appear in a limit or stride "
5534 "expression in the same FORALL at %L", &fa->start->where);
5535 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5536 gfc_error ("A FORALL index must not appear in a limit or stride "
5537 "expression in the same FORALL at %L", &fa->end->where);
5538 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5539 gfc_error ("A FORALL index must not appear in a limit or stride "
5540 "expression in the same FORALL at %L", &fa->stride->where);
5544 /* Resolve the FORALL body. */
5545 gfc_resolve_forall_body (code, nvar, var_expr);
5547 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5548 gfc_resolve_blocks (code->block, ns);
5550 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5551 for (i = 0; i < total_var; i++)
5552 gfc_free_expr (var_expr[i]);
5554 /* Reset the counters. */
5560 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5563 static void resolve_code (gfc_code *, gfc_namespace *);
5566 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5570 for (; b; b = b->block)
5572 t = gfc_resolve_expr (b->expr);
5573 if (gfc_resolve_expr (b->expr2) == FAILURE)
5579 if (t == SUCCESS && b->expr != NULL
5580 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5581 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5588 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5589 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5594 resolve_branch (b->label, b);
5606 case EXEC_OMP_ATOMIC:
5607 case EXEC_OMP_CRITICAL:
5609 case EXEC_OMP_MASTER:
5610 case EXEC_OMP_ORDERED:
5611 case EXEC_OMP_PARALLEL:
5612 case EXEC_OMP_PARALLEL_DO:
5613 case EXEC_OMP_PARALLEL_SECTIONS:
5614 case EXEC_OMP_PARALLEL_WORKSHARE:
5615 case EXEC_OMP_SECTIONS:
5616 case EXEC_OMP_SINGLE:
5617 case EXEC_OMP_WORKSHARE:
5621 gfc_internal_error ("resolve_block(): Bad block type");
5624 resolve_code (b->next, ns);
5629 /* Given a block of code, recursively resolve everything pointed to by this
5633 resolve_code (gfc_code *code, gfc_namespace *ns)
5635 int omp_workshare_save;
5641 frame.prev = cs_base;
5645 reachable_labels (code);
5647 for (; code; code = code->next)
5649 frame.current = code;
5650 forall_save = forall_flag;
5652 if (code->op == EXEC_FORALL)
5655 gfc_resolve_forall (code, ns, forall_save);
5658 else if (code->block)
5660 omp_workshare_save = -1;
5663 case EXEC_OMP_PARALLEL_WORKSHARE:
5664 omp_workshare_save = omp_workshare_flag;
5665 omp_workshare_flag = 1;
5666 gfc_resolve_omp_parallel_blocks (code, ns);
5668 case EXEC_OMP_PARALLEL:
5669 case EXEC_OMP_PARALLEL_DO:
5670 case EXEC_OMP_PARALLEL_SECTIONS:
5671 omp_workshare_save = omp_workshare_flag;
5672 omp_workshare_flag = 0;
5673 gfc_resolve_omp_parallel_blocks (code, ns);
5676 gfc_resolve_omp_do_blocks (code, ns);
5678 case EXEC_OMP_WORKSHARE:
5679 omp_workshare_save = omp_workshare_flag;
5680 omp_workshare_flag = 1;
5683 gfc_resolve_blocks (code->block, ns);
5687 if (omp_workshare_save != -1)
5688 omp_workshare_flag = omp_workshare_save;
5691 t = gfc_resolve_expr (code->expr);
5692 forall_flag = forall_save;
5694 if (gfc_resolve_expr (code->expr2) == FAILURE)
5709 /* Keep track of which entry we are up to. */
5710 current_entry_id = code->ext.entry->id;
5714 resolve_where (code, NULL);
5718 if (code->expr != NULL)
5720 if (code->expr->ts.type != BT_INTEGER)
5721 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5722 "INTEGER variable", &code->expr->where);
5723 else if (code->expr->symtree->n.sym->attr.assign != 1)
5724 gfc_error ("Variable '%s' has not been assigned a target "
5725 "label at %L", code->expr->symtree->n.sym->name,
5726 &code->expr->where);
5729 resolve_branch (code->label, code);
5733 if (code->expr != NULL
5734 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5735 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5736 "INTEGER return specifier", &code->expr->where);
5739 case EXEC_INIT_ASSIGN:
5746 if (gfc_extend_assign (code, ns) == SUCCESS)
5748 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5750 gfc_error ("Subroutine '%s' called instead of assignment at "
5751 "%L must be PURE", code->symtree->n.sym->name,
5758 if (code->expr->ts.type == BT_CHARACTER
5759 && gfc_option.warn_character_truncation)
5761 int llen = 0, rlen = 0;
5763 if (code->expr->ts.cl != NULL
5764 && code->expr->ts.cl->length != NULL
5765 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5766 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5768 if (code->expr2->expr_type == EXPR_CONSTANT)
5769 rlen = code->expr2->value.character.length;
5771 else if (code->expr2->ts.cl != NULL
5772 && code->expr2->ts.cl->length != NULL
5773 && code->expr2->ts.cl->length->expr_type
5775 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5777 if (rlen && llen && rlen > llen)
5778 gfc_warning_now ("CHARACTER expression will be truncated "
5779 "in assignment (%d/%d) at %L",
5780 llen, rlen, &code->loc);
5783 if (gfc_pure (NULL))
5785 if (gfc_impure_variable (code->expr->symtree->n.sym))
5787 gfc_error ("Cannot assign to variable '%s' in PURE "
5789 code->expr->symtree->n.sym->name,
5790 &code->expr->where);
5794 if (code->expr->ts.type == BT_DERIVED
5795 && code->expr->expr_type == EXPR_VARIABLE
5796 && derived_pointer (code->expr->ts.derived)
5797 && gfc_impure_variable (code->expr2->symtree->n.sym))
5799 gfc_error ("The impure variable at %L is assigned to "
5800 "a derived type variable with a POINTER "
5801 "component in a PURE procedure (12.6)",
5802 &code->expr2->where);
5807 gfc_check_assign (code->expr, code->expr2, 1);
5810 case EXEC_LABEL_ASSIGN:
5811 if (code->label->defined == ST_LABEL_UNKNOWN)
5812 gfc_error ("Label %d referenced at %L is never defined",
5813 code->label->value, &code->label->where);
5815 && (code->expr->expr_type != EXPR_VARIABLE
5816 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5817 || code->expr->symtree->n.sym->ts.kind
5818 != gfc_default_integer_kind
5819 || code->expr->symtree->n.sym->as != NULL))
5820 gfc_error ("ASSIGN statement at %L requires a scalar "
5821 "default INTEGER variable", &code->expr->where);
5824 case EXEC_POINTER_ASSIGN:
5828 gfc_check_pointer_assign (code->expr, code->expr2);
5831 case EXEC_ARITHMETIC_IF:
5833 && code->expr->ts.type != BT_INTEGER
5834 && code->expr->ts.type != BT_REAL)
5835 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5836 "expression", &code->expr->where);
5838 resolve_branch (code->label, code);
5839 resolve_branch (code->label2, code);
5840 resolve_branch (code->label3, code);
5844 if (t == SUCCESS && code->expr != NULL
5845 && (code->expr->ts.type != BT_LOGICAL
5846 || code->expr->rank != 0))
5847 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5848 &code->expr->where);
5853 resolve_call (code);
5857 /* Select is complicated. Also, a SELECT construct could be
5858 a transformed computed GOTO. */
5859 resolve_select (code);
5863 if (code->ext.iterator != NULL)
5865 gfc_iterator *iter = code->ext.iterator;
5866 if (gfc_resolve_iterator (iter, true) != FAILURE)
5867 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5872 if (code->expr == NULL)
5873 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5875 && (code->expr->rank != 0
5876 || code->expr->ts.type != BT_LOGICAL))
5877 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5878 "a scalar LOGICAL expression", &code->expr->where);
5882 if (t == SUCCESS && code->expr != NULL
5883 && code->expr->ts.type != BT_INTEGER)
5884 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5885 "of type INTEGER", &code->expr->where);
5887 for (a = code->ext.alloc_list; a; a = a->next)
5888 resolve_allocate_expr (a->expr, code);
5892 case EXEC_DEALLOCATE:
5893 if (t == SUCCESS && code->expr != NULL
5894 && code->expr->ts.type != BT_INTEGER)
5896 ("STAT tag in DEALLOCATE statement at %L must be of type "
5897 "INTEGER", &code->expr->where);
5899 for (a = code->ext.alloc_list; a; a = a->next)
5900 resolve_deallocate_expr (a->expr);
5905 if (gfc_resolve_open (code->ext.open) == FAILURE)
5908 resolve_branch (code->ext.open->err, code);
5912 if (gfc_resolve_close (code->ext.close) == FAILURE)
5915 resolve_branch (code->ext.close->err, code);
5918 case EXEC_BACKSPACE:
5922 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5925 resolve_branch (code->ext.filepos->err, code);
5929 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5932 resolve_branch (code->ext.inquire->err, code);
5936 gcc_assert (code->ext.inquire != NULL);
5937 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5940 resolve_branch (code->ext.inquire->err, code);
5945 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5948 resolve_branch (code->ext.dt->err, code);
5949 resolve_branch (code->ext.dt->end, code);
5950 resolve_branch (code->ext.dt->eor, code);
5954 resolve_transfer (code);
5958 resolve_forall_iterators (code->ext.forall_iterator);
5960 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5961 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5962 "expression", &code->expr->where);
5965 case EXEC_OMP_ATOMIC:
5966 case EXEC_OMP_BARRIER:
5967 case EXEC_OMP_CRITICAL:
5968 case EXEC_OMP_FLUSH:
5970 case EXEC_OMP_MASTER:
5971 case EXEC_OMP_ORDERED:
5972 case EXEC_OMP_SECTIONS:
5973 case EXEC_OMP_SINGLE:
5974 case EXEC_OMP_WORKSHARE:
5975 gfc_resolve_omp_directive (code, ns);
5978 case EXEC_OMP_PARALLEL:
5979 case EXEC_OMP_PARALLEL_DO:
5980 case EXEC_OMP_PARALLEL_SECTIONS:
5981 case EXEC_OMP_PARALLEL_WORKSHARE:
5982 omp_workshare_save = omp_workshare_flag;
5983 omp_workshare_flag = 0;
5984 gfc_resolve_omp_directive (code, ns);
5985 omp_workshare_flag = omp_workshare_save;
5989 gfc_internal_error ("resolve_code(): Bad statement code");
5993 cs_base = frame.prev;
5997 /* Resolve initial values and make sure they are compatible with
6001 resolve_values (gfc_symbol *sym)
6003 if (sym->value == NULL)
6006 if (gfc_resolve_expr (sym->value) == FAILURE)
6009 gfc_check_assign_symbol (sym, sym->value);
6013 /* Verify the binding labels for common blocks that are BIND(C). The label
6014 for a BIND(C) common block must be identical in all scoping units in which
6015 the common block is declared. Further, the binding label can not collide
6016 with any other global entity in the program. */
6019 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6021 if (comm_block_tree->n.common->is_bind_c == 1)
6023 gfc_gsymbol *binding_label_gsym;
6024 gfc_gsymbol *comm_name_gsym;
6026 /* See if a global symbol exists by the common block's name. It may
6027 be NULL if the common block is use-associated. */
6028 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6029 comm_block_tree->n.common->name);
6030 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6031 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6032 "with the global entity '%s' at %L",
6033 comm_block_tree->n.common->binding_label,
6034 comm_block_tree->n.common->name,
6035 &(comm_block_tree->n.common->where),
6036 comm_name_gsym->name, &(comm_name_gsym->where));
6037 else if (comm_name_gsym != NULL
6038 && strcmp (comm_name_gsym->name,
6039 comm_block_tree->n.common->name) == 0)
6041 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6043 if (comm_name_gsym->binding_label == NULL)
6044 /* No binding label for common block stored yet; save this one. */
6045 comm_name_gsym->binding_label =
6046 comm_block_tree->n.common->binding_label;
6048 if (strcmp (comm_name_gsym->binding_label,
6049 comm_block_tree->n.common->binding_label) != 0)
6051 /* Common block names match but binding labels do not. */
6052 gfc_error ("Binding label '%s' for common block '%s' at %L "
6053 "does not match the binding label '%s' for common "
6055 comm_block_tree->n.common->binding_label,
6056 comm_block_tree->n.common->name,
6057 &(comm_block_tree->n.common->where),
6058 comm_name_gsym->binding_label,
6059 comm_name_gsym->name,
6060 &(comm_name_gsym->where));
6065 /* There is no binding label (NAME="") so we have nothing further to
6066 check and nothing to add as a global symbol for the label. */
6067 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6070 binding_label_gsym =
6071 gfc_find_gsymbol (gfc_gsym_root,
6072 comm_block_tree->n.common->binding_label);
6073 if (binding_label_gsym == NULL)
6075 /* Need to make a global symbol for the binding label to prevent
6076 it from colliding with another. */
6077 binding_label_gsym =
6078 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6079 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6080 binding_label_gsym->type = GSYM_COMMON;
6084 /* If comm_name_gsym is NULL, the name common block is use
6085 associated and the name could be colliding. */
6086 if (binding_label_gsym->type != GSYM_COMMON)
6087 gfc_error ("Binding label '%s' for common block '%s' at %L "
6088 "collides with the global entity '%s' at %L",
6089 comm_block_tree->n.common->binding_label,
6090 comm_block_tree->n.common->name,
6091 &(comm_block_tree->n.common->where),
6092 binding_label_gsym->name,
6093 &(binding_label_gsym->where));
6094 else if (comm_name_gsym != NULL
6095 && (strcmp (binding_label_gsym->name,
6096 comm_name_gsym->binding_label) != 0)
6097 && (strcmp (binding_label_gsym->sym_name,
6098 comm_name_gsym->name) != 0))
6099 gfc_error ("Binding label '%s' for common block '%s' at %L "
6100 "collides with global entity '%s' at %L",
6101 binding_label_gsym->name, binding_label_gsym->sym_name,
6102 &(comm_block_tree->n.common->where),
6103 comm_name_gsym->name, &(comm_name_gsym->where));
6111 /* Verify any BIND(C) derived types in the namespace so we can report errors
6112 for them once, rather than for each variable declared of that type. */
6115 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6117 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6118 && derived_sym->attr.is_bind_c == 1)
6119 verify_bind_c_derived_type (derived_sym);
6125 /* Verify that any binding labels used in a given namespace do not collide
6126 with the names or binding labels of any global symbols. */
6129 gfc_verify_binding_labels (gfc_symbol *sym)
6133 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6134 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6136 gfc_gsymbol *bind_c_sym;
6138 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6139 if (bind_c_sym != NULL
6140 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6142 if (sym->attr.if_source == IFSRC_DECL
6143 && (bind_c_sym->type != GSYM_SUBROUTINE
6144 && bind_c_sym->type != GSYM_FUNCTION)
6145 && ((sym->attr.contained == 1
6146 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6147 || (sym->attr.use_assoc == 1
6148 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6150 /* Make sure global procedures don't collide with anything. */
6151 gfc_error ("Binding label '%s' at %L collides with the global "
6152 "entity '%s' at %L", sym->binding_label,
6153 &(sym->declared_at), bind_c_sym->name,
6154 &(bind_c_sym->where));
6157 else if (sym->attr.contained == 0
6158 && (sym->attr.if_source == IFSRC_IFBODY
6159 && sym->attr.flavor == FL_PROCEDURE)
6160 && (bind_c_sym->sym_name != NULL
6161 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6163 /* Make sure procedures in interface bodies don't collide. */
6164 gfc_error ("Binding label '%s' in interface body at %L collides "
6165 "with the global entity '%s' at %L",
6167 &(sym->declared_at), bind_c_sym->name,
6168 &(bind_c_sym->where));
6171 else if (sym->attr.contained == 0
6172 && (sym->attr.if_source == IFSRC_UNKNOWN))
6173 if ((sym->attr.use_assoc
6174 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6175 || sym->attr.use_assoc == 0)
6177 gfc_error ("Binding label '%s' at %L collides with global "
6178 "entity '%s' at %L", sym->binding_label,
6179 &(sym->declared_at), bind_c_sym->name,
6180 &(bind_c_sym->where));
6185 /* Clear the binding label to prevent checking multiple times. */
6186 sym->binding_label[0] = '\0';
6188 else if (bind_c_sym == NULL)
6190 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6191 bind_c_sym->where = sym->declared_at;
6192 bind_c_sym->sym_name = sym->name;
6194 if (sym->attr.use_assoc == 1)
6195 bind_c_sym->mod_name = sym->module;
6197 if (sym->ns->proc_name != NULL)
6198 bind_c_sym->mod_name = sym->ns->proc_name->name;
6200 if (sym->attr.contained == 0)
6202 if (sym->attr.subroutine)
6203 bind_c_sym->type = GSYM_SUBROUTINE;
6204 else if (sym->attr.function)
6205 bind_c_sym->type = GSYM_FUNCTION;
6213 /* Resolve an index expression. */
6216 resolve_index_expr (gfc_expr *e)
6218 if (gfc_resolve_expr (e) == FAILURE)
6221 if (gfc_simplify_expr (e, 0) == FAILURE)
6224 if (gfc_specification_expr (e) == FAILURE)
6230 /* Resolve a charlen structure. */
6233 resolve_charlen (gfc_charlen *cl)
6242 specification_expr = 1;
6244 if (resolve_index_expr (cl->length) == FAILURE)
6246 specification_expr = 0;
6250 /* "If the character length parameter value evaluates to a negative
6251 value, the length of character entities declared is zero." */
6252 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6254 gfc_warning_now ("CHARACTER variable has zero length at %L",
6255 &cl->length->where);
6256 gfc_replace_expr (cl->length, gfc_int_expr (0));
6263 /* Test for non-constant shape arrays. */
6266 is_non_constant_shape_array (gfc_symbol *sym)
6272 not_constant = false;
6273 if (sym->as != NULL)
6275 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6276 has not been simplified; parameter array references. Do the
6277 simplification now. */
6278 for (i = 0; i < sym->as->rank; i++)
6280 e = sym->as->lower[i];
6281 if (e && (resolve_index_expr (e) == FAILURE
6282 || !gfc_is_constant_expr (e)))
6283 not_constant = true;
6285 e = sym->as->upper[i];
6286 if (e && (resolve_index_expr (e) == FAILURE
6287 || !gfc_is_constant_expr (e)))
6288 not_constant = true;
6291 return not_constant;
6295 /* Assign the default initializer to a derived type variable or result. */
6298 apply_default_init (gfc_symbol *sym)
6301 gfc_expr *init = NULL;
6303 gfc_namespace *ns = sym->ns;
6305 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6308 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6309 init = gfc_default_initializer (&sym->ts);
6314 /* Search for the function namespace if this is a contained
6315 function without an explicit result. */
6316 if (sym->attr.function && sym == sym->result
6317 && sym->name != sym->ns->proc_name->name)
6320 for (;ns; ns = ns->sibling)
6321 if (strcmp (ns->proc_name->name, sym->name) == 0)
6327 gfc_free_expr (init);
6331 /* Build an l-value expression for the result. */
6332 lval = gfc_get_expr ();
6333 lval->expr_type = EXPR_VARIABLE;
6334 lval->where = sym->declared_at;
6336 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
6338 /* It will always be a full array. */
6339 lval->rank = sym->as ? sym->as->rank : 0;
6342 lval->ref = gfc_get_ref ();
6343 lval->ref->type = REF_ARRAY;
6344 lval->ref->u.ar.type = AR_FULL;
6345 lval->ref->u.ar.dimen = lval->rank;
6346 lval->ref->u.ar.where = sym->declared_at;
6347 lval->ref->u.ar.as = sym->as;
6350 /* Add the code at scope entry. */
6351 init_st = gfc_get_code ();
6352 init_st->next = ns->code;
6355 /* Assign the default initializer to the l-value. */
6356 init_st->loc = sym->declared_at;
6357 init_st->op = EXEC_INIT_ASSIGN;
6358 init_st->expr = lval;
6359 init_st->expr2 = init;
6363 /* Resolution of common features of flavors variable and procedure. */
6366 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6368 /* Constraints on deferred shape variable. */
6369 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6371 if (sym->attr.allocatable)
6373 if (sym->attr.dimension)
6374 gfc_error ("Allocatable array '%s' at %L must have "
6375 "a deferred shape", sym->name, &sym->declared_at);
6377 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6378 sym->name, &sym->declared_at);
6382 if (sym->attr.pointer && sym->attr.dimension)
6384 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6385 sym->name, &sym->declared_at);
6392 if (!mp_flag && !sym->attr.allocatable
6393 && !sym->attr.pointer && !sym->attr.dummy)
6395 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6396 sym->name, &sym->declared_at);
6404 static gfc_component *
6405 has_default_initializer (gfc_symbol *der)
6408 for (c = der->components; c; c = c->next)
6409 if ((c->ts.type != BT_DERIVED && c->initializer)
6410 || (c->ts.type == BT_DERIVED
6412 && has_default_initializer (c->ts.derived)))
6419 /* Resolve symbols with flavor variable. */
6422 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6428 const char *auto_save_msg;
6430 auto_save_msg = "automatic object '%s' at %L cannot have the "
6433 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6436 /* Set this flag to check that variables are parameters of all entries.
6437 This check is effected by the call to gfc_resolve_expr through
6438 is_non_constant_shape_array. */
6439 specification_expr = 1;
6441 if (!sym->attr.use_assoc
6442 && !sym->attr.allocatable
6443 && !sym->attr.pointer
6444 && is_non_constant_shape_array (sym))
6446 /* The shape of a main program or module array needs to be
6448 if (sym->ns->proc_name
6449 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6450 || sym->ns->proc_name->attr.is_main_program))
6452 gfc_error ("The module or main program array '%s' at %L must "
6453 "have constant shape", sym->name, &sym->declared_at);
6454 specification_expr = 0;
6459 if (sym->ts.type == BT_CHARACTER)
6461 /* Make sure that character string variables with assumed length are
6463 e = sym->ts.cl->length;
6464 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6466 gfc_error ("Entity with assumed character length at %L must be a "
6467 "dummy argument or a PARAMETER", &sym->declared_at);
6471 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6473 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6477 if (!gfc_is_constant_expr (e)
6478 && !(e->expr_type == EXPR_VARIABLE
6479 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6480 && sym->ns->proc_name
6481 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6482 || sym->ns->proc_name->attr.is_main_program)
6483 && !sym->attr.use_assoc)
6485 gfc_error ("'%s' at %L must have constant character length "
6486 "in this context", sym->name, &sym->declared_at);
6491 /* Can the symbol have an initializer? */
6493 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6494 || sym->attr.intrinsic || sym->attr.result)
6496 else if (sym->attr.dimension && !sym->attr.pointer)
6498 /* Don't allow initialization of automatic arrays. */
6499 for (i = 0; i < sym->as->rank; i++)
6501 if (sym->as->lower[i] == NULL
6502 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6503 || sym->as->upper[i] == NULL
6504 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6511 /* Also, they must not have the SAVE attribute.
6512 SAVE_IMPLICIT is checked below. */
6513 if (flag && sym->attr.save == SAVE_EXPLICIT)
6515 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6520 /* Reject illegal initializers. */
6521 if (sym->value && flag)
6523 if (sym->attr.allocatable)
6524 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6525 sym->name, &sym->declared_at);
6526 else if (sym->attr.external)
6527 gfc_error ("External '%s' at %L cannot have an initializer",
6528 sym->name, &sym->declared_at);
6529 else if (sym->attr.dummy
6530 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6531 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6532 sym->name, &sym->declared_at);
6533 else if (sym->attr.intrinsic)
6534 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6535 sym->name, &sym->declared_at);
6536 else if (sym->attr.result)
6537 gfc_error ("Function result '%s' at %L cannot have an initializer",
6538 sym->name, &sym->declared_at);
6540 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6541 sym->name, &sym->declared_at);
6548 /* Check to see if a derived type is blocked from being host associated
6549 by the presence of another class I symbol in the same namespace.
6550 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6551 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6552 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6555 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6556 if (s && (s->attr.flavor != FL_DERIVED
6557 || !gfc_compare_derived_types (s, sym->ts.derived)))
6559 gfc_error ("The type %s cannot be host associated at %L because "
6560 "it is blocked by an incompatible object of the same "
6561 "name at %L", sym->ts.derived->name, &sym->declared_at,
6567 /* Do not use gfc_default_initializer to test for a default initializer
6568 in the fortran because it generates a hidden default for allocatable
6571 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6572 c = has_default_initializer (sym->ts.derived);
6574 /* 4th constraint in section 11.3: "If an object of a type for which
6575 component-initialization is specified (R429) appears in the
6576 specification-part of a module and does not have the ALLOCATABLE
6577 or POINTER attribute, the object shall have the SAVE attribute." */
6578 if (c && sym->ns->proc_name
6579 && sym->ns->proc_name->attr.flavor == FL_MODULE
6580 && !sym->ns->save_all && !sym->attr.save
6581 && !sym->attr.pointer && !sym->attr.allocatable)
6583 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6584 sym->name, &sym->declared_at,
6585 "for default initialization of a component");
6589 /* Assign default initializer. */
6590 if (sym->ts.type == BT_DERIVED
6592 && !sym->attr.pointer
6593 && !sym->attr.allocatable
6594 && (!flag || sym->attr.intent == INTENT_OUT))
6595 sym->value = gfc_default_initializer (&sym->ts);
6601 /* Resolve a procedure. */
6604 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6606 gfc_formal_arglist *arg;
6608 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6609 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6610 "interfaces", sym->name, &sym->declared_at);
6612 if (sym->attr.function
6613 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6616 if (sym->ts.type == BT_CHARACTER)
6618 gfc_charlen *cl = sym->ts.cl;
6620 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6621 && resolve_charlen (cl) == FAILURE)
6624 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6626 if (sym->attr.proc == PROC_ST_FUNCTION)
6628 gfc_error ("Character-valued statement function '%s' at %L must "
6629 "have constant length", sym->name, &sym->declared_at);
6633 if (sym->attr.external && sym->formal == NULL
6634 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6636 gfc_error ("Automatic character length function '%s' at %L must "
6637 "have an explicit interface", sym->name,
6644 /* Ensure that derived type for are not of a private type. Internal
6645 module procedures are excluded by 2.2.3.3 - ie. they are not
6646 externally accessible and can access all the objects accessible in
6648 if (!(sym->ns->parent
6649 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6650 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6652 for (arg = sym->formal; arg; arg = arg->next)
6655 && arg->sym->ts.type == BT_DERIVED
6656 && !arg->sym->ts.derived->attr.use_assoc
6657 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6658 arg->sym->ts.derived->ns->default_access))
6660 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6661 "a dummy argument of '%s', which is "
6662 "PUBLIC at %L", arg->sym->name, sym->name,
6664 /* Stop this message from recurring. */
6665 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6671 /* An external symbol may not have an initializer because it is taken to be
6673 if (sym->attr.external && sym->value)
6675 gfc_error ("External object '%s' at %L may not have an initializer",
6676 sym->name, &sym->declared_at);
6680 /* An elemental function is required to return a scalar 12.7.1 */
6681 if (sym->attr.elemental && sym->attr.function && sym->as)
6683 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6684 "result", sym->name, &sym->declared_at);
6685 /* Reset so that the error only occurs once. */
6686 sym->attr.elemental = 0;
6690 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6691 char-len-param shall not be array-valued, pointer-valued, recursive
6692 or pure. ....snip... A character value of * may only be used in the
6693 following ways: (i) Dummy arg of procedure - dummy associates with
6694 actual length; (ii) To declare a named constant; or (iii) External
6695 function - but length must be declared in calling scoping unit. */
6696 if (sym->attr.function
6697 && sym->ts.type == BT_CHARACTER
6698 && sym->ts.cl && sym->ts.cl->length == NULL)
6700 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6701 || (sym->attr.recursive) || (sym->attr.pure))
6703 if (sym->as && sym->as->rank)
6704 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6705 "array-valued", sym->name, &sym->declared_at);
6707 if (sym->attr.pointer)
6708 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6709 "pointer-valued", sym->name, &sym->declared_at);
6712 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6713 "pure", sym->name, &sym->declared_at);
6715 if (sym->attr.recursive)
6716 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6717 "recursive", sym->name, &sym->declared_at);
6722 /* Appendix B.2 of the standard. Contained functions give an
6723 error anyway. Fixed-form is likely to be F77/legacy. */
6724 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6725 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6726 "'%s' at %L is obsolescent in fortran 95",
6727 sym->name, &sym->declared_at);
6730 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6732 gfc_formal_arglist *curr_arg;
6734 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6735 sym->common_block) == FAILURE)
6737 /* Clear these to prevent looking at them again if there was an
6739 sym->attr.is_bind_c = 0;
6740 sym->attr.is_c_interop = 0;
6741 sym->ts.is_c_interop = 0;
6745 /* So far, no errors have been found. */
6746 sym->attr.is_c_interop = 1;
6747 sym->ts.is_c_interop = 1;
6750 curr_arg = sym->formal;
6751 while (curr_arg != NULL)
6753 /* Skip implicitly typed dummy args here. */
6754 if (curr_arg->sym->attr.implicit_type == 0
6755 && verify_c_interop_param (curr_arg->sym) == FAILURE)
6757 /* If something is found to fail, mark the symbol for the
6758 procedure as not being BIND(C) to try and prevent multiple
6759 errors being reported. */
6760 sym->attr.is_c_interop = 0;
6761 sym->ts.is_c_interop = 0;
6762 sym->attr.is_bind_c = 0;
6764 curr_arg = curr_arg->next;
6772 /* Resolve the components of a derived type. */
6775 resolve_fl_derived (gfc_symbol *sym)
6778 gfc_dt_list * dt_list;
6781 for (c = sym->components; c != NULL; c = c->next)
6783 if (c->ts.type == BT_CHARACTER)
6785 if (c->ts.cl->length == NULL
6786 || (resolve_charlen (c->ts.cl) == FAILURE)
6787 || !gfc_is_constant_expr (c->ts.cl->length))
6789 gfc_error ("Character length of component '%s' needs to "
6790 "be a constant specification expression at %L",
6792 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6797 if (c->ts.type == BT_DERIVED
6798 && sym->component_access != ACCESS_PRIVATE
6799 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6800 && !c->ts.derived->attr.use_assoc
6801 && !gfc_check_access (c->ts.derived->attr.access,
6802 c->ts.derived->ns->default_access))
6804 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6805 "a component of '%s', which is PUBLIC at %L",
6806 c->name, sym->name, &sym->declared_at);
6810 if (sym->attr.sequence)
6812 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6814 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6815 "not have the SEQUENCE attribute",
6816 c->ts.derived->name, &sym->declared_at);
6821 if (c->ts.type == BT_DERIVED && c->pointer
6822 && c->ts.derived->components == NULL)
6824 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6825 "that has not been declared", c->name, sym->name,
6830 if (c->pointer || c->allocatable || c->as == NULL)
6833 for (i = 0; i < c->as->rank; i++)
6835 if (c->as->lower[i] == NULL
6836 || !gfc_is_constant_expr (c->as->lower[i])
6837 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6838 || c->as->upper[i] == NULL
6839 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6840 || !gfc_is_constant_expr (c->as->upper[i]))
6842 gfc_error ("Component '%s' of '%s' at %L must have "
6843 "constant array bounds",
6844 c->name, sym->name, &c->loc);
6850 /* Add derived type to the derived type list. */
6851 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
6852 if (sym == dt_list->derived)
6855 if (dt_list == NULL)
6857 dt_list = gfc_get_dt_list ();
6858 dt_list->next = gfc_derived_types;
6859 dt_list->derived = sym;
6860 gfc_derived_types = dt_list;
6868 resolve_fl_namelist (gfc_symbol *sym)
6873 /* Reject PRIVATE objects in a PUBLIC namelist. */
6874 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
6876 for (nl = sym->namelist; nl; nl = nl->next)
6878 if (!nl->sym->attr.use_assoc
6879 && !(sym->ns->parent == nl->sym->ns)
6880 && !gfc_check_access(nl->sym->attr.access,
6881 nl->sym->ns->default_access))
6883 gfc_error ("PRIVATE symbol '%s' cannot be member of "
6884 "PUBLIC namelist at %L", nl->sym->name,
6891 /* Reject namelist arrays that are not constant shape. */
6892 for (nl = sym->namelist; nl; nl = nl->next)
6894 if (is_non_constant_shape_array (nl->sym))
6896 gfc_error ("The array '%s' must have constant shape to be "
6897 "a NAMELIST object at %L", nl->sym->name,
6903 /* Namelist objects cannot have allocatable components. */
6904 for (nl = sym->namelist; nl; nl = nl->next)
6906 if (nl->sym->ts.type == BT_DERIVED
6907 && nl->sym->ts.derived->attr.alloc_comp)
6909 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
6910 "components", nl->sym->name, &sym->declared_at);
6915 /* 14.1.2 A module or internal procedure represent local entities
6916 of the same type as a namelist member and so are not allowed. */
6917 for (nl = sym->namelist; nl; nl = nl->next)
6919 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
6922 if (nl->sym->attr.function && nl->sym == nl->sym->result)
6923 if ((nl->sym == sym->ns->proc_name)
6925 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
6929 if (nl->sym && nl->sym->name)
6930 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
6931 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
6933 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
6934 "attribute in '%s' at %L", nlsym->name,
6945 resolve_fl_parameter (gfc_symbol *sym)
6947 /* A parameter array's shape needs to be constant. */
6948 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
6950 gfc_error ("Parameter array '%s' at %L cannot be automatic "
6951 "or assumed shape", sym->name, &sym->declared_at);
6955 /* Make sure a parameter that has been implicitly typed still
6956 matches the implicit type, since PARAMETER statements can precede
6957 IMPLICIT statements. */
6958 if (sym->attr.implicit_type
6959 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
6961 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6962 "later IMPLICIT type", sym->name, &sym->declared_at);
6966 /* Make sure the types of derived parameters are consistent. This
6967 type checking is deferred until resolution because the type may
6968 refer to a derived type from the host. */
6969 if (sym->ts.type == BT_DERIVED
6970 && !gfc_compare_types (&sym->ts, &sym->value->ts))
6972 gfc_error ("Incompatible derived type in PARAMETER at %L",
6973 &sym->value->where);
6980 /* Do anything necessary to resolve a symbol. Right now, we just
6981 assume that an otherwise unknown symbol is a variable. This sort
6982 of thing commonly happens for symbols in module. */
6985 resolve_symbol (gfc_symbol *sym)
6987 int check_constant, mp_flag;
6988 gfc_symtree *symtree;
6989 gfc_symtree *this_symtree;
6993 if (sym->attr.flavor == FL_UNKNOWN)
6996 /* If we find that a flavorless symbol is an interface in one of the
6997 parent namespaces, find its symtree in this namespace, free the
6998 symbol and set the symtree to point to the interface symbol. */
6999 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7001 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7002 if (symtree && symtree->n.sym->generic)
7004 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7008 gfc_free_symbol (sym);
7009 symtree->n.sym->refs++;
7010 this_symtree->n.sym = symtree->n.sym;
7015 /* Otherwise give it a flavor according to such attributes as
7017 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7018 sym->attr.flavor = FL_VARIABLE;
7021 sym->attr.flavor = FL_PROCEDURE;
7022 if (sym->attr.dimension)
7023 sym->attr.function = 1;
7027 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7030 /* Symbols that are module procedures with results (functions) have
7031 the types and array specification copied for type checking in
7032 procedures that call them, as well as for saving to a module
7033 file. These symbols can't stand the scrutiny that their results
7035 mp_flag = (sym->result != NULL && sym->result != sym);
7038 /* Make sure that the intrinsic is consistent with its internal
7039 representation. This needs to be done before assigning a default
7040 type to avoid spurious warnings. */
7041 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7043 if (gfc_intrinsic_name (sym->name, 0))
7045 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7046 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7047 sym->name, &sym->declared_at);
7049 else if (gfc_intrinsic_name (sym->name, 1))
7051 if (sym->ts.type != BT_UNKNOWN)
7053 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7054 sym->name, &sym->declared_at);
7060 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7065 /* Assign default type to symbols that need one and don't have one. */
7066 if (sym->ts.type == BT_UNKNOWN)
7068 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7069 gfc_set_default_type (sym, 1, NULL);
7071 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7073 /* The specific case of an external procedure should emit an error
7074 in the case that there is no implicit type. */
7076 gfc_set_default_type (sym, sym->attr.external, NULL);
7079 /* Result may be in another namespace. */
7080 resolve_symbol (sym->result);
7082 sym->ts = sym->result->ts;
7083 sym->as = gfc_copy_array_spec (sym->result->as);
7084 sym->attr.dimension = sym->result->attr.dimension;
7085 sym->attr.pointer = sym->result->attr.pointer;
7086 sym->attr.allocatable = sym->result->attr.allocatable;
7091 /* Assumed size arrays and assumed shape arrays must be dummy
7095 && (sym->as->type == AS_ASSUMED_SIZE
7096 || sym->as->type == AS_ASSUMED_SHAPE)
7097 && sym->attr.dummy == 0)
7099 if (sym->as->type == AS_ASSUMED_SIZE)
7100 gfc_error ("Assumed size array at %L must be a dummy argument",
7103 gfc_error ("Assumed shape array at %L must be a dummy argument",
7108 /* Make sure symbols with known intent or optional are really dummy
7109 variable. Because of ENTRY statement, this has to be deferred
7110 until resolution time. */
7112 if (!sym->attr.dummy
7113 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7115 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7119 if (sym->attr.value && !sym->attr.dummy)
7121 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7122 "it is not a dummy argument", sym->name, &sym->declared_at);
7126 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7128 gfc_charlen *cl = sym->ts.cl;
7129 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7131 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7132 "attribute must have constant length",
7133 sym->name, &sym->declared_at);
7137 if (sym->ts.is_c_interop
7138 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7140 gfc_error ("C interoperable character dummy variable '%s' at %L "
7141 "with VALUE attribute must have length one",
7142 sym->name, &sym->declared_at);
7147 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7148 do this for something that was implicitly typed because that is handled
7149 in gfc_set_default_type. Handle dummy arguments and procedure
7150 definitions separately. Also, anything that is use associated is not
7151 handled here but instead is handled in the module it is declared in.
7152 Finally, derived type definitions are allowed to be BIND(C) since that
7153 only implies that they're interoperable, and they are checked fully for
7154 interoperability when a variable is declared of that type. */
7155 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7156 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7157 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7161 /* First, make sure the variable is declared at the
7162 module-level scope (J3/04-007, Section 15.3). */
7163 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7164 sym->attr.in_common == 0)
7166 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7167 "is neither a COMMON block nor declared at the "
7168 "module level scope", sym->name, &(sym->declared_at));
7171 else if (sym->common_head != NULL)
7173 t = verify_com_block_vars_c_interop (sym->common_head);
7177 /* If type() declaration, we need to verify that the components
7178 of the given type are all C interoperable, etc. */
7179 if (sym->ts.type == BT_DERIVED &&
7180 sym->ts.derived->attr.is_c_interop != 1)
7182 /* Make sure the user marked the derived type as BIND(C). If
7183 not, call the verify routine. This could print an error
7184 for the derived type more than once if multiple variables
7185 of that type are declared. */
7186 if (sym->ts.derived->attr.is_bind_c != 1)
7187 verify_bind_c_derived_type (sym->ts.derived);
7191 /* Verify the variable itself as C interoperable if it
7192 is BIND(C). It is not possible for this to succeed if
7193 the verify_bind_c_derived_type failed, so don't have to handle
7194 any error returned by verify_bind_c_derived_type. */
7195 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7201 /* clear the is_bind_c flag to prevent reporting errors more than
7202 once if something failed. */
7203 sym->attr.is_bind_c = 0;
7208 /* If a derived type symbol has reached this point, without its
7209 type being declared, we have an error. Notice that most
7210 conditions that produce undefined derived types have already
7211 been dealt with. However, the likes of:
7212 implicit type(t) (t) ..... call foo (t) will get us here if
7213 the type is not declared in the scope of the implicit
7214 statement. Change the type to BT_UNKNOWN, both because it is so
7215 and to prevent an ICE. */
7216 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7218 gfc_error ("The derived type '%s' at %L is of type '%s', "
7219 "which has not been defined", sym->name,
7220 &sym->declared_at, sym->ts.derived->name);
7221 sym->ts.type = BT_UNKNOWN;
7225 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7226 default initialization is defined (5.1.2.4.4). */
7227 if (sym->ts.type == BT_DERIVED
7229 && sym->attr.intent == INTENT_OUT
7231 && sym->as->type == AS_ASSUMED_SIZE)
7233 for (c = sym->ts.derived->components; c; c = c->next)
7237 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7238 "ASSUMED SIZE and so cannot have a default initializer",
7239 sym->name, &sym->declared_at);
7245 switch (sym->attr.flavor)
7248 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7253 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7258 if (resolve_fl_namelist (sym) == FAILURE)
7263 if (resolve_fl_parameter (sym) == FAILURE)
7271 /* Resolve array specifier. Check as well some constraints
7272 on COMMON blocks. */
7274 check_constant = sym->attr.in_common && !sym->attr.pointer;
7276 /* Set the formal_arg_flag so that check_conflict will not throw
7277 an error for host associated variables in the specification
7278 expression for an array_valued function. */
7279 if (sym->attr.function && sym->as)
7280 formal_arg_flag = 1;
7282 gfc_resolve_array_spec (sym->as, check_constant);
7284 formal_arg_flag = 0;
7286 /* Resolve formal namespaces. */
7287 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7288 gfc_resolve (sym->formal_ns);
7290 /* Check threadprivate restrictions. */
7291 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7292 && (!sym->attr.in_common
7293 && sym->module == NULL
7294 && (sym->ns->proc_name == NULL
7295 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7296 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7298 /* If we have come this far we can apply default-initializers, as
7299 described in 14.7.5, to those variables that have not already
7300 been assigned one. */
7301 if (sym->ts.type == BT_DERIVED
7302 && sym->attr.referenced
7303 && sym->ns == gfc_current_ns
7305 && !sym->attr.allocatable
7306 && !sym->attr.alloc_comp)
7308 symbol_attribute *a = &sym->attr;
7310 if ((!a->save && !a->dummy && !a->pointer
7311 && !a->in_common && !a->use_assoc
7312 && !(a->function && sym != sym->result))
7313 || (a->dummy && a->intent == INTENT_OUT))
7314 apply_default_init (sym);
7319 /************* Resolve DATA statements *************/
7323 gfc_data_value *vnode;
7329 /* Advance the values structure to point to the next value in the data list. */
7332 next_data_value (void)
7334 while (values.left == 0)
7336 if (values.vnode->next == NULL)
7339 values.vnode = values.vnode->next;
7340 values.left = values.vnode->repeat;
7348 check_data_variable (gfc_data_variable *var, locus *where)
7354 ar_type mark = AR_UNKNOWN;
7356 mpz_t section_index[GFC_MAX_DIMENSIONS];
7360 if (gfc_resolve_expr (var->expr) == FAILURE)
7364 mpz_init_set_si (offset, 0);
7367 if (e->expr_type != EXPR_VARIABLE)
7368 gfc_internal_error ("check_data_variable(): Bad expression");
7370 if (e->symtree->n.sym->ns->is_block_data
7371 && !e->symtree->n.sym->attr.in_common)
7373 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7374 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7379 mpz_init_set_ui (size, 1);
7386 /* Find the array section reference. */
7387 for (ref = e->ref; ref; ref = ref->next)
7389 if (ref->type != REF_ARRAY)
7391 if (ref->u.ar.type == AR_ELEMENT)
7397 /* Set marks according to the reference pattern. */
7398 switch (ref->u.ar.type)
7406 /* Get the start position of array section. */
7407 gfc_get_section_index (ar, section_index, &offset);
7415 if (gfc_array_size (e, &size) == FAILURE)
7417 gfc_error ("Nonconstant array section at %L in DATA statement",
7426 while (mpz_cmp_ui (size, 0) > 0)
7428 if (next_data_value () == FAILURE)
7430 gfc_error ("DATA statement at %L has more variables than values",
7436 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7440 /* If we have more than one element left in the repeat count,
7441 and we have more than one element left in the target variable,
7442 then create a range assignment. */
7443 /* ??? Only done for full arrays for now, since array sections
7445 if (mark == AR_FULL && ref && ref->next == NULL
7446 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7450 if (mpz_cmp_ui (size, values.left) >= 0)
7452 mpz_init_set_ui (range, values.left);
7453 mpz_sub_ui (size, size, values.left);
7458 mpz_init_set (range, size);
7459 values.left -= mpz_get_ui (size);
7460 mpz_set_ui (size, 0);
7463 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7466 mpz_add (offset, offset, range);
7470 /* Assign initial value to symbol. */
7474 mpz_sub_ui (size, size, 1);
7476 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7480 if (mark == AR_FULL)
7481 mpz_add_ui (offset, offset, 1);
7483 /* Modify the array section indexes and recalculate the offset
7484 for next element. */
7485 else if (mark == AR_SECTION)
7486 gfc_advance_section (section_index, ar, &offset);
7490 if (mark == AR_SECTION)
7492 for (i = 0; i < ar->dimen; i++)
7493 mpz_clear (section_index[i]);
7503 static try traverse_data_var (gfc_data_variable *, locus *);
7505 /* Iterate over a list of elements in a DATA statement. */
7508 traverse_data_list (gfc_data_variable *var, locus *where)
7511 iterator_stack frame;
7512 gfc_expr *e, *start, *end, *step;
7513 try retval = SUCCESS;
7515 mpz_init (frame.value);
7517 start = gfc_copy_expr (var->iter.start);
7518 end = gfc_copy_expr (var->iter.end);
7519 step = gfc_copy_expr (var->iter.step);
7521 if (gfc_simplify_expr (start, 1) == FAILURE
7522 || start->expr_type != EXPR_CONSTANT)
7524 gfc_error ("iterator start at %L does not simplify", &start->where);
7528 if (gfc_simplify_expr (end, 1) == FAILURE
7529 || end->expr_type != EXPR_CONSTANT)
7531 gfc_error ("iterator end at %L does not simplify", &end->where);
7535 if (gfc_simplify_expr (step, 1) == FAILURE
7536 || step->expr_type != EXPR_CONSTANT)
7538 gfc_error ("iterator step at %L does not simplify", &step->where);
7543 mpz_init_set (trip, end->value.integer);
7544 mpz_sub (trip, trip, start->value.integer);
7545 mpz_add (trip, trip, step->value.integer);
7547 mpz_div (trip, trip, step->value.integer);
7549 mpz_set (frame.value, start->value.integer);
7551 frame.prev = iter_stack;
7552 frame.variable = var->iter.var->symtree;
7553 iter_stack = &frame;
7555 while (mpz_cmp_ui (trip, 0) > 0)
7557 if (traverse_data_var (var->list, where) == FAILURE)
7564 e = gfc_copy_expr (var->expr);
7565 if (gfc_simplify_expr (e, 1) == FAILURE)
7573 mpz_add (frame.value, frame.value, step->value.integer);
7575 mpz_sub_ui (trip, trip, 1);
7580 mpz_clear (frame.value);
7582 gfc_free_expr (start);
7583 gfc_free_expr (end);
7584 gfc_free_expr (step);
7586 iter_stack = frame.prev;
7591 /* Type resolve variables in the variable list of a DATA statement. */
7594 traverse_data_var (gfc_data_variable *var, locus *where)
7598 for (; var; var = var->next)
7600 if (var->expr == NULL)
7601 t = traverse_data_list (var, where);
7603 t = check_data_variable (var, where);
7613 /* Resolve the expressions and iterators associated with a data statement.
7614 This is separate from the assignment checking because data lists should
7615 only be resolved once. */
7618 resolve_data_variables (gfc_data_variable *d)
7620 for (; d; d = d->next)
7622 if (d->list == NULL)
7624 if (gfc_resolve_expr (d->expr) == FAILURE)
7629 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7632 if (resolve_data_variables (d->list) == FAILURE)
7641 /* Resolve a single DATA statement. We implement this by storing a pointer to
7642 the value list into static variables, and then recursively traversing the
7643 variables list, expanding iterators and such. */
7646 resolve_data (gfc_data * d)
7648 if (resolve_data_variables (d->var) == FAILURE)
7651 values.vnode = d->value;
7652 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7654 if (traverse_data_var (d->var, &d->where) == FAILURE)
7657 /* At this point, we better not have any values left. */
7659 if (next_data_value () == SUCCESS)
7660 gfc_error ("DATA statement at %L has more values than variables",
7665 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7666 accessed by host or use association, is a dummy argument to a pure function,
7667 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7668 is storage associated with any such variable, shall not be used in the
7669 following contexts: (clients of this function). */
7671 /* Determines if a variable is not 'pure', ie not assignable within a pure
7672 procedure. Returns zero if assignment is OK, nonzero if there is a
7675 gfc_impure_variable (gfc_symbol *sym)
7679 if (sym->attr.use_assoc || sym->attr.in_common)
7682 if (sym->ns != gfc_current_ns)
7683 return !sym->attr.function;
7685 proc = sym->ns->proc_name;
7686 if (sym->attr.dummy && gfc_pure (proc)
7687 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7689 proc->attr.function))
7692 /* TODO: Sort out what can be storage associated, if anything, and include
7693 it here. In principle equivalences should be scanned but it does not
7694 seem to be possible to storage associate an impure variable this way. */
7699 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7700 symbol of the current procedure. */
7703 gfc_pure (gfc_symbol *sym)
7705 symbol_attribute attr;
7708 sym = gfc_current_ns->proc_name;
7714 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7718 /* Test whether the current procedure is elemental or not. */
7721 gfc_elemental (gfc_symbol *sym)
7723 symbol_attribute attr;
7726 sym = gfc_current_ns->proc_name;
7731 return attr.flavor == FL_PROCEDURE && attr.elemental;
7735 /* Warn about unused labels. */
7738 warn_unused_fortran_label (gfc_st_label *label)
7743 warn_unused_fortran_label (label->left);
7745 if (label->defined == ST_LABEL_UNKNOWN)
7748 switch (label->referenced)
7750 case ST_LABEL_UNKNOWN:
7751 gfc_warning ("Label %d at %L defined but not used", label->value,
7755 case ST_LABEL_BAD_TARGET:
7756 gfc_warning ("Label %d at %L defined but cannot be used",
7757 label->value, &label->where);
7764 warn_unused_fortran_label (label->right);
7768 /* Returns the sequence type of a symbol or sequence. */
7771 sequence_type (gfc_typespec ts)
7780 if (ts.derived->components == NULL)
7781 return SEQ_NONDEFAULT;
7783 result = sequence_type (ts.derived->components->ts);
7784 for (c = ts.derived->components->next; c; c = c->next)
7785 if (sequence_type (c->ts) != result)
7791 if (ts.kind != gfc_default_character_kind)
7792 return SEQ_NONDEFAULT;
7794 return SEQ_CHARACTER;
7797 if (ts.kind != gfc_default_integer_kind)
7798 return SEQ_NONDEFAULT;
7803 if (!(ts.kind == gfc_default_real_kind
7804 || ts.kind == gfc_default_double_kind))
7805 return SEQ_NONDEFAULT;
7810 if (ts.kind != gfc_default_complex_kind)
7811 return SEQ_NONDEFAULT;
7816 if (ts.kind != gfc_default_logical_kind)
7817 return SEQ_NONDEFAULT;
7822 return SEQ_NONDEFAULT;
7827 /* Resolve derived type EQUIVALENCE object. */
7830 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
7833 gfc_component *c = derived->components;
7838 /* Shall not be an object of nonsequence derived type. */
7839 if (!derived->attr.sequence)
7841 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
7842 "attribute to be an EQUIVALENCE object", sym->name,
7847 /* Shall not have allocatable components. */
7848 if (derived->attr.alloc_comp)
7850 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
7851 "components to be an EQUIVALENCE object",sym->name,
7856 for (; c ; c = c->next)
7860 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
7863 /* Shall not be an object of sequence derived type containing a pointer
7864 in the structure. */
7867 gfc_error ("Derived type variable '%s' at %L with pointer "
7868 "component(s) cannot be an EQUIVALENCE object",
7869 sym->name, &e->where);
7877 /* Resolve equivalence object.
7878 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
7879 an allocatable array, an object of nonsequence derived type, an object of
7880 sequence derived type containing a pointer at any level of component
7881 selection, an automatic object, a function name, an entry name, a result
7882 name, a named constant, a structure component, or a subobject of any of
7883 the preceding objects. A substring shall not have length zero. A
7884 derived type shall not have components with default initialization nor
7885 shall two objects of an equivalence group be initialized.
7886 Either all or none of the objects shall have an protected attribute.
7887 The simple constraints are done in symbol.c(check_conflict) and the rest
7888 are implemented here. */
7891 resolve_equivalence (gfc_equiv *eq)
7894 gfc_symbol *derived;
7895 gfc_symbol *first_sym;
7898 locus *last_where = NULL;
7899 seq_type eq_type, last_eq_type;
7900 gfc_typespec *last_ts;
7901 int object, cnt_protected;
7902 const char *value_name;
7906 last_ts = &eq->expr->symtree->n.sym->ts;
7908 first_sym = eq->expr->symtree->n.sym;
7912 for (object = 1; eq; eq = eq->eq, object++)
7916 e->ts = e->symtree->n.sym->ts;
7917 /* match_varspec might not know yet if it is seeing
7918 array reference or substring reference, as it doesn't
7920 if (e->ref && e->ref->type == REF_ARRAY)
7922 gfc_ref *ref = e->ref;
7923 sym = e->symtree->n.sym;
7925 if (sym->attr.dimension)
7927 ref->u.ar.as = sym->as;
7931 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
7932 if (e->ts.type == BT_CHARACTER
7934 && ref->type == REF_ARRAY
7935 && ref->u.ar.dimen == 1
7936 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
7937 && ref->u.ar.stride[0] == NULL)
7939 gfc_expr *start = ref->u.ar.start[0];
7940 gfc_expr *end = ref->u.ar.end[0];
7943 /* Optimize away the (:) reference. */
7944 if (start == NULL && end == NULL)
7949 e->ref->next = ref->next;
7954 ref->type = REF_SUBSTRING;
7956 start = gfc_int_expr (1);
7957 ref->u.ss.start = start;
7958 if (end == NULL && e->ts.cl)
7959 end = gfc_copy_expr (e->ts.cl->length);
7960 ref->u.ss.end = end;
7961 ref->u.ss.length = e->ts.cl;
7968 /* Any further ref is an error. */
7971 gcc_assert (ref->type == REF_ARRAY);
7972 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
7978 if (gfc_resolve_expr (e) == FAILURE)
7981 sym = e->symtree->n.sym;
7983 if (sym->attr.protected)
7985 if (cnt_protected > 0 && cnt_protected != object)
7987 gfc_error ("Either all or none of the objects in the "
7988 "EQUIVALENCE set at %L shall have the "
7989 "PROTECTED attribute",
7994 /* Shall not equivalence common block variables in a PURE procedure. */
7995 if (sym->ns->proc_name
7996 && sym->ns->proc_name->attr.pure
7997 && sym->attr.in_common)
7999 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8000 "object in the pure procedure '%s'",
8001 sym->name, &e->where, sym->ns->proc_name->name);
8005 /* Shall not be a named constant. */
8006 if (e->expr_type == EXPR_CONSTANT)
8008 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8009 "object", sym->name, &e->where);
8013 derived = e->ts.derived;
8014 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8017 /* Check that the types correspond correctly:
8019 A numeric sequence structure may be equivalenced to another sequence
8020 structure, an object of default integer type, default real type, double
8021 precision real type, default logical type such that components of the
8022 structure ultimately only become associated to objects of the same
8023 kind. A character sequence structure may be equivalenced to an object
8024 of default character kind or another character sequence structure.
8025 Other objects may be equivalenced only to objects of the same type and
8028 /* Identical types are unconditionally OK. */
8029 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8030 goto identical_types;
8032 last_eq_type = sequence_type (*last_ts);
8033 eq_type = sequence_type (sym->ts);
8035 /* Since the pair of objects is not of the same type, mixed or
8036 non-default sequences can be rejected. */
8038 msg = "Sequence %s with mixed components in EQUIVALENCE "
8039 "statement at %L with different type objects";
8041 && last_eq_type == SEQ_MIXED
8042 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8044 || (eq_type == SEQ_MIXED
8045 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8046 &e->where) == FAILURE))
8049 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8050 "statement at %L with objects of different type";
8052 && last_eq_type == SEQ_NONDEFAULT
8053 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8054 last_where) == FAILURE)
8055 || (eq_type == SEQ_NONDEFAULT
8056 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8057 &e->where) == FAILURE))
8060 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8061 "EQUIVALENCE statement at %L";
8062 if (last_eq_type == SEQ_CHARACTER
8063 && eq_type != SEQ_CHARACTER
8064 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8065 &e->where) == FAILURE)
8068 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8069 "EQUIVALENCE statement at %L";
8070 if (last_eq_type == SEQ_NUMERIC
8071 && eq_type != SEQ_NUMERIC
8072 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8073 &e->where) == FAILURE)
8078 last_where = &e->where;
8083 /* Shall not be an automatic array. */
8084 if (e->ref->type == REF_ARRAY
8085 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8087 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8088 "an EQUIVALENCE object", sym->name, &e->where);
8095 /* Shall not be a structure component. */
8096 if (r->type == REF_COMPONENT)
8098 gfc_error ("Structure component '%s' at %L cannot be an "
8099 "EQUIVALENCE object",
8100 r->u.c.component->name, &e->where);
8104 /* A substring shall not have length zero. */
8105 if (r->type == REF_SUBSTRING)
8107 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8109 gfc_error ("Substring at %L has length zero",
8110 &r->u.ss.start->where);
8120 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8123 resolve_fntype (gfc_namespace *ns)
8128 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8131 /* If there are any entries, ns->proc_name is the entry master
8132 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8134 sym = ns->entries->sym;
8136 sym = ns->proc_name;
8137 if (sym->result == sym
8138 && sym->ts.type == BT_UNKNOWN
8139 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8140 && !sym->attr.untyped)
8142 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8143 sym->name, &sym->declared_at);
8144 sym->attr.untyped = 1;
8147 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8148 && !gfc_check_access (sym->ts.derived->attr.access,
8149 sym->ts.derived->ns->default_access)
8150 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8152 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8153 sym->name, &sym->declared_at, sym->ts.derived->name);
8157 for (el = ns->entries->next; el; el = el->next)
8159 if (el->sym->result == el->sym
8160 && el->sym->ts.type == BT_UNKNOWN
8161 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8162 && !el->sym->attr.untyped)
8164 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8165 el->sym->name, &el->sym->declared_at);
8166 el->sym->attr.untyped = 1;
8171 /* 12.3.2.1.1 Defined operators. */
8174 gfc_resolve_uops (gfc_symtree *symtree)
8178 gfc_formal_arglist *formal;
8180 if (symtree == NULL)
8183 gfc_resolve_uops (symtree->left);
8184 gfc_resolve_uops (symtree->right);
8186 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8189 if (!sym->attr.function)
8190 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8191 sym->name, &sym->declared_at);
8193 if (sym->ts.type == BT_CHARACTER
8194 && !(sym->ts.cl && sym->ts.cl->length)
8195 && !(sym->result && sym->result->ts.cl
8196 && sym->result->ts.cl->length))
8197 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8198 "character length", sym->name, &sym->declared_at);
8200 formal = sym->formal;
8201 if (!formal || !formal->sym)
8203 gfc_error ("User operator procedure '%s' at %L must have at least "
8204 "one argument", sym->name, &sym->declared_at);
8208 if (formal->sym->attr.intent != INTENT_IN)
8209 gfc_error ("First argument of operator interface at %L must be "
8210 "INTENT(IN)", &sym->declared_at);
8212 if (formal->sym->attr.optional)
8213 gfc_error ("First argument of operator interface at %L cannot be "
8214 "optional", &sym->declared_at);
8216 formal = formal->next;
8217 if (!formal || !formal->sym)
8220 if (formal->sym->attr.intent != INTENT_IN)
8221 gfc_error ("Second argument of operator interface at %L must be "
8222 "INTENT(IN)", &sym->declared_at);
8224 if (formal->sym->attr.optional)
8225 gfc_error ("Second argument of operator interface at %L cannot be "
8226 "optional", &sym->declared_at);
8229 gfc_error ("Operator interface at %L must have, at most, two "
8230 "arguments", &sym->declared_at);
8235 /* Examine all of the expressions associated with a program unit,
8236 assign types to all intermediate expressions, make sure that all
8237 assignments are to compatible types and figure out which names
8238 refer to which functions or subroutines. It doesn't check code
8239 block, which is handled by resolve_code. */
8242 resolve_types (gfc_namespace *ns)
8249 gfc_current_ns = ns;
8251 resolve_entries (ns);
8253 resolve_common_blocks (ns->common_root);
8255 resolve_contained_functions (ns);
8257 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8259 for (cl = ns->cl_list; cl; cl = cl->next)
8260 resolve_charlen (cl);
8262 gfc_traverse_ns (ns, resolve_symbol);
8264 resolve_fntype (ns);
8266 for (n = ns->contained; n; n = n->sibling)
8268 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8269 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8270 "also be PURE", n->proc_name->name,
8271 &n->proc_name->declared_at);
8277 gfc_check_interfaces (ns);
8279 gfc_traverse_ns (ns, resolve_values);
8285 for (d = ns->data; d; d = d->next)
8289 gfc_traverse_ns (ns, gfc_formalize_init_value);
8291 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8293 if (ns->common_root != NULL)
8294 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8296 for (eq = ns->equiv; eq; eq = eq->next)
8297 resolve_equivalence (eq);
8299 /* Warn about unused labels. */
8300 if (warn_unused_label)
8301 warn_unused_fortran_label (ns->st_labels);
8303 gfc_resolve_uops (ns->uop_root);
8307 /* Call resolve_code recursively. */
8310 resolve_codes (gfc_namespace *ns)
8314 for (n = ns->contained; n; n = n->sibling)
8317 gfc_current_ns = ns;
8319 /* Set to an out of range value. */
8320 current_entry_id = -1;
8322 bitmap_obstack_initialize (&labels_obstack);
8323 resolve_code (ns->code, ns);
8324 bitmap_obstack_release (&labels_obstack);
8328 /* This function is called after a complete program unit has been compiled.
8329 Its purpose is to examine all of the expressions associated with a program
8330 unit, assign types to all intermediate expressions, make sure that all
8331 assignments are to compatible types and figure out which names refer to
8332 which functions or subroutines. */
8335 gfc_resolve (gfc_namespace *ns)
8337 gfc_namespace *old_ns;
8339 old_ns = gfc_current_ns;
8344 gfc_current_ns = old_ns;