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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 /* Types used in equivalence statements. */
35 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
39 /* Stack to keep track of the nesting of blocks as we move through the
40 code. See resolve_branch() and resolve_code(). */
42 typedef struct code_stack
44 struct gfc_code *head, *current, *tail;
45 struct code_stack *prev;
47 /* This bitmap keeps track of the targets valid for a branch from
49 bitmap reachable_labels;
53 static code_stack *cs_base = NULL;
56 /* Nonzero if we're inside a FORALL block. */
58 static int forall_flag;
60 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
62 static int omp_workshare_flag;
64 /* Nonzero if we are processing a formal arglist. The corresponding function
65 resets the flag each time that it is read. */
66 static int formal_arg_flag = 0;
68 /* True if we are resolving a specification expression. */
69 static int specification_expr = 0;
71 /* The id of the last entry seen. */
72 static int current_entry_id;
74 /* We use bitmaps to determine if a branch target is valid. */
75 static bitmap_obstack labels_obstack;
78 gfc_is_formal_arg (void)
80 return formal_arg_flag;
83 /* Resolve types of formal argument lists. These have to be done early so that
84 the formal argument lists of module procedures can be copied to the
85 containing module before the individual procedures are resolved
86 individually. We also resolve argument lists of procedures in interface
87 blocks because they are self-contained scoping units.
89 Since a dummy argument cannot be a non-dummy procedure, the only
90 resort left for untyped names are the IMPLICIT types. */
93 resolve_formal_arglist (gfc_symbol *proc)
95 gfc_formal_arglist *f;
99 if (proc->result != NULL)
104 if (gfc_elemental (proc)
105 || sym->attr.pointer || sym->attr.allocatable
106 || (sym->as && sym->as->rank > 0))
107 proc->attr.always_explicit = 1;
111 for (f = proc->formal; f; f = f->next)
117 /* Alternate return placeholder. */
118 if (gfc_elemental (proc))
119 gfc_error ("Alternate return specifier in elemental subroutine "
120 "'%s' at %L is not allowed", proc->name,
122 if (proc->attr.function)
123 gfc_error ("Alternate return specifier in function "
124 "'%s' at %L is not allowed", proc->name,
129 if (sym->attr.if_source != IFSRC_UNKNOWN)
130 resolve_formal_arglist (sym);
132 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
134 if (gfc_pure (proc) && !gfc_pure (sym))
136 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
137 "also be PURE", sym->name, &sym->declared_at);
141 if (gfc_elemental (proc))
143 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
144 "procedure", &sym->declared_at);
148 if (sym->attr.function
149 && sym->ts.type == BT_UNKNOWN
150 && sym->attr.intrinsic)
152 gfc_intrinsic_sym *isym;
153 isym = gfc_find_function (sym->name);
154 if (isym == NULL || !isym->specific)
156 gfc_error ("Unable to find a specific INTRINSIC procedure "
157 "for the reference '%s' at %L", sym->name,
166 if (sym->ts.type == BT_UNKNOWN)
168 if (!sym->attr.function || sym->result == sym)
169 gfc_set_default_type (sym, 1, sym->ns);
172 gfc_resolve_array_spec (sym->as, 0);
174 /* We can't tell if an array with dimension (:) is assumed or deferred
175 shape until we know if it has the pointer or allocatable attributes.
177 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
178 && !(sym->attr.pointer || sym->attr.allocatable))
180 sym->as->type = AS_ASSUMED_SHAPE;
181 for (i = 0; i < sym->as->rank; i++)
182 sym->as->lower[i] = gfc_int_expr (1);
185 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
186 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
187 || sym->attr.optional)
188 proc->attr.always_explicit = 1;
190 /* If the flavor is unknown at this point, it has to be a variable.
191 A procedure specification would have already set the type. */
193 if (sym->attr.flavor == FL_UNKNOWN)
194 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
196 if (gfc_pure (proc) && !sym->attr.pointer
197 && sym->attr.flavor != FL_PROCEDURE)
199 if (proc->attr.function && sym->attr.intent != INTENT_IN)
200 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
201 "INTENT(IN)", sym->name, proc->name,
204 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
205 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
206 "have its INTENT specified", sym->name, proc->name,
210 if (gfc_elemental (proc))
214 gfc_error ("Argument '%s' of elemental procedure at %L must "
215 "be scalar", sym->name, &sym->declared_at);
219 if (sym->attr.pointer)
221 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
222 "have the POINTER attribute", sym->name,
228 /* Each dummy shall be specified to be scalar. */
229 if (proc->attr.proc == PROC_ST_FUNCTION)
233 gfc_error ("Argument '%s' of statement function at %L must "
234 "be scalar", sym->name, &sym->declared_at);
238 if (sym->ts.type == BT_CHARACTER)
240 gfc_charlen *cl = sym->ts.cl;
241 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
243 gfc_error ("Character-valued argument '%s' of statement "
244 "function at %L must have constant length",
245 sym->name, &sym->declared_at);
255 /* Work function called when searching for symbols that have argument lists
256 associated with them. */
259 find_arglists (gfc_symbol *sym)
261 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
264 resolve_formal_arglist (sym);
268 /* Given a namespace, resolve all formal argument lists within the namespace.
272 resolve_formal_arglists (gfc_namespace *ns)
277 gfc_traverse_ns (ns, find_arglists);
282 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
286 /* If this namespace is not a function, ignore it. */
287 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
290 /* Try to find out of what the return type is. */
291 if (sym->result->ts.type == BT_UNKNOWN)
293 t = gfc_set_default_type (sym->result, 0, ns);
295 if (t == FAILURE && !sym->result->attr.untyped)
297 if (sym->result == sym)
298 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
299 sym->name, &sym->declared_at);
301 gfc_error ("Result '%s' of contained function '%s' at %L has "
302 "no IMPLICIT type", sym->result->name, sym->name,
303 &sym->result->declared_at);
304 sym->result->attr.untyped = 1;
308 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
309 type, lists the only ways a character length value of * can be used:
310 dummy arguments of procedures, named constants, and function results
311 in external functions. Internal function results are not on that list;
312 ergo, not permitted. */
314 if (sym->result->ts.type == BT_CHARACTER)
316 gfc_charlen *cl = sym->result->ts.cl;
317 if (!cl || !cl->length)
318 gfc_error ("Character-valued internal function '%s' at %L must "
319 "not be assumed length", sym->name, &sym->declared_at);
324 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
325 introduce duplicates. */
328 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
330 gfc_formal_arglist *f, *new_arglist;
333 for (; new_args != NULL; new_args = new_args->next)
335 new_sym = new_args->sym;
336 /* See if this arg is already in the formal argument list. */
337 for (f = proc->formal; f; f = f->next)
339 if (new_sym == f->sym)
346 /* Add a new argument. Argument order is not important. */
347 new_arglist = gfc_get_formal_arglist ();
348 new_arglist->sym = new_sym;
349 new_arglist->next = proc->formal;
350 proc->formal = new_arglist;
355 /* Flag the arguments that are not present in all entries. */
358 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
360 gfc_formal_arglist *f, *head;
363 for (f = proc->formal; f; f = f->next)
368 for (new_args = head; new_args; new_args = new_args->next)
370 if (new_args->sym == f->sym)
377 f->sym->attr.not_always_present = 1;
382 /* Resolve alternate entry points. If a symbol has multiple entry points we
383 create a new master symbol for the main routine, and turn the existing
384 symbol into an entry point. */
387 resolve_entries (gfc_namespace *ns)
389 gfc_namespace *old_ns;
393 char name[GFC_MAX_SYMBOL_LEN + 1];
394 static int master_count = 0;
396 if (ns->proc_name == NULL)
399 /* No need to do anything if this procedure doesn't have alternate entry
404 /* We may already have resolved alternate entry points. */
405 if (ns->proc_name->attr.entry_master)
408 /* If this isn't a procedure something has gone horribly wrong. */
409 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
411 /* Remember the current namespace. */
412 old_ns = gfc_current_ns;
416 /* Add the main entry point to the list of entry points. */
417 el = gfc_get_entry_list ();
418 el->sym = ns->proc_name;
420 el->next = ns->entries;
422 ns->proc_name->attr.entry = 1;
424 /* If it is a module function, it needs to be in the right namespace
425 so that gfc_get_fake_result_decl can gather up the results. The
426 need for this arose in get_proc_name, where these beasts were
427 left in their own namespace, to keep prior references linked to
428 the entry declaration.*/
429 if (ns->proc_name->attr.function
430 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
433 /* Do the same for entries where the master is not a module
434 procedure. These are retained in the module namespace because
435 of the module procedure declaration. */
436 for (el = el->next; el; el = el->next)
437 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
438 && el->sym->attr.mod_proc)
442 /* Add an entry statement for it. */
449 /* Create a new symbol for the master function. */
450 /* Give the internal function a unique name (within this file).
451 Also include the function name so the user has some hope of figuring
452 out what is going on. */
453 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
454 master_count++, ns->proc_name->name);
455 gfc_get_ha_symbol (name, &proc);
456 gcc_assert (proc != NULL);
458 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
459 if (ns->proc_name->attr.subroutine)
460 gfc_add_subroutine (&proc->attr, proc->name, NULL);
464 gfc_typespec *ts, *fts;
465 gfc_array_spec *as, *fas;
466 gfc_add_function (&proc->attr, proc->name, NULL);
468 fas = ns->entries->sym->as;
469 fas = fas ? fas : ns->entries->sym->result->as;
470 fts = &ns->entries->sym->result->ts;
471 if (fts->type == BT_UNKNOWN)
472 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
473 for (el = ns->entries->next; el; el = el->next)
475 ts = &el->sym->result->ts;
477 as = as ? as : el->sym->result->as;
478 if (ts->type == BT_UNKNOWN)
479 ts = gfc_get_default_type (el->sym->result, NULL);
481 if (! gfc_compare_types (ts, fts)
482 || (el->sym->result->attr.dimension
483 != ns->entries->sym->result->attr.dimension)
484 || (el->sym->result->attr.pointer
485 != ns->entries->sym->result->attr.pointer))
488 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
489 gfc_error ("Procedure %s at %L has entries with mismatched "
490 "array specifications", ns->entries->sym->name,
491 &ns->entries->sym->declared_at);
496 sym = ns->entries->sym->result;
497 /* All result types the same. */
499 if (sym->attr.dimension)
500 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
501 if (sym->attr.pointer)
502 gfc_add_pointer (&proc->attr, NULL);
506 /* Otherwise the result will be passed through a union by
508 proc->attr.mixed_entry_master = 1;
509 for (el = ns->entries; el; el = el->next)
511 sym = el->sym->result;
512 if (sym->attr.dimension)
514 if (el == ns->entries)
515 gfc_error ("FUNCTION result %s can't be an array in "
516 "FUNCTION %s at %L", sym->name,
517 ns->entries->sym->name, &sym->declared_at);
519 gfc_error ("ENTRY result %s can't be an array in "
520 "FUNCTION %s at %L", sym->name,
521 ns->entries->sym->name, &sym->declared_at);
523 else if (sym->attr.pointer)
525 if (el == ns->entries)
526 gfc_error ("FUNCTION result %s can't be a POINTER in "
527 "FUNCTION %s at %L", sym->name,
528 ns->entries->sym->name, &sym->declared_at);
530 gfc_error ("ENTRY result %s can't be a POINTER in "
531 "FUNCTION %s at %L", sym->name,
532 ns->entries->sym->name, &sym->declared_at);
537 if (ts->type == BT_UNKNOWN)
538 ts = gfc_get_default_type (sym, NULL);
542 if (ts->kind == gfc_default_integer_kind)
546 if (ts->kind == gfc_default_real_kind
547 || ts->kind == gfc_default_double_kind)
551 if (ts->kind == gfc_default_complex_kind)
555 if (ts->kind == gfc_default_logical_kind)
559 /* We will issue error elsewhere. */
567 if (el == ns->entries)
568 gfc_error ("FUNCTION result %s can't be of type %s "
569 "in FUNCTION %s at %L", sym->name,
570 gfc_typename (ts), ns->entries->sym->name,
573 gfc_error ("ENTRY result %s can't be of type %s "
574 "in FUNCTION %s at %L", sym->name,
575 gfc_typename (ts), ns->entries->sym->name,
582 proc->attr.access = ACCESS_PRIVATE;
583 proc->attr.entry_master = 1;
585 /* Merge all the entry point arguments. */
586 for (el = ns->entries; el; el = el->next)
587 merge_argument_lists (proc, el->sym->formal);
589 /* Check the master formal arguments for any that are not
590 present in all entry points. */
591 for (el = ns->entries; el; el = el->next)
592 check_argument_lists (proc, el->sym->formal);
594 /* Use the master function for the function body. */
595 ns->proc_name = proc;
597 /* Finalize the new symbols. */
598 gfc_commit_symbols ();
600 /* Restore the original namespace. */
601 gfc_current_ns = old_ns;
605 /* Resolve common blocks. */
607 resolve_common_blocks (gfc_symtree *common_root)
609 gfc_symtree *symtree;
612 if (common_root == NULL)
615 for (symtree = common_root; symtree->left; symtree = symtree->left);
617 for (; symtree; symtree = symtree->right)
619 gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
623 if (sym->attr.flavor == FL_PARAMETER)
625 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
626 sym->name, &symtree->n.common->where,
630 if (sym->attr.intrinsic)
632 gfc_error ("COMMON block '%s' at %L is also an intrinsic "
633 "procedure", sym->name,
634 &symtree->n.common->where);
636 else if (sym->attr.result
637 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
639 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
640 "at %L that is also a function result", sym->name,
641 &symtree->n.common->where);
643 else if (sym->attr.flavor == FL_PROCEDURE
644 && sym->attr.proc != PROC_INTERNAL
645 && sym->attr.proc != PROC_ST_FUNCTION)
647 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
648 "at %L that is also a global procedure", sym->name,
649 &symtree->n.common->where);
655 /* Resolve contained function types. Because contained functions can call one
656 another, they have to be worked out before any of the contained procedures
659 The good news is that if a function doesn't already have a type, the only
660 way it can get one is through an IMPLICIT type or a RESULT variable, because
661 by definition contained functions are contained namespace they're contained
662 in, not in a sibling or parent namespace. */
665 resolve_contained_functions (gfc_namespace *ns)
667 gfc_namespace *child;
670 resolve_formal_arglists (ns);
672 for (child = ns->contained; child; child = child->sibling)
674 /* Resolve alternate entry points first. */
675 resolve_entries (child);
677 /* Then check function return types. */
678 resolve_contained_fntype (child->proc_name, child);
679 for (el = child->entries; el; el = el->next)
680 resolve_contained_fntype (el->sym, child);
685 /* Resolve all of the elements of a structure constructor and make sure that
686 the types are correct. */
689 resolve_structure_cons (gfc_expr *expr)
691 gfc_constructor *cons;
697 cons = expr->value.constructor;
698 /* A constructor may have references if it is the result of substituting a
699 parameter variable. In this case we just pull out the component we
702 comp = expr->ref->u.c.sym->components;
704 comp = expr->ts.derived->components;
706 for (; comp; comp = comp->next, cons = cons->next)
711 if (gfc_resolve_expr (cons->expr) == FAILURE)
717 if (cons->expr->expr_type != EXPR_NULL
718 && comp->as && comp->as->rank != cons->expr->rank
719 && (comp->allocatable || cons->expr->rank))
721 gfc_error ("The rank of the element in the derived type "
722 "constructor at %L does not match that of the "
723 "component (%d/%d)", &cons->expr->where,
724 cons->expr->rank, comp->as ? comp->as->rank : 0);
728 /* If we don't have the right type, try to convert it. */
730 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
733 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
734 gfc_error ("The element in the derived type constructor at %L, "
735 "for pointer component '%s', is %s but should be %s",
736 &cons->expr->where, comp->name,
737 gfc_basic_typename (cons->expr->ts.type),
738 gfc_basic_typename (comp->ts.type));
740 t = gfc_convert_type (cons->expr, &comp->ts, 1);
743 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
746 a = gfc_expr_attr (cons->expr);
748 if (!a.pointer && !a.target)
751 gfc_error ("The element in the derived type constructor at %L, "
752 "for pointer component '%s' should be a POINTER or "
753 "a TARGET", &cons->expr->where, comp->name);
761 /****************** Expression name resolution ******************/
763 /* Returns 0 if a symbol was not declared with a type or
764 attribute declaration statement, nonzero otherwise. */
767 was_declared (gfc_symbol *sym)
773 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
776 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
777 || a.optional || a.pointer || a.save || a.target || a.volatile_
778 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
785 /* Determine if a symbol is generic or not. */
788 generic_sym (gfc_symbol *sym)
792 if (sym->attr.generic ||
793 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
796 if (was_declared (sym) || sym->ns->parent == NULL)
799 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
806 return generic_sym (s);
813 /* Determine if a symbol is specific or not. */
816 specific_sym (gfc_symbol *sym)
820 if (sym->attr.if_source == IFSRC_IFBODY
821 || sym->attr.proc == PROC_MODULE
822 || sym->attr.proc == PROC_INTERNAL
823 || sym->attr.proc == PROC_ST_FUNCTION
824 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
825 || sym->attr.external)
828 if (was_declared (sym) || sym->ns->parent == NULL)
831 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
833 return (s == NULL) ? 0 : specific_sym (s);
837 /* Figure out if the procedure is specific, generic or unknown. */
840 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
844 procedure_kind (gfc_symbol *sym)
846 if (generic_sym (sym))
847 return PTYPE_GENERIC;
849 if (specific_sym (sym))
850 return PTYPE_SPECIFIC;
852 return PTYPE_UNKNOWN;
855 /* Check references to assumed size arrays. The flag need_full_assumed_size
856 is nonzero when matching actual arguments. */
858 static int need_full_assumed_size = 0;
861 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
867 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
870 for (ref = e->ref; ref; ref = ref->next)
871 if (ref->type == REF_ARRAY)
872 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
873 last = (ref->u.ar.end[dim] == NULL)
874 && (ref->u.ar.type == DIMEN_ELEMENT);
878 gfc_error ("The upper bound in the last dimension must "
879 "appear in the reference to the assumed size "
880 "array '%s' at %L", sym->name, &e->where);
887 /* Look for bad assumed size array references in argument expressions
888 of elemental and array valued intrinsic procedures. Since this is
889 called from procedure resolution functions, it only recurses at
893 resolve_assumed_size_actual (gfc_expr *e)
898 switch (e->expr_type)
901 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
906 if (resolve_assumed_size_actual (e->value.op.op1)
907 || resolve_assumed_size_actual (e->value.op.op2))
918 /* Resolve an actual argument list. Most of the time, this is just
919 resolving the expressions in the list.
920 The exception is that we sometimes have to decide whether arguments
921 that look like procedure arguments are really simple variable
925 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
928 gfc_symtree *parent_st;
931 for (; arg; arg = arg->next)
936 /* Check the label is a valid branching target. */
939 if (arg->label->defined == ST_LABEL_UNKNOWN)
941 gfc_error ("Label %d referenced at %L is never defined",
942 arg->label->value, &arg->label->where);
949 if (e->ts.type != BT_PROCEDURE)
951 if (gfc_resolve_expr (e) != SUCCESS)
956 /* See if the expression node should really be a variable reference. */
958 sym = e->symtree->n.sym;
960 if (sym->attr.flavor == FL_PROCEDURE
961 || sym->attr.intrinsic
962 || sym->attr.external)
966 /* If a procedure is not already determined to be something else
967 check if it is intrinsic. */
968 if (!sym->attr.intrinsic
969 && !(sym->attr.external || sym->attr.use_assoc
970 || sym->attr.if_source == IFSRC_IFBODY)
971 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
972 sym->attr.intrinsic = 1;
974 if (sym->attr.proc == PROC_ST_FUNCTION)
976 gfc_error ("Statement function '%s' at %L is not allowed as an "
977 "actual argument", sym->name, &e->where);
980 actual_ok = gfc_intrinsic_actual_ok (sym->name,
981 sym->attr.subroutine);
982 if (sym->attr.intrinsic && actual_ok == 0)
984 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
985 "actual argument", sym->name, &e->where);
988 if (sym->attr.contained && !sym->attr.use_assoc
989 && sym->ns->proc_name->attr.flavor != FL_MODULE)
991 gfc_error ("Internal procedure '%s' is not allowed as an "
992 "actual argument at %L", sym->name, &e->where);
995 if (sym->attr.elemental && !sym->attr.intrinsic)
997 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
998 "allowed as an actual argument at %L", sym->name,
1002 /* Check if a generic interface has a specific procedure
1003 with the same name before emitting an error. */
1004 if (sym->attr.generic)
1007 for (p = sym->generic; p; p = p->next)
1008 if (strcmp (sym->name, p->sym->name) == 0)
1010 e->symtree = gfc_find_symtree
1011 (p->sym->ns->sym_root, sym->name);
1016 if (p == NULL || e->symtree == NULL)
1017 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1018 "allowed as an actual argument at %L", sym->name,
1022 /* If the symbol is the function that names the current (or
1023 parent) scope, then we really have a variable reference. */
1025 if (sym->attr.function && sym->result == sym
1026 && (sym->ns->proc_name == sym
1027 || (sym->ns->parent != NULL
1028 && sym->ns->parent->proc_name == sym)))
1031 /* If all else fails, see if we have a specific intrinsic. */
1032 if (sym->attr.function
1033 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1035 gfc_intrinsic_sym *isym;
1036 isym = gfc_find_function (sym->name);
1037 if (isym == NULL || !isym->specific)
1039 gfc_error ("Unable to find a specific INTRINSIC procedure "
1040 "for the reference '%s' at %L", sym->name,
1048 /* See if the name is a module procedure in a parent unit. */
1050 if (was_declared (sym) || sym->ns->parent == NULL)
1053 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1055 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1059 if (parent_st == NULL)
1062 sym = parent_st->n.sym;
1063 e->symtree = parent_st; /* Point to the right thing. */
1065 if (sym->attr.flavor == FL_PROCEDURE
1066 || sym->attr.intrinsic
1067 || sym->attr.external)
1073 e->expr_type = EXPR_VARIABLE;
1075 if (sym->as != NULL)
1077 e->rank = sym->as->rank;
1078 e->ref = gfc_get_ref ();
1079 e->ref->type = REF_ARRAY;
1080 e->ref->u.ar.type = AR_FULL;
1081 e->ref->u.ar.as = sym->as;
1084 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1085 primary.c (match_actual_arg). If above code determines that it
1086 is a variable instead, it needs to be resolved as it was not
1087 done at the beginning of this function. */
1088 if (gfc_resolve_expr (e) != SUCCESS)
1092 /* Check argument list functions %VAL, %LOC and %REF. There is
1093 nothing to do for %REF. */
1094 if (arg->name && arg->name[0] == '%')
1096 if (strncmp ("%VAL", arg->name, 4) == 0)
1098 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1100 gfc_error ("By-value argument at %L is not of numeric "
1107 gfc_error ("By-value argument at %L cannot be an array or "
1108 "an array section", &e->where);
1112 /* Intrinsics are still PROC_UNKNOWN here. However,
1113 since same file external procedures are not resolvable
1114 in gfortran, it is a good deal easier to leave them to
1116 if (ptype != PROC_UNKNOWN
1117 && ptype != PROC_DUMMY
1118 && ptype != PROC_EXTERNAL
1119 && ptype != PROC_MODULE)
1121 gfc_error ("By-value argument at %L is not allowed "
1122 "in this context", &e->where);
1127 /* Statement functions have already been excluded above. */
1128 else if (strncmp ("%LOC", arg->name, 4) == 0
1129 && e->ts.type == BT_PROCEDURE)
1131 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1133 gfc_error ("Passing internal procedure at %L by location "
1134 "not allowed", &e->where);
1145 /* Do the checks of the actual argument list that are specific to elemental
1146 procedures. If called with c == NULL, we have a function, otherwise if
1147 expr == NULL, we have a subroutine. */
1150 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1152 gfc_actual_arglist *arg0;
1153 gfc_actual_arglist *arg;
1154 gfc_symbol *esym = NULL;
1155 gfc_intrinsic_sym *isym = NULL;
1157 gfc_intrinsic_arg *iformal = NULL;
1158 gfc_formal_arglist *eformal = NULL;
1159 bool formal_optional = false;
1160 bool set_by_optional = false;
1164 /* Is this an elemental procedure? */
1165 if (expr && expr->value.function.actual != NULL)
1167 if (expr->value.function.esym != NULL
1168 && expr->value.function.esym->attr.elemental)
1170 arg0 = expr->value.function.actual;
1171 esym = expr->value.function.esym;
1173 else if (expr->value.function.isym != NULL
1174 && expr->value.function.isym->elemental)
1176 arg0 = expr->value.function.actual;
1177 isym = expr->value.function.isym;
1182 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1184 arg0 = c->ext.actual;
1185 esym = c->symtree->n.sym;
1190 /* The rank of an elemental is the rank of its array argument(s). */
1191 for (arg = arg0; arg; arg = arg->next)
1193 if (arg->expr != NULL && arg->expr->rank > 0)
1195 rank = arg->expr->rank;
1196 if (arg->expr->expr_type == EXPR_VARIABLE
1197 && arg->expr->symtree->n.sym->attr.optional)
1198 set_by_optional = true;
1200 /* Function specific; set the result rank and shape. */
1204 if (!expr->shape && arg->expr->shape)
1206 expr->shape = gfc_get_shape (rank);
1207 for (i = 0; i < rank; i++)
1208 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1215 /* If it is an array, it shall not be supplied as an actual argument
1216 to an elemental procedure unless an array of the same rank is supplied
1217 as an actual argument corresponding to a nonoptional dummy argument of
1218 that elemental procedure(12.4.1.5). */
1219 formal_optional = false;
1221 iformal = isym->formal;
1223 eformal = esym->formal;
1225 for (arg = arg0; arg; arg = arg->next)
1229 if (eformal->sym && eformal->sym->attr.optional)
1230 formal_optional = true;
1231 eformal = eformal->next;
1233 else if (isym && iformal)
1235 if (iformal->optional)
1236 formal_optional = true;
1237 iformal = iformal->next;
1240 formal_optional = true;
1242 if (pedantic && arg->expr != NULL
1243 && arg->expr->expr_type == EXPR_VARIABLE
1244 && arg->expr->symtree->n.sym->attr.optional
1247 && (set_by_optional || arg->expr->rank != rank)
1248 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1250 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1251 "MISSING, it cannot be the actual argument of an "
1252 "ELEMENTAL procedure unless there is a non-optional "
1253 "argument with the same rank (12.4.1.5)",
1254 arg->expr->symtree->n.sym->name, &arg->expr->where);
1259 for (arg = arg0; arg; arg = arg->next)
1261 if (arg->expr == NULL || arg->expr->rank == 0)
1264 /* Being elemental, the last upper bound of an assumed size array
1265 argument must be present. */
1266 if (resolve_assumed_size_actual (arg->expr))
1272 /* Elemental subroutine array actual arguments must conform. */
1275 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1287 /* Go through each actual argument in ACTUAL and see if it can be
1288 implemented as an inlined, non-copying intrinsic. FNSYM is the
1289 function being called, or NULL if not known. */
1292 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1294 gfc_actual_arglist *ap;
1297 for (ap = actual; ap; ap = ap->next)
1299 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1300 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1301 ap->expr->inline_noncopying_intrinsic = 1;
1305 /* This function does the checking of references to global procedures
1306 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1307 77 and 95 standards. It checks for a gsymbol for the name, making
1308 one if it does not already exist. If it already exists, then the
1309 reference being resolved must correspond to the type of gsymbol.
1310 Otherwise, the new symbol is equipped with the attributes of the
1311 reference. The corresponding code that is called in creating
1312 global entities is parse.c. */
1315 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1320 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1322 gsym = gfc_get_gsymbol (sym->name);
1324 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1325 global_used (gsym, where);
1327 if (gsym->type == GSYM_UNKNOWN)
1330 gsym->where = *where;
1337 /************* Function resolution *************/
1339 /* Resolve a function call known to be generic.
1340 Section 14.1.2.4.1. */
1343 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1347 if (sym->attr.generic)
1349 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1352 expr->value.function.name = s->name;
1353 expr->value.function.esym = s;
1355 if (s->ts.type != BT_UNKNOWN)
1357 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1358 expr->ts = s->result->ts;
1361 expr->rank = s->as->rank;
1362 else if (s->result != NULL && s->result->as != NULL)
1363 expr->rank = s->result->as->rank;
1368 /* TODO: Need to search for elemental references in generic
1372 if (sym->attr.intrinsic)
1373 return gfc_intrinsic_func_interface (expr, 0);
1380 resolve_generic_f (gfc_expr *expr)
1385 sym = expr->symtree->n.sym;
1389 m = resolve_generic_f0 (expr, sym);
1392 else if (m == MATCH_ERROR)
1396 if (sym->ns->parent == NULL)
1398 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1402 if (!generic_sym (sym))
1406 /* Last ditch attempt. See if the reference is to an intrinsic
1407 that possesses a matching interface. 14.1.2.4 */
1408 if (sym && !gfc_intrinsic_name (sym->name, 0))
1410 gfc_error ("There is no specific function for the generic '%s' at %L",
1411 expr->symtree->n.sym->name, &expr->where);
1415 m = gfc_intrinsic_func_interface (expr, 0);
1419 gfc_error ("Generic function '%s' at %L is not consistent with a "
1420 "specific intrinsic interface", expr->symtree->n.sym->name,
1427 /* Resolve a function call known to be specific. */
1430 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1434 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1436 if (sym->attr.dummy)
1438 sym->attr.proc = PROC_DUMMY;
1442 sym->attr.proc = PROC_EXTERNAL;
1446 if (sym->attr.proc == PROC_MODULE
1447 || sym->attr.proc == PROC_ST_FUNCTION
1448 || sym->attr.proc == PROC_INTERNAL)
1451 if (sym->attr.intrinsic)
1453 m = gfc_intrinsic_func_interface (expr, 1);
1457 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1458 "with an intrinsic", sym->name, &expr->where);
1466 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1469 expr->value.function.name = sym->name;
1470 expr->value.function.esym = sym;
1471 if (sym->as != NULL)
1472 expr->rank = sym->as->rank;
1479 resolve_specific_f (gfc_expr *expr)
1484 sym = expr->symtree->n.sym;
1488 m = resolve_specific_f0 (sym, expr);
1491 if (m == MATCH_ERROR)
1494 if (sym->ns->parent == NULL)
1497 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1503 gfc_error ("Unable to resolve the specific function '%s' at %L",
1504 expr->symtree->n.sym->name, &expr->where);
1510 /* Resolve a procedure call not known to be generic nor specific. */
1513 resolve_unknown_f (gfc_expr *expr)
1518 sym = expr->symtree->n.sym;
1520 if (sym->attr.dummy)
1522 sym->attr.proc = PROC_DUMMY;
1523 expr->value.function.name = sym->name;
1527 /* See if we have an intrinsic function reference. */
1529 if (gfc_intrinsic_name (sym->name, 0))
1531 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1536 /* The reference is to an external name. */
1538 sym->attr.proc = PROC_EXTERNAL;
1539 expr->value.function.name = sym->name;
1540 expr->value.function.esym = expr->symtree->n.sym;
1542 if (sym->as != NULL)
1543 expr->rank = sym->as->rank;
1545 /* Type of the expression is either the type of the symbol or the
1546 default type of the symbol. */
1549 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1551 if (sym->ts.type != BT_UNKNOWN)
1555 ts = gfc_get_default_type (sym, sym->ns);
1557 if (ts->type == BT_UNKNOWN)
1559 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1560 sym->name, &expr->where);
1571 /* Return true, if the symbol is an external procedure. */
1573 is_external_proc (gfc_symbol *sym)
1575 if (!sym->attr.dummy && !sym->attr.contained
1576 && !(sym->attr.intrinsic
1577 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1578 && sym->attr.proc != PROC_ST_FUNCTION
1579 && !sym->attr.use_assoc
1587 /* Figure out if a function reference is pure or not. Also set the name
1588 of the function for a potential error message. Return nonzero if the
1589 function is PURE, zero if not. */
1592 pure_function (gfc_expr *e, const char **name)
1598 if (e->symtree != NULL
1599 && e->symtree->n.sym != NULL
1600 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1603 if (e->value.function.esym)
1605 pure = gfc_pure (e->value.function.esym);
1606 *name = e->value.function.esym->name;
1608 else if (e->value.function.isym)
1610 pure = e->value.function.isym->pure
1611 || e->value.function.isym->elemental;
1612 *name = e->value.function.isym->name;
1616 /* Implicit functions are not pure. */
1618 *name = e->value.function.name;
1626 is_scalar_expr_ptr (gfc_expr *expr)
1628 try retval = SUCCESS;
1633 /* See if we have a gfc_ref, which means we have a substring, array
1634 reference, or a component. */
1635 if (expr->ref != NULL)
1638 while (ref->next != NULL)
1644 if (ref->u.ss.length != NULL
1645 && ref->u.ss.length->length != NULL
1647 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1649 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1651 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1652 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1653 if (end - start + 1 != 1)
1660 if (ref->u.ar.type == AR_ELEMENT)
1662 else if (ref->u.ar.type == AR_FULL)
1664 /* The user can give a full array if the array is of size 1. */
1665 if (ref->u.ar.as != NULL
1666 && ref->u.ar.as->rank == 1
1667 && ref->u.ar.as->type == AS_EXPLICIT
1668 && ref->u.ar.as->lower[0] != NULL
1669 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1670 && ref->u.ar.as->upper[0] != NULL
1671 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1673 /* If we have a character string, we need to check if
1674 its length is one. */
1675 if (expr->ts.type == BT_CHARACTER)
1677 if (expr->ts.cl == NULL
1678 || expr->ts.cl->length == NULL
1679 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1685 /* We have constant lower and upper bounds. If the
1686 difference between is 1, it can be considered a
1688 start = (int) mpz_get_si
1689 (ref->u.ar.as->lower[0]->value.integer);
1690 end = (int) mpz_get_si
1691 (ref->u.ar.as->upper[0]->value.integer);
1692 if (end - start + 1 != 1)
1707 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1709 /* Character string. Make sure it's of length 1. */
1710 if (expr->ts.cl == NULL
1711 || expr->ts.cl->length == NULL
1712 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1715 else if (expr->rank != 0)
1722 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1723 and, in the case of c_associated, set the binding label based on
1727 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1728 gfc_symbol **new_sym)
1730 char name[GFC_MAX_SYMBOL_LEN + 1];
1731 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1732 int optional_arg = 0;
1733 try retval = SUCCESS;
1734 gfc_symbol *args_sym;
1736 if (args->expr->expr_type == EXPR_CONSTANT
1737 || args->expr->expr_type == EXPR_OP
1738 || args->expr->expr_type == EXPR_NULL)
1740 gfc_error ("Argument to '%s' at %L is not a variable",
1741 sym->name, &(args->expr->where));
1745 args_sym = args->expr->symtree->n.sym;
1747 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1749 /* If the user gave two args then they are providing something for
1750 the optional arg (the second cptr). Therefore, set the name and
1751 binding label to the c_associated for two cptrs. Otherwise,
1752 set c_associated to expect one cptr. */
1756 sprintf (name, "%s_2", sym->name);
1757 sprintf (binding_label, "%s_2", sym->binding_label);
1763 sprintf (name, "%s_1", sym->name);
1764 sprintf (binding_label, "%s_1", sym->binding_label);
1768 /* Get a new symbol for the version of c_associated that
1770 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1772 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1773 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1775 sprintf (name, "%s", sym->name);
1776 sprintf (binding_label, "%s", sym->binding_label);
1778 /* Error check the call. */
1779 if (args->next != NULL)
1781 gfc_error_now ("More actual than formal arguments in '%s' "
1782 "call at %L", name, &(args->expr->where));
1785 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1787 /* Make sure we have either the target or pointer attribute. */
1788 if (!(args->expr->symtree->n.sym->attr.target)
1789 && !(args->expr->symtree->n.sym->attr.pointer))
1791 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1792 "a TARGET or an associated pointer",
1793 args->expr->symtree->n.sym->name,
1794 sym->name, &(args->expr->where));
1798 /* See if we have interoperable type and type param. */
1799 if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
1800 args->expr->symtree->n.sym->name,
1801 &(args->expr->where)) == SUCCESS
1802 || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
1804 if (args_sym->attr.target == 1)
1806 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1807 has the target attribute and is interoperable. */
1808 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1809 allocatable variable that has the TARGET attribute and
1810 is not an array of zero size. */
1811 if (args_sym->attr.allocatable == 1)
1813 if (args_sym->attr.dimension != 0
1814 && (args_sym->as && args_sym->as->rank == 0))
1816 gfc_error_now ("Allocatable variable '%s' used as a "
1817 "parameter to '%s' at %L must not be "
1818 "an array of zero size",
1819 args_sym->name, sym->name,
1820 &(args->expr->where));
1826 /* A non-allocatable target variable with C
1827 interoperable type and type parameters must be
1829 if (args_sym && args_sym->attr.dimension)
1831 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1833 gfc_error ("Assumed-shape array '%s' at %L "
1834 "cannot be an argument to the "
1835 "procedure '%s' because "
1836 "it is not C interoperable",
1838 &(args->expr->where), sym->name);
1841 else if (args_sym->as->type == AS_DEFERRED)
1843 gfc_error ("Deferred-shape array '%s' at %L "
1844 "cannot be an argument to the "
1845 "procedure '%s' because "
1846 "it is not C interoperable",
1848 &(args->expr->where), sym->name);
1853 /* Make sure it's not a character string. Arrays of
1854 any type should be ok if the variable is of a C
1855 interoperable type. */
1856 if (args_sym->ts.type == BT_CHARACTER)
1857 if (args_sym->ts.cl != NULL
1858 && (args_sym->ts.cl->length == NULL
1859 || args_sym->ts.cl->length->expr_type
1862 (args_sym->ts.cl->length->value.integer, 1)
1864 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1866 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1867 "at %L must have a length of 1",
1868 args_sym->name, sym->name,
1869 &(args->expr->where));
1874 else if (args_sym->attr.pointer == 1
1875 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1877 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1879 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1880 "associated scalar POINTER", args_sym->name,
1881 sym->name, &(args->expr->where));
1887 /* The parameter is not required to be C interoperable. If it
1888 is not C interoperable, it must be a nonpolymorphic scalar
1889 with no length type parameters. It still must have either
1890 the pointer or target attribute, and it can be
1891 allocatable (but must be allocated when c_loc is called). */
1892 if (args_sym->attr.dimension != 0
1893 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1895 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1896 "scalar", args_sym->name, sym->name,
1897 &(args->expr->where));
1900 else if (args_sym->ts.type == BT_CHARACTER
1901 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1903 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1904 "%L must have a length of 1",
1905 args_sym->name, sym->name,
1906 &(args->expr->where));
1911 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1913 if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1915 /* TODO: Update this error message to allow for procedure
1916 pointers once they are implemented. */
1917 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1919 args->expr->symtree->n.sym->name, sym->name,
1920 &(args->expr->where));
1923 else if (args->expr->symtree->n.sym->attr.is_bind_c != 1)
1925 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
1927 args->expr->symtree->n.sym->name, sym->name,
1928 &(args->expr->where));
1933 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1938 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1939 "iso_c_binding function: '%s'!\n", sym->name);
1946 /* Resolve a function call, which means resolving the arguments, then figuring
1947 out which entity the name refers to. */
1948 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1949 to INTENT(OUT) or INTENT(INOUT). */
1952 resolve_function (gfc_expr *expr)
1954 gfc_actual_arglist *arg;
1959 procedure_type p = PROC_INTRINSIC;
1963 sym = expr->symtree->n.sym;
1965 if (sym && sym->attr.flavor == FL_VARIABLE)
1967 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1971 if (sym && sym->attr.abstract)
1973 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
1974 sym->name, &expr->where);
1978 /* If the procedure is external, check for usage. */
1979 if (sym && is_external_proc (sym))
1980 resolve_global_procedure (sym, &expr->where, 0);
1982 /* Switch off assumed size checking and do this again for certain kinds
1983 of procedure, once the procedure itself is resolved. */
1984 need_full_assumed_size++;
1986 if (expr->symtree && expr->symtree->n.sym)
1987 p = expr->symtree->n.sym->attr.proc;
1989 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1992 /* Need to setup the call to the correct c_associated, depending on
1993 the number of cptrs to user gives to compare. */
1994 if (sym && sym->attr.is_iso_c == 1)
1996 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2000 /* Get the symtree for the new symbol (resolved func).
2001 the old one will be freed later, when it's no longer used. */
2002 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2005 /* Resume assumed_size checking. */
2006 need_full_assumed_size--;
2008 if (sym && sym->ts.type == BT_CHARACTER
2010 && sym->ts.cl->length == NULL
2012 && expr->value.function.esym == NULL
2013 && !sym->attr.contained)
2015 /* Internal procedures are taken care of in resolve_contained_fntype. */
2016 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2017 "be used at %L since it is not a dummy argument",
2018 sym->name, &expr->where);
2022 /* See if function is already resolved. */
2024 if (expr->value.function.name != NULL)
2026 if (expr->ts.type == BT_UNKNOWN)
2032 /* Apply the rules of section 14.1.2. */
2034 switch (procedure_kind (sym))
2037 t = resolve_generic_f (expr);
2040 case PTYPE_SPECIFIC:
2041 t = resolve_specific_f (expr);
2045 t = resolve_unknown_f (expr);
2049 gfc_internal_error ("resolve_function(): bad function type");
2053 /* If the expression is still a function (it might have simplified),
2054 then we check to see if we are calling an elemental function. */
2056 if (expr->expr_type != EXPR_FUNCTION)
2059 temp = need_full_assumed_size;
2060 need_full_assumed_size = 0;
2062 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2065 if (omp_workshare_flag
2066 && expr->value.function.esym
2067 && ! gfc_elemental (expr->value.function.esym))
2069 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2070 "in WORKSHARE construct", expr->value.function.esym->name,
2075 #define GENERIC_ID expr->value.function.isym->id
2076 else if (expr->value.function.actual != NULL
2077 && expr->value.function.isym != NULL
2078 && GENERIC_ID != GFC_ISYM_LBOUND
2079 && GENERIC_ID != GFC_ISYM_LEN
2080 && GENERIC_ID != GFC_ISYM_LOC
2081 && GENERIC_ID != GFC_ISYM_PRESENT)
2083 /* Array intrinsics must also have the last upper bound of an
2084 assumed size array argument. UBOUND and SIZE have to be
2085 excluded from the check if the second argument is anything
2088 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2089 || GENERIC_ID == GFC_ISYM_SIZE;
2091 for (arg = expr->value.function.actual; arg; arg = arg->next)
2093 if (inquiry && arg->next != NULL && arg->next->expr)
2095 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2098 if ((int)mpz_get_si (arg->next->expr->value.integer)
2103 if (arg->expr != NULL
2104 && arg->expr->rank > 0
2105 && resolve_assumed_size_actual (arg->expr))
2111 need_full_assumed_size = temp;
2114 if (!pure_function (expr, &name) && name)
2118 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2119 "FORALL %s", name, &expr->where,
2120 forall_flag == 2 ? "mask" : "block");
2123 else if (gfc_pure (NULL))
2125 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2126 "procedure within a PURE procedure", name, &expr->where);
2131 /* Functions without the RECURSIVE attribution are not allowed to
2132 * call themselves. */
2133 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2135 gfc_symbol *esym, *proc;
2136 esym = expr->value.function.esym;
2137 proc = gfc_current_ns->proc_name;
2140 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2141 "RECURSIVE", name, &expr->where);
2145 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2146 && esym->ns->entries->sym == proc->ns->entries->sym)
2148 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2149 "'%s' is not declared as RECURSIVE",
2150 esym->name, &expr->where, esym->ns->entries->sym->name);
2155 /* Character lengths of use associated functions may contains references to
2156 symbols not referenced from the current program unit otherwise. Make sure
2157 those symbols are marked as referenced. */
2159 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2160 && expr->value.function.esym->attr.use_assoc)
2162 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2166 find_noncopying_intrinsics (expr->value.function.esym,
2167 expr->value.function.actual);
2169 /* Make sure that the expression has a typespec that works. */
2170 if (expr->ts.type == BT_UNKNOWN)
2172 if (expr->symtree->n.sym->result
2173 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2174 expr->ts = expr->symtree->n.sym->result->ts;
2181 /************* Subroutine resolution *************/
2184 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2190 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2191 sym->name, &c->loc);
2192 else if (gfc_pure (NULL))
2193 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2199 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2203 if (sym->attr.generic)
2205 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2208 c->resolved_sym = s;
2209 pure_subroutine (c, s);
2213 /* TODO: Need to search for elemental references in generic interface. */
2216 if (sym->attr.intrinsic)
2217 return gfc_intrinsic_sub_interface (c, 0);
2224 resolve_generic_s (gfc_code *c)
2229 sym = c->symtree->n.sym;
2233 m = resolve_generic_s0 (c, sym);
2236 else if (m == MATCH_ERROR)
2240 if (sym->ns->parent == NULL)
2242 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2246 if (!generic_sym (sym))
2250 /* Last ditch attempt. See if the reference is to an intrinsic
2251 that possesses a matching interface. 14.1.2.4 */
2252 sym = c->symtree->n.sym;
2254 if (!gfc_intrinsic_name (sym->name, 1))
2256 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2257 sym->name, &c->loc);
2261 m = gfc_intrinsic_sub_interface (c, 0);
2265 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2266 "intrinsic subroutine interface", sym->name, &c->loc);
2272 /* Set the name and binding label of the subroutine symbol in the call
2273 expression represented by 'c' to include the type and kind of the
2274 second parameter. This function is for resolving the appropriate
2275 version of c_f_pointer() and c_f_procpointer(). For example, a
2276 call to c_f_pointer() for a default integer pointer could have a
2277 name of c_f_pointer_i4. If no second arg exists, which is an error
2278 for these two functions, it defaults to the generic symbol's name
2279 and binding label. */
2282 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2283 char *name, char *binding_label)
2285 gfc_expr *arg = NULL;
2289 /* The second arg of c_f_pointer and c_f_procpointer determines
2290 the type and kind for the procedure name. */
2291 arg = c->ext.actual->next->expr;
2295 /* Set up the name to have the given symbol's name,
2296 plus the type and kind. */
2297 /* a derived type is marked with the type letter 'u' */
2298 if (arg->ts.type == BT_DERIVED)
2301 kind = 0; /* set the kind as 0 for now */
2305 type = gfc_type_letter (arg->ts.type);
2306 kind = arg->ts.kind;
2309 if (arg->ts.type == BT_CHARACTER)
2310 /* Kind info for character strings not needed. */
2313 sprintf (name, "%s_%c%d", sym->name, type, kind);
2314 /* Set up the binding label as the given symbol's label plus
2315 the type and kind. */
2316 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2320 /* If the second arg is missing, set the name and label as
2321 was, cause it should at least be found, and the missing
2322 arg error will be caught by compare_parameters(). */
2323 sprintf (name, "%s", sym->name);
2324 sprintf (binding_label, "%s", sym->binding_label);
2331 /* Resolve a generic version of the iso_c_binding procedure given
2332 (sym) to the specific one based on the type and kind of the
2333 argument(s). Currently, this function resolves c_f_pointer() and
2334 c_f_procpointer based on the type and kind of the second argument
2335 (FPTR). Other iso_c_binding procedures aren't specially handled.
2336 Upon successfully exiting, c->resolved_sym will hold the resolved
2337 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2341 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2343 gfc_symbol *new_sym;
2344 /* this is fine, since we know the names won't use the max */
2345 char name[GFC_MAX_SYMBOL_LEN + 1];
2346 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2347 /* default to success; will override if find error */
2348 match m = MATCH_YES;
2350 /* Make sure the actual arguments are in the necessary order (based on the
2351 formal args) before resolving. */
2352 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2354 /* Give the optional SHAPE formal arg a type now that we've done our
2355 initial checking against the actual. */
2356 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2357 sym->formal->next->next->sym->ts.type = BT_INTEGER;
2359 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2360 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2362 set_name_and_label (c, sym, name, binding_label);
2364 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2366 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2368 /* Make sure we got a third arg if the second arg has non-zero
2369 rank. We must also check that the type and rank are
2370 correct since we short-circuit this check in
2371 gfc_procedure_use() (called above to sort actual args). */
2372 if (c->ext.actual->next->expr->rank != 0)
2374 if(c->ext.actual->next->next == NULL
2375 || c->ext.actual->next->next->expr == NULL)
2378 gfc_error ("Missing SHAPE parameter for call to %s "
2379 "at %L", sym->name, &(c->loc));
2381 else if (c->ext.actual->next->next->expr->ts.type
2383 || c->ext.actual->next->next->expr->rank != 1)
2386 gfc_error ("SHAPE parameter for call to %s at %L must "
2387 "be a rank 1 INTEGER array", sym->name,
2394 if (m != MATCH_ERROR)
2396 /* the 1 means to add the optional arg to formal list */
2397 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2399 /* Set the kind for the SHAPE array to that of the actual
2401 if (c->ext.actual != NULL && c->ext.actual->next != NULL
2402 && c->ext.actual->next->expr->rank != 0)
2403 new_sym->formal->next->next->sym->ts.kind =
2404 c->ext.actual->next->next->expr->ts.kind;
2406 /* for error reporting, say it's declared where the original was */
2407 new_sym->declared_at = sym->declared_at;
2410 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2412 /* TODO: Figure out if this is even reachable; this part of the
2413 conditional may not be necessary. */
2415 if (c->ext.actual->next == NULL)
2417 /* The user did not give two args, so resolve to the version
2418 of c_associated expecting one arg. */
2420 /* get rid of the second arg */
2421 /* TODO!! Should free up the memory here! */
2422 sym->formal->next = NULL;
2430 sprintf (name, "%s_%d", sym->name, num_args);
2431 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2432 sym->name = gfc_get_string (name);
2433 strcpy (sym->binding_label, binding_label);
2437 /* no differences for c_loc or c_funloc */
2441 /* set the resolved symbol */
2442 if (m != MATCH_ERROR)
2443 c->resolved_sym = new_sym;
2445 c->resolved_sym = sym;
2451 /* Resolve a subroutine call known to be specific. */
2454 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2458 if(sym->attr.is_iso_c)
2460 m = gfc_iso_c_sub_interface (c,sym);
2464 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2466 if (sym->attr.dummy)
2468 sym->attr.proc = PROC_DUMMY;
2472 sym->attr.proc = PROC_EXTERNAL;
2476 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2479 if (sym->attr.intrinsic)
2481 m = gfc_intrinsic_sub_interface (c, 1);
2485 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2486 "with an intrinsic", sym->name, &c->loc);
2494 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2496 c->resolved_sym = sym;
2497 pure_subroutine (c, sym);
2504 resolve_specific_s (gfc_code *c)
2509 sym = c->symtree->n.sym;
2513 m = resolve_specific_s0 (c, sym);
2516 if (m == MATCH_ERROR)
2519 if (sym->ns->parent == NULL)
2522 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2528 sym = c->symtree->n.sym;
2529 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2530 sym->name, &c->loc);
2536 /* Resolve a subroutine call not known to be generic nor specific. */
2539 resolve_unknown_s (gfc_code *c)
2543 sym = c->symtree->n.sym;
2545 if (sym->attr.dummy)
2547 sym->attr.proc = PROC_DUMMY;
2551 /* See if we have an intrinsic function reference. */
2553 if (gfc_intrinsic_name (sym->name, 1))
2555 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2560 /* The reference is to an external name. */
2563 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2565 c->resolved_sym = sym;
2567 pure_subroutine (c, sym);
2573 /* Resolve a subroutine call. Although it was tempting to use the same code
2574 for functions, subroutines and functions are stored differently and this
2575 makes things awkward. */
2578 resolve_call (gfc_code *c)
2581 procedure_type ptype = PROC_INTRINSIC;
2583 if (c->symtree && c->symtree->n.sym
2584 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2586 gfc_error ("'%s' at %L has a type, which is not consistent with "
2587 "the CALL at %L", c->symtree->n.sym->name,
2588 &c->symtree->n.sym->declared_at, &c->loc);
2592 /* If external, check for usage. */
2593 if (c->symtree && is_external_proc (c->symtree->n.sym))
2594 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2596 /* Subroutines without the RECURSIVE attribution are not allowed to
2597 * call themselves. */
2598 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2600 gfc_symbol *csym, *proc;
2601 csym = c->symtree->n.sym;
2602 proc = gfc_current_ns->proc_name;
2605 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2606 "RECURSIVE", csym->name, &c->loc);
2610 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2611 && csym->ns->entries->sym == proc->ns->entries->sym)
2613 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2614 "'%s' is not declared as RECURSIVE",
2615 csym->name, &c->loc, csym->ns->entries->sym->name);
2620 /* Switch off assumed size checking and do this again for certain kinds
2621 of procedure, once the procedure itself is resolved. */
2622 need_full_assumed_size++;
2624 if (c->symtree && c->symtree->n.sym)
2625 ptype = c->symtree->n.sym->attr.proc;
2627 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2630 /* Resume assumed_size checking. */
2631 need_full_assumed_size--;
2634 if (c->resolved_sym == NULL)
2635 switch (procedure_kind (c->symtree->n.sym))
2638 t = resolve_generic_s (c);
2641 case PTYPE_SPECIFIC:
2642 t = resolve_specific_s (c);
2646 t = resolve_unknown_s (c);
2650 gfc_internal_error ("resolve_subroutine(): bad function type");
2653 /* Some checks of elemental subroutine actual arguments. */
2654 if (resolve_elemental_actual (NULL, c) == FAILURE)
2658 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2663 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2664 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2665 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2666 if their shapes do not match. If either op1->shape or op2->shape is
2667 NULL, return SUCCESS. */
2670 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2677 if (op1->shape != NULL && op2->shape != NULL)
2679 for (i = 0; i < op1->rank; i++)
2681 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2683 gfc_error ("Shapes for operands at %L and %L are not conformable",
2684 &op1->where, &op2->where);
2695 /* Resolve an operator expression node. This can involve replacing the
2696 operation with a user defined function call. */
2699 resolve_operator (gfc_expr *e)
2701 gfc_expr *op1, *op2;
2703 bool dual_locus_error;
2706 /* Resolve all subnodes-- give them types. */
2708 switch (e->value.op.operator)
2711 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2714 /* Fall through... */
2717 case INTRINSIC_UPLUS:
2718 case INTRINSIC_UMINUS:
2719 case INTRINSIC_PARENTHESES:
2720 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2725 /* Typecheck the new node. */
2727 op1 = e->value.op.op1;
2728 op2 = e->value.op.op2;
2729 dual_locus_error = false;
2731 if ((op1 && op1->expr_type == EXPR_NULL)
2732 || (op2 && op2->expr_type == EXPR_NULL))
2734 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2738 switch (e->value.op.operator)
2740 case INTRINSIC_UPLUS:
2741 case INTRINSIC_UMINUS:
2742 if (op1->ts.type == BT_INTEGER
2743 || op1->ts.type == BT_REAL
2744 || op1->ts.type == BT_COMPLEX)
2750 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2751 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2754 case INTRINSIC_PLUS:
2755 case INTRINSIC_MINUS:
2756 case INTRINSIC_TIMES:
2757 case INTRINSIC_DIVIDE:
2758 case INTRINSIC_POWER:
2759 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2761 gfc_type_convert_binary (e);
2766 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2767 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2768 gfc_typename (&op2->ts));
2771 case INTRINSIC_CONCAT:
2772 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2774 e->ts.type = BT_CHARACTER;
2775 e->ts.kind = op1->ts.kind;
2780 _("Operands of string concatenation operator at %%L are %s/%s"),
2781 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2787 case INTRINSIC_NEQV:
2788 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2790 e->ts.type = BT_LOGICAL;
2791 e->ts.kind = gfc_kind_max (op1, op2);
2792 if (op1->ts.kind < e->ts.kind)
2793 gfc_convert_type (op1, &e->ts, 2);
2794 else if (op2->ts.kind < e->ts.kind)
2795 gfc_convert_type (op2, &e->ts, 2);
2799 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2800 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2801 gfc_typename (&op2->ts));
2806 if (op1->ts.type == BT_LOGICAL)
2808 e->ts.type = BT_LOGICAL;
2809 e->ts.kind = op1->ts.kind;
2813 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2814 gfc_typename (&op1->ts));
2818 case INTRINSIC_GT_OS:
2820 case INTRINSIC_GE_OS:
2822 case INTRINSIC_LT_OS:
2824 case INTRINSIC_LE_OS:
2825 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2827 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2831 /* Fall through... */
2834 case INTRINSIC_EQ_OS:
2836 case INTRINSIC_NE_OS:
2837 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2839 e->ts.type = BT_LOGICAL;
2840 e->ts.kind = gfc_default_logical_kind;
2844 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2846 gfc_type_convert_binary (e);
2848 e->ts.type = BT_LOGICAL;
2849 e->ts.kind = gfc_default_logical_kind;
2853 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2855 _("Logicals at %%L must be compared with %s instead of %s"),
2856 (e->value.op.operator == INTRINSIC_EQ
2857 || e->value.op.operator == INTRINSIC_EQ_OS)
2858 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2861 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2862 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2863 gfc_typename (&op2->ts));
2867 case INTRINSIC_USER:
2868 if (e->value.op.uop->operator == NULL)
2869 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2870 else if (op2 == NULL)
2871 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2872 e->value.op.uop->name, gfc_typename (&op1->ts));
2874 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2875 e->value.op.uop->name, gfc_typename (&op1->ts),
2876 gfc_typename (&op2->ts));
2880 case INTRINSIC_PARENTHESES:
2884 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2887 /* Deal with arrayness of an operand through an operator. */
2891 switch (e->value.op.operator)
2893 case INTRINSIC_PLUS:
2894 case INTRINSIC_MINUS:
2895 case INTRINSIC_TIMES:
2896 case INTRINSIC_DIVIDE:
2897 case INTRINSIC_POWER:
2898 case INTRINSIC_CONCAT:
2902 case INTRINSIC_NEQV:
2904 case INTRINSIC_EQ_OS:
2906 case INTRINSIC_NE_OS:
2908 case INTRINSIC_GT_OS:
2910 case INTRINSIC_GE_OS:
2912 case INTRINSIC_LT_OS:
2914 case INTRINSIC_LE_OS:
2916 if (op1->rank == 0 && op2->rank == 0)
2919 if (op1->rank == 0 && op2->rank != 0)
2921 e->rank = op2->rank;
2923 if (e->shape == NULL)
2924 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2927 if (op1->rank != 0 && op2->rank == 0)
2929 e->rank = op1->rank;
2931 if (e->shape == NULL)
2932 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2935 if (op1->rank != 0 && op2->rank != 0)
2937 if (op1->rank == op2->rank)
2939 e->rank = op1->rank;
2940 if (e->shape == NULL)
2942 t = compare_shapes(op1, op2);
2946 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2951 /* Allow higher level expressions to work. */
2954 /* Try user-defined operators, and otherwise throw an error. */
2955 dual_locus_error = true;
2957 _("Inconsistent ranks for operator at %%L and %%L"));
2964 case INTRINSIC_PARENTHESES:
2966 /* This is always correct and sometimes necessary! */
2967 if (e->ts.type == BT_UNKNOWN)
2970 if (e->ts.type == BT_CHARACTER && !e->ts.cl)
2971 e->ts.cl = op1->ts.cl;
2974 case INTRINSIC_UPLUS:
2975 case INTRINSIC_UMINUS:
2976 /* Simply copy arrayness attribute */
2977 e->rank = op1->rank;
2979 if (e->shape == NULL)
2980 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2988 /* Attempt to simplify the expression. */
2991 t = gfc_simplify_expr (e, 0);
2992 /* Some calls do not succeed in simplification and return FAILURE
2993 even though there is no error; eg. variable references to
2994 PARAMETER arrays. */
2995 if (!gfc_is_constant_expr (e))
3002 if (gfc_extend_expr (e) == SUCCESS)
3005 if (dual_locus_error)
3006 gfc_error (msg, &op1->where, &op2->where);
3008 gfc_error (msg, &e->where);
3014 /************** Array resolution subroutines **************/
3017 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3020 /* Compare two integer expressions. */
3023 compare_bound (gfc_expr *a, gfc_expr *b)
3027 if (a == NULL || a->expr_type != EXPR_CONSTANT
3028 || b == NULL || b->expr_type != EXPR_CONSTANT)
3031 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3032 gfc_internal_error ("compare_bound(): Bad expression");
3034 i = mpz_cmp (a->value.integer, b->value.integer);
3044 /* Compare an integer expression with an integer. */
3047 compare_bound_int (gfc_expr *a, int b)
3051 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3054 if (a->ts.type != BT_INTEGER)
3055 gfc_internal_error ("compare_bound_int(): Bad expression");
3057 i = mpz_cmp_si (a->value.integer, b);
3067 /* Compare an integer expression with a mpz_t. */
3070 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3074 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3077 if (a->ts.type != BT_INTEGER)
3078 gfc_internal_error ("compare_bound_int(): Bad expression");
3080 i = mpz_cmp (a->value.integer, b);
3090 /* Compute the last value of a sequence given by a triplet.
3091 Return 0 if it wasn't able to compute the last value, or if the
3092 sequence if empty, and 1 otherwise. */
3095 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3096 gfc_expr *stride, mpz_t last)
3100 if (start == NULL || start->expr_type != EXPR_CONSTANT
3101 || end == NULL || end->expr_type != EXPR_CONSTANT
3102 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3105 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3106 || (stride != NULL && stride->ts.type != BT_INTEGER))
3109 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3111 if (compare_bound (start, end) == CMP_GT)
3113 mpz_set (last, end->value.integer);
3117 if (compare_bound_int (stride, 0) == CMP_GT)
3119 /* Stride is positive */
3120 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3125 /* Stride is negative */
3126 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3131 mpz_sub (rem, end->value.integer, start->value.integer);
3132 mpz_tdiv_r (rem, rem, stride->value.integer);
3133 mpz_sub (last, end->value.integer, rem);
3140 /* Compare a single dimension of an array reference to the array
3144 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3148 /* Given start, end and stride values, calculate the minimum and
3149 maximum referenced indexes. */
3157 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3159 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3166 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3167 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3169 comparison comp_start_end = compare_bound (AR_START, AR_END);
3171 /* Check for zero stride, which is not allowed. */
3172 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3174 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3178 /* if start == len || (stride > 0 && start < len)
3179 || (stride < 0 && start > len),
3180 then the array section contains at least one element. In this
3181 case, there is an out-of-bounds access if
3182 (start < lower || start > upper). */
3183 if (compare_bound (AR_START, AR_END) == CMP_EQ
3184 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3185 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3186 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3187 && comp_start_end == CMP_GT))
3189 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3190 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3194 /* If we can compute the highest index of the array section,
3195 then it also has to be between lower and upper. */
3196 mpz_init (last_value);
3197 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3200 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3201 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3203 mpz_clear (last_value);
3207 mpz_clear (last_value);
3215 gfc_internal_error ("check_dimension(): Bad array reference");
3221 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3226 /* Compare an array reference with an array specification. */
3229 compare_spec_to_ref (gfc_array_ref *ar)
3236 /* TODO: Full array sections are only allowed as actual parameters. */
3237 if (as->type == AS_ASSUMED_SIZE
3238 && (/*ar->type == AR_FULL
3239 ||*/ (ar->type == AR_SECTION
3240 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3242 gfc_error ("Rightmost upper bound of assumed size array section "
3243 "not specified at %L", &ar->where);
3247 if (ar->type == AR_FULL)
3250 if (as->rank != ar->dimen)
3252 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3253 &ar->where, ar->dimen, as->rank);
3257 for (i = 0; i < as->rank; i++)
3258 if (check_dimension (i, ar, as) == FAILURE)
3265 /* Resolve one part of an array index. */
3268 gfc_resolve_index (gfc_expr *index, int check_scalar)
3275 if (gfc_resolve_expr (index) == FAILURE)
3278 if (check_scalar && index->rank != 0)
3280 gfc_error ("Array index at %L must be scalar", &index->where);
3284 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3286 gfc_error ("Array index at %L must be of INTEGER type",
3291 if (index->ts.type == BT_REAL)
3292 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3293 &index->where) == FAILURE)
3296 if (index->ts.kind != gfc_index_integer_kind
3297 || index->ts.type != BT_INTEGER)
3300 ts.type = BT_INTEGER;
3301 ts.kind = gfc_index_integer_kind;
3303 gfc_convert_type_warn (index, &ts, 2, 0);
3309 /* Resolve a dim argument to an intrinsic function. */
3312 gfc_resolve_dim_arg (gfc_expr *dim)
3317 if (gfc_resolve_expr (dim) == FAILURE)
3322 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3326 if (dim->ts.type != BT_INTEGER)
3328 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3331 if (dim->ts.kind != gfc_index_integer_kind)
3335 ts.type = BT_INTEGER;
3336 ts.kind = gfc_index_integer_kind;
3338 gfc_convert_type_warn (dim, &ts, 2, 0);
3344 /* Given an expression that contains array references, update those array
3345 references to point to the right array specifications. While this is
3346 filled in during matching, this information is difficult to save and load
3347 in a module, so we take care of it here.
3349 The idea here is that the original array reference comes from the
3350 base symbol. We traverse the list of reference structures, setting
3351 the stored reference to references. Component references can
3352 provide an additional array specification. */
3355 find_array_spec (gfc_expr *e)
3359 gfc_symbol *derived;
3362 as = e->symtree->n.sym->as;
3365 for (ref = e->ref; ref; ref = ref->next)
3370 gfc_internal_error ("find_array_spec(): Missing spec");
3377 if (derived == NULL)
3378 derived = e->symtree->n.sym->ts.derived;
3380 c = derived->components;
3382 for (; c; c = c->next)
3383 if (c == ref->u.c.component)
3385 /* Track the sequence of component references. */
3386 if (c->ts.type == BT_DERIVED)
3387 derived = c->ts.derived;
3392 gfc_internal_error ("find_array_spec(): Component not found");
3397 gfc_internal_error ("find_array_spec(): unused as(1)");
3408 gfc_internal_error ("find_array_spec(): unused as(2)");
3412 /* Resolve an array reference. */
3415 resolve_array_ref (gfc_array_ref *ar)
3417 int i, check_scalar;
3420 for (i = 0; i < ar->dimen; i++)
3422 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3424 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3426 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3428 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3433 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3437 ar->dimen_type[i] = DIMEN_ELEMENT;
3441 ar->dimen_type[i] = DIMEN_VECTOR;
3442 if (e->expr_type == EXPR_VARIABLE
3443 && e->symtree->n.sym->ts.type == BT_DERIVED)
3444 ar->start[i] = gfc_get_parentheses (e);
3448 gfc_error ("Array index at %L is an array of rank %d",
3449 &ar->c_where[i], e->rank);
3454 /* If the reference type is unknown, figure out what kind it is. */
3456 if (ar->type == AR_UNKNOWN)
3458 ar->type = AR_ELEMENT;
3459 for (i = 0; i < ar->dimen; i++)
3460 if (ar->dimen_type[i] == DIMEN_RANGE
3461 || ar->dimen_type[i] == DIMEN_VECTOR)
3463 ar->type = AR_SECTION;
3468 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3476 resolve_substring (gfc_ref *ref)
3478 if (ref->u.ss.start != NULL)
3480 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3483 if (ref->u.ss.start->ts.type != BT_INTEGER)
3485 gfc_error ("Substring start index at %L must be of type INTEGER",
3486 &ref->u.ss.start->where);
3490 if (ref->u.ss.start->rank != 0)
3492 gfc_error ("Substring start index at %L must be scalar",
3493 &ref->u.ss.start->where);
3497 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3498 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3499 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3501 gfc_error ("Substring start index at %L is less than one",
3502 &ref->u.ss.start->where);
3507 if (ref->u.ss.end != NULL)
3509 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3512 if (ref->u.ss.end->ts.type != BT_INTEGER)
3514 gfc_error ("Substring end index at %L must be of type INTEGER",
3515 &ref->u.ss.end->where);
3519 if (ref->u.ss.end->rank != 0)
3521 gfc_error ("Substring end index at %L must be scalar",
3522 &ref->u.ss.end->where);
3526 if (ref->u.ss.length != NULL
3527 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3528 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3529 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3531 gfc_error ("Substring end index at %L exceeds the string length",
3532 &ref->u.ss.start->where);
3541 /* Resolve subtype references. */
3544 resolve_ref (gfc_expr *expr)
3546 int current_part_dimension, n_components, seen_part_dimension;
3549 for (ref = expr->ref; ref; ref = ref->next)
3550 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3552 find_array_spec (expr);
3556 for (ref = expr->ref; ref; ref = ref->next)
3560 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3568 resolve_substring (ref);
3572 /* Check constraints on part references. */
3574 current_part_dimension = 0;
3575 seen_part_dimension = 0;
3578 for (ref = expr->ref; ref; ref = ref->next)
3583 switch (ref->u.ar.type)
3587 current_part_dimension = 1;
3591 current_part_dimension = 0;
3595 gfc_internal_error ("resolve_ref(): Bad array reference");
3601 if (current_part_dimension || seen_part_dimension)
3603 if (ref->u.c.component->pointer)
3605 gfc_error ("Component to the right of a part reference "
3606 "with nonzero rank must not have the POINTER "
3607 "attribute at %L", &expr->where);
3610 else if (ref->u.c.component->allocatable)
3612 gfc_error ("Component to the right of a part reference "
3613 "with nonzero rank must not have the ALLOCATABLE "
3614 "attribute at %L", &expr->where);
3626 if (((ref->type == REF_COMPONENT && n_components > 1)
3627 || ref->next == NULL)
3628 && current_part_dimension
3629 && seen_part_dimension)
3631 gfc_error ("Two or more part references with nonzero rank must "
3632 "not be specified at %L", &expr->where);
3636 if (ref->type == REF_COMPONENT)
3638 if (current_part_dimension)
3639 seen_part_dimension = 1;
3641 /* reset to make sure */
3642 current_part_dimension = 0;
3650 /* Given an expression, determine its shape. This is easier than it sounds.
3651 Leaves the shape array NULL if it is not possible to determine the shape. */
3654 expression_shape (gfc_expr *e)
3656 mpz_t array[GFC_MAX_DIMENSIONS];
3659 if (e->rank == 0 || e->shape != NULL)
3662 for (i = 0; i < e->rank; i++)
3663 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3666 e->shape = gfc_get_shape (e->rank);
3668 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3673 for (i--; i >= 0; i--)
3674 mpz_clear (array[i]);
3678 /* Given a variable expression node, compute the rank of the expression by
3679 examining the base symbol and any reference structures it may have. */
3682 expression_rank (gfc_expr *e)
3689 if (e->expr_type == EXPR_ARRAY)
3691 /* Constructors can have a rank different from one via RESHAPE(). */
3693 if (e->symtree == NULL)
3699 e->rank = (e->symtree->n.sym->as == NULL)
3700 ? 0 : e->symtree->n.sym->as->rank;
3706 for (ref = e->ref; ref; ref = ref->next)
3708 if (ref->type != REF_ARRAY)
3711 if (ref->u.ar.type == AR_FULL)
3713 rank = ref->u.ar.as->rank;
3717 if (ref->u.ar.type == AR_SECTION)
3719 /* Figure out the rank of the section. */
3721 gfc_internal_error ("expression_rank(): Two array specs");
3723 for (i = 0; i < ref->u.ar.dimen; i++)
3724 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3725 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3735 expression_shape (e);
3739 /* Resolve a variable expression. */
3742 resolve_variable (gfc_expr *e)
3749 if (e->symtree == NULL)
3752 if (e->ref && resolve_ref (e) == FAILURE)
3755 sym = e->symtree->n.sym;
3756 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3758 e->ts.type = BT_PROCEDURE;
3762 if (sym->ts.type != BT_UNKNOWN)
3763 gfc_variable_attr (e, &e->ts);
3766 /* Must be a simple variable reference. */
3767 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3772 if (check_assumed_size_reference (sym, e))
3775 /* Deal with forward references to entries during resolve_code, to
3776 satisfy, at least partially, 12.5.2.5. */
3777 if (gfc_current_ns->entries
3778 && current_entry_id == sym->entry_id
3781 && cs_base->current->op != EXEC_ENTRY)
3783 gfc_entry_list *entry;
3784 gfc_formal_arglist *formal;
3788 /* If the symbol is a dummy... */
3789 if (sym->attr.dummy)
3791 entry = gfc_current_ns->entries;
3794 /* ...test if the symbol is a parameter of previous entries. */
3795 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3796 for (formal = entry->sym->formal; formal; formal = formal->next)
3798 if (formal->sym && sym->name == formal->sym->name)
3802 /* If it has not been seen as a dummy, this is an error. */
3805 if (specification_expr)
3806 gfc_error ("Variable '%s',used in a specification expression, "
3807 "is referenced at %L before the ENTRY statement "
3808 "in which it is a parameter",
3809 sym->name, &cs_base->current->loc);
3811 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3812 "statement in which it is a parameter",
3813 sym->name, &cs_base->current->loc);
3818 /* Now do the same check on the specification expressions. */
3819 specification_expr = 1;
3820 if (sym->ts.type == BT_CHARACTER
3821 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3825 for (n = 0; n < sym->as->rank; n++)
3827 specification_expr = 1;
3828 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3830 specification_expr = 1;
3831 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3834 specification_expr = 0;
3837 /* Update the symbol's entry level. */
3838 sym->entry_id = current_entry_id + 1;
3845 /* Checks to see that the correct symbol has been host associated.
3846 The only situation where this arises is that in which a twice
3847 contained function is parsed after the host association is made.
3848 Therefore, on detecting this, the line is rematched, having got
3849 rid of the existing references and actual_arg_list. */
3851 check_host_association (gfc_expr *e)
3853 gfc_symbol *sym, *old_sym;
3857 bool retval = e->expr_type == EXPR_FUNCTION;
3859 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3862 old_sym = e->symtree->n.sym;
3864 if (old_sym->attr.use_assoc)
3867 if (gfc_current_ns->parent
3868 && gfc_current_ns->parent->parent
3869 && old_sym->ns != gfc_current_ns)
3871 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3872 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3874 temp_locus = gfc_current_locus;
3875 gfc_current_locus = e->where;
3877 gfc_buffer_error (1);
3879 gfc_free_ref_list (e->ref);
3884 gfc_free_actual_arglist (e->value.function.actual);
3885 e->value.function.actual = NULL;
3888 if (e->shape != NULL)
3890 for (n = 0; n < e->rank; n++)
3891 mpz_clear (e->shape[n]);
3893 gfc_free (e->shape);
3896 gfc_match_rvalue (&expr);
3898 gfc_buffer_error (0);
3900 gcc_assert (expr && sym == expr->symtree->n.sym);
3906 gfc_current_locus = temp_locus;
3909 /* This might have changed! */
3910 return e->expr_type == EXPR_FUNCTION;
3914 /* Resolve an expression. That is, make sure that types of operands agree
3915 with their operators, intrinsic operators are converted to function calls
3916 for overloaded types and unresolved function references are resolved. */
3919 gfc_resolve_expr (gfc_expr *e)
3926 switch (e->expr_type)
3929 t = resolve_operator (e);
3935 if (check_host_association (e))
3936 t = resolve_function (e);
3939 t = resolve_variable (e);
3941 expression_rank (e);
3945 case EXPR_SUBSTRING:
3946 t = resolve_ref (e);
3956 if (resolve_ref (e) == FAILURE)
3959 t = gfc_resolve_array_constructor (e);
3960 /* Also try to expand a constructor. */
3963 expression_rank (e);
3964 gfc_expand_constructor (e);
3967 /* This provides the opportunity for the length of constructors with
3968 character valued function elements to propagate the string length
3969 to the expression. */
3970 if (e->ts.type == BT_CHARACTER)
3971 gfc_resolve_character_array_constructor (e);
3975 case EXPR_STRUCTURE:
3976 t = resolve_ref (e);
3980 t = resolve_structure_cons (e);
3984 t = gfc_simplify_expr (e, 0);
3988 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3995 /* Resolve an expression from an iterator. They must be scalar and have
3996 INTEGER or (optionally) REAL type. */
3999 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4000 const char *name_msgid)
4002 if (gfc_resolve_expr (expr) == FAILURE)
4005 if (expr->rank != 0)
4007 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4011 if (expr->ts.type != BT_INTEGER)
4013 if (expr->ts.type == BT_REAL)
4016 return gfc_notify_std (GFC_STD_F95_DEL,
4017 "Deleted feature: %s at %L must be integer",
4018 _(name_msgid), &expr->where);
4021 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4028 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4036 /* Resolve the expressions in an iterator structure. If REAL_OK is
4037 false allow only INTEGER type iterators, otherwise allow REAL types. */
4040 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4042 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4046 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4048 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4053 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4054 "Start expression in DO loop") == FAILURE)
4057 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4058 "End expression in DO loop") == FAILURE)
4061 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4062 "Step expression in DO loop") == FAILURE)
4065 if (iter->step->expr_type == EXPR_CONSTANT)
4067 if ((iter->step->ts.type == BT_INTEGER
4068 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4069 || (iter->step->ts.type == BT_REAL
4070 && mpfr_sgn (iter->step->value.real) == 0))
4072 gfc_error ("Step expression in DO loop at %L cannot be zero",
4073 &iter->step->where);
4078 /* Convert start, end, and step to the same type as var. */
4079 if (iter->start->ts.kind != iter->var->ts.kind
4080 || iter->start->ts.type != iter->var->ts.type)
4081 gfc_convert_type (iter->start, &iter->var->ts, 2);
4083 if (iter->end->ts.kind != iter->var->ts.kind
4084 || iter->end->ts.type != iter->var->ts.type)
4085 gfc_convert_type (iter->end, &iter->var->ts, 2);
4087 if (iter->step->ts.kind != iter->var->ts.kind
4088 || iter->step->ts.type != iter->var->ts.type)
4089 gfc_convert_type (iter->step, &iter->var->ts, 2);
4095 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4096 to be a scalar INTEGER variable. The subscripts and stride are scalar
4097 INTEGERs, and if stride is a constant it must be nonzero. */
4100 resolve_forall_iterators (gfc_forall_iterator *iter)
4104 if (gfc_resolve_expr (iter->var) == SUCCESS
4105 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4106 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4109 if (gfc_resolve_expr (iter->start) == SUCCESS
4110 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4111 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4112 &iter->start->where);
4113 if (iter->var->ts.kind != iter->start->ts.kind)
4114 gfc_convert_type (iter->start, &iter->var->ts, 2);
4116 if (gfc_resolve_expr (iter->end) == SUCCESS
4117 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4118 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4120 if (iter->var->ts.kind != iter->end->ts.kind)
4121 gfc_convert_type (iter->end, &iter->var->ts, 2);
4123 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4125 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4126 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4127 &iter->stride->where, "INTEGER");
4129 if (iter->stride->expr_type == EXPR_CONSTANT
4130 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4131 gfc_error ("FORALL stride expression at %L cannot be zero",
4132 &iter->stride->where);
4134 if (iter->var->ts.kind != iter->stride->ts.kind)
4135 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4142 /* Given a pointer to a symbol that is a derived type, see if it's
4143 inaccessible, i.e. if it's defined in another module and the components are
4144 PRIVATE. The search is recursive if necessary. Returns zero if no
4145 inaccessible components are found, nonzero otherwise. */
4148 derived_inaccessible (gfc_symbol *sym)
4152 if (sym->attr.use_assoc && sym->attr.private_comp)
4155 for (c = sym->components; c; c = c->next)
4157 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4165 /* Resolve the argument of a deallocate expression. The expression must be
4166 a pointer or a full array. */
4169 resolve_deallocate_expr (gfc_expr *e)
4171 symbol_attribute attr;
4172 int allocatable, pointer, check_intent_in;
4175 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4176 check_intent_in = 1;
4178 if (gfc_resolve_expr (e) == FAILURE)
4181 if (e->expr_type != EXPR_VARIABLE)
4184 allocatable = e->symtree->n.sym->attr.allocatable;
4185 pointer = e->symtree->n.sym->attr.pointer;
4186 for (ref = e->ref; ref; ref = ref->next)
4189 check_intent_in = 0;
4194 if (ref->u.ar.type != AR_FULL)
4199 allocatable = (ref->u.c.component->as != NULL
4200 && ref->u.c.component->as->type == AS_DEFERRED);
4201 pointer = ref->u.c.component->pointer;
4210 attr = gfc_expr_attr (e);
4212 if (allocatable == 0 && attr.pointer == 0)
4215 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4216 "ALLOCATABLE or a POINTER", &e->where);
4220 && e->symtree->n.sym->attr.intent == INTENT_IN)
4222 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4223 e->symtree->n.sym->name, &e->where);
4231 /* Returns true if the expression e contains a reference the symbol sym. */
4233 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4235 gfc_actual_arglist *arg;
4243 switch (e->expr_type)
4246 for (arg = e->value.function.actual; arg; arg = arg->next)
4247 rv = rv || find_sym_in_expr (sym, arg->expr);
4250 /* If the variable is not the same as the dependent, 'sym', and
4251 it is not marked as being declared and it is in the same
4252 namespace as 'sym', add it to the local declarations. */
4254 if (sym == e->symtree->n.sym)
4259 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4260 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4269 for (ref = e->ref; ref; ref = ref->next)
4274 for (i = 0; i < ref->u.ar.dimen; i++)
4276 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4277 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4278 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4283 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4284 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4288 if (ref->u.c.component->ts.type == BT_CHARACTER
4289 && ref->u.c.component->ts.cl->length->expr_type
4292 || find_sym_in_expr (sym,
4293 ref->u.c.component->ts.cl->length);
4295 if (ref->u.c.component->as)
4296 for (i = 0; i < ref->u.c.component->as->rank; i++)
4299 || find_sym_in_expr (sym,
4300 ref->u.c.component->as->lower[i]);
4302 || find_sym_in_expr (sym,
4303 ref->u.c.component->as->upper[i]);
4313 /* Given the expression node e for an allocatable/pointer of derived type to be
4314 allocated, get the expression node to be initialized afterwards (needed for
4315 derived types with default initializers, and derived types with allocatable
4316 components that need nullification.) */
4319 expr_to_initialize (gfc_expr *e)
4325 result = gfc_copy_expr (e);
4327 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4328 for (ref = result->ref; ref; ref = ref->next)
4329 if (ref->type == REF_ARRAY && ref->next == NULL)
4331 ref->u.ar.type = AR_FULL;
4333 for (i = 0; i < ref->u.ar.dimen; i++)
4334 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4336 result->rank = ref->u.ar.dimen;
4344 /* Resolve the expression in an ALLOCATE statement, doing the additional
4345 checks to see whether the expression is OK or not. The expression must
4346 have a trailing array reference that gives the size of the array. */
4349 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4351 int i, pointer, allocatable, dimension, check_intent_in;
4352 symbol_attribute attr;
4353 gfc_ref *ref, *ref2;
4360 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4361 check_intent_in = 1;
4363 if (gfc_resolve_expr (e) == FAILURE)
4366 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4367 sym = code->expr->symtree->n.sym;
4371 /* Make sure the expression is allocatable or a pointer. If it is
4372 pointer, the next-to-last reference must be a pointer. */
4376 if (e->expr_type != EXPR_VARIABLE)
4379 attr = gfc_expr_attr (e);
4380 pointer = attr.pointer;
4381 dimension = attr.dimension;
4385 allocatable = e->symtree->n.sym->attr.allocatable;
4386 pointer = e->symtree->n.sym->attr.pointer;
4387 dimension = e->symtree->n.sym->attr.dimension;
4389 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4391 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4392 "not be allocated in the same statement at %L",
4393 sym->name, &e->where);
4397 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4400 check_intent_in = 0;
4405 if (ref->next != NULL)
4410 allocatable = (ref->u.c.component->as != NULL
4411 && ref->u.c.component->as->type == AS_DEFERRED);
4413 pointer = ref->u.c.component->pointer;
4414 dimension = ref->u.c.component->dimension;
4425 if (allocatable == 0 && pointer == 0)
4427 gfc_error ("Expression in ALLOCATE statement at %L must be "
4428 "ALLOCATABLE or a POINTER", &e->where);
4433 && e->symtree->n.sym->attr.intent == INTENT_IN)
4435 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4436 e->symtree->n.sym->name, &e->where);
4440 /* Add default initializer for those derived types that need them. */
4441 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4443 init_st = gfc_get_code ();
4444 init_st->loc = code->loc;
4445 init_st->op = EXEC_INIT_ASSIGN;
4446 init_st->expr = expr_to_initialize (e);
4447 init_st->expr2 = init_e;
4448 init_st->next = code->next;
4449 code->next = init_st;
4452 if (pointer && dimension == 0)
4455 /* Make sure the next-to-last reference node is an array specification. */
4457 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4459 gfc_error ("Array specification required in ALLOCATE statement "
4460 "at %L", &e->where);
4464 /* Make sure that the array section reference makes sense in the
4465 context of an ALLOCATE specification. */
4469 for (i = 0; i < ar->dimen; i++)
4471 if (ref2->u.ar.type == AR_ELEMENT)
4474 switch (ar->dimen_type[i])
4480 if (ar->start[i] != NULL
4481 && ar->end[i] != NULL
4482 && ar->stride[i] == NULL)
4485 /* Fall Through... */
4489 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4496 for (a = code->ext.alloc_list; a; a = a->next)
4498 sym = a->expr->symtree->n.sym;
4500 /* TODO - check derived type components. */
4501 if (sym->ts.type == BT_DERIVED)
4504 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4505 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4507 gfc_error ("'%s' must not appear an the array specification at "
4508 "%L in the same ALLOCATE statement where it is "
4509 "itself allocated", sym->name, &ar->where);
4519 /************ SELECT CASE resolution subroutines ************/
4521 /* Callback function for our mergesort variant. Determines interval
4522 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4523 op1 > op2. Assumes we're not dealing with the default case.
4524 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4525 There are nine situations to check. */
4528 compare_cases (const gfc_case *op1, const gfc_case *op2)
4532 if (op1->low == NULL) /* op1 = (:L) */
4534 /* op2 = (:N), so overlap. */
4536 /* op2 = (M:) or (M:N), L < M */
4537 if (op2->low != NULL
4538 && gfc_compare_expr (op1->high, op2->low) < 0)
4541 else if (op1->high == NULL) /* op1 = (K:) */
4543 /* op2 = (M:), so overlap. */
4545 /* op2 = (:N) or (M:N), K > N */
4546 if (op2->high != NULL
4547 && gfc_compare_expr (op1->low, op2->high) > 0)
4550 else /* op1 = (K:L) */
4552 if (op2->low == NULL) /* op2 = (:N), K > N */
4553 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4554 else if (op2->high == NULL) /* op2 = (M:), L < M */
4555 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4556 else /* op2 = (M:N) */
4560 if (gfc_compare_expr (op1->high, op2->low) < 0)
4563 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4572 /* Merge-sort a double linked case list, detecting overlap in the
4573 process. LIST is the head of the double linked case list before it
4574 is sorted. Returns the head of the sorted list if we don't see any
4575 overlap, or NULL otherwise. */
4578 check_case_overlap (gfc_case *list)
4580 gfc_case *p, *q, *e, *tail;
4581 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4583 /* If the passed list was empty, return immediately. */
4590 /* Loop unconditionally. The only exit from this loop is a return
4591 statement, when we've finished sorting the case list. */
4598 /* Count the number of merges we do in this pass. */
4601 /* Loop while there exists a merge to be done. */
4606 /* Count this merge. */
4609 /* Cut the list in two pieces by stepping INSIZE places
4610 forward in the list, starting from P. */
4613 for (i = 0; i < insize; i++)
4622 /* Now we have two lists. Merge them! */
4623 while (psize > 0 || (qsize > 0 && q != NULL))
4625 /* See from which the next case to merge comes from. */
4628 /* P is empty so the next case must come from Q. */
4633 else if (qsize == 0 || q == NULL)
4642 cmp = compare_cases (p, q);
4645 /* The whole case range for P is less than the
4653 /* The whole case range for Q is greater than
4654 the case range for P. */
4661 /* The cases overlap, or they are the same
4662 element in the list. Either way, we must
4663 issue an error and get the next case from P. */
4664 /* FIXME: Sort P and Q by line number. */
4665 gfc_error ("CASE label at %L overlaps with CASE "
4666 "label at %L", &p->where, &q->where);
4674 /* Add the next element to the merged list. */
4683 /* P has now stepped INSIZE places along, and so has Q. So
4684 they're the same. */
4689 /* If we have done only one merge or none at all, we've
4690 finished sorting the cases. */
4699 /* Otherwise repeat, merging lists twice the size. */
4705 /* Check to see if an expression is suitable for use in a CASE statement.
4706 Makes sure that all case expressions are scalar constants of the same
4707 type. Return FAILURE if anything is wrong. */
4710 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4712 if (e == NULL) return SUCCESS;
4714 if (e->ts.type != case_expr->ts.type)
4716 gfc_error ("Expression in CASE statement at %L must be of type %s",
4717 &e->where, gfc_basic_typename (case_expr->ts.type));
4721 /* C805 (R808) For a given case-construct, each case-value shall be of
4722 the same type as case-expr. For character type, length differences
4723 are allowed, but the kind type parameters shall be the same. */
4725 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4727 gfc_error("Expression in CASE statement at %L must be kind %d",
4728 &e->where, case_expr->ts.kind);
4732 /* Convert the case value kind to that of case expression kind, if needed.
4733 FIXME: Should a warning be issued? */
4734 if (e->ts.kind != case_expr->ts.kind)
4735 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4739 gfc_error ("Expression in CASE statement at %L must be scalar",
4748 /* Given a completely parsed select statement, we:
4750 - Validate all expressions and code within the SELECT.
4751 - Make sure that the selection expression is not of the wrong type.
4752 - Make sure that no case ranges overlap.
4753 - Eliminate unreachable cases and unreachable code resulting from
4754 removing case labels.
4756 The standard does allow unreachable cases, e.g. CASE (5:3). But
4757 they are a hassle for code generation, and to prevent that, we just
4758 cut them out here. This is not necessary for overlapping cases
4759 because they are illegal and we never even try to generate code.
4761 We have the additional caveat that a SELECT construct could have
4762 been a computed GOTO in the source code. Fortunately we can fairly
4763 easily work around that here: The case_expr for a "real" SELECT CASE
4764 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4765 we have to do is make sure that the case_expr is a scalar integer
4769 resolve_select (gfc_code *code)
4772 gfc_expr *case_expr;
4773 gfc_case *cp, *default_case, *tail, *head;
4774 int seen_unreachable;
4780 if (code->expr == NULL)
4782 /* This was actually a computed GOTO statement. */
4783 case_expr = code->expr2;
4784 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4785 gfc_error ("Selection expression in computed GOTO statement "
4786 "at %L must be a scalar integer expression",
4789 /* Further checking is not necessary because this SELECT was built
4790 by the compiler, so it should always be OK. Just move the
4791 case_expr from expr2 to expr so that we can handle computed
4792 GOTOs as normal SELECTs from here on. */
4793 code->expr = code->expr2;
4798 case_expr = code->expr;
4800 type = case_expr->ts.type;
4801 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4803 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4804 &case_expr->where, gfc_typename (&case_expr->ts));
4806 /* Punt. Going on here just produce more garbage error messages. */
4810 if (case_expr->rank != 0)
4812 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4813 "expression", &case_expr->where);
4819 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4820 of the SELECT CASE expression and its CASE values. Walk the lists
4821 of case values, and if we find a mismatch, promote case_expr to
4822 the appropriate kind. */
4824 if (type == BT_LOGICAL || type == BT_INTEGER)
4826 for (body = code->block; body; body = body->block)
4828 /* Walk the case label list. */
4829 for (cp = body->ext.case_list; cp; cp = cp->next)
4831 /* Intercept the DEFAULT case. It does not have a kind. */
4832 if (cp->low == NULL && cp->high == NULL)
4835 /* Unreachable case ranges are discarded, so ignore. */
4836 if (cp->low != NULL && cp->high != NULL
4837 && cp->low != cp->high
4838 && gfc_compare_expr (cp->low, cp->high) > 0)
4841 /* FIXME: Should a warning be issued? */
4843 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4844 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4846 if (cp->high != NULL
4847 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4848 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4853 /* Assume there is no DEFAULT case. */
4854 default_case = NULL;
4859 for (body = code->block; body; body = body->block)
4861 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4863 seen_unreachable = 0;
4865 /* Walk the case label list, making sure that all case labels
4867 for (cp = body->ext.case_list; cp; cp = cp->next)
4869 /* Count the number of cases in the whole construct. */
4872 /* Intercept the DEFAULT case. */
4873 if (cp->low == NULL && cp->high == NULL)
4875 if (default_case != NULL)
4877 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4878 "by a second DEFAULT CASE at %L",
4879 &default_case->where, &cp->where);
4890 /* Deal with single value cases and case ranges. Errors are
4891 issued from the validation function. */
4892 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4893 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4899 if (type == BT_LOGICAL
4900 && ((cp->low == NULL || cp->high == NULL)
4901 || cp->low != cp->high))
4903 gfc_error ("Logical range in CASE statement at %L is not "
4904 "allowed", &cp->low->where);
4909 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4912 value = cp->low->value.logical == 0 ? 2 : 1;
4913 if (value & seen_logical)
4915 gfc_error ("constant logical value in CASE statement "
4916 "is repeated at %L",
4921 seen_logical |= value;
4924 if (cp->low != NULL && cp->high != NULL
4925 && cp->low != cp->high
4926 && gfc_compare_expr (cp->low, cp->high) > 0)
4928 if (gfc_option.warn_surprising)
4929 gfc_warning ("Range specification at %L can never "
4930 "be matched", &cp->where);
4932 cp->unreachable = 1;
4933 seen_unreachable = 1;
4937 /* If the case range can be matched, it can also overlap with
4938 other cases. To make sure it does not, we put it in a
4939 double linked list here. We sort that with a merge sort
4940 later on to detect any overlapping cases. */
4944 head->right = head->left = NULL;
4949 tail->right->left = tail;
4956 /* It there was a failure in the previous case label, give up
4957 for this case label list. Continue with the next block. */
4961 /* See if any case labels that are unreachable have been seen.
4962 If so, we eliminate them. This is a bit of a kludge because
4963 the case lists for a single case statement (label) is a
4964 single forward linked lists. */
4965 if (seen_unreachable)
4967 /* Advance until the first case in the list is reachable. */
4968 while (body->ext.case_list != NULL
4969 && body->ext.case_list->unreachable)
4971 gfc_case *n = body->ext.case_list;
4972 body->ext.case_list = body->ext.case_list->next;
4974 gfc_free_case_list (n);
4977 /* Strip all other unreachable cases. */
4978 if (body->ext.case_list)
4980 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4982 if (cp->next->unreachable)
4984 gfc_case *n = cp->next;
4985 cp->next = cp->next->next;
4987 gfc_free_case_list (n);
4994 /* See if there were overlapping cases. If the check returns NULL,
4995 there was overlap. In that case we don't do anything. If head
4996 is non-NULL, we prepend the DEFAULT case. The sorted list can
4997 then used during code generation for SELECT CASE constructs with
4998 a case expression of a CHARACTER type. */
5001 head = check_case_overlap (head);
5003 /* Prepend the default_case if it is there. */
5004 if (head != NULL && default_case)
5006 default_case->left = NULL;
5007 default_case->right = head;
5008 head->left = default_case;
5012 /* Eliminate dead blocks that may be the result if we've seen
5013 unreachable case labels for a block. */
5014 for (body = code; body && body->block; body = body->block)
5016 if (body->block->ext.case_list == NULL)
5018 /* Cut the unreachable block from the code chain. */
5019 gfc_code *c = body->block;
5020 body->block = c->block;
5022 /* Kill the dead block, but not the blocks below it. */
5024 gfc_free_statements (c);
5028 /* More than two cases is legal but insane for logical selects.
5029 Issue a warning for it. */
5030 if (gfc_option.warn_surprising && type == BT_LOGICAL
5032 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5037 /* Resolve a transfer statement. This is making sure that:
5038 -- a derived type being transferred has only non-pointer components
5039 -- a derived type being transferred doesn't have private components, unless
5040 it's being transferred from the module where the type was defined
5041 -- we're not trying to transfer a whole assumed size array. */
5044 resolve_transfer (gfc_code *code)
5053 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5056 sym = exp->symtree->n.sym;
5059 /* Go to actual component transferred. */
5060 for (ref = code->expr->ref; ref; ref = ref->next)
5061 if (ref->type == REF_COMPONENT)
5062 ts = &ref->u.c.component->ts;
5064 if (ts->type == BT_DERIVED)
5066 /* Check that transferred derived type doesn't contain POINTER
5068 if (ts->derived->attr.pointer_comp)
5070 gfc_error ("Data transfer element at %L cannot have "
5071 "POINTER components", &code->loc);
5075 if (ts->derived->attr.alloc_comp)
5077 gfc_error ("Data transfer element at %L cannot have "
5078 "ALLOCATABLE components", &code->loc);
5082 if (derived_inaccessible (ts->derived))
5084 gfc_error ("Data transfer element at %L cannot have "
5085 "PRIVATE components",&code->loc);
5090 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5091 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5093 gfc_error ("Data transfer element at %L cannot be a full reference to "
5094 "an assumed-size array", &code->loc);
5100 /*********** Toplevel code resolution subroutines ***********/
5102 /* Find the set of labels that are reachable from this block. We also
5103 record the last statement in each block so that we don't have to do
5104 a linear search to find the END DO statements of the blocks. */
5107 reachable_labels (gfc_code *block)
5114 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5116 /* Collect labels in this block. */
5117 for (c = block; c; c = c->next)
5120 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5122 if (!c->next && cs_base->prev)
5123 cs_base->prev->tail = c;
5126 /* Merge with labels from parent block. */
5129 gcc_assert (cs_base->prev->reachable_labels);
5130 bitmap_ior_into (cs_base->reachable_labels,
5131 cs_base->prev->reachable_labels);
5135 /* Given a branch to a label and a namespace, if the branch is conforming.
5136 The code node describes where the branch is located. */
5139 resolve_branch (gfc_st_label *label, gfc_code *code)
5146 /* Step one: is this a valid branching target? */
5148 if (label->defined == ST_LABEL_UNKNOWN)
5150 gfc_error ("Label %d referenced at %L is never defined", label->value,
5155 if (label->defined != ST_LABEL_TARGET)
5157 gfc_error ("Statement at %L is not a valid branch target statement "
5158 "for the branch statement at %L", &label->where, &code->loc);
5162 /* Step two: make sure this branch is not a branch to itself ;-) */
5164 if (code->here == label)
5166 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5170 /* Step three: See if the label is in the same block as the
5171 branching statement. The hard work has been done by setting up
5172 the bitmap reachable_labels. */
5174 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5176 /* The label is not in an enclosing block, so illegal. This was
5177 allowed in Fortran 66, so we allow it as extension. No
5178 further checks are necessary in this case. */
5179 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5180 "as the GOTO statement at %L", &label->where,
5185 /* Step four: Make sure that the branching target is legal if
5186 the statement is an END {SELECT,IF}. */
5188 for (stack = cs_base; stack; stack = stack->prev)
5189 if (stack->current->next && stack->current->next->here == label)
5192 if (stack && stack->current->next->op == EXEC_NOP)
5194 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5195 "END of construct at %L", &code->loc,
5196 &stack->current->next->loc);
5197 return; /* We know this is not an END DO. */
5200 /* Step five: Make sure that we're not jumping to the end of a DO
5201 loop from within the loop. */
5203 for (stack = cs_base; stack; stack = stack->prev)
5204 if ((stack->current->op == EXEC_DO
5205 || stack->current->op == EXEC_DO_WHILE)
5206 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5208 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5209 "to END of construct at %L", &code->loc,
5217 /* Check whether EXPR1 has the same shape as EXPR2. */
5220 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5222 mpz_t shape[GFC_MAX_DIMENSIONS];
5223 mpz_t shape2[GFC_MAX_DIMENSIONS];
5224 try result = FAILURE;
5227 /* Compare the rank. */
5228 if (expr1->rank != expr2->rank)
5231 /* Compare the size of each dimension. */
5232 for (i=0; i<expr1->rank; i++)
5234 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5237 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5240 if (mpz_cmp (shape[i], shape2[i]))
5244 /* When either of the two expression is an assumed size array, we
5245 ignore the comparison of dimension sizes. */
5250 for (i--; i >= 0; i--)
5252 mpz_clear (shape[i]);
5253 mpz_clear (shape2[i]);
5259 /* Check whether a WHERE assignment target or a WHERE mask expression
5260 has the same shape as the outmost WHERE mask expression. */
5263 resolve_where (gfc_code *code, gfc_expr *mask)
5269 cblock = code->block;
5271 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5272 In case of nested WHERE, only the outmost one is stored. */
5273 if (mask == NULL) /* outmost WHERE */
5275 else /* inner WHERE */
5282 /* Check if the mask-expr has a consistent shape with the
5283 outmost WHERE mask-expr. */
5284 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5285 gfc_error ("WHERE mask at %L has inconsistent shape",
5286 &cblock->expr->where);
5289 /* the assignment statement of a WHERE statement, or the first
5290 statement in where-body-construct of a WHERE construct */
5291 cnext = cblock->next;
5296 /* WHERE assignment statement */
5299 /* Check shape consistent for WHERE assignment target. */
5300 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5301 gfc_error ("WHERE assignment target at %L has "
5302 "inconsistent shape", &cnext->expr->where);
5306 case EXEC_ASSIGN_CALL:
5307 resolve_call (cnext);
5310 /* WHERE or WHERE construct is part of a where-body-construct */
5312 resolve_where (cnext, e);
5316 gfc_error ("Unsupported statement inside WHERE at %L",
5319 /* the next statement within the same where-body-construct */
5320 cnext = cnext->next;
5322 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5323 cblock = cblock->block;
5328 /* Check whether the FORALL index appears in the expression or not. */
5331 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5335 gfc_actual_arglist *args;
5338 switch (expr->expr_type)
5341 gcc_assert (expr->symtree->n.sym);
5343 /* A scalar assignment */
5346 if (expr->symtree->n.sym == symbol)
5352 /* the expr is array ref, substring or struct component. */
5359 /* Check if the symbol appears in the array subscript. */
5361 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5364 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5368 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5372 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5378 if (expr->symtree->n.sym == symbol)
5381 /* Check if the symbol appears in the substring section. */
5382 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5384 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5392 gfc_error("expression reference type error at %L", &expr->where);
5398 /* If the expression is a function call, then check if the symbol
5399 appears in the actual arglist of the function. */
5401 for (args = expr->value.function.actual; args; args = args->next)
5403 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5408 /* It seems not to happen. */
5409 case EXPR_SUBSTRING:
5413 gcc_assert (expr->ref->type == REF_SUBSTRING);
5414 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5416 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5421 /* It seems not to happen. */
5422 case EXPR_STRUCTURE:
5424 gfc_error ("Unsupported statement while finding forall index in "
5429 /* Find the FORALL index in the first operand. */
5430 if (expr->value.op.op1)
5432 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5436 /* Find the FORALL index in the second operand. */
5437 if (expr->value.op.op2)
5439 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5452 /* Resolve assignment in FORALL construct.
5453 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5454 FORALL index variables. */
5457 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5461 for (n = 0; n < nvar; n++)
5463 gfc_symbol *forall_index;
5465 forall_index = var_expr[n]->symtree->n.sym;
5467 /* Check whether the assignment target is one of the FORALL index
5469 if ((code->expr->expr_type == EXPR_VARIABLE)
5470 && (code->expr->symtree->n.sym == forall_index))
5471 gfc_error ("Assignment to a FORALL index variable at %L",
5472 &code->expr->where);
5475 /* If one of the FORALL index variables doesn't appear in the
5476 assignment target, then there will be a many-to-one
5478 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5479 gfc_error ("The FORALL with index '%s' cause more than one "
5480 "assignment to this object at %L",
5481 var_expr[n]->symtree->name, &code->expr->where);
5487 /* Resolve WHERE statement in FORALL construct. */
5490 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5491 gfc_expr **var_expr)
5496 cblock = code->block;
5499 /* the assignment statement of a WHERE statement, or the first
5500 statement in where-body-construct of a WHERE construct */
5501 cnext = cblock->next;
5506 /* WHERE assignment statement */
5508 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5511 /* WHERE operator assignment statement */
5512 case EXEC_ASSIGN_CALL:
5513 resolve_call (cnext);
5516 /* WHERE or WHERE construct is part of a where-body-construct */
5518 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5522 gfc_error ("Unsupported statement inside WHERE at %L",
5525 /* the next statement within the same where-body-construct */
5526 cnext = cnext->next;
5528 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5529 cblock = cblock->block;
5534 /* Traverse the FORALL body to check whether the following errors exist:
5535 1. For assignment, check if a many-to-one assignment happens.
5536 2. For WHERE statement, check the WHERE body to see if there is any
5537 many-to-one assignment. */
5540 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5544 c = code->block->next;
5550 case EXEC_POINTER_ASSIGN:
5551 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5554 case EXEC_ASSIGN_CALL:
5558 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5559 there is no need to handle it here. */
5563 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5568 /* The next statement in the FORALL body. */
5574 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5575 gfc_resolve_forall_body to resolve the FORALL body. */
5578 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5580 static gfc_expr **var_expr;
5581 static int total_var = 0;
5582 static int nvar = 0;
5583 gfc_forall_iterator *fa;
5584 gfc_symbol *forall_index;
5588 /* Start to resolve a FORALL construct */
5589 if (forall_save == 0)
5591 /* Count the total number of FORALL index in the nested FORALL
5592 construct in order to allocate the VAR_EXPR with proper size. */
5594 while ((next != NULL) && (next->op == EXEC_FORALL))
5596 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5598 next = next->block->next;
5601 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5602 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5605 /* The information about FORALL iterator, including FORALL index start, end
5606 and stride. The FORALL index can not appear in start, end or stride. */
5607 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5609 /* Check if any outer FORALL index name is the same as the current
5611 for (i = 0; i < nvar; i++)
5613 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5615 gfc_error ("An outer FORALL construct already has an index "
5616 "with this name %L", &fa->var->where);
5620 /* Record the current FORALL index. */
5621 var_expr[nvar] = gfc_copy_expr (fa->var);
5623 forall_index = fa->var->symtree->n.sym;
5625 /* Check if the FORALL index appears in start, end or stride. */
5626 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5627 gfc_error ("A FORALL index must not appear in a limit or stride "
5628 "expression in the same FORALL at %L", &fa->start->where);
5629 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5630 gfc_error ("A FORALL index must not appear in a limit or stride "
5631 "expression in the same FORALL at %L", &fa->end->where);
5632 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5633 gfc_error ("A FORALL index must not appear in a limit or stride "
5634 "expression in the same FORALL at %L", &fa->stride->where);
5638 /* Resolve the FORALL body. */
5639 gfc_resolve_forall_body (code, nvar, var_expr);
5641 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5642 gfc_resolve_blocks (code->block, ns);
5644 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5645 for (i = 0; i < total_var; i++)
5646 gfc_free_expr (var_expr[i]);
5648 /* Reset the counters. */
5654 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5657 static void resolve_code (gfc_code *, gfc_namespace *);
5660 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5664 for (; b; b = b->block)
5666 t = gfc_resolve_expr (b->expr);
5667 if (gfc_resolve_expr (b->expr2) == FAILURE)
5673 if (t == SUCCESS && b->expr != NULL
5674 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5675 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5682 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5683 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5688 resolve_branch (b->label, b);
5700 case EXEC_OMP_ATOMIC:
5701 case EXEC_OMP_CRITICAL:
5703 case EXEC_OMP_MASTER:
5704 case EXEC_OMP_ORDERED:
5705 case EXEC_OMP_PARALLEL:
5706 case EXEC_OMP_PARALLEL_DO:
5707 case EXEC_OMP_PARALLEL_SECTIONS:
5708 case EXEC_OMP_PARALLEL_WORKSHARE:
5709 case EXEC_OMP_SECTIONS:
5710 case EXEC_OMP_SINGLE:
5711 case EXEC_OMP_WORKSHARE:
5715 gfc_internal_error ("resolve_block(): Bad block type");
5718 resolve_code (b->next, ns);
5723 static gfc_component *
5724 has_default_initializer (gfc_symbol *der)
5727 for (c = der->components; c; c = c->next)
5728 if ((c->ts.type != BT_DERIVED && c->initializer)
5729 || (c->ts.type == BT_DERIVED
5731 && has_default_initializer (c->ts.derived)))
5738 /* Given a block of code, recursively resolve everything pointed to by this
5742 resolve_code (gfc_code *code, gfc_namespace *ns)
5744 int omp_workshare_save;
5750 frame.prev = cs_base;
5754 reachable_labels (code);
5756 for (; code; code = code->next)
5758 frame.current = code;
5759 forall_save = forall_flag;
5761 if (code->op == EXEC_FORALL)
5764 gfc_resolve_forall (code, ns, forall_save);
5767 else if (code->block)
5769 omp_workshare_save = -1;
5772 case EXEC_OMP_PARALLEL_WORKSHARE:
5773 omp_workshare_save = omp_workshare_flag;
5774 omp_workshare_flag = 1;
5775 gfc_resolve_omp_parallel_blocks (code, ns);
5777 case EXEC_OMP_PARALLEL:
5778 case EXEC_OMP_PARALLEL_DO:
5779 case EXEC_OMP_PARALLEL_SECTIONS:
5780 omp_workshare_save = omp_workshare_flag;
5781 omp_workshare_flag = 0;
5782 gfc_resolve_omp_parallel_blocks (code, ns);
5785 gfc_resolve_omp_do_blocks (code, ns);
5787 case EXEC_OMP_WORKSHARE:
5788 omp_workshare_save = omp_workshare_flag;
5789 omp_workshare_flag = 1;
5792 gfc_resolve_blocks (code->block, ns);
5796 if (omp_workshare_save != -1)
5797 omp_workshare_flag = omp_workshare_save;
5800 t = gfc_resolve_expr (code->expr);
5801 forall_flag = forall_save;
5803 if (gfc_resolve_expr (code->expr2) == FAILURE)
5818 /* Keep track of which entry we are up to. */
5819 current_entry_id = code->ext.entry->id;
5823 resolve_where (code, NULL);
5827 if (code->expr != NULL)
5829 if (code->expr->ts.type != BT_INTEGER)
5830 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5831 "INTEGER variable", &code->expr->where);
5832 else if (code->expr->symtree->n.sym->attr.assign != 1)
5833 gfc_error ("Variable '%s' has not been assigned a target "
5834 "label at %L", code->expr->symtree->n.sym->name,
5835 &code->expr->where);
5838 resolve_branch (code->label, code);
5842 if (code->expr != NULL
5843 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5844 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5845 "INTEGER return specifier", &code->expr->where);
5848 case EXEC_INIT_ASSIGN:
5855 if (gfc_extend_assign (code, ns) == SUCCESS)
5857 gfc_expr *lhs = code->ext.actual->expr;
5858 gfc_expr *rhs = code->ext.actual->next->expr;
5860 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5862 gfc_error ("Subroutine '%s' called instead of assignment at "
5863 "%L must be PURE", code->symtree->n.sym->name,
5868 /* Make a temporary rhs when there is a default initializer
5869 and rhs is the same symbol as the lhs. */
5870 if (rhs->expr_type == EXPR_VARIABLE
5871 && rhs->symtree->n.sym->ts.type == BT_DERIVED
5872 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
5873 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
5874 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
5879 if (code->expr->ts.type == BT_CHARACTER
5880 && gfc_option.warn_character_truncation)
5882 int llen = 0, rlen = 0;
5884 if (code->expr->ts.cl != NULL
5885 && code->expr->ts.cl->length != NULL
5886 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5887 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5889 if (code->expr2->expr_type == EXPR_CONSTANT)
5890 rlen = code->expr2->value.character.length;
5892 else if (code->expr2->ts.cl != NULL
5893 && code->expr2->ts.cl->length != NULL
5894 && code->expr2->ts.cl->length->expr_type
5896 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5898 if (rlen && llen && rlen > llen)
5899 gfc_warning_now ("CHARACTER expression will be truncated "
5900 "in assignment (%d/%d) at %L",
5901 llen, rlen, &code->loc);
5904 if (gfc_pure (NULL))
5906 if (gfc_impure_variable (code->expr->symtree->n.sym))
5908 gfc_error ("Cannot assign to variable '%s' in PURE "
5910 code->expr->symtree->n.sym->name,
5911 &code->expr->where);
5915 if (code->expr->ts.type == BT_DERIVED
5916 && code->expr->expr_type == EXPR_VARIABLE
5917 && code->expr->ts.derived->attr.pointer_comp
5918 && gfc_impure_variable (code->expr2->symtree->n.sym))
5920 gfc_error ("The impure variable at %L is assigned to "
5921 "a derived type variable with a POINTER "
5922 "component in a PURE procedure (12.6)",
5923 &code->expr2->where);
5928 gfc_check_assign (code->expr, code->expr2, 1);
5931 case EXEC_LABEL_ASSIGN:
5932 if (code->label->defined == ST_LABEL_UNKNOWN)
5933 gfc_error ("Label %d referenced at %L is never defined",
5934 code->label->value, &code->label->where);
5936 && (code->expr->expr_type != EXPR_VARIABLE
5937 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5938 || code->expr->symtree->n.sym->ts.kind
5939 != gfc_default_integer_kind
5940 || code->expr->symtree->n.sym->as != NULL))
5941 gfc_error ("ASSIGN statement at %L requires a scalar "
5942 "default INTEGER variable", &code->expr->where);
5945 case EXEC_POINTER_ASSIGN:
5949 gfc_check_pointer_assign (code->expr, code->expr2);
5952 case EXEC_ARITHMETIC_IF:
5954 && code->expr->ts.type != BT_INTEGER
5955 && code->expr->ts.type != BT_REAL)
5956 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5957 "expression", &code->expr->where);
5959 resolve_branch (code->label, code);
5960 resolve_branch (code->label2, code);
5961 resolve_branch (code->label3, code);
5965 if (t == SUCCESS && code->expr != NULL
5966 && (code->expr->ts.type != BT_LOGICAL
5967 || code->expr->rank != 0))
5968 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5969 &code->expr->where);
5974 resolve_call (code);
5978 /* Select is complicated. Also, a SELECT construct could be
5979 a transformed computed GOTO. */
5980 resolve_select (code);
5984 if (code->ext.iterator != NULL)
5986 gfc_iterator *iter = code->ext.iterator;
5987 if (gfc_resolve_iterator (iter, true) != FAILURE)
5988 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5993 if (code->expr == NULL)
5994 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5996 && (code->expr->rank != 0
5997 || code->expr->ts.type != BT_LOGICAL))
5998 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5999 "a scalar LOGICAL expression", &code->expr->where);
6003 if (t == SUCCESS && code->expr != NULL
6004 && code->expr->ts.type != BT_INTEGER)
6005 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6006 "of type INTEGER", &code->expr->where);
6008 for (a = code->ext.alloc_list; a; a = a->next)
6009 resolve_allocate_expr (a->expr, code);
6013 case EXEC_DEALLOCATE:
6014 if (t == SUCCESS && code->expr != NULL
6015 && code->expr->ts.type != BT_INTEGER)
6017 ("STAT tag in DEALLOCATE statement at %L must be of type "
6018 "INTEGER", &code->expr->where);
6020 for (a = code->ext.alloc_list; a; a = a->next)
6021 resolve_deallocate_expr (a->expr);
6026 if (gfc_resolve_open (code->ext.open) == FAILURE)
6029 resolve_branch (code->ext.open->err, code);
6033 if (gfc_resolve_close (code->ext.close) == FAILURE)
6036 resolve_branch (code->ext.close->err, code);
6039 case EXEC_BACKSPACE:
6043 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6046 resolve_branch (code->ext.filepos->err, code);
6050 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6053 resolve_branch (code->ext.inquire->err, code);
6057 gcc_assert (code->ext.inquire != NULL);
6058 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6061 resolve_branch (code->ext.inquire->err, code);
6066 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6069 resolve_branch (code->ext.dt->err, code);
6070 resolve_branch (code->ext.dt->end, code);
6071 resolve_branch (code->ext.dt->eor, code);
6075 resolve_transfer (code);
6079 resolve_forall_iterators (code->ext.forall_iterator);
6081 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6082 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6083 "expression", &code->expr->where);
6086 case EXEC_OMP_ATOMIC:
6087 case EXEC_OMP_BARRIER:
6088 case EXEC_OMP_CRITICAL:
6089 case EXEC_OMP_FLUSH:
6091 case EXEC_OMP_MASTER:
6092 case EXEC_OMP_ORDERED:
6093 case EXEC_OMP_SECTIONS:
6094 case EXEC_OMP_SINGLE:
6095 case EXEC_OMP_WORKSHARE:
6096 gfc_resolve_omp_directive (code, ns);
6099 case EXEC_OMP_PARALLEL:
6100 case EXEC_OMP_PARALLEL_DO:
6101 case EXEC_OMP_PARALLEL_SECTIONS:
6102 case EXEC_OMP_PARALLEL_WORKSHARE:
6103 omp_workshare_save = omp_workshare_flag;
6104 omp_workshare_flag = 0;
6105 gfc_resolve_omp_directive (code, ns);
6106 omp_workshare_flag = omp_workshare_save;
6110 gfc_internal_error ("resolve_code(): Bad statement code");
6114 cs_base = frame.prev;
6118 /* Resolve initial values and make sure they are compatible with
6122 resolve_values (gfc_symbol *sym)
6124 if (sym->value == NULL)
6127 if (gfc_resolve_expr (sym->value) == FAILURE)
6130 gfc_check_assign_symbol (sym, sym->value);
6134 /* Verify the binding labels for common blocks that are BIND(C). The label
6135 for a BIND(C) common block must be identical in all scoping units in which
6136 the common block is declared. Further, the binding label can not collide
6137 with any other global entity in the program. */
6140 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6142 if (comm_block_tree->n.common->is_bind_c == 1)
6144 gfc_gsymbol *binding_label_gsym;
6145 gfc_gsymbol *comm_name_gsym;
6147 /* See if a global symbol exists by the common block's name. It may
6148 be NULL if the common block is use-associated. */
6149 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6150 comm_block_tree->n.common->name);
6151 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6152 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6153 "with the global entity '%s' at %L",
6154 comm_block_tree->n.common->binding_label,
6155 comm_block_tree->n.common->name,
6156 &(comm_block_tree->n.common->where),
6157 comm_name_gsym->name, &(comm_name_gsym->where));
6158 else if (comm_name_gsym != NULL
6159 && strcmp (comm_name_gsym->name,
6160 comm_block_tree->n.common->name) == 0)
6162 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6164 if (comm_name_gsym->binding_label == NULL)
6165 /* No binding label for common block stored yet; save this one. */
6166 comm_name_gsym->binding_label =
6167 comm_block_tree->n.common->binding_label;
6169 if (strcmp (comm_name_gsym->binding_label,
6170 comm_block_tree->n.common->binding_label) != 0)
6172 /* Common block names match but binding labels do not. */
6173 gfc_error ("Binding label '%s' for common block '%s' at %L "
6174 "does not match the binding label '%s' for common "
6176 comm_block_tree->n.common->binding_label,
6177 comm_block_tree->n.common->name,
6178 &(comm_block_tree->n.common->where),
6179 comm_name_gsym->binding_label,
6180 comm_name_gsym->name,
6181 &(comm_name_gsym->where));
6186 /* There is no binding label (NAME="") so we have nothing further to
6187 check and nothing to add as a global symbol for the label. */
6188 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6191 binding_label_gsym =
6192 gfc_find_gsymbol (gfc_gsym_root,
6193 comm_block_tree->n.common->binding_label);
6194 if (binding_label_gsym == NULL)
6196 /* Need to make a global symbol for the binding label to prevent
6197 it from colliding with another. */
6198 binding_label_gsym =
6199 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6200 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6201 binding_label_gsym->type = GSYM_COMMON;
6205 /* If comm_name_gsym is NULL, the name common block is use
6206 associated and the name could be colliding. */
6207 if (binding_label_gsym->type != GSYM_COMMON)
6208 gfc_error ("Binding label '%s' for common block '%s' at %L "
6209 "collides with the global entity '%s' at %L",
6210 comm_block_tree->n.common->binding_label,
6211 comm_block_tree->n.common->name,
6212 &(comm_block_tree->n.common->where),
6213 binding_label_gsym->name,
6214 &(binding_label_gsym->where));
6215 else if (comm_name_gsym != NULL
6216 && (strcmp (binding_label_gsym->name,
6217 comm_name_gsym->binding_label) != 0)
6218 && (strcmp (binding_label_gsym->sym_name,
6219 comm_name_gsym->name) != 0))
6220 gfc_error ("Binding label '%s' for common block '%s' at %L "
6221 "collides with global entity '%s' at %L",
6222 binding_label_gsym->name, binding_label_gsym->sym_name,
6223 &(comm_block_tree->n.common->where),
6224 comm_name_gsym->name, &(comm_name_gsym->where));
6232 /* Verify any BIND(C) derived types in the namespace so we can report errors
6233 for them once, rather than for each variable declared of that type. */
6236 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6238 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6239 && derived_sym->attr.is_bind_c == 1)
6240 verify_bind_c_derived_type (derived_sym);
6246 /* Verify that any binding labels used in a given namespace do not collide
6247 with the names or binding labels of any global symbols. */
6250 gfc_verify_binding_labels (gfc_symbol *sym)
6254 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6255 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6257 gfc_gsymbol *bind_c_sym;
6259 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6260 if (bind_c_sym != NULL
6261 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6263 if (sym->attr.if_source == IFSRC_DECL
6264 && (bind_c_sym->type != GSYM_SUBROUTINE
6265 && bind_c_sym->type != GSYM_FUNCTION)
6266 && ((sym->attr.contained == 1
6267 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6268 || (sym->attr.use_assoc == 1
6269 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6271 /* Make sure global procedures don't collide with anything. */
6272 gfc_error ("Binding label '%s' at %L collides with the global "
6273 "entity '%s' at %L", sym->binding_label,
6274 &(sym->declared_at), bind_c_sym->name,
6275 &(bind_c_sym->where));
6278 else if (sym->attr.contained == 0
6279 && (sym->attr.if_source == IFSRC_IFBODY
6280 && sym->attr.flavor == FL_PROCEDURE)
6281 && (bind_c_sym->sym_name != NULL
6282 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6284 /* Make sure procedures in interface bodies don't collide. */
6285 gfc_error ("Binding label '%s' in interface body at %L collides "
6286 "with the global entity '%s' at %L",
6288 &(sym->declared_at), bind_c_sym->name,
6289 &(bind_c_sym->where));
6292 else if (sym->attr.contained == 0
6293 && (sym->attr.if_source == IFSRC_UNKNOWN))
6294 if ((sym->attr.use_assoc
6295 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6296 || sym->attr.use_assoc == 0)
6298 gfc_error ("Binding label '%s' at %L collides with global "
6299 "entity '%s' at %L", sym->binding_label,
6300 &(sym->declared_at), bind_c_sym->name,
6301 &(bind_c_sym->where));
6306 /* Clear the binding label to prevent checking multiple times. */
6307 sym->binding_label[0] = '\0';
6309 else if (bind_c_sym == NULL)
6311 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6312 bind_c_sym->where = sym->declared_at;
6313 bind_c_sym->sym_name = sym->name;
6315 if (sym->attr.use_assoc == 1)
6316 bind_c_sym->mod_name = sym->module;
6318 if (sym->ns->proc_name != NULL)
6319 bind_c_sym->mod_name = sym->ns->proc_name->name;
6321 if (sym->attr.contained == 0)
6323 if (sym->attr.subroutine)
6324 bind_c_sym->type = GSYM_SUBROUTINE;
6325 else if (sym->attr.function)
6326 bind_c_sym->type = GSYM_FUNCTION;
6334 /* Resolve an index expression. */
6337 resolve_index_expr (gfc_expr *e)
6339 if (gfc_resolve_expr (e) == FAILURE)
6342 if (gfc_simplify_expr (e, 0) == FAILURE)
6345 if (gfc_specification_expr (e) == FAILURE)
6351 /* Resolve a charlen structure. */
6354 resolve_charlen (gfc_charlen *cl)
6363 specification_expr = 1;
6365 if (resolve_index_expr (cl->length) == FAILURE)
6367 specification_expr = 0;
6371 /* "If the character length parameter value evaluates to a negative
6372 value, the length of character entities declared is zero." */
6373 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6375 gfc_warning_now ("CHARACTER variable has zero length at %L",
6376 &cl->length->where);
6377 gfc_replace_expr (cl->length, gfc_int_expr (0));
6384 /* Test for non-constant shape arrays. */
6387 is_non_constant_shape_array (gfc_symbol *sym)
6393 not_constant = false;
6394 if (sym->as != NULL)
6396 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6397 has not been simplified; parameter array references. Do the
6398 simplification now. */
6399 for (i = 0; i < sym->as->rank; i++)
6401 e = sym->as->lower[i];
6402 if (e && (resolve_index_expr (e) == FAILURE
6403 || !gfc_is_constant_expr (e)))
6404 not_constant = true;
6406 e = sym->as->upper[i];
6407 if (e && (resolve_index_expr (e) == FAILURE
6408 || !gfc_is_constant_expr (e)))
6409 not_constant = true;
6412 return not_constant;
6416 /* Assign the default initializer to a derived type variable or result. */
6419 apply_default_init (gfc_symbol *sym)
6422 gfc_expr *init = NULL;
6424 gfc_namespace *ns = sym->ns;
6426 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6429 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6430 init = gfc_default_initializer (&sym->ts);
6435 /* Search for the function namespace if this is a contained
6436 function without an explicit result. */
6437 if (sym->attr.function && sym == sym->result
6438 && sym->name != sym->ns->proc_name->name)
6441 for (;ns; ns = ns->sibling)
6442 if (strcmp (ns->proc_name->name, sym->name) == 0)
6448 gfc_free_expr (init);
6452 /* Build an l-value expression for the result. */
6453 lval = gfc_lval_expr_from_sym (sym);
6455 /* Add the code at scope entry. */
6456 init_st = gfc_get_code ();
6457 init_st->next = ns->code;
6460 /* Assign the default initializer to the l-value. */
6461 init_st->loc = sym->declared_at;
6462 init_st->op = EXEC_INIT_ASSIGN;
6463 init_st->expr = lval;
6464 init_st->expr2 = init;
6468 /* Resolution of common features of flavors variable and procedure. */
6471 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6473 /* Constraints on deferred shape variable. */
6474 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6476 if (sym->attr.allocatable)
6478 if (sym->attr.dimension)
6479 gfc_error ("Allocatable array '%s' at %L must have "
6480 "a deferred shape", sym->name, &sym->declared_at);
6482 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6483 sym->name, &sym->declared_at);
6487 if (sym->attr.pointer && sym->attr.dimension)
6489 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6490 sym->name, &sym->declared_at);
6497 if (!mp_flag && !sym->attr.allocatable
6498 && !sym->attr.pointer && !sym->attr.dummy)
6500 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6501 sym->name, &sym->declared_at);
6509 /* Resolve symbols with flavor variable. */
6512 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6518 const char *auto_save_msg;
6520 auto_save_msg = "automatic object '%s' at %L cannot have the "
6523 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6526 /* Set this flag to check that variables are parameters of all entries.
6527 This check is effected by the call to gfc_resolve_expr through
6528 is_non_constant_shape_array. */
6529 specification_expr = 1;
6531 if (!sym->attr.use_assoc
6532 && !sym->attr.allocatable
6533 && !sym->attr.pointer
6534 && is_non_constant_shape_array (sym))
6536 /* The shape of a main program or module array needs to be
6538 if (sym->ns->proc_name
6539 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6540 || sym->ns->proc_name->attr.is_main_program))
6542 gfc_error ("The module or main program array '%s' at %L must "
6543 "have constant shape", sym->name, &sym->declared_at);
6544 specification_expr = 0;
6549 if (sym->ts.type == BT_CHARACTER)
6551 /* Make sure that character string variables with assumed length are
6553 e = sym->ts.cl->length;
6554 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6556 gfc_error ("Entity with assumed character length at %L must be a "
6557 "dummy argument or a PARAMETER", &sym->declared_at);
6561 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6563 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6567 if (!gfc_is_constant_expr (e)
6568 && !(e->expr_type == EXPR_VARIABLE
6569 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6570 && sym->ns->proc_name
6571 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6572 || sym->ns->proc_name->attr.is_main_program)
6573 && !sym->attr.use_assoc)
6575 gfc_error ("'%s' at %L must have constant character length "
6576 "in this context", sym->name, &sym->declared_at);
6581 /* Can the symbol have an initializer? */
6583 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6584 || sym->attr.intrinsic || sym->attr.result)
6586 else if (sym->attr.dimension && !sym->attr.pointer)
6588 /* Don't allow initialization of automatic arrays. */
6589 for (i = 0; i < sym->as->rank; i++)
6591 if (sym->as->lower[i] == NULL
6592 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6593 || sym->as->upper[i] == NULL
6594 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6601 /* Also, they must not have the SAVE attribute.
6602 SAVE_IMPLICIT is checked below. */
6603 if (flag && sym->attr.save == SAVE_EXPLICIT)
6605 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6610 /* Reject illegal initializers. */
6611 if (!sym->mark && sym->value && flag)
6613 if (sym->attr.allocatable)
6614 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6615 sym->name, &sym->declared_at);
6616 else if (sym->attr.external)
6617 gfc_error ("External '%s' at %L cannot have an initializer",
6618 sym->name, &sym->declared_at);
6619 else if (sym->attr.dummy
6620 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6621 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6622 sym->name, &sym->declared_at);
6623 else if (sym->attr.intrinsic)
6624 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6625 sym->name, &sym->declared_at);
6626 else if (sym->attr.result)
6627 gfc_error ("Function result '%s' at %L cannot have an initializer",
6628 sym->name, &sym->declared_at);
6630 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6631 sym->name, &sym->declared_at);
6638 /* Check to see if a derived type is blocked from being host associated
6639 by the presence of another class I symbol in the same namespace.
6640 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6641 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6642 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6645 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6646 if (s && (s->attr.flavor != FL_DERIVED
6647 || !gfc_compare_derived_types (s, sym->ts.derived)))
6649 gfc_error ("The type %s cannot be host associated at %L because "
6650 "it is blocked by an incompatible object of the same "
6651 "name at %L", sym->ts.derived->name, &sym->declared_at,
6657 /* Do not use gfc_default_initializer to test for a default initializer
6658 in the fortran because it generates a hidden default for allocatable
6661 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6662 c = has_default_initializer (sym->ts.derived);
6664 /* 4th constraint in section 11.3: "If an object of a type for which
6665 component-initialization is specified (R429) appears in the
6666 specification-part of a module and does not have the ALLOCATABLE
6667 or POINTER attribute, the object shall have the SAVE attribute." */
6668 if (c && sym->ns->proc_name
6669 && sym->ns->proc_name->attr.flavor == FL_MODULE
6670 && !sym->ns->save_all && !sym->attr.save
6671 && !sym->attr.pointer && !sym->attr.allocatable)
6673 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6674 sym->name, &sym->declared_at,
6675 "for default initialization of a component");
6679 /* Assign default initializer. */
6680 if (sym->ts.type == BT_DERIVED
6682 && !sym->attr.pointer
6683 && !sym->attr.allocatable
6684 && (!flag || sym->attr.intent == INTENT_OUT))
6685 sym->value = gfc_default_initializer (&sym->ts);
6691 /* Resolve a procedure. */
6694 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6696 gfc_formal_arglist *arg;
6698 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6699 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6700 "interfaces", sym->name, &sym->declared_at);
6702 if (sym->attr.function
6703 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6706 if (sym->ts.type == BT_CHARACTER)
6708 gfc_charlen *cl = sym->ts.cl;
6710 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6711 && resolve_charlen (cl) == FAILURE)
6714 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6716 if (sym->attr.proc == PROC_ST_FUNCTION)
6718 gfc_error ("Character-valued statement function '%s' at %L must "
6719 "have constant length", sym->name, &sym->declared_at);
6723 if (sym->attr.external && sym->formal == NULL
6724 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6726 gfc_error ("Automatic character length function '%s' at %L must "
6727 "have an explicit interface", sym->name,
6734 /* Ensure that derived type for are not of a private type. Internal
6735 module procedures are excluded by 2.2.3.3 - ie. they are not
6736 externally accessible and can access all the objects accessible in
6738 if (!(sym->ns->parent
6739 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6740 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6742 gfc_interface *iface;
6744 for (arg = sym->formal; arg; arg = arg->next)
6747 && arg->sym->ts.type == BT_DERIVED
6748 && !arg->sym->ts.derived->attr.use_assoc
6749 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6750 arg->sym->ts.derived->ns->default_access))
6752 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6753 "a dummy argument of '%s', which is "
6754 "PUBLIC at %L", arg->sym->name, sym->name,
6756 /* Stop this message from recurring. */
6757 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6762 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6763 PRIVATE to the containing module. */
6764 for (iface = sym->generic; iface; iface = iface->next)
6766 for (arg = iface->sym->formal; arg; arg = arg->next)
6769 && arg->sym->ts.type == BT_DERIVED
6770 && !arg->sym->ts.derived->attr.use_assoc
6771 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6772 arg->sym->ts.derived->ns->default_access))
6774 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6775 "dummy arguments of '%s' which is PRIVATE",
6776 iface->sym->name, sym->name, &iface->sym->declared_at,
6777 gfc_typename(&arg->sym->ts));
6778 /* Stop this message from recurring. */
6779 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6785 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6786 PRIVATE to the containing module. */
6787 for (iface = sym->generic; iface; iface = iface->next)
6789 for (arg = iface->sym->formal; arg; arg = arg->next)
6792 && arg->sym->ts.type == BT_DERIVED
6793 && !arg->sym->ts.derived->attr.use_assoc
6794 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6795 arg->sym->ts.derived->ns->default_access))
6797 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6798 "dummy arguments of '%s' which is PRIVATE",
6799 iface->sym->name, sym->name, &iface->sym->declared_at,
6800 gfc_typename(&arg->sym->ts));
6801 /* Stop this message from recurring. */
6802 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6809 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
6811 gfc_error ("Function '%s' at %L cannot have an initializer",
6812 sym->name, &sym->declared_at);
6816 /* An external symbol may not have an initializer because it is taken to be
6818 if (sym->attr.external && sym->value)
6820 gfc_error ("External object '%s' at %L may not have an initializer",
6821 sym->name, &sym->declared_at);
6825 /* An elemental function is required to return a scalar 12.7.1 */
6826 if (sym->attr.elemental && sym->attr.function && sym->as)
6828 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6829 "result", sym->name, &sym->declared_at);
6830 /* Reset so that the error only occurs once. */
6831 sym->attr.elemental = 0;
6835 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6836 char-len-param shall not be array-valued, pointer-valued, recursive
6837 or pure. ....snip... A character value of * may only be used in the
6838 following ways: (i) Dummy arg of procedure - dummy associates with
6839 actual length; (ii) To declare a named constant; or (iii) External
6840 function - but length must be declared in calling scoping unit. */
6841 if (sym->attr.function
6842 && sym->ts.type == BT_CHARACTER
6843 && sym->ts.cl && sym->ts.cl->length == NULL)
6845 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6846 || (sym->attr.recursive) || (sym->attr.pure))
6848 if (sym->as && sym->as->rank)
6849 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6850 "array-valued", sym->name, &sym->declared_at);
6852 if (sym->attr.pointer)
6853 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6854 "pointer-valued", sym->name, &sym->declared_at);
6857 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6858 "pure", sym->name, &sym->declared_at);
6860 if (sym->attr.recursive)
6861 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6862 "recursive", sym->name, &sym->declared_at);
6867 /* Appendix B.2 of the standard. Contained functions give an
6868 error anyway. Fixed-form is likely to be F77/legacy. */
6869 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6870 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6871 "'%s' at %L is obsolescent in fortran 95",
6872 sym->name, &sym->declared_at);
6875 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6877 gfc_formal_arglist *curr_arg;
6878 int has_non_interop_arg = 0;
6880 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6881 sym->common_block) == FAILURE)
6883 /* Clear these to prevent looking at them again if there was an
6885 sym->attr.is_bind_c = 0;
6886 sym->attr.is_c_interop = 0;
6887 sym->ts.is_c_interop = 0;
6891 /* So far, no errors have been found. */
6892 sym->attr.is_c_interop = 1;
6893 sym->ts.is_c_interop = 1;
6896 curr_arg = sym->formal;
6897 while (curr_arg != NULL)
6899 /* Skip implicitly typed dummy args here. */
6900 if (curr_arg->sym->attr.implicit_type == 0)
6901 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
6902 /* If something is found to fail, record the fact so we
6903 can mark the symbol for the procedure as not being
6904 BIND(C) to try and prevent multiple errors being
6906 has_non_interop_arg = 1;
6908 curr_arg = curr_arg->next;
6911 /* See if any of the arguments were not interoperable and if so, clear
6912 the procedure symbol to prevent duplicate error messages. */
6913 if (has_non_interop_arg != 0)
6915 sym->attr.is_c_interop = 0;
6916 sym->ts.is_c_interop = 0;
6917 sym->attr.is_bind_c = 0;
6925 /* Resolve the components of a derived type. */
6928 resolve_fl_derived (gfc_symbol *sym)
6931 gfc_dt_list * dt_list;
6934 for (c = sym->components; c != NULL; c = c->next)
6936 if (c->ts.type == BT_CHARACTER)
6938 if (c->ts.cl->length == NULL
6939 || (resolve_charlen (c->ts.cl) == FAILURE)
6940 || !gfc_is_constant_expr (c->ts.cl->length))
6942 gfc_error ("Character length of component '%s' needs to "
6943 "be a constant specification expression at %L",
6945 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6950 if (c->ts.type == BT_DERIVED
6951 && sym->component_access != ACCESS_PRIVATE
6952 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6953 && !c->ts.derived->attr.use_assoc
6954 && !gfc_check_access (c->ts.derived->attr.access,
6955 c->ts.derived->ns->default_access))
6957 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6958 "a component of '%s', which is PUBLIC at %L",
6959 c->name, sym->name, &sym->declared_at);
6963 if (sym->attr.sequence)
6965 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6967 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6968 "not have the SEQUENCE attribute",
6969 c->ts.derived->name, &sym->declared_at);
6974 if (c->ts.type == BT_DERIVED && c->pointer
6975 && c->ts.derived->components == NULL)
6977 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6978 "that has not been declared", c->name, sym->name,
6983 if (c->pointer || c->allocatable || c->as == NULL)
6986 for (i = 0; i < c->as->rank; i++)
6988 if (c->as->lower[i] == NULL
6989 || !gfc_is_constant_expr (c->as->lower[i])
6990 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6991 || c->as->upper[i] == NULL
6992 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6993 || !gfc_is_constant_expr (c->as->upper[i]))
6995 gfc_error ("Component '%s' of '%s' at %L must have "
6996 "constant array bounds",
6997 c->name, sym->name, &c->loc);
7003 /* Add derived type to the derived type list. */
7004 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7005 if (sym == dt_list->derived)
7008 if (dt_list == NULL)
7010 dt_list = gfc_get_dt_list ();
7011 dt_list->next = gfc_derived_types;
7012 dt_list->derived = sym;
7013 gfc_derived_types = dt_list;
7021 resolve_fl_namelist (gfc_symbol *sym)
7026 /* Reject PRIVATE objects in a PUBLIC namelist. */
7027 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7029 for (nl = sym->namelist; nl; nl = nl->next)
7031 if (!nl->sym->attr.use_assoc
7032 && !(sym->ns->parent == nl->sym->ns)
7033 && !(sym->ns->parent
7034 && sym->ns->parent->parent == nl->sym->ns)
7035 && !gfc_check_access(nl->sym->attr.access,
7036 nl->sym->ns->default_access))
7038 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7039 "cannot be member of PUBLIC namelist '%s' at %L",
7040 nl->sym->name, sym->name, &sym->declared_at);
7044 /* Types with private components that came here by USE-association. */
7045 if (nl->sym->ts.type == BT_DERIVED
7046 && derived_inaccessible (nl->sym->ts.derived))
7048 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7049 "components and cannot be member of namelist '%s' at %L",
7050 nl->sym->name, sym->name, &sym->declared_at);
7054 /* Types with private components that are defined in the same module. */
7055 if (nl->sym->ts.type == BT_DERIVED
7056 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7057 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7058 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7059 nl->sym->ns->default_access))
7061 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7062 "cannot be a member of PUBLIC namelist '%s' at %L",
7063 nl->sym->name, sym->name, &sym->declared_at);
7069 for (nl = sym->namelist; nl; nl = nl->next)
7071 /* Reject namelist arrays of assumed shape. */
7072 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7073 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7074 "must not have assumed shape in namelist "
7075 "'%s' at %L", nl->sym->name, sym->name,
7076 &sym->declared_at) == FAILURE)
7079 /* Reject namelist arrays that are not constant shape. */
7080 if (is_non_constant_shape_array (nl->sym))
7082 gfc_error ("NAMELIST array object '%s' must have constant "
7083 "shape in namelist '%s' at %L", nl->sym->name,
7084 sym->name, &sym->declared_at);
7088 /* Namelist objects cannot have allocatable or pointer components. */
7089 if (nl->sym->ts.type != BT_DERIVED)
7092 if (nl->sym->ts.derived->attr.alloc_comp)
7094 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7095 "have ALLOCATABLE components",
7096 nl->sym->name, sym->name, &sym->declared_at);
7100 if (nl->sym->ts.derived->attr.pointer_comp)
7102 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7103 "have POINTER components",
7104 nl->sym->name, sym->name, &sym->declared_at);
7110 /* 14.1.2 A module or internal procedure represent local entities
7111 of the same type as a namelist member and so are not allowed. */
7112 for (nl = sym->namelist; nl; nl = nl->next)
7114 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7117 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7118 if ((nl->sym == sym->ns->proc_name)
7120 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7124 if (nl->sym && nl->sym->name)
7125 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7126 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7128 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7129 "attribute in '%s' at %L", nlsym->name,
7140 resolve_fl_parameter (gfc_symbol *sym)
7142 /* A parameter array's shape needs to be constant. */
7144 && (sym->as->type == AS_DEFERRED
7145 || is_non_constant_shape_array (sym)))
7147 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7148 "or of deferred shape", sym->name, &sym->declared_at);
7152 /* Make sure a parameter that has been implicitly typed still
7153 matches the implicit type, since PARAMETER statements can precede
7154 IMPLICIT statements. */
7155 if (sym->attr.implicit_type
7156 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7158 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7159 "later IMPLICIT type", sym->name, &sym->declared_at);
7163 /* Make sure the types of derived parameters are consistent. This
7164 type checking is deferred until resolution because the type may
7165 refer to a derived type from the host. */
7166 if (sym->ts.type == BT_DERIVED
7167 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7169 gfc_error ("Incompatible derived type in PARAMETER at %L",
7170 &sym->value->where);
7177 /* Do anything necessary to resolve a symbol. Right now, we just
7178 assume that an otherwise unknown symbol is a variable. This sort
7179 of thing commonly happens for symbols in module. */
7182 resolve_symbol (gfc_symbol *sym)
7184 int check_constant, mp_flag;
7185 gfc_symtree *symtree;
7186 gfc_symtree *this_symtree;
7190 if (sym->attr.flavor == FL_UNKNOWN)
7193 /* If we find that a flavorless symbol is an interface in one of the
7194 parent namespaces, find its symtree in this namespace, free the
7195 symbol and set the symtree to point to the interface symbol. */
7196 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7198 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7199 if (symtree && symtree->n.sym->generic)
7201 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7205 gfc_free_symbol (sym);
7206 symtree->n.sym->refs++;
7207 this_symtree->n.sym = symtree->n.sym;
7212 /* Otherwise give it a flavor according to such attributes as
7214 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7215 sym->attr.flavor = FL_VARIABLE;
7218 sym->attr.flavor = FL_PROCEDURE;
7219 if (sym->attr.dimension)
7220 sym->attr.function = 1;
7224 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7227 /* Symbols that are module procedures with results (functions) have
7228 the types and array specification copied for type checking in
7229 procedures that call them, as well as for saving to a module
7230 file. These symbols can't stand the scrutiny that their results
7232 mp_flag = (sym->result != NULL && sym->result != sym);
7235 /* Make sure that the intrinsic is consistent with its internal
7236 representation. This needs to be done before assigning a default
7237 type to avoid spurious warnings. */
7238 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7240 if (gfc_intrinsic_name (sym->name, 0))
7242 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7243 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7244 sym->name, &sym->declared_at);
7246 else if (gfc_intrinsic_name (sym->name, 1))
7248 if (sym->ts.type != BT_UNKNOWN)
7250 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7251 sym->name, &sym->declared_at);
7257 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7262 /* Assign default type to symbols that need one and don't have one. */
7263 if (sym->ts.type == BT_UNKNOWN)
7265 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7266 gfc_set_default_type (sym, 1, NULL);
7268 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7270 /* The specific case of an external procedure should emit an error
7271 in the case that there is no implicit type. */
7273 gfc_set_default_type (sym, sym->attr.external, NULL);
7276 /* Result may be in another namespace. */
7277 resolve_symbol (sym->result);
7279 sym->ts = sym->result->ts;
7280 sym->as = gfc_copy_array_spec (sym->result->as);
7281 sym->attr.dimension = sym->result->attr.dimension;
7282 sym->attr.pointer = sym->result->attr.pointer;
7283 sym->attr.allocatable = sym->result->attr.allocatable;
7288 /* Assumed size arrays and assumed shape arrays must be dummy
7292 && (sym->as->type == AS_ASSUMED_SIZE
7293 || sym->as->type == AS_ASSUMED_SHAPE)
7294 && sym->attr.dummy == 0)
7296 if (sym->as->type == AS_ASSUMED_SIZE)
7297 gfc_error ("Assumed size array at %L must be a dummy argument",
7300 gfc_error ("Assumed shape array at %L must be a dummy argument",
7305 /* Make sure symbols with known intent or optional are really dummy
7306 variable. Because of ENTRY statement, this has to be deferred
7307 until resolution time. */
7309 if (!sym->attr.dummy
7310 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7312 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7316 if (sym->attr.value && !sym->attr.dummy)
7318 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7319 "it is not a dummy argument", sym->name, &sym->declared_at);
7323 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7325 gfc_charlen *cl = sym->ts.cl;
7326 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7328 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7329 "attribute must have constant length",
7330 sym->name, &sym->declared_at);
7334 if (sym->ts.is_c_interop
7335 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7337 gfc_error ("C interoperable character dummy variable '%s' at %L "
7338 "with VALUE attribute must have length one",
7339 sym->name, &sym->declared_at);
7344 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7345 do this for something that was implicitly typed because that is handled
7346 in gfc_set_default_type. Handle dummy arguments and procedure
7347 definitions separately. Also, anything that is use associated is not
7348 handled here but instead is handled in the module it is declared in.
7349 Finally, derived type definitions are allowed to be BIND(C) since that
7350 only implies that they're interoperable, and they are checked fully for
7351 interoperability when a variable is declared of that type. */
7352 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7353 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7354 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7358 /* First, make sure the variable is declared at the
7359 module-level scope (J3/04-007, Section 15.3). */
7360 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7361 sym->attr.in_common == 0)
7363 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7364 "is neither a COMMON block nor declared at the "
7365 "module level scope", sym->name, &(sym->declared_at));
7368 else if (sym->common_head != NULL)
7370 t = verify_com_block_vars_c_interop (sym->common_head);
7374 /* If type() declaration, we need to verify that the components
7375 of the given type are all C interoperable, etc. */
7376 if (sym->ts.type == BT_DERIVED &&
7377 sym->ts.derived->attr.is_c_interop != 1)
7379 /* Make sure the user marked the derived type as BIND(C). If
7380 not, call the verify routine. This could print an error
7381 for the derived type more than once if multiple variables
7382 of that type are declared. */
7383 if (sym->ts.derived->attr.is_bind_c != 1)
7384 verify_bind_c_derived_type (sym->ts.derived);
7388 /* Verify the variable itself as C interoperable if it
7389 is BIND(C). It is not possible for this to succeed if
7390 the verify_bind_c_derived_type failed, so don't have to handle
7391 any error returned by verify_bind_c_derived_type. */
7392 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7398 /* clear the is_bind_c flag to prevent reporting errors more than
7399 once if something failed. */
7400 sym->attr.is_bind_c = 0;
7405 /* If a derived type symbol has reached this point, without its
7406 type being declared, we have an error. Notice that most
7407 conditions that produce undefined derived types have already
7408 been dealt with. However, the likes of:
7409 implicit type(t) (t) ..... call foo (t) will get us here if
7410 the type is not declared in the scope of the implicit
7411 statement. Change the type to BT_UNKNOWN, both because it is so
7412 and to prevent an ICE. */
7413 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7415 gfc_error ("The derived type '%s' at %L is of type '%s', "
7416 "which has not been defined", sym->name,
7417 &sym->declared_at, sym->ts.derived->name);
7418 sym->ts.type = BT_UNKNOWN;
7422 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7423 default initialization is defined (5.1.2.4.4). */
7424 if (sym->ts.type == BT_DERIVED
7426 && sym->attr.intent == INTENT_OUT
7428 && sym->as->type == AS_ASSUMED_SIZE)
7430 for (c = sym->ts.derived->components; c; c = c->next)
7434 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7435 "ASSUMED SIZE and so cannot have a default initializer",
7436 sym->name, &sym->declared_at);
7442 switch (sym->attr.flavor)
7445 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7450 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7455 if (resolve_fl_namelist (sym) == FAILURE)
7460 if (resolve_fl_parameter (sym) == FAILURE)
7468 /* Resolve array specifier. Check as well some constraints
7469 on COMMON blocks. */
7471 check_constant = sym->attr.in_common && !sym->attr.pointer;
7473 /* Set the formal_arg_flag so that check_conflict will not throw
7474 an error for host associated variables in the specification
7475 expression for an array_valued function. */
7476 if (sym->attr.function && sym->as)
7477 formal_arg_flag = 1;
7479 gfc_resolve_array_spec (sym->as, check_constant);
7481 formal_arg_flag = 0;
7483 /* Resolve formal namespaces. */
7484 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7485 gfc_resolve (sym->formal_ns);
7487 /* Check threadprivate restrictions. */
7488 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7489 && (!sym->attr.in_common
7490 && sym->module == NULL
7491 && (sym->ns->proc_name == NULL
7492 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7493 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7495 /* If we have come this far we can apply default-initializers, as
7496 described in 14.7.5, to those variables that have not already
7497 been assigned one. */
7498 if (sym->ts.type == BT_DERIVED
7499 && sym->attr.referenced
7500 && sym->ns == gfc_current_ns
7502 && !sym->attr.allocatable
7503 && !sym->attr.alloc_comp)
7505 symbol_attribute *a = &sym->attr;
7507 if ((!a->save && !a->dummy && !a->pointer
7508 && !a->in_common && !a->use_assoc
7509 && !(a->function && sym != sym->result))
7510 || (a->dummy && a->intent == INTENT_OUT))
7511 apply_default_init (sym);
7516 /************* Resolve DATA statements *************/
7520 gfc_data_value *vnode;
7526 /* Advance the values structure to point to the next value in the data list. */
7529 next_data_value (void)
7531 while (values.left == 0)
7533 if (values.vnode->next == NULL)
7536 values.vnode = values.vnode->next;
7537 values.left = values.vnode->repeat;
7545 check_data_variable (gfc_data_variable *var, locus *where)
7551 ar_type mark = AR_UNKNOWN;
7553 mpz_t section_index[GFC_MAX_DIMENSIONS];
7557 if (gfc_resolve_expr (var->expr) == FAILURE)
7561 mpz_init_set_si (offset, 0);
7564 if (e->expr_type != EXPR_VARIABLE)
7565 gfc_internal_error ("check_data_variable(): Bad expression");
7567 if (e->symtree->n.sym->ns->is_block_data
7568 && !e->symtree->n.sym->attr.in_common)
7570 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7571 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7576 mpz_init_set_ui (size, 1);
7583 /* Find the array section reference. */
7584 for (ref = e->ref; ref; ref = ref->next)
7586 if (ref->type != REF_ARRAY)
7588 if (ref->u.ar.type == AR_ELEMENT)
7594 /* Set marks according to the reference pattern. */
7595 switch (ref->u.ar.type)
7603 /* Get the start position of array section. */
7604 gfc_get_section_index (ar, section_index, &offset);
7612 if (gfc_array_size (e, &size) == FAILURE)
7614 gfc_error ("Nonconstant array section at %L in DATA statement",
7623 while (mpz_cmp_ui (size, 0) > 0)
7625 if (next_data_value () == FAILURE)
7627 gfc_error ("DATA statement at %L has more variables than values",
7633 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7637 /* If we have more than one element left in the repeat count,
7638 and we have more than one element left in the target variable,
7639 then create a range assignment. */
7640 /* ??? Only done for full arrays for now, since array sections
7642 if (mark == AR_FULL && ref && ref->next == NULL
7643 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7647 if (mpz_cmp_ui (size, values.left) >= 0)
7649 mpz_init_set_ui (range, values.left);
7650 mpz_sub_ui (size, size, values.left);
7655 mpz_init_set (range, size);
7656 values.left -= mpz_get_ui (size);
7657 mpz_set_ui (size, 0);
7660 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7663 mpz_add (offset, offset, range);
7667 /* Assign initial value to symbol. */
7671 mpz_sub_ui (size, size, 1);
7673 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7677 if (mark == AR_FULL)
7678 mpz_add_ui (offset, offset, 1);
7680 /* Modify the array section indexes and recalculate the offset
7681 for next element. */
7682 else if (mark == AR_SECTION)
7683 gfc_advance_section (section_index, ar, &offset);
7687 if (mark == AR_SECTION)
7689 for (i = 0; i < ar->dimen; i++)
7690 mpz_clear (section_index[i]);
7700 static try traverse_data_var (gfc_data_variable *, locus *);
7702 /* Iterate over a list of elements in a DATA statement. */
7705 traverse_data_list (gfc_data_variable *var, locus *where)
7708 iterator_stack frame;
7709 gfc_expr *e, *start, *end, *step;
7710 try retval = SUCCESS;
7712 mpz_init (frame.value);
7714 start = gfc_copy_expr (var->iter.start);
7715 end = gfc_copy_expr (var->iter.end);
7716 step = gfc_copy_expr (var->iter.step);
7718 if (gfc_simplify_expr (start, 1) == FAILURE
7719 || start->expr_type != EXPR_CONSTANT)
7721 gfc_error ("iterator start at %L does not simplify", &start->where);
7725 if (gfc_simplify_expr (end, 1) == FAILURE
7726 || end->expr_type != EXPR_CONSTANT)
7728 gfc_error ("iterator end at %L does not simplify", &end->where);
7732 if (gfc_simplify_expr (step, 1) == FAILURE
7733 || step->expr_type != EXPR_CONSTANT)
7735 gfc_error ("iterator step at %L does not simplify", &step->where);
7740 mpz_init_set (trip, end->value.integer);
7741 mpz_sub (trip, trip, start->value.integer);
7742 mpz_add (trip, trip, step->value.integer);
7744 mpz_div (trip, trip, step->value.integer);
7746 mpz_set (frame.value, start->value.integer);
7748 frame.prev = iter_stack;
7749 frame.variable = var->iter.var->symtree;
7750 iter_stack = &frame;
7752 while (mpz_cmp_ui (trip, 0) > 0)
7754 if (traverse_data_var (var->list, where) == FAILURE)
7761 e = gfc_copy_expr (var->expr);
7762 if (gfc_simplify_expr (e, 1) == FAILURE)
7770 mpz_add (frame.value, frame.value, step->value.integer);
7772 mpz_sub_ui (trip, trip, 1);
7777 mpz_clear (frame.value);
7779 gfc_free_expr (start);
7780 gfc_free_expr (end);
7781 gfc_free_expr (step);
7783 iter_stack = frame.prev;
7788 /* Type resolve variables in the variable list of a DATA statement. */
7791 traverse_data_var (gfc_data_variable *var, locus *where)
7795 for (; var; var = var->next)
7797 if (var->expr == NULL)
7798 t = traverse_data_list (var, where);
7800 t = check_data_variable (var, where);
7810 /* Resolve the expressions and iterators associated with a data statement.
7811 This is separate from the assignment checking because data lists should
7812 only be resolved once. */
7815 resolve_data_variables (gfc_data_variable *d)
7817 for (; d; d = d->next)
7819 if (d->list == NULL)
7821 if (gfc_resolve_expr (d->expr) == FAILURE)
7826 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7829 if (resolve_data_variables (d->list) == FAILURE)
7838 /* Resolve a single DATA statement. We implement this by storing a pointer to
7839 the value list into static variables, and then recursively traversing the
7840 variables list, expanding iterators and such. */
7843 resolve_data (gfc_data * d)
7845 if (resolve_data_variables (d->var) == FAILURE)
7848 values.vnode = d->value;
7849 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7851 if (traverse_data_var (d->var, &d->where) == FAILURE)
7854 /* At this point, we better not have any values left. */
7856 if (next_data_value () == SUCCESS)
7857 gfc_error ("DATA statement at %L has more values than variables",
7862 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7863 accessed by host or use association, is a dummy argument to a pure function,
7864 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7865 is storage associated with any such variable, shall not be used in the
7866 following contexts: (clients of this function). */
7868 /* Determines if a variable is not 'pure', ie not assignable within a pure
7869 procedure. Returns zero if assignment is OK, nonzero if there is a
7872 gfc_impure_variable (gfc_symbol *sym)
7876 if (sym->attr.use_assoc || sym->attr.in_common)
7879 if (sym->ns != gfc_current_ns)
7880 return !sym->attr.function;
7882 proc = sym->ns->proc_name;
7883 if (sym->attr.dummy && gfc_pure (proc)
7884 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7886 proc->attr.function))
7889 /* TODO: Sort out what can be storage associated, if anything, and include
7890 it here. In principle equivalences should be scanned but it does not
7891 seem to be possible to storage associate an impure variable this way. */
7896 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7897 symbol of the current procedure. */
7900 gfc_pure (gfc_symbol *sym)
7902 symbol_attribute attr;
7905 sym = gfc_current_ns->proc_name;
7911 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7915 /* Test whether the current procedure is elemental or not. */
7918 gfc_elemental (gfc_symbol *sym)
7920 symbol_attribute attr;
7923 sym = gfc_current_ns->proc_name;
7928 return attr.flavor == FL_PROCEDURE && attr.elemental;
7932 /* Warn about unused labels. */
7935 warn_unused_fortran_label (gfc_st_label *label)
7940 warn_unused_fortran_label (label->left);
7942 if (label->defined == ST_LABEL_UNKNOWN)
7945 switch (label->referenced)
7947 case ST_LABEL_UNKNOWN:
7948 gfc_warning ("Label %d at %L defined but not used", label->value,
7952 case ST_LABEL_BAD_TARGET:
7953 gfc_warning ("Label %d at %L defined but cannot be used",
7954 label->value, &label->where);
7961 warn_unused_fortran_label (label->right);
7965 /* Returns the sequence type of a symbol or sequence. */
7968 sequence_type (gfc_typespec ts)
7977 if (ts.derived->components == NULL)
7978 return SEQ_NONDEFAULT;
7980 result = sequence_type (ts.derived->components->ts);
7981 for (c = ts.derived->components->next; c; c = c->next)
7982 if (sequence_type (c->ts) != result)
7988 if (ts.kind != gfc_default_character_kind)
7989 return SEQ_NONDEFAULT;
7991 return SEQ_CHARACTER;
7994 if (ts.kind != gfc_default_integer_kind)
7995 return SEQ_NONDEFAULT;
8000 if (!(ts.kind == gfc_default_real_kind
8001 || ts.kind == gfc_default_double_kind))
8002 return SEQ_NONDEFAULT;
8007 if (ts.kind != gfc_default_complex_kind)
8008 return SEQ_NONDEFAULT;
8013 if (ts.kind != gfc_default_logical_kind)
8014 return SEQ_NONDEFAULT;
8019 return SEQ_NONDEFAULT;
8024 /* Resolve derived type EQUIVALENCE object. */
8027 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8030 gfc_component *c = derived->components;
8035 /* Shall not be an object of nonsequence derived type. */
8036 if (!derived->attr.sequence)
8038 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8039 "attribute to be an EQUIVALENCE object", sym->name,
8044 /* Shall not have allocatable components. */
8045 if (derived->attr.alloc_comp)
8047 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8048 "components to be an EQUIVALENCE object",sym->name,
8053 for (; c ; c = c->next)
8057 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8060 /* Shall not be an object of sequence derived type containing a pointer
8061 in the structure. */
8064 gfc_error ("Derived type variable '%s' at %L with pointer "
8065 "component(s) cannot be an EQUIVALENCE object",
8066 sym->name, &e->where);
8074 /* Resolve equivalence object.
8075 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8076 an allocatable array, an object of nonsequence derived type, an object of
8077 sequence derived type containing a pointer at any level of component
8078 selection, an automatic object, a function name, an entry name, a result
8079 name, a named constant, a structure component, or a subobject of any of
8080 the preceding objects. A substring shall not have length zero. A
8081 derived type shall not have components with default initialization nor
8082 shall two objects of an equivalence group be initialized.
8083 Either all or none of the objects shall have an protected attribute.
8084 The simple constraints are done in symbol.c(check_conflict) and the rest
8085 are implemented here. */
8088 resolve_equivalence (gfc_equiv *eq)
8091 gfc_symbol *derived;
8092 gfc_symbol *first_sym;
8095 locus *last_where = NULL;
8096 seq_type eq_type, last_eq_type;
8097 gfc_typespec *last_ts;
8098 int object, cnt_protected;
8099 const char *value_name;
8103 last_ts = &eq->expr->symtree->n.sym->ts;
8105 first_sym = eq->expr->symtree->n.sym;
8109 for (object = 1; eq; eq = eq->eq, object++)
8113 e->ts = e->symtree->n.sym->ts;
8114 /* match_varspec might not know yet if it is seeing
8115 array reference or substring reference, as it doesn't
8117 if (e->ref && e->ref->type == REF_ARRAY)
8119 gfc_ref *ref = e->ref;
8120 sym = e->symtree->n.sym;
8122 if (sym->attr.dimension)
8124 ref->u.ar.as = sym->as;
8128 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8129 if (e->ts.type == BT_CHARACTER
8131 && ref->type == REF_ARRAY
8132 && ref->u.ar.dimen == 1
8133 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8134 && ref->u.ar.stride[0] == NULL)
8136 gfc_expr *start = ref->u.ar.start[0];
8137 gfc_expr *end = ref->u.ar.end[0];
8140 /* Optimize away the (:) reference. */
8141 if (start == NULL && end == NULL)
8146 e->ref->next = ref->next;
8151 ref->type = REF_SUBSTRING;
8153 start = gfc_int_expr (1);
8154 ref->u.ss.start = start;
8155 if (end == NULL && e->ts.cl)
8156 end = gfc_copy_expr (e->ts.cl->length);
8157 ref->u.ss.end = end;
8158 ref->u.ss.length = e->ts.cl;
8165 /* Any further ref is an error. */
8168 gcc_assert (ref->type == REF_ARRAY);
8169 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8175 if (gfc_resolve_expr (e) == FAILURE)
8178 sym = e->symtree->n.sym;
8180 if (sym->attr.protected)
8182 if (cnt_protected > 0 && cnt_protected != object)
8184 gfc_error ("Either all or none of the objects in the "
8185 "EQUIVALENCE set at %L shall have the "
8186 "PROTECTED attribute",
8191 /* Shall not equivalence common block variables in a PURE procedure. */
8192 if (sym->ns->proc_name
8193 && sym->ns->proc_name->attr.pure
8194 && sym->attr.in_common)
8196 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8197 "object in the pure procedure '%s'",
8198 sym->name, &e->where, sym->ns->proc_name->name);
8202 /* Shall not be a named constant. */
8203 if (e->expr_type == EXPR_CONSTANT)
8205 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8206 "object", sym->name, &e->where);
8210 derived = e->ts.derived;
8211 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8214 /* Check that the types correspond correctly:
8216 A numeric sequence structure may be equivalenced to another sequence
8217 structure, an object of default integer type, default real type, double
8218 precision real type, default logical type such that components of the
8219 structure ultimately only become associated to objects of the same
8220 kind. A character sequence structure may be equivalenced to an object
8221 of default character kind or another character sequence structure.
8222 Other objects may be equivalenced only to objects of the same type and
8225 /* Identical types are unconditionally OK. */
8226 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8227 goto identical_types;
8229 last_eq_type = sequence_type (*last_ts);
8230 eq_type = sequence_type (sym->ts);
8232 /* Since the pair of objects is not of the same type, mixed or
8233 non-default sequences can be rejected. */
8235 msg = "Sequence %s with mixed components in EQUIVALENCE "
8236 "statement at %L with different type objects";
8238 && last_eq_type == SEQ_MIXED
8239 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8241 || (eq_type == SEQ_MIXED
8242 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8243 &e->where) == FAILURE))
8246 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8247 "statement at %L with objects of different type";
8249 && last_eq_type == SEQ_NONDEFAULT
8250 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8251 last_where) == FAILURE)
8252 || (eq_type == SEQ_NONDEFAULT
8253 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8254 &e->where) == FAILURE))
8257 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8258 "EQUIVALENCE statement at %L";
8259 if (last_eq_type == SEQ_CHARACTER
8260 && eq_type != SEQ_CHARACTER
8261 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8262 &e->where) == FAILURE)
8265 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8266 "EQUIVALENCE statement at %L";
8267 if (last_eq_type == SEQ_NUMERIC
8268 && eq_type != SEQ_NUMERIC
8269 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8270 &e->where) == FAILURE)
8275 last_where = &e->where;
8280 /* Shall not be an automatic array. */
8281 if (e->ref->type == REF_ARRAY
8282 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8284 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8285 "an EQUIVALENCE object", sym->name, &e->where);
8292 /* Shall not be a structure component. */
8293 if (r->type == REF_COMPONENT)
8295 gfc_error ("Structure component '%s' at %L cannot be an "
8296 "EQUIVALENCE object",
8297 r->u.c.component->name, &e->where);
8301 /* A substring shall not have length zero. */
8302 if (r->type == REF_SUBSTRING)
8304 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8306 gfc_error ("Substring at %L has length zero",
8307 &r->u.ss.start->where);
8317 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8320 resolve_fntype (gfc_namespace *ns)
8325 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8328 /* If there are any entries, ns->proc_name is the entry master
8329 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8331 sym = ns->entries->sym;
8333 sym = ns->proc_name;
8334 if (sym->result == sym
8335 && sym->ts.type == BT_UNKNOWN
8336 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8337 && !sym->attr.untyped)
8339 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8340 sym->name, &sym->declared_at);
8341 sym->attr.untyped = 1;
8344 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8345 && !gfc_check_access (sym->ts.derived->attr.access,
8346 sym->ts.derived->ns->default_access)
8347 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8349 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8350 sym->name, &sym->declared_at, sym->ts.derived->name);
8354 for (el = ns->entries->next; el; el = el->next)
8356 if (el->sym->result == el->sym
8357 && el->sym->ts.type == BT_UNKNOWN
8358 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8359 && !el->sym->attr.untyped)
8361 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8362 el->sym->name, &el->sym->declared_at);
8363 el->sym->attr.untyped = 1;
8368 /* 12.3.2.1.1 Defined operators. */
8371 gfc_resolve_uops (gfc_symtree *symtree)
8375 gfc_formal_arglist *formal;
8377 if (symtree == NULL)
8380 gfc_resolve_uops (symtree->left);
8381 gfc_resolve_uops (symtree->right);
8383 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8386 if (!sym->attr.function)
8387 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8388 sym->name, &sym->declared_at);
8390 if (sym->ts.type == BT_CHARACTER
8391 && !(sym->ts.cl && sym->ts.cl->length)
8392 && !(sym->result && sym->result->ts.cl
8393 && sym->result->ts.cl->length))
8394 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8395 "character length", sym->name, &sym->declared_at);
8397 formal = sym->formal;
8398 if (!formal || !formal->sym)
8400 gfc_error ("User operator procedure '%s' at %L must have at least "
8401 "one argument", sym->name, &sym->declared_at);
8405 if (formal->sym->attr.intent != INTENT_IN)
8406 gfc_error ("First argument of operator interface at %L must be "
8407 "INTENT(IN)", &sym->declared_at);
8409 if (formal->sym->attr.optional)
8410 gfc_error ("First argument of operator interface at %L cannot be "
8411 "optional", &sym->declared_at);
8413 formal = formal->next;
8414 if (!formal || !formal->sym)
8417 if (formal->sym->attr.intent != INTENT_IN)
8418 gfc_error ("Second argument of operator interface at %L must be "
8419 "INTENT(IN)", &sym->declared_at);
8421 if (formal->sym->attr.optional)
8422 gfc_error ("Second argument of operator interface at %L cannot be "
8423 "optional", &sym->declared_at);
8426 gfc_error ("Operator interface at %L must have, at most, two "
8427 "arguments", &sym->declared_at);
8432 /* Examine all of the expressions associated with a program unit,
8433 assign types to all intermediate expressions, make sure that all
8434 assignments are to compatible types and figure out which names
8435 refer to which functions or subroutines. It doesn't check code
8436 block, which is handled by resolve_code. */
8439 resolve_types (gfc_namespace *ns)
8446 gfc_current_ns = ns;
8448 resolve_entries (ns);
8450 resolve_common_blocks (ns->common_root);
8452 resolve_contained_functions (ns);
8454 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8456 for (cl = ns->cl_list; cl; cl = cl->next)
8457 resolve_charlen (cl);
8459 gfc_traverse_ns (ns, resolve_symbol);
8461 resolve_fntype (ns);
8463 for (n = ns->contained; n; n = n->sibling)
8465 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8466 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8467 "also be PURE", n->proc_name->name,
8468 &n->proc_name->declared_at);
8474 gfc_check_interfaces (ns);
8476 gfc_traverse_ns (ns, resolve_values);
8482 for (d = ns->data; d; d = d->next)
8486 gfc_traverse_ns (ns, gfc_formalize_init_value);
8488 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8490 if (ns->common_root != NULL)
8491 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8493 for (eq = ns->equiv; eq; eq = eq->next)
8494 resolve_equivalence (eq);
8496 /* Warn about unused labels. */
8497 if (warn_unused_label)
8498 warn_unused_fortran_label (ns->st_labels);
8500 gfc_resolve_uops (ns->uop_root);
8504 /* Call resolve_code recursively. */
8507 resolve_codes (gfc_namespace *ns)
8511 for (n = ns->contained; n; n = n->sibling)
8514 gfc_current_ns = ns;
8516 /* Set to an out of range value. */
8517 current_entry_id = -1;
8519 bitmap_obstack_initialize (&labels_obstack);
8520 resolve_code (ns->code, ns);
8521 bitmap_obstack_release (&labels_obstack);
8525 /* This function is called after a complete program unit has been compiled.
8526 Its purpose is to examine all of the expressions associated with a program
8527 unit, assign types to all intermediate expressions, make sure that all
8528 assignments are to compatible types and figure out which names refer to
8529 which functions or subroutines. */
8532 gfc_resolve (gfc_namespace *ns)
8534 gfc_namespace *old_ns;
8536 old_ns = gfc_current_ns;
8541 gfc_current_ns = old_ns;