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_symbol *sym, *csym;
611 if (common_root == NULL)
614 if (common_root->left)
615 resolve_common_blocks (common_root->left);
616 if (common_root->right)
617 resolve_common_blocks (common_root->right);
619 for (csym = common_root->n.common->head; csym; csym = csym->common_next)
621 if (csym->ts.type == BT_DERIVED
622 && !(csym->ts.derived->attr.sequence
623 || csym->ts.derived->attr.is_bind_c))
625 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
626 "has neither the SEQUENCE nor the BIND(C) "
627 "attribute", csym->name,
630 else if (csym->ts.type == BT_DERIVED
631 && csym->ts.derived->attr.alloc_comp)
633 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
634 "has an ultimate component that is "
635 "allocatable", csym->name,
640 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
644 if (sym->attr.flavor == FL_PARAMETER)
645 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
646 sym->name, &common_root->n.common->where, &sym->declared_at);
648 if (sym->attr.intrinsic)
649 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
650 sym->name, &common_root->n.common->where);
651 else if (sym->attr.result
652 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
653 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
654 "that is also a function result", sym->name,
655 &common_root->n.common->where);
656 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
657 && sym->attr.proc != PROC_ST_FUNCTION)
658 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
659 "that is also a global procedure", sym->name,
660 &common_root->n.common->where);
664 /* Resolve contained function types. Because contained functions can call one
665 another, they have to be worked out before any of the contained procedures
668 The good news is that if a function doesn't already have a type, the only
669 way it can get one is through an IMPLICIT type or a RESULT variable, because
670 by definition contained functions are contained namespace they're contained
671 in, not in a sibling or parent namespace. */
674 resolve_contained_functions (gfc_namespace *ns)
676 gfc_namespace *child;
679 resolve_formal_arglists (ns);
681 for (child = ns->contained; child; child = child->sibling)
683 /* Resolve alternate entry points first. */
684 resolve_entries (child);
686 /* Then check function return types. */
687 resolve_contained_fntype (child->proc_name, child);
688 for (el = child->entries; el; el = el->next)
689 resolve_contained_fntype (el->sym, child);
694 /* Resolve all of the elements of a structure constructor and make sure that
695 the types are correct. */
698 resolve_structure_cons (gfc_expr *expr)
700 gfc_constructor *cons;
706 cons = expr->value.constructor;
707 /* A constructor may have references if it is the result of substituting a
708 parameter variable. In this case we just pull out the component we
711 comp = expr->ref->u.c.sym->components;
713 comp = expr->ts.derived->components;
715 for (; comp; comp = comp->next, cons = cons->next)
720 if (gfc_resolve_expr (cons->expr) == FAILURE)
726 if (cons->expr->expr_type != EXPR_NULL
727 && comp->as && comp->as->rank != cons->expr->rank
728 && (comp->allocatable || cons->expr->rank))
730 gfc_error ("The rank of the element in the derived type "
731 "constructor at %L does not match that of the "
732 "component (%d/%d)", &cons->expr->where,
733 cons->expr->rank, comp->as ? comp->as->rank : 0);
737 /* If we don't have the right type, try to convert it. */
739 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
742 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
743 gfc_error ("The element in the derived type constructor at %L, "
744 "for pointer component '%s', is %s but should be %s",
745 &cons->expr->where, comp->name,
746 gfc_basic_typename (cons->expr->ts.type),
747 gfc_basic_typename (comp->ts.type));
749 t = gfc_convert_type (cons->expr, &comp->ts, 1);
752 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
755 a = gfc_expr_attr (cons->expr);
757 if (!a.pointer && !a.target)
760 gfc_error ("The element in the derived type constructor at %L, "
761 "for pointer component '%s' should be a POINTER or "
762 "a TARGET", &cons->expr->where, comp->name);
770 /****************** Expression name resolution ******************/
772 /* Returns 0 if a symbol was not declared with a type or
773 attribute declaration statement, nonzero otherwise. */
776 was_declared (gfc_symbol *sym)
782 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
785 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
786 || a.optional || a.pointer || a.save || a.target || a.volatile_
787 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
794 /* Determine if a symbol is generic or not. */
797 generic_sym (gfc_symbol *sym)
801 if (sym->attr.generic ||
802 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
805 if (was_declared (sym) || sym->ns->parent == NULL)
808 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
815 return generic_sym (s);
822 /* Determine if a symbol is specific or not. */
825 specific_sym (gfc_symbol *sym)
829 if (sym->attr.if_source == IFSRC_IFBODY
830 || sym->attr.proc == PROC_MODULE
831 || sym->attr.proc == PROC_INTERNAL
832 || sym->attr.proc == PROC_ST_FUNCTION
833 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
834 || sym->attr.external)
837 if (was_declared (sym) || sym->ns->parent == NULL)
840 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
842 return (s == NULL) ? 0 : specific_sym (s);
846 /* Figure out if the procedure is specific, generic or unknown. */
849 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
853 procedure_kind (gfc_symbol *sym)
855 if (generic_sym (sym))
856 return PTYPE_GENERIC;
858 if (specific_sym (sym))
859 return PTYPE_SPECIFIC;
861 return PTYPE_UNKNOWN;
864 /* Check references to assumed size arrays. The flag need_full_assumed_size
865 is nonzero when matching actual arguments. */
867 static int need_full_assumed_size = 0;
870 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
876 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
879 for (ref = e->ref; ref; ref = ref->next)
880 if (ref->type == REF_ARRAY)
881 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
882 last = (ref->u.ar.end[dim] == NULL)
883 && (ref->u.ar.type == DIMEN_ELEMENT);
887 gfc_error ("The upper bound in the last dimension must "
888 "appear in the reference to the assumed size "
889 "array '%s' at %L", sym->name, &e->where);
896 /* Look for bad assumed size array references in argument expressions
897 of elemental and array valued intrinsic procedures. Since this is
898 called from procedure resolution functions, it only recurses at
902 resolve_assumed_size_actual (gfc_expr *e)
907 switch (e->expr_type)
910 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
915 if (resolve_assumed_size_actual (e->value.op.op1)
916 || resolve_assumed_size_actual (e->value.op.op2))
927 /* Resolve an actual argument list. Most of the time, this is just
928 resolving the expressions in the list.
929 The exception is that we sometimes have to decide whether arguments
930 that look like procedure arguments are really simple variable
934 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
937 gfc_symtree *parent_st;
940 for (; arg; arg = arg->next)
945 /* Check the label is a valid branching target. */
948 if (arg->label->defined == ST_LABEL_UNKNOWN)
950 gfc_error ("Label %d referenced at %L is never defined",
951 arg->label->value, &arg->label->where);
958 if (e->ts.type != BT_PROCEDURE)
960 if (gfc_resolve_expr (e) != SUCCESS)
965 /* See if the expression node should really be a variable reference. */
967 sym = e->symtree->n.sym;
969 if (sym->attr.flavor == FL_PROCEDURE
970 || sym->attr.intrinsic
971 || sym->attr.external)
975 /* If a procedure is not already determined to be something else
976 check if it is intrinsic. */
977 if (!sym->attr.intrinsic
978 && !(sym->attr.external || sym->attr.use_assoc
979 || sym->attr.if_source == IFSRC_IFBODY)
980 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
981 sym->attr.intrinsic = 1;
983 if (sym->attr.proc == PROC_ST_FUNCTION)
985 gfc_error ("Statement function '%s' at %L is not allowed as an "
986 "actual argument", sym->name, &e->where);
989 actual_ok = gfc_intrinsic_actual_ok (sym->name,
990 sym->attr.subroutine);
991 if (sym->attr.intrinsic && actual_ok == 0)
993 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
994 "actual argument", sym->name, &e->where);
997 if (sym->attr.contained && !sym->attr.use_assoc
998 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1000 gfc_error ("Internal procedure '%s' is not allowed as an "
1001 "actual argument at %L", sym->name, &e->where);
1004 if (sym->attr.elemental && !sym->attr.intrinsic)
1006 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1007 "allowed as an actual argument at %L", sym->name,
1011 /* Check if a generic interface has a specific procedure
1012 with the same name before emitting an error. */
1013 if (sym->attr.generic)
1016 for (p = sym->generic; p; p = p->next)
1017 if (strcmp (sym->name, p->sym->name) == 0)
1019 e->symtree = gfc_find_symtree
1020 (p->sym->ns->sym_root, sym->name);
1025 if (p == NULL || e->symtree == NULL)
1026 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1027 "allowed as an actual argument at %L", sym->name,
1031 /* If the symbol is the function that names the current (or
1032 parent) scope, then we really have a variable reference. */
1034 if (sym->attr.function && sym->result == sym
1035 && (sym->ns->proc_name == sym
1036 || (sym->ns->parent != NULL
1037 && sym->ns->parent->proc_name == sym)))
1040 /* If all else fails, see if we have a specific intrinsic. */
1041 if (sym->attr.function
1042 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1044 gfc_intrinsic_sym *isym;
1045 isym = gfc_find_function (sym->name);
1046 if (isym == NULL || !isym->specific)
1048 gfc_error ("Unable to find a specific INTRINSIC procedure "
1049 "for the reference '%s' at %L", sym->name,
1057 /* See if the name is a module procedure in a parent unit. */
1059 if (was_declared (sym) || sym->ns->parent == NULL)
1062 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1064 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1068 if (parent_st == NULL)
1071 sym = parent_st->n.sym;
1072 e->symtree = parent_st; /* Point to the right thing. */
1074 if (sym->attr.flavor == FL_PROCEDURE
1075 || sym->attr.intrinsic
1076 || sym->attr.external)
1082 e->expr_type = EXPR_VARIABLE;
1084 if (sym->as != NULL)
1086 e->rank = sym->as->rank;
1087 e->ref = gfc_get_ref ();
1088 e->ref->type = REF_ARRAY;
1089 e->ref->u.ar.type = AR_FULL;
1090 e->ref->u.ar.as = sym->as;
1093 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1094 primary.c (match_actual_arg). If above code determines that it
1095 is a variable instead, it needs to be resolved as it was not
1096 done at the beginning of this function. */
1097 if (gfc_resolve_expr (e) != SUCCESS)
1101 /* Check argument list functions %VAL, %LOC and %REF. There is
1102 nothing to do for %REF. */
1103 if (arg->name && arg->name[0] == '%')
1105 if (strncmp ("%VAL", arg->name, 4) == 0)
1107 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1109 gfc_error ("By-value argument at %L is not of numeric "
1116 gfc_error ("By-value argument at %L cannot be an array or "
1117 "an array section", &e->where);
1121 /* Intrinsics are still PROC_UNKNOWN here. However,
1122 since same file external procedures are not resolvable
1123 in gfortran, it is a good deal easier to leave them to
1125 if (ptype != PROC_UNKNOWN
1126 && ptype != PROC_DUMMY
1127 && ptype != PROC_EXTERNAL
1128 && ptype != PROC_MODULE)
1130 gfc_error ("By-value argument at %L is not allowed "
1131 "in this context", &e->where);
1136 /* Statement functions have already been excluded above. */
1137 else if (strncmp ("%LOC", arg->name, 4) == 0
1138 && e->ts.type == BT_PROCEDURE)
1140 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1142 gfc_error ("Passing internal procedure at %L by location "
1143 "not allowed", &e->where);
1154 /* Do the checks of the actual argument list that are specific to elemental
1155 procedures. If called with c == NULL, we have a function, otherwise if
1156 expr == NULL, we have a subroutine. */
1159 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1161 gfc_actual_arglist *arg0;
1162 gfc_actual_arglist *arg;
1163 gfc_symbol *esym = NULL;
1164 gfc_intrinsic_sym *isym = NULL;
1166 gfc_intrinsic_arg *iformal = NULL;
1167 gfc_formal_arglist *eformal = NULL;
1168 bool formal_optional = false;
1169 bool set_by_optional = false;
1173 /* Is this an elemental procedure? */
1174 if (expr && expr->value.function.actual != NULL)
1176 if (expr->value.function.esym != NULL
1177 && expr->value.function.esym->attr.elemental)
1179 arg0 = expr->value.function.actual;
1180 esym = expr->value.function.esym;
1182 else if (expr->value.function.isym != NULL
1183 && expr->value.function.isym->elemental)
1185 arg0 = expr->value.function.actual;
1186 isym = expr->value.function.isym;
1191 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1193 arg0 = c->ext.actual;
1194 esym = c->symtree->n.sym;
1199 /* The rank of an elemental is the rank of its array argument(s). */
1200 for (arg = arg0; arg; arg = arg->next)
1202 if (arg->expr != NULL && arg->expr->rank > 0)
1204 rank = arg->expr->rank;
1205 if (arg->expr->expr_type == EXPR_VARIABLE
1206 && arg->expr->symtree->n.sym->attr.optional)
1207 set_by_optional = true;
1209 /* Function specific; set the result rank and shape. */
1213 if (!expr->shape && arg->expr->shape)
1215 expr->shape = gfc_get_shape (rank);
1216 for (i = 0; i < rank; i++)
1217 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1224 /* If it is an array, it shall not be supplied as an actual argument
1225 to an elemental procedure unless an array of the same rank is supplied
1226 as an actual argument corresponding to a nonoptional dummy argument of
1227 that elemental procedure(12.4.1.5). */
1228 formal_optional = false;
1230 iformal = isym->formal;
1232 eformal = esym->formal;
1234 for (arg = arg0; arg; arg = arg->next)
1238 if (eformal->sym && eformal->sym->attr.optional)
1239 formal_optional = true;
1240 eformal = eformal->next;
1242 else if (isym && iformal)
1244 if (iformal->optional)
1245 formal_optional = true;
1246 iformal = iformal->next;
1249 formal_optional = true;
1251 if (pedantic && arg->expr != NULL
1252 && arg->expr->expr_type == EXPR_VARIABLE
1253 && arg->expr->symtree->n.sym->attr.optional
1256 && (set_by_optional || arg->expr->rank != rank)
1257 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1259 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1260 "MISSING, it cannot be the actual argument of an "
1261 "ELEMENTAL procedure unless there is a non-optional "
1262 "argument with the same rank (12.4.1.5)",
1263 arg->expr->symtree->n.sym->name, &arg->expr->where);
1268 for (arg = arg0; arg; arg = arg->next)
1270 if (arg->expr == NULL || arg->expr->rank == 0)
1273 /* Being elemental, the last upper bound of an assumed size array
1274 argument must be present. */
1275 if (resolve_assumed_size_actual (arg->expr))
1278 /* Elemental procedure's array actual arguments must conform. */
1281 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1289 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1290 is an array, the intent inout/out variable needs to be also an array. */
1291 if (rank > 0 && esym && expr == NULL)
1292 for (eformal = esym->formal, arg = arg0; arg && eformal;
1293 arg = arg->next, eformal = eformal->next)
1294 if ((eformal->sym->attr.intent == INTENT_OUT
1295 || eformal->sym->attr.intent == INTENT_INOUT)
1296 && arg->expr && arg->expr->rank == 0)
1298 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1299 "ELEMENTAL subroutine '%s' is a scalar, but another "
1300 "actual argument is an array", &arg->expr->where,
1301 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1302 : "INOUT", eformal->sym->name, esym->name);
1309 /* Go through each actual argument in ACTUAL and see if it can be
1310 implemented as an inlined, non-copying intrinsic. FNSYM is the
1311 function being called, or NULL if not known. */
1314 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1316 gfc_actual_arglist *ap;
1319 for (ap = actual; ap; ap = ap->next)
1321 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1322 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1323 ap->expr->inline_noncopying_intrinsic = 1;
1327 /* This function does the checking of references to global procedures
1328 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1329 77 and 95 standards. It checks for a gsymbol for the name, making
1330 one if it does not already exist. If it already exists, then the
1331 reference being resolved must correspond to the type of gsymbol.
1332 Otherwise, the new symbol is equipped with the attributes of the
1333 reference. The corresponding code that is called in creating
1334 global entities is parse.c. */
1337 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1342 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1344 gsym = gfc_get_gsymbol (sym->name);
1346 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1347 global_used (gsym, where);
1349 if (gsym->type == GSYM_UNKNOWN)
1352 gsym->where = *where;
1359 /************* Function resolution *************/
1361 /* Resolve a function call known to be generic.
1362 Section 14.1.2.4.1. */
1365 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1369 if (sym->attr.generic)
1371 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1374 expr->value.function.name = s->name;
1375 expr->value.function.esym = s;
1377 if (s->ts.type != BT_UNKNOWN)
1379 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1380 expr->ts = s->result->ts;
1383 expr->rank = s->as->rank;
1384 else if (s->result != NULL && s->result->as != NULL)
1385 expr->rank = s->result->as->rank;
1390 /* TODO: Need to search for elemental references in generic
1394 if (sym->attr.intrinsic)
1395 return gfc_intrinsic_func_interface (expr, 0);
1402 resolve_generic_f (gfc_expr *expr)
1407 sym = expr->symtree->n.sym;
1411 m = resolve_generic_f0 (expr, sym);
1414 else if (m == MATCH_ERROR)
1418 if (sym->ns->parent == NULL)
1420 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1424 if (!generic_sym (sym))
1428 /* Last ditch attempt. See if the reference is to an intrinsic
1429 that possesses a matching interface. 14.1.2.4 */
1430 if (sym && !gfc_intrinsic_name (sym->name, 0))
1432 gfc_error ("There is no specific function for the generic '%s' at %L",
1433 expr->symtree->n.sym->name, &expr->where);
1437 m = gfc_intrinsic_func_interface (expr, 0);
1441 gfc_error ("Generic function '%s' at %L is not consistent with a "
1442 "specific intrinsic interface", expr->symtree->n.sym->name,
1449 /* Resolve a function call known to be specific. */
1452 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1456 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1458 if (sym->attr.dummy)
1460 sym->attr.proc = PROC_DUMMY;
1464 sym->attr.proc = PROC_EXTERNAL;
1468 if (sym->attr.proc == PROC_MODULE
1469 || sym->attr.proc == PROC_ST_FUNCTION
1470 || sym->attr.proc == PROC_INTERNAL)
1473 if (sym->attr.intrinsic)
1475 m = gfc_intrinsic_func_interface (expr, 1);
1479 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1480 "with an intrinsic", sym->name, &expr->where);
1488 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1491 expr->value.function.name = sym->name;
1492 expr->value.function.esym = sym;
1493 if (sym->as != NULL)
1494 expr->rank = sym->as->rank;
1501 resolve_specific_f (gfc_expr *expr)
1506 sym = expr->symtree->n.sym;
1510 m = resolve_specific_f0 (sym, expr);
1513 if (m == MATCH_ERROR)
1516 if (sym->ns->parent == NULL)
1519 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1525 gfc_error ("Unable to resolve the specific function '%s' at %L",
1526 expr->symtree->n.sym->name, &expr->where);
1532 /* Resolve a procedure call not known to be generic nor specific. */
1535 resolve_unknown_f (gfc_expr *expr)
1540 sym = expr->symtree->n.sym;
1542 if (sym->attr.dummy)
1544 sym->attr.proc = PROC_DUMMY;
1545 expr->value.function.name = sym->name;
1549 /* See if we have an intrinsic function reference. */
1551 if (gfc_intrinsic_name (sym->name, 0))
1553 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1558 /* The reference is to an external name. */
1560 sym->attr.proc = PROC_EXTERNAL;
1561 expr->value.function.name = sym->name;
1562 expr->value.function.esym = expr->symtree->n.sym;
1564 if (sym->as != NULL)
1565 expr->rank = sym->as->rank;
1567 /* Type of the expression is either the type of the symbol or the
1568 default type of the symbol. */
1571 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1573 if (sym->ts.type != BT_UNKNOWN)
1577 ts = gfc_get_default_type (sym, sym->ns);
1579 if (ts->type == BT_UNKNOWN)
1581 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1582 sym->name, &expr->where);
1593 /* Return true, if the symbol is an external procedure. */
1595 is_external_proc (gfc_symbol *sym)
1597 if (!sym->attr.dummy && !sym->attr.contained
1598 && !(sym->attr.intrinsic
1599 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1600 && sym->attr.proc != PROC_ST_FUNCTION
1601 && !sym->attr.use_assoc
1609 /* Figure out if a function reference is pure or not. Also set the name
1610 of the function for a potential error message. Return nonzero if the
1611 function is PURE, zero if not. */
1614 pure_function (gfc_expr *e, const char **name)
1620 if (e->symtree != NULL
1621 && e->symtree->n.sym != NULL
1622 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1625 if (e->value.function.esym)
1627 pure = gfc_pure (e->value.function.esym);
1628 *name = e->value.function.esym->name;
1630 else if (e->value.function.isym)
1632 pure = e->value.function.isym->pure
1633 || e->value.function.isym->elemental;
1634 *name = e->value.function.isym->name;
1638 /* Implicit functions are not pure. */
1640 *name = e->value.function.name;
1648 is_scalar_expr_ptr (gfc_expr *expr)
1650 try retval = SUCCESS;
1655 /* See if we have a gfc_ref, which means we have a substring, array
1656 reference, or a component. */
1657 if (expr->ref != NULL)
1660 while (ref->next != NULL)
1666 if (ref->u.ss.length != NULL
1667 && ref->u.ss.length->length != NULL
1669 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1671 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1673 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1674 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1675 if (end - start + 1 != 1)
1682 if (ref->u.ar.type == AR_ELEMENT)
1684 else if (ref->u.ar.type == AR_FULL)
1686 /* The user can give a full array if the array is of size 1. */
1687 if (ref->u.ar.as != NULL
1688 && ref->u.ar.as->rank == 1
1689 && ref->u.ar.as->type == AS_EXPLICIT
1690 && ref->u.ar.as->lower[0] != NULL
1691 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1692 && ref->u.ar.as->upper[0] != NULL
1693 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1695 /* If we have a character string, we need to check if
1696 its length is one. */
1697 if (expr->ts.type == BT_CHARACTER)
1699 if (expr->ts.cl == NULL
1700 || expr->ts.cl->length == NULL
1701 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1707 /* We have constant lower and upper bounds. If the
1708 difference between is 1, it can be considered a
1710 start = (int) mpz_get_si
1711 (ref->u.ar.as->lower[0]->value.integer);
1712 end = (int) mpz_get_si
1713 (ref->u.ar.as->upper[0]->value.integer);
1714 if (end - start + 1 != 1)
1729 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1731 /* Character string. Make sure it's of length 1. */
1732 if (expr->ts.cl == NULL
1733 || expr->ts.cl->length == NULL
1734 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1737 else if (expr->rank != 0)
1744 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1745 and, in the case of c_associated, set the binding label based on
1749 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1750 gfc_symbol **new_sym)
1752 char name[GFC_MAX_SYMBOL_LEN + 1];
1753 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1754 int optional_arg = 0;
1755 try retval = SUCCESS;
1756 gfc_symbol *args_sym;
1757 gfc_typespec *arg_ts;
1758 gfc_ref *parent_ref;
1761 if (args->expr->expr_type == EXPR_CONSTANT
1762 || args->expr->expr_type == EXPR_OP
1763 || args->expr->expr_type == EXPR_NULL)
1765 gfc_error ("Argument to '%s' at %L is not a variable",
1766 sym->name, &(args->expr->where));
1770 args_sym = args->expr->symtree->n.sym;
1772 /* The typespec for the actual arg should be that stored in the expr
1773 and not necessarily that of the expr symbol (args_sym), because
1774 the actual expression could be a part-ref of the expr symbol. */
1775 arg_ts = &(args->expr->ts);
1777 /* Get the parent reference (if any) for the expression. This happens for
1778 cases such as a%b%c. */
1779 parent_ref = args->expr->ref;
1781 if (parent_ref != NULL)
1783 curr_ref = parent_ref->next;
1784 while (curr_ref != NULL && curr_ref->next != NULL)
1786 parent_ref = curr_ref;
1787 curr_ref = curr_ref->next;
1791 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1792 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1793 the name, etc. Otherwise, the current parent_ref should be correct. */
1794 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1795 parent_ref = curr_ref;
1797 if (parent_ref == args->expr->ref)
1799 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1800 gfc_internal_error ("Unexpected expression reference type in "
1801 "gfc_iso_c_func_interface");
1803 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1805 /* If the user gave two args then they are providing something for
1806 the optional arg (the second cptr). Therefore, set the name and
1807 binding label to the c_associated for two cptrs. Otherwise,
1808 set c_associated to expect one cptr. */
1812 sprintf (name, "%s_2", sym->name);
1813 sprintf (binding_label, "%s_2", sym->binding_label);
1819 sprintf (name, "%s_1", sym->name);
1820 sprintf (binding_label, "%s_1", sym->binding_label);
1824 /* Get a new symbol for the version of c_associated that
1826 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1828 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1829 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1831 sprintf (name, "%s", sym->name);
1832 sprintf (binding_label, "%s", sym->binding_label);
1834 /* Error check the call. */
1835 if (args->next != NULL)
1837 gfc_error_now ("More actual than formal arguments in '%s' "
1838 "call at %L", name, &(args->expr->where));
1841 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1843 /* Make sure we have either the target or pointer attribute. */
1844 if (!(args_sym->attr.target)
1845 && !(args_sym->attr.pointer)
1846 && (parent_ref == NULL ||
1847 !parent_ref->u.c.component->pointer))
1849 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1850 "a TARGET or an associated pointer",
1852 sym->name, &(args->expr->where));
1856 /* See if we have interoperable type and type param. */
1857 if (verify_c_interop (arg_ts,
1858 (parent_ref ? parent_ref->u.c.component->name
1860 &(args->expr->where)) == SUCCESS
1861 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
1863 if (args_sym->attr.target == 1)
1865 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1866 has the target attribute and is interoperable. */
1867 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1868 allocatable variable that has the TARGET attribute and
1869 is not an array of zero size. */
1870 if (args_sym->attr.allocatable == 1)
1872 if (args_sym->attr.dimension != 0
1873 && (args_sym->as && args_sym->as->rank == 0))
1875 gfc_error_now ("Allocatable variable '%s' used as a "
1876 "parameter to '%s' at %L must not be "
1877 "an array of zero size",
1878 args_sym->name, sym->name,
1879 &(args->expr->where));
1885 /* A non-allocatable target variable with C
1886 interoperable type and type parameters must be
1888 if (args_sym && args_sym->attr.dimension)
1890 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1892 gfc_error ("Assumed-shape array '%s' at %L "
1893 "cannot be an argument to the "
1894 "procedure '%s' because "
1895 "it is not C interoperable",
1897 &(args->expr->where), sym->name);
1900 else if (args_sym->as->type == AS_DEFERRED)
1902 gfc_error ("Deferred-shape array '%s' at %L "
1903 "cannot be an argument to the "
1904 "procedure '%s' because "
1905 "it is not C interoperable",
1907 &(args->expr->where), sym->name);
1912 /* Make sure it's not a character string. Arrays of
1913 any type should be ok if the variable is of a C
1914 interoperable type. */
1915 if (arg_ts->type == BT_CHARACTER)
1916 if (arg_ts->cl != NULL
1917 && (arg_ts->cl->length == NULL
1918 || arg_ts->cl->length->expr_type
1921 (arg_ts->cl->length->value.integer, 1)
1923 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1925 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1926 "at %L must have a length of 1",
1927 args_sym->name, sym->name,
1928 &(args->expr->where));
1933 else if ((args_sym->attr.pointer == 1 ||
1935 && parent_ref->u.c.component->pointer))
1936 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1938 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1940 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1941 "associated scalar POINTER", args_sym->name,
1942 sym->name, &(args->expr->where));
1948 /* The parameter is not required to be C interoperable. If it
1949 is not C interoperable, it must be a nonpolymorphic scalar
1950 with no length type parameters. It still must have either
1951 the pointer or target attribute, and it can be
1952 allocatable (but must be allocated when c_loc is called). */
1953 if (args->expr->rank != 0
1954 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1956 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1957 "scalar", args_sym->name, sym->name,
1958 &(args->expr->where));
1961 else if (arg_ts->type == BT_CHARACTER
1962 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1964 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1965 "%L must have a length of 1",
1966 args_sym->name, sym->name,
1967 &(args->expr->where));
1972 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1974 if (args_sym->attr.flavor != FL_PROCEDURE)
1976 /* TODO: Update this error message to allow for procedure
1977 pointers once they are implemented. */
1978 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1980 args_sym->name, sym->name,
1981 &(args->expr->where));
1984 else if (args_sym->attr.is_bind_c != 1)
1986 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
1988 args_sym->name, sym->name,
1989 &(args->expr->where));
1994 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1999 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2000 "iso_c_binding function: '%s'!\n", sym->name);
2007 /* Resolve a function call, which means resolving the arguments, then figuring
2008 out which entity the name refers to. */
2009 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2010 to INTENT(OUT) or INTENT(INOUT). */
2013 resolve_function (gfc_expr *expr)
2015 gfc_actual_arglist *arg;
2020 procedure_type p = PROC_INTRINSIC;
2024 sym = expr->symtree->n.sym;
2026 if (sym && sym->attr.flavor == FL_VARIABLE)
2028 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2032 if (sym && sym->attr.abstract)
2034 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2035 sym->name, &expr->where);
2039 /* If the procedure is external, check for usage. */
2040 if (sym && is_external_proc (sym))
2041 resolve_global_procedure (sym, &expr->where, 0);
2043 /* Switch off assumed size checking and do this again for certain kinds
2044 of procedure, once the procedure itself is resolved. */
2045 need_full_assumed_size++;
2047 if (expr->symtree && expr->symtree->n.sym)
2048 p = expr->symtree->n.sym->attr.proc;
2050 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2053 /* Need to setup the call to the correct c_associated, depending on
2054 the number of cptrs to user gives to compare. */
2055 if (sym && sym->attr.is_iso_c == 1)
2057 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2061 /* Get the symtree for the new symbol (resolved func).
2062 the old one will be freed later, when it's no longer used. */
2063 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2066 /* Resume assumed_size checking. */
2067 need_full_assumed_size--;
2069 if (sym && sym->ts.type == BT_CHARACTER
2071 && sym->ts.cl->length == NULL
2073 && expr->value.function.esym == NULL
2074 && !sym->attr.contained)
2076 /* Internal procedures are taken care of in resolve_contained_fntype. */
2077 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2078 "be used at %L since it is not a dummy argument",
2079 sym->name, &expr->where);
2083 /* See if function is already resolved. */
2085 if (expr->value.function.name != NULL)
2087 if (expr->ts.type == BT_UNKNOWN)
2093 /* Apply the rules of section 14.1.2. */
2095 switch (procedure_kind (sym))
2098 t = resolve_generic_f (expr);
2101 case PTYPE_SPECIFIC:
2102 t = resolve_specific_f (expr);
2106 t = resolve_unknown_f (expr);
2110 gfc_internal_error ("resolve_function(): bad function type");
2114 /* If the expression is still a function (it might have simplified),
2115 then we check to see if we are calling an elemental function. */
2117 if (expr->expr_type != EXPR_FUNCTION)
2120 temp = need_full_assumed_size;
2121 need_full_assumed_size = 0;
2123 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2126 if (omp_workshare_flag
2127 && expr->value.function.esym
2128 && ! gfc_elemental (expr->value.function.esym))
2130 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2131 "in WORKSHARE construct", expr->value.function.esym->name,
2136 #define GENERIC_ID expr->value.function.isym->id
2137 else if (expr->value.function.actual != NULL
2138 && expr->value.function.isym != NULL
2139 && GENERIC_ID != GFC_ISYM_LBOUND
2140 && GENERIC_ID != GFC_ISYM_LEN
2141 && GENERIC_ID != GFC_ISYM_LOC
2142 && GENERIC_ID != GFC_ISYM_PRESENT)
2144 /* Array intrinsics must also have the last upper bound of an
2145 assumed size array argument. UBOUND and SIZE have to be
2146 excluded from the check if the second argument is anything
2149 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2150 || GENERIC_ID == GFC_ISYM_SIZE;
2152 for (arg = expr->value.function.actual; arg; arg = arg->next)
2154 if (inquiry && arg->next != NULL && arg->next->expr)
2156 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2159 if ((int)mpz_get_si (arg->next->expr->value.integer)
2164 if (arg->expr != NULL
2165 && arg->expr->rank > 0
2166 && resolve_assumed_size_actual (arg->expr))
2172 need_full_assumed_size = temp;
2175 if (!pure_function (expr, &name) && name)
2179 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2180 "FORALL %s", name, &expr->where,
2181 forall_flag == 2 ? "mask" : "block");
2184 else if (gfc_pure (NULL))
2186 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2187 "procedure within a PURE procedure", name, &expr->where);
2192 /* Functions without the RECURSIVE attribution are not allowed to
2193 * call themselves. */
2194 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2196 gfc_symbol *esym, *proc;
2197 esym = expr->value.function.esym;
2198 proc = gfc_current_ns->proc_name;
2201 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2202 "RECURSIVE", name, &expr->where);
2206 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2207 && esym->ns->entries->sym == proc->ns->entries->sym)
2209 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2210 "'%s' is not declared as RECURSIVE",
2211 esym->name, &expr->where, esym->ns->entries->sym->name);
2216 /* Character lengths of use associated functions may contains references to
2217 symbols not referenced from the current program unit otherwise. Make sure
2218 those symbols are marked as referenced. */
2220 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2221 && expr->value.function.esym->attr.use_assoc)
2223 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2227 find_noncopying_intrinsics (expr->value.function.esym,
2228 expr->value.function.actual);
2230 /* Make sure that the expression has a typespec that works. */
2231 if (expr->ts.type == BT_UNKNOWN)
2233 if (expr->symtree->n.sym->result
2234 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2235 expr->ts = expr->symtree->n.sym->result->ts;
2242 /************* Subroutine resolution *************/
2245 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2251 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2252 sym->name, &c->loc);
2253 else if (gfc_pure (NULL))
2254 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2260 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2264 if (sym->attr.generic)
2266 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2269 c->resolved_sym = s;
2270 pure_subroutine (c, s);
2274 /* TODO: Need to search for elemental references in generic interface. */
2277 if (sym->attr.intrinsic)
2278 return gfc_intrinsic_sub_interface (c, 0);
2285 resolve_generic_s (gfc_code *c)
2290 sym = c->symtree->n.sym;
2294 m = resolve_generic_s0 (c, sym);
2297 else if (m == MATCH_ERROR)
2301 if (sym->ns->parent == NULL)
2303 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2307 if (!generic_sym (sym))
2311 /* Last ditch attempt. See if the reference is to an intrinsic
2312 that possesses a matching interface. 14.1.2.4 */
2313 sym = c->symtree->n.sym;
2315 if (!gfc_intrinsic_name (sym->name, 1))
2317 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2318 sym->name, &c->loc);
2322 m = gfc_intrinsic_sub_interface (c, 0);
2326 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2327 "intrinsic subroutine interface", sym->name, &c->loc);
2333 /* Set the name and binding label of the subroutine symbol in the call
2334 expression represented by 'c' to include the type and kind of the
2335 second parameter. This function is for resolving the appropriate
2336 version of c_f_pointer() and c_f_procpointer(). For example, a
2337 call to c_f_pointer() for a default integer pointer could have a
2338 name of c_f_pointer_i4. If no second arg exists, which is an error
2339 for these two functions, it defaults to the generic symbol's name
2340 and binding label. */
2343 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2344 char *name, char *binding_label)
2346 gfc_expr *arg = NULL;
2350 /* The second arg of c_f_pointer and c_f_procpointer determines
2351 the type and kind for the procedure name. */
2352 arg = c->ext.actual->next->expr;
2356 /* Set up the name to have the given symbol's name,
2357 plus the type and kind. */
2358 /* a derived type is marked with the type letter 'u' */
2359 if (arg->ts.type == BT_DERIVED)
2362 kind = 0; /* set the kind as 0 for now */
2366 type = gfc_type_letter (arg->ts.type);
2367 kind = arg->ts.kind;
2370 if (arg->ts.type == BT_CHARACTER)
2371 /* Kind info for character strings not needed. */
2374 sprintf (name, "%s_%c%d", sym->name, type, kind);
2375 /* Set up the binding label as the given symbol's label plus
2376 the type and kind. */
2377 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2381 /* If the second arg is missing, set the name and label as
2382 was, cause it should at least be found, and the missing
2383 arg error will be caught by compare_parameters(). */
2384 sprintf (name, "%s", sym->name);
2385 sprintf (binding_label, "%s", sym->binding_label);
2392 /* Resolve a generic version of the iso_c_binding procedure given
2393 (sym) to the specific one based on the type and kind of the
2394 argument(s). Currently, this function resolves c_f_pointer() and
2395 c_f_procpointer based on the type and kind of the second argument
2396 (FPTR). Other iso_c_binding procedures aren't specially handled.
2397 Upon successfully exiting, c->resolved_sym will hold the resolved
2398 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2402 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2404 gfc_symbol *new_sym;
2405 /* this is fine, since we know the names won't use the max */
2406 char name[GFC_MAX_SYMBOL_LEN + 1];
2407 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2408 /* default to success; will override if find error */
2409 match m = MATCH_YES;
2411 /* Make sure the actual arguments are in the necessary order (based on the
2412 formal args) before resolving. */
2413 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2415 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2416 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2418 set_name_and_label (c, sym, name, binding_label);
2420 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2422 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2424 /* Make sure we got a third arg if the second arg has non-zero
2425 rank. We must also check that the type and rank are
2426 correct since we short-circuit this check in
2427 gfc_procedure_use() (called above to sort actual args). */
2428 if (c->ext.actual->next->expr->rank != 0)
2430 if(c->ext.actual->next->next == NULL
2431 || c->ext.actual->next->next->expr == NULL)
2434 gfc_error ("Missing SHAPE parameter for call to %s "
2435 "at %L", sym->name, &(c->loc));
2437 else if (c->ext.actual->next->next->expr->ts.type
2439 || c->ext.actual->next->next->expr->rank != 1)
2442 gfc_error ("SHAPE parameter for call to %s at %L must "
2443 "be a rank 1 INTEGER array", sym->name,
2450 if (m != MATCH_ERROR)
2452 /* the 1 means to add the optional arg to formal list */
2453 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2455 /* for error reporting, say it's declared where the original was */
2456 new_sym->declared_at = sym->declared_at;
2459 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2461 /* TODO: Figure out if this is even reachable; this part of the
2462 conditional may not be necessary. */
2464 if (c->ext.actual->next == NULL)
2466 /* The user did not give two args, so resolve to the version
2467 of c_associated expecting one arg. */
2469 /* get rid of the second arg */
2470 /* TODO!! Should free up the memory here! */
2471 sym->formal->next = NULL;
2479 sprintf (name, "%s_%d", sym->name, num_args);
2480 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2481 sym->name = gfc_get_string (name);
2482 strcpy (sym->binding_label, binding_label);
2486 /* no differences for c_loc or c_funloc */
2490 /* set the resolved symbol */
2491 if (m != MATCH_ERROR)
2492 c->resolved_sym = new_sym;
2494 c->resolved_sym = sym;
2500 /* Resolve a subroutine call known to be specific. */
2503 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2507 if(sym->attr.is_iso_c)
2509 m = gfc_iso_c_sub_interface (c,sym);
2513 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2515 if (sym->attr.dummy)
2517 sym->attr.proc = PROC_DUMMY;
2521 sym->attr.proc = PROC_EXTERNAL;
2525 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2528 if (sym->attr.intrinsic)
2530 m = gfc_intrinsic_sub_interface (c, 1);
2534 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2535 "with an intrinsic", sym->name, &c->loc);
2543 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2545 c->resolved_sym = sym;
2546 pure_subroutine (c, sym);
2553 resolve_specific_s (gfc_code *c)
2558 sym = c->symtree->n.sym;
2562 m = resolve_specific_s0 (c, sym);
2565 if (m == MATCH_ERROR)
2568 if (sym->ns->parent == NULL)
2571 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2577 sym = c->symtree->n.sym;
2578 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2579 sym->name, &c->loc);
2585 /* Resolve a subroutine call not known to be generic nor specific. */
2588 resolve_unknown_s (gfc_code *c)
2592 sym = c->symtree->n.sym;
2594 if (sym->attr.dummy)
2596 sym->attr.proc = PROC_DUMMY;
2600 /* See if we have an intrinsic function reference. */
2602 if (gfc_intrinsic_name (sym->name, 1))
2604 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2609 /* The reference is to an external name. */
2612 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2614 c->resolved_sym = sym;
2616 pure_subroutine (c, sym);
2622 /* Resolve a subroutine call. Although it was tempting to use the same code
2623 for functions, subroutines and functions are stored differently and this
2624 makes things awkward. */
2627 resolve_call (gfc_code *c)
2630 procedure_type ptype = PROC_INTRINSIC;
2632 if (c->symtree && c->symtree->n.sym
2633 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2635 gfc_error ("'%s' at %L has a type, which is not consistent with "
2636 "the CALL at %L", c->symtree->n.sym->name,
2637 &c->symtree->n.sym->declared_at, &c->loc);
2641 /* If external, check for usage. */
2642 if (c->symtree && is_external_proc (c->symtree->n.sym))
2643 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2645 /* Subroutines without the RECURSIVE attribution are not allowed to
2646 * call themselves. */
2647 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2649 gfc_symbol *csym, *proc;
2650 csym = c->symtree->n.sym;
2651 proc = gfc_current_ns->proc_name;
2654 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2655 "RECURSIVE", csym->name, &c->loc);
2659 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2660 && csym->ns->entries->sym == proc->ns->entries->sym)
2662 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2663 "'%s' is not declared as RECURSIVE",
2664 csym->name, &c->loc, csym->ns->entries->sym->name);
2669 /* Switch off assumed size checking and do this again for certain kinds
2670 of procedure, once the procedure itself is resolved. */
2671 need_full_assumed_size++;
2673 if (c->symtree && c->symtree->n.sym)
2674 ptype = c->symtree->n.sym->attr.proc;
2676 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2679 /* Resume assumed_size checking. */
2680 need_full_assumed_size--;
2683 if (c->resolved_sym == NULL)
2684 switch (procedure_kind (c->symtree->n.sym))
2687 t = resolve_generic_s (c);
2690 case PTYPE_SPECIFIC:
2691 t = resolve_specific_s (c);
2695 t = resolve_unknown_s (c);
2699 gfc_internal_error ("resolve_subroutine(): bad function type");
2702 /* Some checks of elemental subroutine actual arguments. */
2703 if (resolve_elemental_actual (NULL, c) == FAILURE)
2707 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2712 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2713 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2714 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2715 if their shapes do not match. If either op1->shape or op2->shape is
2716 NULL, return SUCCESS. */
2719 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2726 if (op1->shape != NULL && op2->shape != NULL)
2728 for (i = 0; i < op1->rank; i++)
2730 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2732 gfc_error ("Shapes for operands at %L and %L are not conformable",
2733 &op1->where, &op2->where);
2744 /* Resolve an operator expression node. This can involve replacing the
2745 operation with a user defined function call. */
2748 resolve_operator (gfc_expr *e)
2750 gfc_expr *op1, *op2;
2752 bool dual_locus_error;
2755 /* Resolve all subnodes-- give them types. */
2757 switch (e->value.op.operator)
2760 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2763 /* Fall through... */
2766 case INTRINSIC_UPLUS:
2767 case INTRINSIC_UMINUS:
2768 case INTRINSIC_PARENTHESES:
2769 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2774 /* Typecheck the new node. */
2776 op1 = e->value.op.op1;
2777 op2 = e->value.op.op2;
2778 dual_locus_error = false;
2780 if ((op1 && op1->expr_type == EXPR_NULL)
2781 || (op2 && op2->expr_type == EXPR_NULL))
2783 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2787 switch (e->value.op.operator)
2789 case INTRINSIC_UPLUS:
2790 case INTRINSIC_UMINUS:
2791 if (op1->ts.type == BT_INTEGER
2792 || op1->ts.type == BT_REAL
2793 || op1->ts.type == BT_COMPLEX)
2799 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2800 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2803 case INTRINSIC_PLUS:
2804 case INTRINSIC_MINUS:
2805 case INTRINSIC_TIMES:
2806 case INTRINSIC_DIVIDE:
2807 case INTRINSIC_POWER:
2808 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2810 gfc_type_convert_binary (e);
2815 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2816 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2817 gfc_typename (&op2->ts));
2820 case INTRINSIC_CONCAT:
2821 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2823 e->ts.type = BT_CHARACTER;
2824 e->ts.kind = op1->ts.kind;
2829 _("Operands of string concatenation operator at %%L are %s/%s"),
2830 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2836 case INTRINSIC_NEQV:
2837 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2839 e->ts.type = BT_LOGICAL;
2840 e->ts.kind = gfc_kind_max (op1, op2);
2841 if (op1->ts.kind < e->ts.kind)
2842 gfc_convert_type (op1, &e->ts, 2);
2843 else if (op2->ts.kind < e->ts.kind)
2844 gfc_convert_type (op2, &e->ts, 2);
2848 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2849 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2850 gfc_typename (&op2->ts));
2855 if (op1->ts.type == BT_LOGICAL)
2857 e->ts.type = BT_LOGICAL;
2858 e->ts.kind = op1->ts.kind;
2862 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2863 gfc_typename (&op1->ts));
2867 case INTRINSIC_GT_OS:
2869 case INTRINSIC_GE_OS:
2871 case INTRINSIC_LT_OS:
2873 case INTRINSIC_LE_OS:
2874 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2876 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2880 /* Fall through... */
2883 case INTRINSIC_EQ_OS:
2885 case INTRINSIC_NE_OS:
2886 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2888 e->ts.type = BT_LOGICAL;
2889 e->ts.kind = gfc_default_logical_kind;
2893 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2895 gfc_type_convert_binary (e);
2897 e->ts.type = BT_LOGICAL;
2898 e->ts.kind = gfc_default_logical_kind;
2902 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2904 _("Logicals at %%L must be compared with %s instead of %s"),
2905 (e->value.op.operator == INTRINSIC_EQ
2906 || e->value.op.operator == INTRINSIC_EQ_OS)
2907 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2910 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2911 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2912 gfc_typename (&op2->ts));
2916 case INTRINSIC_USER:
2917 if (e->value.op.uop->operator == NULL)
2918 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2919 else if (op2 == NULL)
2920 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2921 e->value.op.uop->name, gfc_typename (&op1->ts));
2923 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2924 e->value.op.uop->name, gfc_typename (&op1->ts),
2925 gfc_typename (&op2->ts));
2929 case INTRINSIC_PARENTHESES:
2933 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2936 /* Deal with arrayness of an operand through an operator. */
2940 switch (e->value.op.operator)
2942 case INTRINSIC_PLUS:
2943 case INTRINSIC_MINUS:
2944 case INTRINSIC_TIMES:
2945 case INTRINSIC_DIVIDE:
2946 case INTRINSIC_POWER:
2947 case INTRINSIC_CONCAT:
2951 case INTRINSIC_NEQV:
2953 case INTRINSIC_EQ_OS:
2955 case INTRINSIC_NE_OS:
2957 case INTRINSIC_GT_OS:
2959 case INTRINSIC_GE_OS:
2961 case INTRINSIC_LT_OS:
2963 case INTRINSIC_LE_OS:
2965 if (op1->rank == 0 && op2->rank == 0)
2968 if (op1->rank == 0 && op2->rank != 0)
2970 e->rank = op2->rank;
2972 if (e->shape == NULL)
2973 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2976 if (op1->rank != 0 && op2->rank == 0)
2978 e->rank = op1->rank;
2980 if (e->shape == NULL)
2981 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2984 if (op1->rank != 0 && op2->rank != 0)
2986 if (op1->rank == op2->rank)
2988 e->rank = op1->rank;
2989 if (e->shape == NULL)
2991 t = compare_shapes(op1, op2);
2995 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3000 /* Allow higher level expressions to work. */
3003 /* Try user-defined operators, and otherwise throw an error. */
3004 dual_locus_error = true;
3006 _("Inconsistent ranks for operator at %%L and %%L"));
3013 case INTRINSIC_PARENTHESES:
3015 /* This is always correct and sometimes necessary! */
3016 if (e->ts.type == BT_UNKNOWN)
3019 if (e->ts.type == BT_CHARACTER && !e->ts.cl)
3020 e->ts.cl = op1->ts.cl;
3023 case INTRINSIC_UPLUS:
3024 case INTRINSIC_UMINUS:
3025 /* Simply copy arrayness attribute */
3026 e->rank = op1->rank;
3028 if (e->shape == NULL)
3029 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3037 /* Attempt to simplify the expression. */
3040 t = gfc_simplify_expr (e, 0);
3041 /* Some calls do not succeed in simplification and return FAILURE
3042 even though there is no error; eg. variable references to
3043 PARAMETER arrays. */
3044 if (!gfc_is_constant_expr (e))
3051 if (gfc_extend_expr (e) == SUCCESS)
3054 if (dual_locus_error)
3055 gfc_error (msg, &op1->where, &op2->where);
3057 gfc_error (msg, &e->where);
3063 /************** Array resolution subroutines **************/
3066 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3069 /* Compare two integer expressions. */
3072 compare_bound (gfc_expr *a, gfc_expr *b)
3076 if (a == NULL || a->expr_type != EXPR_CONSTANT
3077 || b == NULL || b->expr_type != EXPR_CONSTANT)
3080 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3081 gfc_internal_error ("compare_bound(): Bad expression");
3083 i = mpz_cmp (a->value.integer, b->value.integer);
3093 /* Compare an integer expression with an integer. */
3096 compare_bound_int (gfc_expr *a, int b)
3100 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3103 if (a->ts.type != BT_INTEGER)
3104 gfc_internal_error ("compare_bound_int(): Bad expression");
3106 i = mpz_cmp_si (a->value.integer, b);
3116 /* Compare an integer expression with a mpz_t. */
3119 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3123 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3126 if (a->ts.type != BT_INTEGER)
3127 gfc_internal_error ("compare_bound_int(): Bad expression");
3129 i = mpz_cmp (a->value.integer, b);
3139 /* Compute the last value of a sequence given by a triplet.
3140 Return 0 if it wasn't able to compute the last value, or if the
3141 sequence if empty, and 1 otherwise. */
3144 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3145 gfc_expr *stride, mpz_t last)
3149 if (start == NULL || start->expr_type != EXPR_CONSTANT
3150 || end == NULL || end->expr_type != EXPR_CONSTANT
3151 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3154 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3155 || (stride != NULL && stride->ts.type != BT_INTEGER))
3158 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3160 if (compare_bound (start, end) == CMP_GT)
3162 mpz_set (last, end->value.integer);
3166 if (compare_bound_int (stride, 0) == CMP_GT)
3168 /* Stride is positive */
3169 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3174 /* Stride is negative */
3175 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3180 mpz_sub (rem, end->value.integer, start->value.integer);
3181 mpz_tdiv_r (rem, rem, stride->value.integer);
3182 mpz_sub (last, end->value.integer, rem);
3189 /* Compare a single dimension of an array reference to the array
3193 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3197 /* Given start, end and stride values, calculate the minimum and
3198 maximum referenced indexes. */
3206 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3208 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3215 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3216 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3218 comparison comp_start_end = compare_bound (AR_START, AR_END);
3220 /* Check for zero stride, which is not allowed. */
3221 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3223 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3227 /* if start == len || (stride > 0 && start < len)
3228 || (stride < 0 && start > len),
3229 then the array section contains at least one element. In this
3230 case, there is an out-of-bounds access if
3231 (start < lower || start > upper). */
3232 if (compare_bound (AR_START, AR_END) == CMP_EQ
3233 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3234 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3235 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3236 && comp_start_end == CMP_GT))
3238 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3239 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3243 /* If we can compute the highest index of the array section,
3244 then it also has to be between lower and upper. */
3245 mpz_init (last_value);
3246 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3249 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3250 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3252 mpz_clear (last_value);
3256 mpz_clear (last_value);
3264 gfc_internal_error ("check_dimension(): Bad array reference");
3270 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3275 /* Compare an array reference with an array specification. */
3278 compare_spec_to_ref (gfc_array_ref *ar)
3285 /* TODO: Full array sections are only allowed as actual parameters. */
3286 if (as->type == AS_ASSUMED_SIZE
3287 && (/*ar->type == AR_FULL
3288 ||*/ (ar->type == AR_SECTION
3289 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3291 gfc_error ("Rightmost upper bound of assumed size array section "
3292 "not specified at %L", &ar->where);
3296 if (ar->type == AR_FULL)
3299 if (as->rank != ar->dimen)
3301 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3302 &ar->where, ar->dimen, as->rank);
3306 for (i = 0; i < as->rank; i++)
3307 if (check_dimension (i, ar, as) == FAILURE)
3314 /* Resolve one part of an array index. */
3317 gfc_resolve_index (gfc_expr *index, int check_scalar)
3324 if (gfc_resolve_expr (index) == FAILURE)
3327 if (check_scalar && index->rank != 0)
3329 gfc_error ("Array index at %L must be scalar", &index->where);
3333 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3335 gfc_error ("Array index at %L must be of INTEGER type",
3340 if (index->ts.type == BT_REAL)
3341 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3342 &index->where) == FAILURE)
3345 if (index->ts.kind != gfc_index_integer_kind
3346 || index->ts.type != BT_INTEGER)
3349 ts.type = BT_INTEGER;
3350 ts.kind = gfc_index_integer_kind;
3352 gfc_convert_type_warn (index, &ts, 2, 0);
3358 /* Resolve a dim argument to an intrinsic function. */
3361 gfc_resolve_dim_arg (gfc_expr *dim)
3366 if (gfc_resolve_expr (dim) == FAILURE)
3371 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3375 if (dim->ts.type != BT_INTEGER)
3377 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3380 if (dim->ts.kind != gfc_index_integer_kind)
3384 ts.type = BT_INTEGER;
3385 ts.kind = gfc_index_integer_kind;
3387 gfc_convert_type_warn (dim, &ts, 2, 0);
3393 /* Given an expression that contains array references, update those array
3394 references to point to the right array specifications. While this is
3395 filled in during matching, this information is difficult to save and load
3396 in a module, so we take care of it here.
3398 The idea here is that the original array reference comes from the
3399 base symbol. We traverse the list of reference structures, setting
3400 the stored reference to references. Component references can
3401 provide an additional array specification. */
3404 find_array_spec (gfc_expr *e)
3408 gfc_symbol *derived;
3411 as = e->symtree->n.sym->as;
3414 for (ref = e->ref; ref; ref = ref->next)
3419 gfc_internal_error ("find_array_spec(): Missing spec");
3426 if (derived == NULL)
3427 derived = e->symtree->n.sym->ts.derived;
3429 c = derived->components;
3431 for (; c; c = c->next)
3432 if (c == ref->u.c.component)
3434 /* Track the sequence of component references. */
3435 if (c->ts.type == BT_DERIVED)
3436 derived = c->ts.derived;
3441 gfc_internal_error ("find_array_spec(): Component not found");
3446 gfc_internal_error ("find_array_spec(): unused as(1)");
3457 gfc_internal_error ("find_array_spec(): unused as(2)");
3461 /* Resolve an array reference. */
3464 resolve_array_ref (gfc_array_ref *ar)
3466 int i, check_scalar;
3469 for (i = 0; i < ar->dimen; i++)
3471 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3473 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3475 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3477 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3482 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3486 ar->dimen_type[i] = DIMEN_ELEMENT;
3490 ar->dimen_type[i] = DIMEN_VECTOR;
3491 if (e->expr_type == EXPR_VARIABLE
3492 && e->symtree->n.sym->ts.type == BT_DERIVED)
3493 ar->start[i] = gfc_get_parentheses (e);
3497 gfc_error ("Array index at %L is an array of rank %d",
3498 &ar->c_where[i], e->rank);
3503 /* If the reference type is unknown, figure out what kind it is. */
3505 if (ar->type == AR_UNKNOWN)
3507 ar->type = AR_ELEMENT;
3508 for (i = 0; i < ar->dimen; i++)
3509 if (ar->dimen_type[i] == DIMEN_RANGE
3510 || ar->dimen_type[i] == DIMEN_VECTOR)
3512 ar->type = AR_SECTION;
3517 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3525 resolve_substring (gfc_ref *ref)
3527 if (ref->u.ss.start != NULL)
3529 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3532 if (ref->u.ss.start->ts.type != BT_INTEGER)
3534 gfc_error ("Substring start index at %L must be of type INTEGER",
3535 &ref->u.ss.start->where);
3539 if (ref->u.ss.start->rank != 0)
3541 gfc_error ("Substring start index at %L must be scalar",
3542 &ref->u.ss.start->where);
3546 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3547 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3548 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3550 gfc_error ("Substring start index at %L is less than one",
3551 &ref->u.ss.start->where);
3556 if (ref->u.ss.end != NULL)
3558 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3561 if (ref->u.ss.end->ts.type != BT_INTEGER)
3563 gfc_error ("Substring end index at %L must be of type INTEGER",
3564 &ref->u.ss.end->where);
3568 if (ref->u.ss.end->rank != 0)
3570 gfc_error ("Substring end index at %L must be scalar",
3571 &ref->u.ss.end->where);
3575 if (ref->u.ss.length != NULL
3576 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3577 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3578 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3580 gfc_error ("Substring end index at %L exceeds the string length",
3581 &ref->u.ss.start->where);
3590 /* This function supplies missing substring charlens. */
3593 gfc_resolve_substring_charlen (gfc_expr *e)
3596 gfc_expr *start, *end;
3598 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3599 if (char_ref->type == REF_SUBSTRING)
3605 gcc_assert (char_ref->next == NULL);
3609 if (e->ts.cl->length)
3610 gfc_free_expr (e->ts.cl->length);
3611 else if (e->expr_type == EXPR_VARIABLE
3612 && e->symtree->n.sym->attr.dummy)
3616 e->ts.type = BT_CHARACTER;
3617 e->ts.kind = gfc_default_character_kind;
3621 e->ts.cl = gfc_get_charlen ();
3622 e->ts.cl->next = gfc_current_ns->cl_list;
3623 gfc_current_ns->cl_list = e->ts.cl;
3626 if (char_ref->u.ss.start)
3627 start = gfc_copy_expr (char_ref->u.ss.start);
3629 start = gfc_int_expr (1);
3631 if (char_ref->u.ss.end)
3632 end = gfc_copy_expr (char_ref->u.ss.end);
3633 else if (e->expr_type == EXPR_VARIABLE)
3634 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3641 /* Length = (end - start +1). */
3642 e->ts.cl->length = gfc_subtract (end, start);
3643 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3645 e->ts.cl->length->ts.type = BT_INTEGER;
3646 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3648 /* Make sure that the length is simplified. */
3649 gfc_simplify_expr (e->ts.cl->length, 1);
3650 gfc_resolve_expr (e->ts.cl->length);
3654 /* Resolve subtype references. */
3657 resolve_ref (gfc_expr *expr)
3659 int current_part_dimension, n_components, seen_part_dimension;
3662 for (ref = expr->ref; ref; ref = ref->next)
3663 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3665 find_array_spec (expr);
3669 for (ref = expr->ref; ref; ref = ref->next)
3673 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3681 resolve_substring (ref);
3685 /* Check constraints on part references. */
3687 current_part_dimension = 0;
3688 seen_part_dimension = 0;
3691 for (ref = expr->ref; ref; ref = ref->next)
3696 switch (ref->u.ar.type)
3700 current_part_dimension = 1;
3704 current_part_dimension = 0;
3708 gfc_internal_error ("resolve_ref(): Bad array reference");
3714 if (current_part_dimension || seen_part_dimension)
3716 if (ref->u.c.component->pointer)
3718 gfc_error ("Component to the right of a part reference "
3719 "with nonzero rank must not have the POINTER "
3720 "attribute at %L", &expr->where);
3723 else if (ref->u.c.component->allocatable)
3725 gfc_error ("Component to the right of a part reference "
3726 "with nonzero rank must not have the ALLOCATABLE "
3727 "attribute at %L", &expr->where);
3739 if (((ref->type == REF_COMPONENT && n_components > 1)
3740 || ref->next == NULL)
3741 && current_part_dimension
3742 && seen_part_dimension)
3744 gfc_error ("Two or more part references with nonzero rank must "
3745 "not be specified at %L", &expr->where);
3749 if (ref->type == REF_COMPONENT)
3751 if (current_part_dimension)
3752 seen_part_dimension = 1;
3754 /* reset to make sure */
3755 current_part_dimension = 0;
3763 /* Given an expression, determine its shape. This is easier than it sounds.
3764 Leaves the shape array NULL if it is not possible to determine the shape. */
3767 expression_shape (gfc_expr *e)
3769 mpz_t array[GFC_MAX_DIMENSIONS];
3772 if (e->rank == 0 || e->shape != NULL)
3775 for (i = 0; i < e->rank; i++)
3776 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3779 e->shape = gfc_get_shape (e->rank);
3781 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3786 for (i--; i >= 0; i--)
3787 mpz_clear (array[i]);
3791 /* Given a variable expression node, compute the rank of the expression by
3792 examining the base symbol and any reference structures it may have. */
3795 expression_rank (gfc_expr *e)
3802 if (e->expr_type == EXPR_ARRAY)
3804 /* Constructors can have a rank different from one via RESHAPE(). */
3806 if (e->symtree == NULL)
3812 e->rank = (e->symtree->n.sym->as == NULL)
3813 ? 0 : e->symtree->n.sym->as->rank;
3819 for (ref = e->ref; ref; ref = ref->next)
3821 if (ref->type != REF_ARRAY)
3824 if (ref->u.ar.type == AR_FULL)
3826 rank = ref->u.ar.as->rank;
3830 if (ref->u.ar.type == AR_SECTION)
3832 /* Figure out the rank of the section. */
3834 gfc_internal_error ("expression_rank(): Two array specs");
3836 for (i = 0; i < ref->u.ar.dimen; i++)
3837 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3838 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3848 expression_shape (e);
3852 /* Resolve a variable expression. */
3855 resolve_variable (gfc_expr *e)
3862 if (e->symtree == NULL)
3865 if (e->ref && resolve_ref (e) == FAILURE)
3868 sym = e->symtree->n.sym;
3869 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3871 e->ts.type = BT_PROCEDURE;
3875 if (sym->ts.type != BT_UNKNOWN)
3876 gfc_variable_attr (e, &e->ts);
3879 /* Must be a simple variable reference. */
3880 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3885 if (check_assumed_size_reference (sym, e))
3888 /* Deal with forward references to entries during resolve_code, to
3889 satisfy, at least partially, 12.5.2.5. */
3890 if (gfc_current_ns->entries
3891 && current_entry_id == sym->entry_id
3894 && cs_base->current->op != EXEC_ENTRY)
3896 gfc_entry_list *entry;
3897 gfc_formal_arglist *formal;
3901 /* If the symbol is a dummy... */
3902 if (sym->attr.dummy)
3904 entry = gfc_current_ns->entries;
3907 /* ...test if the symbol is a parameter of previous entries. */
3908 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3909 for (formal = entry->sym->formal; formal; formal = formal->next)
3911 if (formal->sym && sym->name == formal->sym->name)
3915 /* If it has not been seen as a dummy, this is an error. */
3918 if (specification_expr)
3919 gfc_error ("Variable '%s',used in a specification expression, "
3920 "is referenced at %L before the ENTRY statement "
3921 "in which it is a parameter",
3922 sym->name, &cs_base->current->loc);
3924 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3925 "statement in which it is a parameter",
3926 sym->name, &cs_base->current->loc);
3931 /* Now do the same check on the specification expressions. */
3932 specification_expr = 1;
3933 if (sym->ts.type == BT_CHARACTER
3934 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3938 for (n = 0; n < sym->as->rank; n++)
3940 specification_expr = 1;
3941 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3943 specification_expr = 1;
3944 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3947 specification_expr = 0;
3950 /* Update the symbol's entry level. */
3951 sym->entry_id = current_entry_id + 1;
3958 /* Checks to see that the correct symbol has been host associated.
3959 The only situation where this arises is that in which a twice
3960 contained function is parsed after the host association is made.
3961 Therefore, on detecting this, the line is rematched, having got
3962 rid of the existing references and actual_arg_list. */
3964 check_host_association (gfc_expr *e)
3966 gfc_symbol *sym, *old_sym;
3970 bool retval = e->expr_type == EXPR_FUNCTION;
3972 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3975 old_sym = e->symtree->n.sym;
3977 if (old_sym->attr.use_assoc)
3980 if (gfc_current_ns->parent
3981 && gfc_current_ns->parent->parent
3982 && old_sym->ns != gfc_current_ns)
3984 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3985 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3987 temp_locus = gfc_current_locus;
3988 gfc_current_locus = e->where;
3990 gfc_buffer_error (1);
3992 gfc_free_ref_list (e->ref);
3997 gfc_free_actual_arglist (e->value.function.actual);
3998 e->value.function.actual = NULL;
4001 if (e->shape != NULL)
4003 for (n = 0; n < e->rank; n++)
4004 mpz_clear (e->shape[n]);
4006 gfc_free (e->shape);
4009 gfc_match_rvalue (&expr);
4011 gfc_buffer_error (0);
4013 gcc_assert (expr && sym == expr->symtree->n.sym);
4019 gfc_current_locus = temp_locus;
4022 /* This might have changed! */
4023 return e->expr_type == EXPR_FUNCTION;
4028 gfc_resolve_character_operator (gfc_expr *e)
4030 gfc_expr *op1 = e->value.op.op1;
4031 gfc_expr *op2 = e->value.op.op2;
4032 gfc_expr *e1 = NULL;
4033 gfc_expr *e2 = NULL;
4035 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4037 if (op1->ts.cl && op1->ts.cl->length)
4038 e1 = gfc_copy_expr (op1->ts.cl->length);
4039 else if (op1->expr_type == EXPR_CONSTANT)
4040 e1 = gfc_int_expr (op1->value.character.length);
4042 if (op2->ts.cl && op2->ts.cl->length)
4043 e2 = gfc_copy_expr (op2->ts.cl->length);
4044 else if (op2->expr_type == EXPR_CONSTANT)
4045 e2 = gfc_int_expr (op2->value.character.length);
4047 e->ts.cl = gfc_get_charlen ();
4048 e->ts.cl->next = gfc_current_ns->cl_list;
4049 gfc_current_ns->cl_list = e->ts.cl;
4054 e->ts.cl->length = gfc_add (e1, e2);
4055 e->ts.cl->length->ts.type = BT_INTEGER;
4056 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4057 gfc_simplify_expr (e->ts.cl->length, 0);
4058 gfc_resolve_expr (e->ts.cl->length);
4064 /* Ensure that an character expression has a charlen and, if possible, a
4065 length expression. */
4068 fixup_charlen (gfc_expr *e)
4070 /* The cases fall through so that changes in expression type and the need
4071 for multiple fixes are picked up. In all circumstances, a charlen should
4072 be available for the middle end to hang a backend_decl on. */
4073 switch (e->expr_type)
4076 gfc_resolve_character_operator (e);
4079 if (e->expr_type == EXPR_ARRAY)
4080 gfc_resolve_character_array_constructor (e);
4082 case EXPR_SUBSTRING:
4083 if (!e->ts.cl && e->ref)
4084 gfc_resolve_substring_charlen (e);
4089 e->ts.cl = gfc_get_charlen ();
4090 e->ts.cl->next = gfc_current_ns->cl_list;
4091 gfc_current_ns->cl_list = e->ts.cl;
4099 /* Resolve an expression. That is, make sure that types of operands agree
4100 with their operators, intrinsic operators are converted to function calls
4101 for overloaded types and unresolved function references are resolved. */
4104 gfc_resolve_expr (gfc_expr *e)
4111 switch (e->expr_type)
4114 t = resolve_operator (e);
4120 if (check_host_association (e))
4121 t = resolve_function (e);
4124 t = resolve_variable (e);
4126 expression_rank (e);
4129 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4130 && e->ref->type != REF_SUBSTRING)
4131 gfc_resolve_substring_charlen (e);
4135 case EXPR_SUBSTRING:
4136 t = resolve_ref (e);
4146 if (resolve_ref (e) == FAILURE)
4149 t = gfc_resolve_array_constructor (e);
4150 /* Also try to expand a constructor. */
4153 expression_rank (e);
4154 gfc_expand_constructor (e);
4157 /* This provides the opportunity for the length of constructors with
4158 character valued function elements to propagate the string length
4159 to the expression. */
4160 if (e->ts.type == BT_CHARACTER)
4161 gfc_resolve_character_array_constructor (e);
4165 case EXPR_STRUCTURE:
4166 t = resolve_ref (e);
4170 t = resolve_structure_cons (e);
4174 t = gfc_simplify_expr (e, 0);
4178 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4181 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4188 /* Resolve an expression from an iterator. They must be scalar and have
4189 INTEGER or (optionally) REAL type. */
4192 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4193 const char *name_msgid)
4195 if (gfc_resolve_expr (expr) == FAILURE)
4198 if (expr->rank != 0)
4200 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4204 if (expr->ts.type != BT_INTEGER)
4206 if (expr->ts.type == BT_REAL)
4209 return gfc_notify_std (GFC_STD_F95_DEL,
4210 "Deleted feature: %s at %L must be integer",
4211 _(name_msgid), &expr->where);
4214 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4221 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4229 /* Resolve the expressions in an iterator structure. If REAL_OK is
4230 false allow only INTEGER type iterators, otherwise allow REAL types. */
4233 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4235 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4239 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4241 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4246 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4247 "Start expression in DO loop") == FAILURE)
4250 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4251 "End expression in DO loop") == FAILURE)
4254 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4255 "Step expression in DO loop") == FAILURE)
4258 if (iter->step->expr_type == EXPR_CONSTANT)
4260 if ((iter->step->ts.type == BT_INTEGER
4261 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4262 || (iter->step->ts.type == BT_REAL
4263 && mpfr_sgn (iter->step->value.real) == 0))
4265 gfc_error ("Step expression in DO loop at %L cannot be zero",
4266 &iter->step->where);
4271 /* Convert start, end, and step to the same type as var. */
4272 if (iter->start->ts.kind != iter->var->ts.kind
4273 || iter->start->ts.type != iter->var->ts.type)
4274 gfc_convert_type (iter->start, &iter->var->ts, 2);
4276 if (iter->end->ts.kind != iter->var->ts.kind
4277 || iter->end->ts.type != iter->var->ts.type)
4278 gfc_convert_type (iter->end, &iter->var->ts, 2);
4280 if (iter->step->ts.kind != iter->var->ts.kind
4281 || iter->step->ts.type != iter->var->ts.type)
4282 gfc_convert_type (iter->step, &iter->var->ts, 2);
4288 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4289 to be a scalar INTEGER variable. The subscripts and stride are scalar
4290 INTEGERs, and if stride is a constant it must be nonzero. */
4293 resolve_forall_iterators (gfc_forall_iterator *iter)
4297 if (gfc_resolve_expr (iter->var) == SUCCESS
4298 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4299 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4302 if (gfc_resolve_expr (iter->start) == SUCCESS
4303 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4304 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4305 &iter->start->where);
4306 if (iter->var->ts.kind != iter->start->ts.kind)
4307 gfc_convert_type (iter->start, &iter->var->ts, 2);
4309 if (gfc_resolve_expr (iter->end) == SUCCESS
4310 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4311 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4313 if (iter->var->ts.kind != iter->end->ts.kind)
4314 gfc_convert_type (iter->end, &iter->var->ts, 2);
4316 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4318 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4319 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4320 &iter->stride->where, "INTEGER");
4322 if (iter->stride->expr_type == EXPR_CONSTANT
4323 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4324 gfc_error ("FORALL stride expression at %L cannot be zero",
4325 &iter->stride->where);
4327 if (iter->var->ts.kind != iter->stride->ts.kind)
4328 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4335 /* Given a pointer to a symbol that is a derived type, see if it's
4336 inaccessible, i.e. if it's defined in another module and the components are
4337 PRIVATE. The search is recursive if necessary. Returns zero if no
4338 inaccessible components are found, nonzero otherwise. */
4341 derived_inaccessible (gfc_symbol *sym)
4345 if (sym->attr.use_assoc && sym->attr.private_comp)
4348 for (c = sym->components; c; c = c->next)
4350 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4358 /* Resolve the argument of a deallocate expression. The expression must be
4359 a pointer or a full array. */
4362 resolve_deallocate_expr (gfc_expr *e)
4364 symbol_attribute attr;
4365 int allocatable, pointer, check_intent_in;
4368 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4369 check_intent_in = 1;
4371 if (gfc_resolve_expr (e) == FAILURE)
4374 if (e->expr_type != EXPR_VARIABLE)
4377 allocatable = e->symtree->n.sym->attr.allocatable;
4378 pointer = e->symtree->n.sym->attr.pointer;
4379 for (ref = e->ref; ref; ref = ref->next)
4382 check_intent_in = 0;
4387 if (ref->u.ar.type != AR_FULL)
4392 allocatable = (ref->u.c.component->as != NULL
4393 && ref->u.c.component->as->type == AS_DEFERRED);
4394 pointer = ref->u.c.component->pointer;
4403 attr = gfc_expr_attr (e);
4405 if (allocatable == 0 && attr.pointer == 0)
4408 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4409 "ALLOCATABLE or a POINTER", &e->where);
4413 && e->symtree->n.sym->attr.intent == INTENT_IN)
4415 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4416 e->symtree->n.sym->name, &e->where);
4424 /* Returns true if the expression e contains a reference the symbol sym. */
4426 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4428 gfc_actual_arglist *arg;
4436 switch (e->expr_type)
4439 for (arg = e->value.function.actual; arg; arg = arg->next)
4440 rv = rv || find_sym_in_expr (sym, arg->expr);
4443 /* If the variable is not the same as the dependent, 'sym', and
4444 it is not marked as being declared and it is in the same
4445 namespace as 'sym', add it to the local declarations. */
4447 if (sym == e->symtree->n.sym)
4452 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4453 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4462 for (ref = e->ref; ref; ref = ref->next)
4467 for (i = 0; i < ref->u.ar.dimen; i++)
4469 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4470 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4471 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4476 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4477 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4481 if (ref->u.c.component->ts.type == BT_CHARACTER
4482 && ref->u.c.component->ts.cl->length->expr_type
4485 || find_sym_in_expr (sym,
4486 ref->u.c.component->ts.cl->length);
4488 if (ref->u.c.component->as)
4489 for (i = 0; i < ref->u.c.component->as->rank; i++)
4492 || find_sym_in_expr (sym,
4493 ref->u.c.component->as->lower[i]);
4495 || find_sym_in_expr (sym,
4496 ref->u.c.component->as->upper[i]);
4506 /* Given the expression node e for an allocatable/pointer of derived type to be
4507 allocated, get the expression node to be initialized afterwards (needed for
4508 derived types with default initializers, and derived types with allocatable
4509 components that need nullification.) */
4512 expr_to_initialize (gfc_expr *e)
4518 result = gfc_copy_expr (e);
4520 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4521 for (ref = result->ref; ref; ref = ref->next)
4522 if (ref->type == REF_ARRAY && ref->next == NULL)
4524 ref->u.ar.type = AR_FULL;
4526 for (i = 0; i < ref->u.ar.dimen; i++)
4527 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4529 result->rank = ref->u.ar.dimen;
4537 /* Resolve the expression in an ALLOCATE statement, doing the additional
4538 checks to see whether the expression is OK or not. The expression must
4539 have a trailing array reference that gives the size of the array. */
4542 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4544 int i, pointer, allocatable, dimension, check_intent_in;
4545 symbol_attribute attr;
4546 gfc_ref *ref, *ref2;
4553 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4554 check_intent_in = 1;
4556 if (gfc_resolve_expr (e) == FAILURE)
4559 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4560 sym = code->expr->symtree->n.sym;
4564 /* Make sure the expression is allocatable or a pointer. If it is
4565 pointer, the next-to-last reference must be a pointer. */
4569 if (e->expr_type != EXPR_VARIABLE)
4572 attr = gfc_expr_attr (e);
4573 pointer = attr.pointer;
4574 dimension = attr.dimension;
4578 allocatable = e->symtree->n.sym->attr.allocatable;
4579 pointer = e->symtree->n.sym->attr.pointer;
4580 dimension = e->symtree->n.sym->attr.dimension;
4582 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4584 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4585 "not be allocated in the same statement at %L",
4586 sym->name, &e->where);
4590 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4593 check_intent_in = 0;
4598 if (ref->next != NULL)
4603 allocatable = (ref->u.c.component->as != NULL
4604 && ref->u.c.component->as->type == AS_DEFERRED);
4606 pointer = ref->u.c.component->pointer;
4607 dimension = ref->u.c.component->dimension;
4618 if (allocatable == 0 && pointer == 0)
4620 gfc_error ("Expression in ALLOCATE statement at %L must be "
4621 "ALLOCATABLE or a POINTER", &e->where);
4626 && e->symtree->n.sym->attr.intent == INTENT_IN)
4628 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4629 e->symtree->n.sym->name, &e->where);
4633 /* Add default initializer for those derived types that need them. */
4634 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4636 init_st = gfc_get_code ();
4637 init_st->loc = code->loc;
4638 init_st->op = EXEC_INIT_ASSIGN;
4639 init_st->expr = expr_to_initialize (e);
4640 init_st->expr2 = init_e;
4641 init_st->next = code->next;
4642 code->next = init_st;
4645 if (pointer && dimension == 0)
4648 /* Make sure the next-to-last reference node is an array specification. */
4650 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4652 gfc_error ("Array specification required in ALLOCATE statement "
4653 "at %L", &e->where);
4657 /* Make sure that the array section reference makes sense in the
4658 context of an ALLOCATE specification. */
4662 for (i = 0; i < ar->dimen; i++)
4664 if (ref2->u.ar.type == AR_ELEMENT)
4667 switch (ar->dimen_type[i])
4673 if (ar->start[i] != NULL
4674 && ar->end[i] != NULL
4675 && ar->stride[i] == NULL)
4678 /* Fall Through... */
4682 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4689 for (a = code->ext.alloc_list; a; a = a->next)
4691 sym = a->expr->symtree->n.sym;
4693 /* TODO - check derived type components. */
4694 if (sym->ts.type == BT_DERIVED)
4697 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4698 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4700 gfc_error ("'%s' must not appear an the array specification at "
4701 "%L in the same ALLOCATE statement where it is "
4702 "itself allocated", sym->name, &ar->where);
4712 /************ SELECT CASE resolution subroutines ************/
4714 /* Callback function for our mergesort variant. Determines interval
4715 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4716 op1 > op2. Assumes we're not dealing with the default case.
4717 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4718 There are nine situations to check. */
4721 compare_cases (const gfc_case *op1, const gfc_case *op2)
4725 if (op1->low == NULL) /* op1 = (:L) */
4727 /* op2 = (:N), so overlap. */
4729 /* op2 = (M:) or (M:N), L < M */
4730 if (op2->low != NULL
4731 && gfc_compare_expr (op1->high, op2->low) < 0)
4734 else if (op1->high == NULL) /* op1 = (K:) */
4736 /* op2 = (M:), so overlap. */
4738 /* op2 = (:N) or (M:N), K > N */
4739 if (op2->high != NULL
4740 && gfc_compare_expr (op1->low, op2->high) > 0)
4743 else /* op1 = (K:L) */
4745 if (op2->low == NULL) /* op2 = (:N), K > N */
4746 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4747 else if (op2->high == NULL) /* op2 = (M:), L < M */
4748 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4749 else /* op2 = (M:N) */
4753 if (gfc_compare_expr (op1->high, op2->low) < 0)
4756 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4765 /* Merge-sort a double linked case list, detecting overlap in the
4766 process. LIST is the head of the double linked case list before it
4767 is sorted. Returns the head of the sorted list if we don't see any
4768 overlap, or NULL otherwise. */
4771 check_case_overlap (gfc_case *list)
4773 gfc_case *p, *q, *e, *tail;
4774 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4776 /* If the passed list was empty, return immediately. */
4783 /* Loop unconditionally. The only exit from this loop is a return
4784 statement, when we've finished sorting the case list. */
4791 /* Count the number of merges we do in this pass. */
4794 /* Loop while there exists a merge to be done. */
4799 /* Count this merge. */
4802 /* Cut the list in two pieces by stepping INSIZE places
4803 forward in the list, starting from P. */
4806 for (i = 0; i < insize; i++)
4815 /* Now we have two lists. Merge them! */
4816 while (psize > 0 || (qsize > 0 && q != NULL))
4818 /* See from which the next case to merge comes from. */
4821 /* P is empty so the next case must come from Q. */
4826 else if (qsize == 0 || q == NULL)
4835 cmp = compare_cases (p, q);
4838 /* The whole case range for P is less than the
4846 /* The whole case range for Q is greater than
4847 the case range for P. */
4854 /* The cases overlap, or they are the same
4855 element in the list. Either way, we must
4856 issue an error and get the next case from P. */
4857 /* FIXME: Sort P and Q by line number. */
4858 gfc_error ("CASE label at %L overlaps with CASE "
4859 "label at %L", &p->where, &q->where);
4867 /* Add the next element to the merged list. */
4876 /* P has now stepped INSIZE places along, and so has Q. So
4877 they're the same. */
4882 /* If we have done only one merge or none at all, we've
4883 finished sorting the cases. */
4892 /* Otherwise repeat, merging lists twice the size. */
4898 /* Check to see if an expression is suitable for use in a CASE statement.
4899 Makes sure that all case expressions are scalar constants of the same
4900 type. Return FAILURE if anything is wrong. */
4903 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4905 if (e == NULL) return SUCCESS;
4907 if (e->ts.type != case_expr->ts.type)
4909 gfc_error ("Expression in CASE statement at %L must be of type %s",
4910 &e->where, gfc_basic_typename (case_expr->ts.type));
4914 /* C805 (R808) For a given case-construct, each case-value shall be of
4915 the same type as case-expr. For character type, length differences
4916 are allowed, but the kind type parameters shall be the same. */
4918 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4920 gfc_error("Expression in CASE statement at %L must be kind %d",
4921 &e->where, case_expr->ts.kind);
4925 /* Convert the case value kind to that of case expression kind, if needed.
4926 FIXME: Should a warning be issued? */
4927 if (e->ts.kind != case_expr->ts.kind)
4928 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4932 gfc_error ("Expression in CASE statement at %L must be scalar",
4941 /* Given a completely parsed select statement, we:
4943 - Validate all expressions and code within the SELECT.
4944 - Make sure that the selection expression is not of the wrong type.
4945 - Make sure that no case ranges overlap.
4946 - Eliminate unreachable cases and unreachable code resulting from
4947 removing case labels.
4949 The standard does allow unreachable cases, e.g. CASE (5:3). But
4950 they are a hassle for code generation, and to prevent that, we just
4951 cut them out here. This is not necessary for overlapping cases
4952 because they are illegal and we never even try to generate code.
4954 We have the additional caveat that a SELECT construct could have
4955 been a computed GOTO in the source code. Fortunately we can fairly
4956 easily work around that here: The case_expr for a "real" SELECT CASE
4957 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4958 we have to do is make sure that the case_expr is a scalar integer
4962 resolve_select (gfc_code *code)
4965 gfc_expr *case_expr;
4966 gfc_case *cp, *default_case, *tail, *head;
4967 int seen_unreachable;
4973 if (code->expr == NULL)
4975 /* This was actually a computed GOTO statement. */
4976 case_expr = code->expr2;
4977 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4978 gfc_error ("Selection expression in computed GOTO statement "
4979 "at %L must be a scalar integer expression",
4982 /* Further checking is not necessary because this SELECT was built
4983 by the compiler, so it should always be OK. Just move the
4984 case_expr from expr2 to expr so that we can handle computed
4985 GOTOs as normal SELECTs from here on. */
4986 code->expr = code->expr2;
4991 case_expr = code->expr;
4993 type = case_expr->ts.type;
4994 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4996 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4997 &case_expr->where, gfc_typename (&case_expr->ts));
4999 /* Punt. Going on here just produce more garbage error messages. */
5003 if (case_expr->rank != 0)
5005 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5006 "expression", &case_expr->where);
5012 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5013 of the SELECT CASE expression and its CASE values. Walk the lists
5014 of case values, and if we find a mismatch, promote case_expr to
5015 the appropriate kind. */
5017 if (type == BT_LOGICAL || type == BT_INTEGER)
5019 for (body = code->block; body; body = body->block)
5021 /* Walk the case label list. */
5022 for (cp = body->ext.case_list; cp; cp = cp->next)
5024 /* Intercept the DEFAULT case. It does not have a kind. */
5025 if (cp->low == NULL && cp->high == NULL)
5028 /* Unreachable case ranges are discarded, so ignore. */
5029 if (cp->low != NULL && cp->high != NULL
5030 && cp->low != cp->high
5031 && gfc_compare_expr (cp->low, cp->high) > 0)
5034 /* FIXME: Should a warning be issued? */
5036 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5037 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5039 if (cp->high != NULL
5040 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5041 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5046 /* Assume there is no DEFAULT case. */
5047 default_case = NULL;
5052 for (body = code->block; body; body = body->block)
5054 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5056 seen_unreachable = 0;
5058 /* Walk the case label list, making sure that all case labels
5060 for (cp = body->ext.case_list; cp; cp = cp->next)
5062 /* Count the number of cases in the whole construct. */
5065 /* Intercept the DEFAULT case. */
5066 if (cp->low == NULL && cp->high == NULL)
5068 if (default_case != NULL)
5070 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5071 "by a second DEFAULT CASE at %L",
5072 &default_case->where, &cp->where);
5083 /* Deal with single value cases and case ranges. Errors are
5084 issued from the validation function. */
5085 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5086 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5092 if (type == BT_LOGICAL
5093 && ((cp->low == NULL || cp->high == NULL)
5094 || cp->low != cp->high))
5096 gfc_error ("Logical range in CASE statement at %L is not "
5097 "allowed", &cp->low->where);
5102 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5105 value = cp->low->value.logical == 0 ? 2 : 1;
5106 if (value & seen_logical)
5108 gfc_error ("constant logical value in CASE statement "
5109 "is repeated at %L",
5114 seen_logical |= value;
5117 if (cp->low != NULL && cp->high != NULL
5118 && cp->low != cp->high
5119 && gfc_compare_expr (cp->low, cp->high) > 0)
5121 if (gfc_option.warn_surprising)
5122 gfc_warning ("Range specification at %L can never "
5123 "be matched", &cp->where);
5125 cp->unreachable = 1;
5126 seen_unreachable = 1;
5130 /* If the case range can be matched, it can also overlap with
5131 other cases. To make sure it does not, we put it in a
5132 double linked list here. We sort that with a merge sort
5133 later on to detect any overlapping cases. */
5137 head->right = head->left = NULL;
5142 tail->right->left = tail;
5149 /* It there was a failure in the previous case label, give up
5150 for this case label list. Continue with the next block. */
5154 /* See if any case labels that are unreachable have been seen.
5155 If so, we eliminate them. This is a bit of a kludge because
5156 the case lists for a single case statement (label) is a
5157 single forward linked lists. */
5158 if (seen_unreachable)
5160 /* Advance until the first case in the list is reachable. */
5161 while (body->ext.case_list != NULL
5162 && body->ext.case_list->unreachable)
5164 gfc_case *n = body->ext.case_list;
5165 body->ext.case_list = body->ext.case_list->next;
5167 gfc_free_case_list (n);
5170 /* Strip all other unreachable cases. */
5171 if (body->ext.case_list)
5173 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5175 if (cp->next->unreachable)
5177 gfc_case *n = cp->next;
5178 cp->next = cp->next->next;
5180 gfc_free_case_list (n);
5187 /* See if there were overlapping cases. If the check returns NULL,
5188 there was overlap. In that case we don't do anything. If head
5189 is non-NULL, we prepend the DEFAULT case. The sorted list can
5190 then used during code generation for SELECT CASE constructs with
5191 a case expression of a CHARACTER type. */
5194 head = check_case_overlap (head);
5196 /* Prepend the default_case if it is there. */
5197 if (head != NULL && default_case)
5199 default_case->left = NULL;
5200 default_case->right = head;
5201 head->left = default_case;
5205 /* Eliminate dead blocks that may be the result if we've seen
5206 unreachable case labels for a block. */
5207 for (body = code; body && body->block; body = body->block)
5209 if (body->block->ext.case_list == NULL)
5211 /* Cut the unreachable block from the code chain. */
5212 gfc_code *c = body->block;
5213 body->block = c->block;
5215 /* Kill the dead block, but not the blocks below it. */
5217 gfc_free_statements (c);
5221 /* More than two cases is legal but insane for logical selects.
5222 Issue a warning for it. */
5223 if (gfc_option.warn_surprising && type == BT_LOGICAL
5225 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5230 /* Resolve a transfer statement. This is making sure that:
5231 -- a derived type being transferred has only non-pointer components
5232 -- a derived type being transferred doesn't have private components, unless
5233 it's being transferred from the module where the type was defined
5234 -- we're not trying to transfer a whole assumed size array. */
5237 resolve_transfer (gfc_code *code)
5246 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5249 sym = exp->symtree->n.sym;
5252 /* Go to actual component transferred. */
5253 for (ref = code->expr->ref; ref; ref = ref->next)
5254 if (ref->type == REF_COMPONENT)
5255 ts = &ref->u.c.component->ts;
5257 if (ts->type == BT_DERIVED)
5259 /* Check that transferred derived type doesn't contain POINTER
5261 if (ts->derived->attr.pointer_comp)
5263 gfc_error ("Data transfer element at %L cannot have "
5264 "POINTER components", &code->loc);
5268 if (ts->derived->attr.alloc_comp)
5270 gfc_error ("Data transfer element at %L cannot have "
5271 "ALLOCATABLE components", &code->loc);
5275 if (derived_inaccessible (ts->derived))
5277 gfc_error ("Data transfer element at %L cannot have "
5278 "PRIVATE components",&code->loc);
5283 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5284 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5286 gfc_error ("Data transfer element at %L cannot be a full reference to "
5287 "an assumed-size array", &code->loc);
5293 /*********** Toplevel code resolution subroutines ***********/
5295 /* Find the set of labels that are reachable from this block. We also
5296 record the last statement in each block so that we don't have to do
5297 a linear search to find the END DO statements of the blocks. */
5300 reachable_labels (gfc_code *block)
5307 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5309 /* Collect labels in this block. */
5310 for (c = block; c; c = c->next)
5313 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5315 if (!c->next && cs_base->prev)
5316 cs_base->prev->tail = c;
5319 /* Merge with labels from parent block. */
5322 gcc_assert (cs_base->prev->reachable_labels);
5323 bitmap_ior_into (cs_base->reachable_labels,
5324 cs_base->prev->reachable_labels);
5328 /* Given a branch to a label and a namespace, if the branch is conforming.
5329 The code node describes where the branch is located. */
5332 resolve_branch (gfc_st_label *label, gfc_code *code)
5339 /* Step one: is this a valid branching target? */
5341 if (label->defined == ST_LABEL_UNKNOWN)
5343 gfc_error ("Label %d referenced at %L is never defined", label->value,
5348 if (label->defined != ST_LABEL_TARGET)
5350 gfc_error ("Statement at %L is not a valid branch target statement "
5351 "for the branch statement at %L", &label->where, &code->loc);
5355 /* Step two: make sure this branch is not a branch to itself ;-) */
5357 if (code->here == label)
5359 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5363 /* Step three: See if the label is in the same block as the
5364 branching statement. The hard work has been done by setting up
5365 the bitmap reachable_labels. */
5367 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5369 /* The label is not in an enclosing block, so illegal. This was
5370 allowed in Fortran 66, so we allow it as extension. No
5371 further checks are necessary in this case. */
5372 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5373 "as the GOTO statement at %L", &label->where,
5378 /* Step four: Make sure that the branching target is legal if
5379 the statement is an END {SELECT,IF}. */
5381 for (stack = cs_base; stack; stack = stack->prev)
5382 if (stack->current->next && stack->current->next->here == label)
5385 if (stack && stack->current->next->op == EXEC_NOP)
5387 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5388 "END of construct at %L", &code->loc,
5389 &stack->current->next->loc);
5390 return; /* We know this is not an END DO. */
5393 /* Step five: Make sure that we're not jumping to the end of a DO
5394 loop from within the loop. */
5396 for (stack = cs_base; stack; stack = stack->prev)
5397 if ((stack->current->op == EXEC_DO
5398 || stack->current->op == EXEC_DO_WHILE)
5399 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5401 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5402 "to END of construct at %L", &code->loc,
5410 /* Check whether EXPR1 has the same shape as EXPR2. */
5413 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5415 mpz_t shape[GFC_MAX_DIMENSIONS];
5416 mpz_t shape2[GFC_MAX_DIMENSIONS];
5417 try result = FAILURE;
5420 /* Compare the rank. */
5421 if (expr1->rank != expr2->rank)
5424 /* Compare the size of each dimension. */
5425 for (i=0; i<expr1->rank; i++)
5427 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5430 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5433 if (mpz_cmp (shape[i], shape2[i]))
5437 /* When either of the two expression is an assumed size array, we
5438 ignore the comparison of dimension sizes. */
5443 for (i--; i >= 0; i--)
5445 mpz_clear (shape[i]);
5446 mpz_clear (shape2[i]);
5452 /* Check whether a WHERE assignment target or a WHERE mask expression
5453 has the same shape as the outmost WHERE mask expression. */
5456 resolve_where (gfc_code *code, gfc_expr *mask)
5462 cblock = code->block;
5464 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5465 In case of nested WHERE, only the outmost one is stored. */
5466 if (mask == NULL) /* outmost WHERE */
5468 else /* inner WHERE */
5475 /* Check if the mask-expr has a consistent shape with the
5476 outmost WHERE mask-expr. */
5477 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5478 gfc_error ("WHERE mask at %L has inconsistent shape",
5479 &cblock->expr->where);
5482 /* the assignment statement of a WHERE statement, or the first
5483 statement in where-body-construct of a WHERE construct */
5484 cnext = cblock->next;
5489 /* WHERE assignment statement */
5492 /* Check shape consistent for WHERE assignment target. */
5493 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5494 gfc_error ("WHERE assignment target at %L has "
5495 "inconsistent shape", &cnext->expr->where);
5499 case EXEC_ASSIGN_CALL:
5500 resolve_call (cnext);
5503 /* WHERE or WHERE construct is part of a where-body-construct */
5505 resolve_where (cnext, e);
5509 gfc_error ("Unsupported statement inside WHERE at %L",
5512 /* the next statement within the same where-body-construct */
5513 cnext = cnext->next;
5515 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5516 cblock = cblock->block;
5521 /* Check whether the FORALL index appears in the expression or not. */
5524 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5528 gfc_actual_arglist *args;
5531 switch (expr->expr_type)
5534 gcc_assert (expr->symtree->n.sym);
5536 /* A scalar assignment */
5539 if (expr->symtree->n.sym == symbol)
5545 /* the expr is array ref, substring or struct component. */
5552 /* Check if the symbol appears in the array subscript. */
5554 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5557 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5561 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5565 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5571 if (expr->symtree->n.sym == symbol)
5574 /* Check if the symbol appears in the substring section. */
5575 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5577 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5585 gfc_error("expression reference type error at %L", &expr->where);
5591 /* If the expression is a function call, then check if the symbol
5592 appears in the actual arglist of the function. */
5594 for (args = expr->value.function.actual; args; args = args->next)
5596 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5601 /* It seems not to happen. */
5602 case EXPR_SUBSTRING:
5606 gcc_assert (expr->ref->type == REF_SUBSTRING);
5607 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5609 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5614 /* It seems not to happen. */
5615 case EXPR_STRUCTURE:
5617 gfc_error ("Unsupported statement while finding forall index in "
5622 /* Find the FORALL index in the first operand. */
5623 if (expr->value.op.op1)
5625 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5629 /* Find the FORALL index in the second operand. */
5630 if (expr->value.op.op2)
5632 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5645 /* Resolve assignment in FORALL construct.
5646 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5647 FORALL index variables. */
5650 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5654 for (n = 0; n < nvar; n++)
5656 gfc_symbol *forall_index;
5658 forall_index = var_expr[n]->symtree->n.sym;
5660 /* Check whether the assignment target is one of the FORALL index
5662 if ((code->expr->expr_type == EXPR_VARIABLE)
5663 && (code->expr->symtree->n.sym == forall_index))
5664 gfc_error ("Assignment to a FORALL index variable at %L",
5665 &code->expr->where);
5668 /* If one of the FORALL index variables doesn't appear in the
5669 assignment target, then there will be a many-to-one
5671 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5672 gfc_error ("The FORALL with index '%s' cause more than one "
5673 "assignment to this object at %L",
5674 var_expr[n]->symtree->name, &code->expr->where);
5680 /* Resolve WHERE statement in FORALL construct. */
5683 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5684 gfc_expr **var_expr)
5689 cblock = code->block;
5692 /* the assignment statement of a WHERE statement, or the first
5693 statement in where-body-construct of a WHERE construct */
5694 cnext = cblock->next;
5699 /* WHERE assignment statement */
5701 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5704 /* WHERE operator assignment statement */
5705 case EXEC_ASSIGN_CALL:
5706 resolve_call (cnext);
5709 /* WHERE or WHERE construct is part of a where-body-construct */
5711 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5715 gfc_error ("Unsupported statement inside WHERE at %L",
5718 /* the next statement within the same where-body-construct */
5719 cnext = cnext->next;
5721 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5722 cblock = cblock->block;
5727 /* Traverse the FORALL body to check whether the following errors exist:
5728 1. For assignment, check if a many-to-one assignment happens.
5729 2. For WHERE statement, check the WHERE body to see if there is any
5730 many-to-one assignment. */
5733 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5737 c = code->block->next;
5743 case EXEC_POINTER_ASSIGN:
5744 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5747 case EXEC_ASSIGN_CALL:
5751 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5752 there is no need to handle it here. */
5756 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5761 /* The next statement in the FORALL body. */
5767 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5768 gfc_resolve_forall_body to resolve the FORALL body. */
5771 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5773 static gfc_expr **var_expr;
5774 static int total_var = 0;
5775 static int nvar = 0;
5776 gfc_forall_iterator *fa;
5777 gfc_symbol *forall_index;
5781 /* Start to resolve a FORALL construct */
5782 if (forall_save == 0)
5784 /* Count the total number of FORALL index in the nested FORALL
5785 construct in order to allocate the VAR_EXPR with proper size. */
5787 while ((next != NULL) && (next->op == EXEC_FORALL))
5789 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5791 next = next->block->next;
5794 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5795 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5798 /* The information about FORALL iterator, including FORALL index start, end
5799 and stride. The FORALL index can not appear in start, end or stride. */
5800 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5802 /* Check if any outer FORALL index name is the same as the current
5804 for (i = 0; i < nvar; i++)
5806 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5808 gfc_error ("An outer FORALL construct already has an index "
5809 "with this name %L", &fa->var->where);
5813 /* Record the current FORALL index. */
5814 var_expr[nvar] = gfc_copy_expr (fa->var);
5816 forall_index = fa->var->symtree->n.sym;
5818 /* Check if the FORALL index appears in start, end or stride. */
5819 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5820 gfc_error ("A FORALL index must not appear in a limit or stride "
5821 "expression in the same FORALL at %L", &fa->start->where);
5822 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5823 gfc_error ("A FORALL index must not appear in a limit or stride "
5824 "expression in the same FORALL at %L", &fa->end->where);
5825 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5826 gfc_error ("A FORALL index must not appear in a limit or stride "
5827 "expression in the same FORALL at %L", &fa->stride->where);
5831 /* Resolve the FORALL body. */
5832 gfc_resolve_forall_body (code, nvar, var_expr);
5834 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5835 gfc_resolve_blocks (code->block, ns);
5837 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5838 for (i = 0; i < total_var; i++)
5839 gfc_free_expr (var_expr[i]);
5841 /* Reset the counters. */
5847 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5850 static void resolve_code (gfc_code *, gfc_namespace *);
5853 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5857 for (; b; b = b->block)
5859 t = gfc_resolve_expr (b->expr);
5860 if (gfc_resolve_expr (b->expr2) == FAILURE)
5866 if (t == SUCCESS && b->expr != NULL
5867 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5868 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5875 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5876 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5881 resolve_branch (b->label, b);
5893 case EXEC_OMP_ATOMIC:
5894 case EXEC_OMP_CRITICAL:
5896 case EXEC_OMP_MASTER:
5897 case EXEC_OMP_ORDERED:
5898 case EXEC_OMP_PARALLEL:
5899 case EXEC_OMP_PARALLEL_DO:
5900 case EXEC_OMP_PARALLEL_SECTIONS:
5901 case EXEC_OMP_PARALLEL_WORKSHARE:
5902 case EXEC_OMP_SECTIONS:
5903 case EXEC_OMP_SINGLE:
5904 case EXEC_OMP_WORKSHARE:
5908 gfc_internal_error ("resolve_block(): Bad block type");
5911 resolve_code (b->next, ns);
5916 static gfc_component *
5917 has_default_initializer (gfc_symbol *der)
5920 for (c = der->components; c; c = c->next)
5921 if ((c->ts.type != BT_DERIVED && c->initializer)
5922 || (c->ts.type == BT_DERIVED
5924 && has_default_initializer (c->ts.derived)))
5931 /* Given a block of code, recursively resolve everything pointed to by this
5935 resolve_code (gfc_code *code, gfc_namespace *ns)
5937 int omp_workshare_save;
5943 frame.prev = cs_base;
5947 reachable_labels (code);
5949 for (; code; code = code->next)
5951 frame.current = code;
5952 forall_save = forall_flag;
5954 if (code->op == EXEC_FORALL)
5957 gfc_resolve_forall (code, ns, forall_save);
5960 else if (code->block)
5962 omp_workshare_save = -1;
5965 case EXEC_OMP_PARALLEL_WORKSHARE:
5966 omp_workshare_save = omp_workshare_flag;
5967 omp_workshare_flag = 1;
5968 gfc_resolve_omp_parallel_blocks (code, ns);
5970 case EXEC_OMP_PARALLEL:
5971 case EXEC_OMP_PARALLEL_DO:
5972 case EXEC_OMP_PARALLEL_SECTIONS:
5973 omp_workshare_save = omp_workshare_flag;
5974 omp_workshare_flag = 0;
5975 gfc_resolve_omp_parallel_blocks (code, ns);
5978 gfc_resolve_omp_do_blocks (code, ns);
5980 case EXEC_OMP_WORKSHARE:
5981 omp_workshare_save = omp_workshare_flag;
5982 omp_workshare_flag = 1;
5985 gfc_resolve_blocks (code->block, ns);
5989 if (omp_workshare_save != -1)
5990 omp_workshare_flag = omp_workshare_save;
5993 t = gfc_resolve_expr (code->expr);
5994 forall_flag = forall_save;
5996 if (gfc_resolve_expr (code->expr2) == FAILURE)
6011 /* Keep track of which entry we are up to. */
6012 current_entry_id = code->ext.entry->id;
6016 resolve_where (code, NULL);
6020 if (code->expr != NULL)
6022 if (code->expr->ts.type != BT_INTEGER)
6023 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6024 "INTEGER variable", &code->expr->where);
6025 else if (code->expr->symtree->n.sym->attr.assign != 1)
6026 gfc_error ("Variable '%s' has not been assigned a target "
6027 "label at %L", code->expr->symtree->n.sym->name,
6028 &code->expr->where);
6031 resolve_branch (code->label, code);
6035 if (code->expr != NULL
6036 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6037 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6038 "INTEGER return specifier", &code->expr->where);
6041 case EXEC_INIT_ASSIGN:
6048 if (gfc_extend_assign (code, ns) == SUCCESS)
6050 gfc_expr *lhs = code->ext.actual->expr;
6051 gfc_expr *rhs = code->ext.actual->next->expr;
6053 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6055 gfc_error ("Subroutine '%s' called instead of assignment at "
6056 "%L must be PURE", code->symtree->n.sym->name,
6061 /* Make a temporary rhs when there is a default initializer
6062 and rhs is the same symbol as the lhs. */
6063 if (rhs->expr_type == EXPR_VARIABLE
6064 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6065 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6066 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6067 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6072 if (code->expr->ts.type == BT_CHARACTER
6073 && gfc_option.warn_character_truncation)
6075 int llen = 0, rlen = 0;
6077 if (code->expr->ts.cl != NULL
6078 && code->expr->ts.cl->length != NULL
6079 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
6080 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
6082 if (code->expr2->expr_type == EXPR_CONSTANT)
6083 rlen = code->expr2->value.character.length;
6085 else if (code->expr2->ts.cl != NULL
6086 && code->expr2->ts.cl->length != NULL
6087 && code->expr2->ts.cl->length->expr_type
6089 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
6091 if (rlen && llen && rlen > llen)
6092 gfc_warning_now ("CHARACTER expression will be truncated "
6093 "in assignment (%d/%d) at %L",
6094 llen, rlen, &code->loc);
6097 if (gfc_pure (NULL))
6099 if (gfc_impure_variable (code->expr->symtree->n.sym))
6101 gfc_error ("Cannot assign to variable '%s' in PURE "
6103 code->expr->symtree->n.sym->name,
6104 &code->expr->where);
6108 if (code->expr->ts.type == BT_DERIVED
6109 && code->expr->expr_type == EXPR_VARIABLE
6110 && code->expr->ts.derived->attr.pointer_comp
6111 && gfc_impure_variable (code->expr2->symtree->n.sym))
6113 gfc_error ("The impure variable at %L is assigned to "
6114 "a derived type variable with a POINTER "
6115 "component in a PURE procedure (12.6)",
6116 &code->expr2->where);
6121 gfc_check_assign (code->expr, code->expr2, 1);
6124 case EXEC_LABEL_ASSIGN:
6125 if (code->label->defined == ST_LABEL_UNKNOWN)
6126 gfc_error ("Label %d referenced at %L is never defined",
6127 code->label->value, &code->label->where);
6129 && (code->expr->expr_type != EXPR_VARIABLE
6130 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6131 || code->expr->symtree->n.sym->ts.kind
6132 != gfc_default_integer_kind
6133 || code->expr->symtree->n.sym->as != NULL))
6134 gfc_error ("ASSIGN statement at %L requires a scalar "
6135 "default INTEGER variable", &code->expr->where);
6138 case EXEC_POINTER_ASSIGN:
6142 gfc_check_pointer_assign (code->expr, code->expr2);
6145 case EXEC_ARITHMETIC_IF:
6147 && code->expr->ts.type != BT_INTEGER
6148 && code->expr->ts.type != BT_REAL)
6149 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6150 "expression", &code->expr->where);
6152 resolve_branch (code->label, code);
6153 resolve_branch (code->label2, code);
6154 resolve_branch (code->label3, code);
6158 if (t == SUCCESS && code->expr != NULL
6159 && (code->expr->ts.type != BT_LOGICAL
6160 || code->expr->rank != 0))
6161 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6162 &code->expr->where);
6167 resolve_call (code);
6171 /* Select is complicated. Also, a SELECT construct could be
6172 a transformed computed GOTO. */
6173 resolve_select (code);
6177 if (code->ext.iterator != NULL)
6179 gfc_iterator *iter = code->ext.iterator;
6180 if (gfc_resolve_iterator (iter, true) != FAILURE)
6181 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6186 if (code->expr == NULL)
6187 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6189 && (code->expr->rank != 0
6190 || code->expr->ts.type != BT_LOGICAL))
6191 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6192 "a scalar LOGICAL expression", &code->expr->where);
6196 if (t == SUCCESS && code->expr != NULL
6197 && code->expr->ts.type != BT_INTEGER)
6198 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6199 "of type INTEGER", &code->expr->where);
6201 for (a = code->ext.alloc_list; a; a = a->next)
6202 resolve_allocate_expr (a->expr, code);
6206 case EXEC_DEALLOCATE:
6207 if (t == SUCCESS && code->expr != NULL
6208 && code->expr->ts.type != BT_INTEGER)
6210 ("STAT tag in DEALLOCATE statement at %L must be of type "
6211 "INTEGER", &code->expr->where);
6213 for (a = code->ext.alloc_list; a; a = a->next)
6214 resolve_deallocate_expr (a->expr);
6219 if (gfc_resolve_open (code->ext.open) == FAILURE)
6222 resolve_branch (code->ext.open->err, code);
6226 if (gfc_resolve_close (code->ext.close) == FAILURE)
6229 resolve_branch (code->ext.close->err, code);
6232 case EXEC_BACKSPACE:
6236 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6239 resolve_branch (code->ext.filepos->err, code);
6243 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6246 resolve_branch (code->ext.inquire->err, code);
6250 gcc_assert (code->ext.inquire != NULL);
6251 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6254 resolve_branch (code->ext.inquire->err, code);
6259 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6262 resolve_branch (code->ext.dt->err, code);
6263 resolve_branch (code->ext.dt->end, code);
6264 resolve_branch (code->ext.dt->eor, code);
6268 resolve_transfer (code);
6272 resolve_forall_iterators (code->ext.forall_iterator);
6274 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6275 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6276 "expression", &code->expr->where);
6279 case EXEC_OMP_ATOMIC:
6280 case EXEC_OMP_BARRIER:
6281 case EXEC_OMP_CRITICAL:
6282 case EXEC_OMP_FLUSH:
6284 case EXEC_OMP_MASTER:
6285 case EXEC_OMP_ORDERED:
6286 case EXEC_OMP_SECTIONS:
6287 case EXEC_OMP_SINGLE:
6288 case EXEC_OMP_WORKSHARE:
6289 gfc_resolve_omp_directive (code, ns);
6292 case EXEC_OMP_PARALLEL:
6293 case EXEC_OMP_PARALLEL_DO:
6294 case EXEC_OMP_PARALLEL_SECTIONS:
6295 case EXEC_OMP_PARALLEL_WORKSHARE:
6296 omp_workshare_save = omp_workshare_flag;
6297 omp_workshare_flag = 0;
6298 gfc_resolve_omp_directive (code, ns);
6299 omp_workshare_flag = omp_workshare_save;
6303 gfc_internal_error ("resolve_code(): Bad statement code");
6307 cs_base = frame.prev;
6311 /* Resolve initial values and make sure they are compatible with
6315 resolve_values (gfc_symbol *sym)
6317 if (sym->value == NULL)
6320 if (gfc_resolve_expr (sym->value) == FAILURE)
6323 gfc_check_assign_symbol (sym, sym->value);
6327 /* Verify the binding labels for common blocks that are BIND(C). The label
6328 for a BIND(C) common block must be identical in all scoping units in which
6329 the common block is declared. Further, the binding label can not collide
6330 with any other global entity in the program. */
6333 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6335 if (comm_block_tree->n.common->is_bind_c == 1)
6337 gfc_gsymbol *binding_label_gsym;
6338 gfc_gsymbol *comm_name_gsym;
6340 /* See if a global symbol exists by the common block's name. It may
6341 be NULL if the common block is use-associated. */
6342 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6343 comm_block_tree->n.common->name);
6344 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6345 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6346 "with the global entity '%s' at %L",
6347 comm_block_tree->n.common->binding_label,
6348 comm_block_tree->n.common->name,
6349 &(comm_block_tree->n.common->where),
6350 comm_name_gsym->name, &(comm_name_gsym->where));
6351 else if (comm_name_gsym != NULL
6352 && strcmp (comm_name_gsym->name,
6353 comm_block_tree->n.common->name) == 0)
6355 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6357 if (comm_name_gsym->binding_label == NULL)
6358 /* No binding label for common block stored yet; save this one. */
6359 comm_name_gsym->binding_label =
6360 comm_block_tree->n.common->binding_label;
6362 if (strcmp (comm_name_gsym->binding_label,
6363 comm_block_tree->n.common->binding_label) != 0)
6365 /* Common block names match but binding labels do not. */
6366 gfc_error ("Binding label '%s' for common block '%s' at %L "
6367 "does not match the binding label '%s' for common "
6369 comm_block_tree->n.common->binding_label,
6370 comm_block_tree->n.common->name,
6371 &(comm_block_tree->n.common->where),
6372 comm_name_gsym->binding_label,
6373 comm_name_gsym->name,
6374 &(comm_name_gsym->where));
6379 /* There is no binding label (NAME="") so we have nothing further to
6380 check and nothing to add as a global symbol for the label. */
6381 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6384 binding_label_gsym =
6385 gfc_find_gsymbol (gfc_gsym_root,
6386 comm_block_tree->n.common->binding_label);
6387 if (binding_label_gsym == NULL)
6389 /* Need to make a global symbol for the binding label to prevent
6390 it from colliding with another. */
6391 binding_label_gsym =
6392 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6393 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6394 binding_label_gsym->type = GSYM_COMMON;
6398 /* If comm_name_gsym is NULL, the name common block is use
6399 associated and the name could be colliding. */
6400 if (binding_label_gsym->type != GSYM_COMMON)
6401 gfc_error ("Binding label '%s' for common block '%s' at %L "
6402 "collides with the global entity '%s' at %L",
6403 comm_block_tree->n.common->binding_label,
6404 comm_block_tree->n.common->name,
6405 &(comm_block_tree->n.common->where),
6406 binding_label_gsym->name,
6407 &(binding_label_gsym->where));
6408 else if (comm_name_gsym != NULL
6409 && (strcmp (binding_label_gsym->name,
6410 comm_name_gsym->binding_label) != 0)
6411 && (strcmp (binding_label_gsym->sym_name,
6412 comm_name_gsym->name) != 0))
6413 gfc_error ("Binding label '%s' for common block '%s' at %L "
6414 "collides with global entity '%s' at %L",
6415 binding_label_gsym->name, binding_label_gsym->sym_name,
6416 &(comm_block_tree->n.common->where),
6417 comm_name_gsym->name, &(comm_name_gsym->where));
6425 /* Verify any BIND(C) derived types in the namespace so we can report errors
6426 for them once, rather than for each variable declared of that type. */
6429 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6431 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6432 && derived_sym->attr.is_bind_c == 1)
6433 verify_bind_c_derived_type (derived_sym);
6439 /* Verify that any binding labels used in a given namespace do not collide
6440 with the names or binding labels of any global symbols. */
6443 gfc_verify_binding_labels (gfc_symbol *sym)
6447 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6448 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6450 gfc_gsymbol *bind_c_sym;
6452 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6453 if (bind_c_sym != NULL
6454 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6456 if (sym->attr.if_source == IFSRC_DECL
6457 && (bind_c_sym->type != GSYM_SUBROUTINE
6458 && bind_c_sym->type != GSYM_FUNCTION)
6459 && ((sym->attr.contained == 1
6460 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6461 || (sym->attr.use_assoc == 1
6462 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6464 /* Make sure global procedures don't collide with anything. */
6465 gfc_error ("Binding label '%s' at %L collides with the global "
6466 "entity '%s' at %L", sym->binding_label,
6467 &(sym->declared_at), bind_c_sym->name,
6468 &(bind_c_sym->where));
6471 else if (sym->attr.contained == 0
6472 && (sym->attr.if_source == IFSRC_IFBODY
6473 && sym->attr.flavor == FL_PROCEDURE)
6474 && (bind_c_sym->sym_name != NULL
6475 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6477 /* Make sure procedures in interface bodies don't collide. */
6478 gfc_error ("Binding label '%s' in interface body at %L collides "
6479 "with the global entity '%s' at %L",
6481 &(sym->declared_at), bind_c_sym->name,
6482 &(bind_c_sym->where));
6485 else if (sym->attr.contained == 0
6486 && (sym->attr.if_source == IFSRC_UNKNOWN))
6487 if ((sym->attr.use_assoc
6488 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6489 || sym->attr.use_assoc == 0)
6491 gfc_error ("Binding label '%s' at %L collides with global "
6492 "entity '%s' at %L", sym->binding_label,
6493 &(sym->declared_at), bind_c_sym->name,
6494 &(bind_c_sym->where));
6499 /* Clear the binding label to prevent checking multiple times. */
6500 sym->binding_label[0] = '\0';
6502 else if (bind_c_sym == NULL)
6504 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6505 bind_c_sym->where = sym->declared_at;
6506 bind_c_sym->sym_name = sym->name;
6508 if (sym->attr.use_assoc == 1)
6509 bind_c_sym->mod_name = sym->module;
6511 if (sym->ns->proc_name != NULL)
6512 bind_c_sym->mod_name = sym->ns->proc_name->name;
6514 if (sym->attr.contained == 0)
6516 if (sym->attr.subroutine)
6517 bind_c_sym->type = GSYM_SUBROUTINE;
6518 else if (sym->attr.function)
6519 bind_c_sym->type = GSYM_FUNCTION;
6527 /* Resolve an index expression. */
6530 resolve_index_expr (gfc_expr *e)
6532 if (gfc_resolve_expr (e) == FAILURE)
6535 if (gfc_simplify_expr (e, 0) == FAILURE)
6538 if (gfc_specification_expr (e) == FAILURE)
6544 /* Resolve a charlen structure. */
6547 resolve_charlen (gfc_charlen *cl)
6556 specification_expr = 1;
6558 if (resolve_index_expr (cl->length) == FAILURE)
6560 specification_expr = 0;
6564 /* "If the character length parameter value evaluates to a negative
6565 value, the length of character entities declared is zero." */
6566 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6568 gfc_warning_now ("CHARACTER variable has zero length at %L",
6569 &cl->length->where);
6570 gfc_replace_expr (cl->length, gfc_int_expr (0));
6577 /* Test for non-constant shape arrays. */
6580 is_non_constant_shape_array (gfc_symbol *sym)
6586 not_constant = false;
6587 if (sym->as != NULL)
6589 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6590 has not been simplified; parameter array references. Do the
6591 simplification now. */
6592 for (i = 0; i < sym->as->rank; i++)
6594 e = sym->as->lower[i];
6595 if (e && (resolve_index_expr (e) == FAILURE
6596 || !gfc_is_constant_expr (e)))
6597 not_constant = true;
6599 e = sym->as->upper[i];
6600 if (e && (resolve_index_expr (e) == FAILURE
6601 || !gfc_is_constant_expr (e)))
6602 not_constant = true;
6605 return not_constant;
6609 /* Assign the default initializer to a derived type variable or result. */
6612 apply_default_init (gfc_symbol *sym)
6615 gfc_expr *init = NULL;
6617 gfc_namespace *ns = sym->ns;
6619 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6622 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6623 init = gfc_default_initializer (&sym->ts);
6628 /* Search for the function namespace if this is a contained
6629 function without an explicit result. */
6630 if (sym->attr.function && sym == sym->result
6631 && sym->name != sym->ns->proc_name->name)
6634 for (;ns; ns = ns->sibling)
6635 if (strcmp (ns->proc_name->name, sym->name) == 0)
6641 gfc_free_expr (init);
6645 /* Build an l-value expression for the result. */
6646 lval = gfc_lval_expr_from_sym (sym);
6648 /* Add the code at scope entry. */
6649 init_st = gfc_get_code ();
6650 init_st->next = ns->code;
6653 /* Assign the default initializer to the l-value. */
6654 init_st->loc = sym->declared_at;
6655 init_st->op = EXEC_INIT_ASSIGN;
6656 init_st->expr = lval;
6657 init_st->expr2 = init;
6661 /* Resolution of common features of flavors variable and procedure. */
6664 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6666 /* Constraints on deferred shape variable. */
6667 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6669 if (sym->attr.allocatable)
6671 if (sym->attr.dimension)
6672 gfc_error ("Allocatable array '%s' at %L must have "
6673 "a deferred shape", sym->name, &sym->declared_at);
6675 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6676 sym->name, &sym->declared_at);
6680 if (sym->attr.pointer && sym->attr.dimension)
6682 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6683 sym->name, &sym->declared_at);
6690 if (!mp_flag && !sym->attr.allocatable
6691 && !sym->attr.pointer && !sym->attr.dummy)
6693 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6694 sym->name, &sym->declared_at);
6702 /* Resolve symbols with flavor variable. */
6705 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6711 const char *auto_save_msg;
6713 auto_save_msg = "automatic object '%s' at %L cannot have the "
6716 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6719 /* Set this flag to check that variables are parameters of all entries.
6720 This check is effected by the call to gfc_resolve_expr through
6721 is_non_constant_shape_array. */
6722 specification_expr = 1;
6724 if (!sym->attr.use_assoc
6725 && !sym->attr.allocatable
6726 && !sym->attr.pointer
6727 && is_non_constant_shape_array (sym))
6729 /* The shape of a main program or module array needs to be
6731 if (sym->ns->proc_name
6732 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6733 || sym->ns->proc_name->attr.is_main_program))
6735 gfc_error ("The module or main program array '%s' at %L must "
6736 "have constant shape", sym->name, &sym->declared_at);
6737 specification_expr = 0;
6742 if (sym->ts.type == BT_CHARACTER)
6744 /* Make sure that character string variables with assumed length are
6746 e = sym->ts.cl->length;
6747 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6749 gfc_error ("Entity with assumed character length at %L must be a "
6750 "dummy argument or a PARAMETER", &sym->declared_at);
6754 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6756 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6760 if (!gfc_is_constant_expr (e)
6761 && !(e->expr_type == EXPR_VARIABLE
6762 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6763 && sym->ns->proc_name
6764 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6765 || sym->ns->proc_name->attr.is_main_program)
6766 && !sym->attr.use_assoc)
6768 gfc_error ("'%s' at %L must have constant character length "
6769 "in this context", sym->name, &sym->declared_at);
6774 /* Can the symbol have an initializer? */
6776 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6777 || sym->attr.intrinsic || sym->attr.result)
6779 else if (sym->attr.dimension && !sym->attr.pointer)
6781 /* Don't allow initialization of automatic arrays. */
6782 for (i = 0; i < sym->as->rank; i++)
6784 if (sym->as->lower[i] == NULL
6785 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6786 || sym->as->upper[i] == NULL
6787 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6794 /* Also, they must not have the SAVE attribute.
6795 SAVE_IMPLICIT is checked below. */
6796 if (flag && sym->attr.save == SAVE_EXPLICIT)
6798 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6803 /* Reject illegal initializers. */
6804 if (!sym->mark && sym->value && flag)
6806 if (sym->attr.allocatable)
6807 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6808 sym->name, &sym->declared_at);
6809 else if (sym->attr.external)
6810 gfc_error ("External '%s' at %L cannot have an initializer",
6811 sym->name, &sym->declared_at);
6812 else if (sym->attr.dummy
6813 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6814 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6815 sym->name, &sym->declared_at);
6816 else if (sym->attr.intrinsic)
6817 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6818 sym->name, &sym->declared_at);
6819 else if (sym->attr.result)
6820 gfc_error ("Function result '%s' at %L cannot have an initializer",
6821 sym->name, &sym->declared_at);
6823 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6824 sym->name, &sym->declared_at);
6831 /* Check to see if a derived type is blocked from being host associated
6832 by the presence of another class I symbol in the same namespace.
6833 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6834 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6835 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6838 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6839 if (s && (s->attr.flavor != FL_DERIVED
6840 || !gfc_compare_derived_types (s, sym->ts.derived)))
6842 gfc_error ("The type %s cannot be host associated at %L because "
6843 "it is blocked by an incompatible object of the same "
6844 "name at %L", sym->ts.derived->name, &sym->declared_at,
6850 /* Do not use gfc_default_initializer to test for a default initializer
6851 in the fortran because it generates a hidden default for allocatable
6854 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6855 c = has_default_initializer (sym->ts.derived);
6857 /* 4th constraint in section 11.3: "If an object of a type for which
6858 component-initialization is specified (R429) appears in the
6859 specification-part of a module and does not have the ALLOCATABLE
6860 or POINTER attribute, the object shall have the SAVE attribute." */
6861 if (c && sym->ns->proc_name
6862 && sym->ns->proc_name->attr.flavor == FL_MODULE
6863 && !sym->ns->save_all && !sym->attr.save
6864 && !sym->attr.pointer && !sym->attr.allocatable)
6866 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6867 sym->name, &sym->declared_at,
6868 "for default initialization of a component");
6872 /* Assign default initializer. */
6873 if (sym->ts.type == BT_DERIVED
6875 && !sym->attr.pointer
6876 && !sym->attr.allocatable
6877 && (!flag || sym->attr.intent == INTENT_OUT))
6878 sym->value = gfc_default_initializer (&sym->ts);
6884 /* Resolve a procedure. */
6887 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6889 gfc_formal_arglist *arg;
6891 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6892 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6893 "interfaces", sym->name, &sym->declared_at);
6895 if (sym->attr.function
6896 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6899 if (sym->ts.type == BT_CHARACTER)
6901 gfc_charlen *cl = sym->ts.cl;
6903 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6904 && resolve_charlen (cl) == FAILURE)
6907 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6909 if (sym->attr.proc == PROC_ST_FUNCTION)
6911 gfc_error ("Character-valued statement function '%s' at %L must "
6912 "have constant length", sym->name, &sym->declared_at);
6916 if (sym->attr.external && sym->formal == NULL
6917 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6919 gfc_error ("Automatic character length function '%s' at %L must "
6920 "have an explicit interface", sym->name,
6927 /* Ensure that derived type for are not of a private type. Internal
6928 module procedures are excluded by 2.2.3.3 - ie. they are not
6929 externally accessible and can access all the objects accessible in
6931 if (!(sym->ns->parent
6932 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6933 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6935 gfc_interface *iface;
6937 for (arg = sym->formal; arg; arg = arg->next)
6940 && arg->sym->ts.type == BT_DERIVED
6941 && !arg->sym->ts.derived->attr.use_assoc
6942 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6943 arg->sym->ts.derived->ns->default_access)
6944 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
6945 "PRIVATE type and cannot be a dummy argument"
6946 " of '%s', which is PUBLIC at %L",
6947 arg->sym->name, sym->name, &sym->declared_at)
6950 /* Stop this message from recurring. */
6951 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6956 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6957 PRIVATE to the containing module. */
6958 for (iface = sym->generic; iface; iface = iface->next)
6960 for (arg = iface->sym->formal; arg; arg = arg->next)
6963 && arg->sym->ts.type == BT_DERIVED
6964 && !arg->sym->ts.derived->attr.use_assoc
6965 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6966 arg->sym->ts.derived->ns->default_access)
6967 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
6968 "'%s' in PUBLIC interface '%s' at %L "
6969 "takes dummy arguments of '%s' which is "
6970 "PRIVATE", iface->sym->name, sym->name,
6971 &iface->sym->declared_at,
6972 gfc_typename (&arg->sym->ts)) == FAILURE)
6974 /* Stop this message from recurring. */
6975 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6981 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6982 PRIVATE to the containing module. */
6983 for (iface = sym->generic; iface; iface = iface->next)
6985 for (arg = iface->sym->formal; arg; arg = arg->next)
6988 && arg->sym->ts.type == BT_DERIVED
6989 && !arg->sym->ts.derived->attr.use_assoc
6990 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6991 arg->sym->ts.derived->ns->default_access)
6992 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
6993 "'%s' in PUBLIC interface '%s' at %L "
6994 "takes dummy arguments of '%s' which is "
6995 "PRIVATE", iface->sym->name, sym->name,
6996 &iface->sym->declared_at,
6997 gfc_typename (&arg->sym->ts)) == FAILURE)
6999 /* Stop this message from recurring. */
7000 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7007 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7009 gfc_error ("Function '%s' at %L cannot have an initializer",
7010 sym->name, &sym->declared_at);
7014 /* An external symbol may not have an initializer because it is taken to be
7016 if (sym->attr.external && sym->value)
7018 gfc_error ("External object '%s' at %L may not have an initializer",
7019 sym->name, &sym->declared_at);
7023 /* An elemental function is required to return a scalar 12.7.1 */
7024 if (sym->attr.elemental && sym->attr.function && sym->as)
7026 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7027 "result", sym->name, &sym->declared_at);
7028 /* Reset so that the error only occurs once. */
7029 sym->attr.elemental = 0;
7033 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7034 char-len-param shall not be array-valued, pointer-valued, recursive
7035 or pure. ....snip... A character value of * may only be used in the
7036 following ways: (i) Dummy arg of procedure - dummy associates with
7037 actual length; (ii) To declare a named constant; or (iii) External
7038 function - but length must be declared in calling scoping unit. */
7039 if (sym->attr.function
7040 && sym->ts.type == BT_CHARACTER
7041 && sym->ts.cl && sym->ts.cl->length == NULL)
7043 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7044 || (sym->attr.recursive) || (sym->attr.pure))
7046 if (sym->as && sym->as->rank)
7047 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7048 "array-valued", sym->name, &sym->declared_at);
7050 if (sym->attr.pointer)
7051 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7052 "pointer-valued", sym->name, &sym->declared_at);
7055 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7056 "pure", sym->name, &sym->declared_at);
7058 if (sym->attr.recursive)
7059 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7060 "recursive", sym->name, &sym->declared_at);
7065 /* Appendix B.2 of the standard. Contained functions give an
7066 error anyway. Fixed-form is likely to be F77/legacy. */
7067 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7068 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7069 "'%s' at %L is obsolescent in fortran 95",
7070 sym->name, &sym->declared_at);
7073 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7075 gfc_formal_arglist *curr_arg;
7076 int has_non_interop_arg = 0;
7078 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7079 sym->common_block) == FAILURE)
7081 /* Clear these to prevent looking at them again if there was an
7083 sym->attr.is_bind_c = 0;
7084 sym->attr.is_c_interop = 0;
7085 sym->ts.is_c_interop = 0;
7089 /* So far, no errors have been found. */
7090 sym->attr.is_c_interop = 1;
7091 sym->ts.is_c_interop = 1;
7094 curr_arg = sym->formal;
7095 while (curr_arg != NULL)
7097 /* Skip implicitly typed dummy args here. */
7098 if (curr_arg->sym->attr.implicit_type == 0)
7099 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7100 /* If something is found to fail, record the fact so we
7101 can mark the symbol for the procedure as not being
7102 BIND(C) to try and prevent multiple errors being
7104 has_non_interop_arg = 1;
7106 curr_arg = curr_arg->next;
7109 /* See if any of the arguments were not interoperable and if so, clear
7110 the procedure symbol to prevent duplicate error messages. */
7111 if (has_non_interop_arg != 0)
7113 sym->attr.is_c_interop = 0;
7114 sym->ts.is_c_interop = 0;
7115 sym->attr.is_bind_c = 0;
7123 /* Resolve the components of a derived type. */
7126 resolve_fl_derived (gfc_symbol *sym)
7129 gfc_dt_list * dt_list;
7132 for (c = sym->components; c != NULL; c = c->next)
7134 if (c->ts.type == BT_CHARACTER)
7136 if (c->ts.cl->length == NULL
7137 || (resolve_charlen (c->ts.cl) == FAILURE)
7138 || !gfc_is_constant_expr (c->ts.cl->length))
7140 gfc_error ("Character length of component '%s' needs to "
7141 "be a constant specification expression at %L",
7143 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7148 if (c->ts.type == BT_DERIVED
7149 && sym->component_access != ACCESS_PRIVATE
7150 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7151 && !c->ts.derived->attr.use_assoc
7152 && !gfc_check_access (c->ts.derived->attr.access,
7153 c->ts.derived->ns->default_access))
7155 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7156 "a component of '%s', which is PUBLIC at %L",
7157 c->name, sym->name, &sym->declared_at);
7161 if (sym->attr.sequence)
7163 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7165 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7166 "not have the SEQUENCE attribute",
7167 c->ts.derived->name, &sym->declared_at);
7172 if (c->ts.type == BT_DERIVED && c->pointer
7173 && c->ts.derived->components == NULL)
7175 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7176 "that has not been declared", c->name, sym->name,
7181 if (c->pointer || c->allocatable || c->as == NULL)
7184 for (i = 0; i < c->as->rank; i++)
7186 if (c->as->lower[i] == NULL
7187 || !gfc_is_constant_expr (c->as->lower[i])
7188 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7189 || c->as->upper[i] == NULL
7190 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7191 || !gfc_is_constant_expr (c->as->upper[i]))
7193 gfc_error ("Component '%s' of '%s' at %L must have "
7194 "constant array bounds",
7195 c->name, sym->name, &c->loc);
7201 /* Add derived type to the derived type list. */
7202 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7203 if (sym == dt_list->derived)
7206 if (dt_list == NULL)
7208 dt_list = gfc_get_dt_list ();
7209 dt_list->next = gfc_derived_types;
7210 dt_list->derived = sym;
7211 gfc_derived_types = dt_list;
7219 resolve_fl_namelist (gfc_symbol *sym)
7224 /* Reject PRIVATE objects in a PUBLIC namelist. */
7225 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7227 for (nl = sym->namelist; nl; nl = nl->next)
7229 if (!nl->sym->attr.use_assoc
7230 && !(sym->ns->parent == nl->sym->ns)
7231 && !(sym->ns->parent
7232 && sym->ns->parent->parent == nl->sym->ns)
7233 && !gfc_check_access(nl->sym->attr.access,
7234 nl->sym->ns->default_access))
7236 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7237 "cannot be member of PUBLIC namelist '%s' at %L",
7238 nl->sym->name, sym->name, &sym->declared_at);
7242 /* Types with private components that came here by USE-association. */
7243 if (nl->sym->ts.type == BT_DERIVED
7244 && derived_inaccessible (nl->sym->ts.derived))
7246 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7247 "components and cannot be member of namelist '%s' at %L",
7248 nl->sym->name, sym->name, &sym->declared_at);
7252 /* Types with private components that are defined in the same module. */
7253 if (nl->sym->ts.type == BT_DERIVED
7254 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7255 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7256 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7257 nl->sym->ns->default_access))
7259 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7260 "cannot be a member of PUBLIC namelist '%s' at %L",
7261 nl->sym->name, sym->name, &sym->declared_at);
7267 for (nl = sym->namelist; nl; nl = nl->next)
7269 /* Reject namelist arrays of assumed shape. */
7270 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7271 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7272 "must not have assumed shape in namelist "
7273 "'%s' at %L", nl->sym->name, sym->name,
7274 &sym->declared_at) == FAILURE)
7277 /* Reject namelist arrays that are not constant shape. */
7278 if (is_non_constant_shape_array (nl->sym))
7280 gfc_error ("NAMELIST array object '%s' must have constant "
7281 "shape in namelist '%s' at %L", nl->sym->name,
7282 sym->name, &sym->declared_at);
7286 /* Namelist objects cannot have allocatable or pointer components. */
7287 if (nl->sym->ts.type != BT_DERIVED)
7290 if (nl->sym->ts.derived->attr.alloc_comp)
7292 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7293 "have ALLOCATABLE components",
7294 nl->sym->name, sym->name, &sym->declared_at);
7298 if (nl->sym->ts.derived->attr.pointer_comp)
7300 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7301 "have POINTER components",
7302 nl->sym->name, sym->name, &sym->declared_at);
7308 /* 14.1.2 A module or internal procedure represent local entities
7309 of the same type as a namelist member and so are not allowed. */
7310 for (nl = sym->namelist; nl; nl = nl->next)
7312 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7315 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7316 if ((nl->sym == sym->ns->proc_name)
7318 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7322 if (nl->sym && nl->sym->name)
7323 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7324 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7326 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7327 "attribute in '%s' at %L", nlsym->name,
7338 resolve_fl_parameter (gfc_symbol *sym)
7340 /* A parameter array's shape needs to be constant. */
7342 && (sym->as->type == AS_DEFERRED
7343 || is_non_constant_shape_array (sym)))
7345 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7346 "or of deferred shape", sym->name, &sym->declared_at);
7350 /* Make sure a parameter that has been implicitly typed still
7351 matches the implicit type, since PARAMETER statements can precede
7352 IMPLICIT statements. */
7353 if (sym->attr.implicit_type
7354 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7356 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7357 "later IMPLICIT type", sym->name, &sym->declared_at);
7361 /* Make sure the types of derived parameters are consistent. This
7362 type checking is deferred until resolution because the type may
7363 refer to a derived type from the host. */
7364 if (sym->ts.type == BT_DERIVED
7365 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7367 gfc_error ("Incompatible derived type in PARAMETER at %L",
7368 &sym->value->where);
7375 /* Do anything necessary to resolve a symbol. Right now, we just
7376 assume that an otherwise unknown symbol is a variable. This sort
7377 of thing commonly happens for symbols in module. */
7380 resolve_symbol (gfc_symbol *sym)
7382 int check_constant, mp_flag;
7383 gfc_symtree *symtree;
7384 gfc_symtree *this_symtree;
7388 if (sym->attr.flavor == FL_UNKNOWN)
7391 /* If we find that a flavorless symbol is an interface in one of the
7392 parent namespaces, find its symtree in this namespace, free the
7393 symbol and set the symtree to point to the interface symbol. */
7394 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7396 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7397 if (symtree && symtree->n.sym->generic)
7399 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7403 gfc_free_symbol (sym);
7404 symtree->n.sym->refs++;
7405 this_symtree->n.sym = symtree->n.sym;
7410 /* Otherwise give it a flavor according to such attributes as
7412 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7413 sym->attr.flavor = FL_VARIABLE;
7416 sym->attr.flavor = FL_PROCEDURE;
7417 if (sym->attr.dimension)
7418 sym->attr.function = 1;
7422 if (sym->attr.procedure && sym->interface
7423 && sym->attr.if_source != IFSRC_DECL)
7425 /* Get the attributes from the interface (now resolved). */
7426 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7428 sym->ts = sym->interface->ts;
7429 sym->attr.function = sym->interface->attr.function;
7430 sym->attr.subroutine = sym->interface->attr.subroutine;
7431 copy_formal_args (sym, sym->interface);
7433 else if (sym->interface->name[0] != '\0')
7435 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7436 sym->interface->name, sym->name, &sym->declared_at);
7441 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7444 /* Symbols that are module procedures with results (functions) have
7445 the types and array specification copied for type checking in
7446 procedures that call them, as well as for saving to a module
7447 file. These symbols can't stand the scrutiny that their results
7449 mp_flag = (sym->result != NULL && sym->result != sym);
7452 /* Make sure that the intrinsic is consistent with its internal
7453 representation. This needs to be done before assigning a default
7454 type to avoid spurious warnings. */
7455 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7457 if (gfc_intrinsic_name (sym->name, 0))
7459 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7460 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7461 sym->name, &sym->declared_at);
7463 else if (gfc_intrinsic_name (sym->name, 1))
7465 if (sym->ts.type != BT_UNKNOWN)
7467 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7468 sym->name, &sym->declared_at);
7474 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7479 /* Assign default type to symbols that need one and don't have one. */
7480 if (sym->ts.type == BT_UNKNOWN)
7482 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7483 gfc_set_default_type (sym, 1, NULL);
7485 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7487 /* The specific case of an external procedure should emit an error
7488 in the case that there is no implicit type. */
7490 gfc_set_default_type (sym, sym->attr.external, NULL);
7493 /* Result may be in another namespace. */
7494 resolve_symbol (sym->result);
7496 sym->ts = sym->result->ts;
7497 sym->as = gfc_copy_array_spec (sym->result->as);
7498 sym->attr.dimension = sym->result->attr.dimension;
7499 sym->attr.pointer = sym->result->attr.pointer;
7500 sym->attr.allocatable = sym->result->attr.allocatable;
7505 /* Assumed size arrays and assumed shape arrays must be dummy
7509 && (sym->as->type == AS_ASSUMED_SIZE
7510 || sym->as->type == AS_ASSUMED_SHAPE)
7511 && sym->attr.dummy == 0)
7513 if (sym->as->type == AS_ASSUMED_SIZE)
7514 gfc_error ("Assumed size array at %L must be a dummy argument",
7517 gfc_error ("Assumed shape array at %L must be a dummy argument",
7522 /* Make sure symbols with known intent or optional are really dummy
7523 variable. Because of ENTRY statement, this has to be deferred
7524 until resolution time. */
7526 if (!sym->attr.dummy
7527 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7529 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7533 if (sym->attr.value && !sym->attr.dummy)
7535 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7536 "it is not a dummy argument", sym->name, &sym->declared_at);
7540 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7542 gfc_charlen *cl = sym->ts.cl;
7543 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7545 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7546 "attribute must have constant length",
7547 sym->name, &sym->declared_at);
7551 if (sym->ts.is_c_interop
7552 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7554 gfc_error ("C interoperable character dummy variable '%s' at %L "
7555 "with VALUE attribute must have length one",
7556 sym->name, &sym->declared_at);
7561 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7562 do this for something that was implicitly typed because that is handled
7563 in gfc_set_default_type. Handle dummy arguments and procedure
7564 definitions separately. Also, anything that is use associated is not
7565 handled here but instead is handled in the module it is declared in.
7566 Finally, derived type definitions are allowed to be BIND(C) since that
7567 only implies that they're interoperable, and they are checked fully for
7568 interoperability when a variable is declared of that type. */
7569 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7570 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7571 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7575 /* First, make sure the variable is declared at the
7576 module-level scope (J3/04-007, Section 15.3). */
7577 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7578 sym->attr.in_common == 0)
7580 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7581 "is neither a COMMON block nor declared at the "
7582 "module level scope", sym->name, &(sym->declared_at));
7585 else if (sym->common_head != NULL)
7587 t = verify_com_block_vars_c_interop (sym->common_head);
7591 /* If type() declaration, we need to verify that the components
7592 of the given type are all C interoperable, etc. */
7593 if (sym->ts.type == BT_DERIVED &&
7594 sym->ts.derived->attr.is_c_interop != 1)
7596 /* Make sure the user marked the derived type as BIND(C). If
7597 not, call the verify routine. This could print an error
7598 for the derived type more than once if multiple variables
7599 of that type are declared. */
7600 if (sym->ts.derived->attr.is_bind_c != 1)
7601 verify_bind_c_derived_type (sym->ts.derived);
7605 /* Verify the variable itself as C interoperable if it
7606 is BIND(C). It is not possible for this to succeed if
7607 the verify_bind_c_derived_type failed, so don't have to handle
7608 any error returned by verify_bind_c_derived_type. */
7609 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7615 /* clear the is_bind_c flag to prevent reporting errors more than
7616 once if something failed. */
7617 sym->attr.is_bind_c = 0;
7622 /* If a derived type symbol has reached this point, without its
7623 type being declared, we have an error. Notice that most
7624 conditions that produce undefined derived types have already
7625 been dealt with. However, the likes of:
7626 implicit type(t) (t) ..... call foo (t) will get us here if
7627 the type is not declared in the scope of the implicit
7628 statement. Change the type to BT_UNKNOWN, both because it is so
7629 and to prevent an ICE. */
7630 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7632 gfc_error ("The derived type '%s' at %L is of type '%s', "
7633 "which has not been defined", sym->name,
7634 &sym->declared_at, sym->ts.derived->name);
7635 sym->ts.type = BT_UNKNOWN;
7639 /* Unless the derived-type declaration is use associated, Fortran 95
7640 does not allow public entries of private derived types.
7641 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7643 if (sym->ts.type == BT_DERIVED
7644 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7645 && !gfc_check_access (sym->ts.derived->attr.access,
7646 sym->ts.derived->ns->default_access)
7647 && !sym->ts.derived->attr.use_assoc
7648 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7649 "of PRIVATE derived type '%s'",
7650 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7651 : "variable", sym->name, &sym->declared_at,
7652 sym->ts.derived->name) == FAILURE)
7655 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7656 default initialization is defined (5.1.2.4.4). */
7657 if (sym->ts.type == BT_DERIVED
7659 && sym->attr.intent == INTENT_OUT
7661 && sym->as->type == AS_ASSUMED_SIZE)
7663 for (c = sym->ts.derived->components; c; c = c->next)
7667 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7668 "ASSUMED SIZE and so cannot have a default initializer",
7669 sym->name, &sym->declared_at);
7675 switch (sym->attr.flavor)
7678 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7683 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7688 if (resolve_fl_namelist (sym) == FAILURE)
7693 if (resolve_fl_parameter (sym) == FAILURE)
7701 /* Resolve array specifier. Check as well some constraints
7702 on COMMON blocks. */
7704 check_constant = sym->attr.in_common && !sym->attr.pointer;
7706 /* Set the formal_arg_flag so that check_conflict will not throw
7707 an error for host associated variables in the specification
7708 expression for an array_valued function. */
7709 if (sym->attr.function && sym->as)
7710 formal_arg_flag = 1;
7712 gfc_resolve_array_spec (sym->as, check_constant);
7714 formal_arg_flag = 0;
7716 /* Resolve formal namespaces. */
7717 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7718 gfc_resolve (sym->formal_ns);
7720 /* Check threadprivate restrictions. */
7721 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7722 && (!sym->attr.in_common
7723 && sym->module == NULL
7724 && (sym->ns->proc_name == NULL
7725 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7726 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7728 /* If we have come this far we can apply default-initializers, as
7729 described in 14.7.5, to those variables that have not already
7730 been assigned one. */
7731 if (sym->ts.type == BT_DERIVED
7732 && sym->attr.referenced
7733 && sym->ns == gfc_current_ns
7735 && !sym->attr.allocatable
7736 && !sym->attr.alloc_comp)
7738 symbol_attribute *a = &sym->attr;
7740 if ((!a->save && !a->dummy && !a->pointer
7741 && !a->in_common && !a->use_assoc
7742 && !(a->function && sym != sym->result))
7743 || (a->dummy && a->intent == INTENT_OUT))
7744 apply_default_init (sym);
7749 /************* Resolve DATA statements *************/
7753 gfc_data_value *vnode;
7759 /* Advance the values structure to point to the next value in the data list. */
7762 next_data_value (void)
7764 while (values.left == 0)
7766 if (values.vnode->next == NULL)
7769 values.vnode = values.vnode->next;
7770 values.left = values.vnode->repeat;
7778 check_data_variable (gfc_data_variable *var, locus *where)
7784 ar_type mark = AR_UNKNOWN;
7786 mpz_t section_index[GFC_MAX_DIMENSIONS];
7790 if (gfc_resolve_expr (var->expr) == FAILURE)
7794 mpz_init_set_si (offset, 0);
7797 if (e->expr_type != EXPR_VARIABLE)
7798 gfc_internal_error ("check_data_variable(): Bad expression");
7800 if (e->symtree->n.sym->ns->is_block_data
7801 && !e->symtree->n.sym->attr.in_common)
7803 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7804 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7809 mpz_init_set_ui (size, 1);
7816 /* Find the array section reference. */
7817 for (ref = e->ref; ref; ref = ref->next)
7819 if (ref->type != REF_ARRAY)
7821 if (ref->u.ar.type == AR_ELEMENT)
7827 /* Set marks according to the reference pattern. */
7828 switch (ref->u.ar.type)
7836 /* Get the start position of array section. */
7837 gfc_get_section_index (ar, section_index, &offset);
7845 if (gfc_array_size (e, &size) == FAILURE)
7847 gfc_error ("Nonconstant array section at %L in DATA statement",
7856 while (mpz_cmp_ui (size, 0) > 0)
7858 if (next_data_value () == FAILURE)
7860 gfc_error ("DATA statement at %L has more variables than values",
7866 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7870 /* If we have more than one element left in the repeat count,
7871 and we have more than one element left in the target variable,
7872 then create a range assignment. */
7873 /* ??? Only done for full arrays for now, since array sections
7875 if (mark == AR_FULL && ref && ref->next == NULL
7876 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7880 if (mpz_cmp_ui (size, values.left) >= 0)
7882 mpz_init_set_ui (range, values.left);
7883 mpz_sub_ui (size, size, values.left);
7888 mpz_init_set (range, size);
7889 values.left -= mpz_get_ui (size);
7890 mpz_set_ui (size, 0);
7893 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7896 mpz_add (offset, offset, range);
7900 /* Assign initial value to symbol. */
7904 mpz_sub_ui (size, size, 1);
7906 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7910 if (mark == AR_FULL)
7911 mpz_add_ui (offset, offset, 1);
7913 /* Modify the array section indexes and recalculate the offset
7914 for next element. */
7915 else if (mark == AR_SECTION)
7916 gfc_advance_section (section_index, ar, &offset);
7920 if (mark == AR_SECTION)
7922 for (i = 0; i < ar->dimen; i++)
7923 mpz_clear (section_index[i]);
7933 static try traverse_data_var (gfc_data_variable *, locus *);
7935 /* Iterate over a list of elements in a DATA statement. */
7938 traverse_data_list (gfc_data_variable *var, locus *where)
7941 iterator_stack frame;
7942 gfc_expr *e, *start, *end, *step;
7943 try retval = SUCCESS;
7945 mpz_init (frame.value);
7947 start = gfc_copy_expr (var->iter.start);
7948 end = gfc_copy_expr (var->iter.end);
7949 step = gfc_copy_expr (var->iter.step);
7951 if (gfc_simplify_expr (start, 1) == FAILURE
7952 || start->expr_type != EXPR_CONSTANT)
7954 gfc_error ("iterator start at %L does not simplify", &start->where);
7958 if (gfc_simplify_expr (end, 1) == FAILURE
7959 || end->expr_type != EXPR_CONSTANT)
7961 gfc_error ("iterator end at %L does not simplify", &end->where);
7965 if (gfc_simplify_expr (step, 1) == FAILURE
7966 || step->expr_type != EXPR_CONSTANT)
7968 gfc_error ("iterator step at %L does not simplify", &step->where);
7973 mpz_init_set (trip, end->value.integer);
7974 mpz_sub (trip, trip, start->value.integer);
7975 mpz_add (trip, trip, step->value.integer);
7977 mpz_div (trip, trip, step->value.integer);
7979 mpz_set (frame.value, start->value.integer);
7981 frame.prev = iter_stack;
7982 frame.variable = var->iter.var->symtree;
7983 iter_stack = &frame;
7985 while (mpz_cmp_ui (trip, 0) > 0)
7987 if (traverse_data_var (var->list, where) == FAILURE)
7994 e = gfc_copy_expr (var->expr);
7995 if (gfc_simplify_expr (e, 1) == FAILURE)
8003 mpz_add (frame.value, frame.value, step->value.integer);
8005 mpz_sub_ui (trip, trip, 1);
8010 mpz_clear (frame.value);
8012 gfc_free_expr (start);
8013 gfc_free_expr (end);
8014 gfc_free_expr (step);
8016 iter_stack = frame.prev;
8021 /* Type resolve variables in the variable list of a DATA statement. */
8024 traverse_data_var (gfc_data_variable *var, locus *where)
8028 for (; var; var = var->next)
8030 if (var->expr == NULL)
8031 t = traverse_data_list (var, where);
8033 t = check_data_variable (var, where);
8043 /* Resolve the expressions and iterators associated with a data statement.
8044 This is separate from the assignment checking because data lists should
8045 only be resolved once. */
8048 resolve_data_variables (gfc_data_variable *d)
8050 for (; d; d = d->next)
8052 if (d->list == NULL)
8054 if (gfc_resolve_expr (d->expr) == FAILURE)
8059 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8062 if (resolve_data_variables (d->list) == FAILURE)
8071 /* Resolve a single DATA statement. We implement this by storing a pointer to
8072 the value list into static variables, and then recursively traversing the
8073 variables list, expanding iterators and such. */
8076 resolve_data (gfc_data * d)
8078 if (resolve_data_variables (d->var) == FAILURE)
8081 values.vnode = d->value;
8082 values.left = (d->value == NULL) ? 0 : d->value->repeat;
8084 if (traverse_data_var (d->var, &d->where) == FAILURE)
8087 /* At this point, we better not have any values left. */
8089 if (next_data_value () == SUCCESS)
8090 gfc_error ("DATA statement at %L has more values than variables",
8095 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8096 accessed by host or use association, is a dummy argument to a pure function,
8097 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8098 is storage associated with any such variable, shall not be used in the
8099 following contexts: (clients of this function). */
8101 /* Determines if a variable is not 'pure', ie not assignable within a pure
8102 procedure. Returns zero if assignment is OK, nonzero if there is a
8105 gfc_impure_variable (gfc_symbol *sym)
8109 if (sym->attr.use_assoc || sym->attr.in_common)
8112 if (sym->ns != gfc_current_ns)
8113 return !sym->attr.function;
8115 proc = sym->ns->proc_name;
8116 if (sym->attr.dummy && gfc_pure (proc)
8117 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8119 proc->attr.function))
8122 /* TODO: Sort out what can be storage associated, if anything, and include
8123 it here. In principle equivalences should be scanned but it does not
8124 seem to be possible to storage associate an impure variable this way. */
8129 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8130 symbol of the current procedure. */
8133 gfc_pure (gfc_symbol *sym)
8135 symbol_attribute attr;
8138 sym = gfc_current_ns->proc_name;
8144 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8148 /* Test whether the current procedure is elemental or not. */
8151 gfc_elemental (gfc_symbol *sym)
8153 symbol_attribute attr;
8156 sym = gfc_current_ns->proc_name;
8161 return attr.flavor == FL_PROCEDURE && attr.elemental;
8165 /* Warn about unused labels. */
8168 warn_unused_fortran_label (gfc_st_label *label)
8173 warn_unused_fortran_label (label->left);
8175 if (label->defined == ST_LABEL_UNKNOWN)
8178 switch (label->referenced)
8180 case ST_LABEL_UNKNOWN:
8181 gfc_warning ("Label %d at %L defined but not used", label->value,
8185 case ST_LABEL_BAD_TARGET:
8186 gfc_warning ("Label %d at %L defined but cannot be used",
8187 label->value, &label->where);
8194 warn_unused_fortran_label (label->right);
8198 /* Returns the sequence type of a symbol or sequence. */
8201 sequence_type (gfc_typespec ts)
8210 if (ts.derived->components == NULL)
8211 return SEQ_NONDEFAULT;
8213 result = sequence_type (ts.derived->components->ts);
8214 for (c = ts.derived->components->next; c; c = c->next)
8215 if (sequence_type (c->ts) != result)
8221 if (ts.kind != gfc_default_character_kind)
8222 return SEQ_NONDEFAULT;
8224 return SEQ_CHARACTER;
8227 if (ts.kind != gfc_default_integer_kind)
8228 return SEQ_NONDEFAULT;
8233 if (!(ts.kind == gfc_default_real_kind
8234 || ts.kind == gfc_default_double_kind))
8235 return SEQ_NONDEFAULT;
8240 if (ts.kind != gfc_default_complex_kind)
8241 return SEQ_NONDEFAULT;
8246 if (ts.kind != gfc_default_logical_kind)
8247 return SEQ_NONDEFAULT;
8252 return SEQ_NONDEFAULT;
8257 /* Resolve derived type EQUIVALENCE object. */
8260 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8263 gfc_component *c = derived->components;
8268 /* Shall not be an object of nonsequence derived type. */
8269 if (!derived->attr.sequence)
8271 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8272 "attribute to be an EQUIVALENCE object", sym->name,
8277 /* Shall not have allocatable components. */
8278 if (derived->attr.alloc_comp)
8280 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8281 "components to be an EQUIVALENCE object",sym->name,
8286 for (; c ; c = c->next)
8290 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8293 /* Shall not be an object of sequence derived type containing a pointer
8294 in the structure. */
8297 gfc_error ("Derived type variable '%s' at %L with pointer "
8298 "component(s) cannot be an EQUIVALENCE object",
8299 sym->name, &e->where);
8307 /* Resolve equivalence object.
8308 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8309 an allocatable array, an object of nonsequence derived type, an object of
8310 sequence derived type containing a pointer at any level of component
8311 selection, an automatic object, a function name, an entry name, a result
8312 name, a named constant, a structure component, or a subobject of any of
8313 the preceding objects. A substring shall not have length zero. A
8314 derived type shall not have components with default initialization nor
8315 shall two objects of an equivalence group be initialized.
8316 Either all or none of the objects shall have an protected attribute.
8317 The simple constraints are done in symbol.c(check_conflict) and the rest
8318 are implemented here. */
8321 resolve_equivalence (gfc_equiv *eq)
8324 gfc_symbol *derived;
8325 gfc_symbol *first_sym;
8328 locus *last_where = NULL;
8329 seq_type eq_type, last_eq_type;
8330 gfc_typespec *last_ts;
8331 int object, cnt_protected;
8332 const char *value_name;
8336 last_ts = &eq->expr->symtree->n.sym->ts;
8338 first_sym = eq->expr->symtree->n.sym;
8342 for (object = 1; eq; eq = eq->eq, object++)
8346 e->ts = e->symtree->n.sym->ts;
8347 /* match_varspec might not know yet if it is seeing
8348 array reference or substring reference, as it doesn't
8350 if (e->ref && e->ref->type == REF_ARRAY)
8352 gfc_ref *ref = e->ref;
8353 sym = e->symtree->n.sym;
8355 if (sym->attr.dimension)
8357 ref->u.ar.as = sym->as;
8361 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8362 if (e->ts.type == BT_CHARACTER
8364 && ref->type == REF_ARRAY
8365 && ref->u.ar.dimen == 1
8366 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8367 && ref->u.ar.stride[0] == NULL)
8369 gfc_expr *start = ref->u.ar.start[0];
8370 gfc_expr *end = ref->u.ar.end[0];
8373 /* Optimize away the (:) reference. */
8374 if (start == NULL && end == NULL)
8379 e->ref->next = ref->next;
8384 ref->type = REF_SUBSTRING;
8386 start = gfc_int_expr (1);
8387 ref->u.ss.start = start;
8388 if (end == NULL && e->ts.cl)
8389 end = gfc_copy_expr (e->ts.cl->length);
8390 ref->u.ss.end = end;
8391 ref->u.ss.length = e->ts.cl;
8398 /* Any further ref is an error. */
8401 gcc_assert (ref->type == REF_ARRAY);
8402 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8408 if (gfc_resolve_expr (e) == FAILURE)
8411 sym = e->symtree->n.sym;
8413 if (sym->attr.protected)
8415 if (cnt_protected > 0 && cnt_protected != object)
8417 gfc_error ("Either all or none of the objects in the "
8418 "EQUIVALENCE set at %L shall have the "
8419 "PROTECTED attribute",
8424 /* Shall not equivalence common block variables in a PURE procedure. */
8425 if (sym->ns->proc_name
8426 && sym->ns->proc_name->attr.pure
8427 && sym->attr.in_common)
8429 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8430 "object in the pure procedure '%s'",
8431 sym->name, &e->where, sym->ns->proc_name->name);
8435 /* Shall not be a named constant. */
8436 if (e->expr_type == EXPR_CONSTANT)
8438 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8439 "object", sym->name, &e->where);
8443 derived = e->ts.derived;
8444 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8447 /* Check that the types correspond correctly:
8449 A numeric sequence structure may be equivalenced to another sequence
8450 structure, an object of default integer type, default real type, double
8451 precision real type, default logical type such that components of the
8452 structure ultimately only become associated to objects of the same
8453 kind. A character sequence structure may be equivalenced to an object
8454 of default character kind or another character sequence structure.
8455 Other objects may be equivalenced only to objects of the same type and
8458 /* Identical types are unconditionally OK. */
8459 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8460 goto identical_types;
8462 last_eq_type = sequence_type (*last_ts);
8463 eq_type = sequence_type (sym->ts);
8465 /* Since the pair of objects is not of the same type, mixed or
8466 non-default sequences can be rejected. */
8468 msg = "Sequence %s with mixed components in EQUIVALENCE "
8469 "statement at %L with different type objects";
8471 && last_eq_type == SEQ_MIXED
8472 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8474 || (eq_type == SEQ_MIXED
8475 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8476 &e->where) == FAILURE))
8479 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8480 "statement at %L with objects of different type";
8482 && last_eq_type == SEQ_NONDEFAULT
8483 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8484 last_where) == FAILURE)
8485 || (eq_type == SEQ_NONDEFAULT
8486 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8487 &e->where) == FAILURE))
8490 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8491 "EQUIVALENCE statement at %L";
8492 if (last_eq_type == SEQ_CHARACTER
8493 && eq_type != SEQ_CHARACTER
8494 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8495 &e->where) == FAILURE)
8498 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8499 "EQUIVALENCE statement at %L";
8500 if (last_eq_type == SEQ_NUMERIC
8501 && eq_type != SEQ_NUMERIC
8502 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8503 &e->where) == FAILURE)
8508 last_where = &e->where;
8513 /* Shall not be an automatic array. */
8514 if (e->ref->type == REF_ARRAY
8515 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8517 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8518 "an EQUIVALENCE object", sym->name, &e->where);
8525 /* Shall not be a structure component. */
8526 if (r->type == REF_COMPONENT)
8528 gfc_error ("Structure component '%s' at %L cannot be an "
8529 "EQUIVALENCE object",
8530 r->u.c.component->name, &e->where);
8534 /* A substring shall not have length zero. */
8535 if (r->type == REF_SUBSTRING)
8537 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8539 gfc_error ("Substring at %L has length zero",
8540 &r->u.ss.start->where);
8550 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8553 resolve_fntype (gfc_namespace *ns)
8558 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8561 /* If there are any entries, ns->proc_name is the entry master
8562 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8564 sym = ns->entries->sym;
8566 sym = ns->proc_name;
8567 if (sym->result == sym
8568 && sym->ts.type == BT_UNKNOWN
8569 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8570 && !sym->attr.untyped)
8572 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8573 sym->name, &sym->declared_at);
8574 sym->attr.untyped = 1;
8577 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8578 && !gfc_check_access (sym->ts.derived->attr.access,
8579 sym->ts.derived->ns->default_access)
8580 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8582 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8583 sym->name, &sym->declared_at, sym->ts.derived->name);
8587 for (el = ns->entries->next; el; el = el->next)
8589 if (el->sym->result == el->sym
8590 && el->sym->ts.type == BT_UNKNOWN
8591 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8592 && !el->sym->attr.untyped)
8594 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8595 el->sym->name, &el->sym->declared_at);
8596 el->sym->attr.untyped = 1;
8601 /* 12.3.2.1.1 Defined operators. */
8604 gfc_resolve_uops (gfc_symtree *symtree)
8608 gfc_formal_arglist *formal;
8610 if (symtree == NULL)
8613 gfc_resolve_uops (symtree->left);
8614 gfc_resolve_uops (symtree->right);
8616 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8619 if (!sym->attr.function)
8620 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8621 sym->name, &sym->declared_at);
8623 if (sym->ts.type == BT_CHARACTER
8624 && !(sym->ts.cl && sym->ts.cl->length)
8625 && !(sym->result && sym->result->ts.cl
8626 && sym->result->ts.cl->length))
8627 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8628 "character length", sym->name, &sym->declared_at);
8630 formal = sym->formal;
8631 if (!formal || !formal->sym)
8633 gfc_error ("User operator procedure '%s' at %L must have at least "
8634 "one argument", sym->name, &sym->declared_at);
8638 if (formal->sym->attr.intent != INTENT_IN)
8639 gfc_error ("First argument of operator interface at %L must be "
8640 "INTENT(IN)", &sym->declared_at);
8642 if (formal->sym->attr.optional)
8643 gfc_error ("First argument of operator interface at %L cannot be "
8644 "optional", &sym->declared_at);
8646 formal = formal->next;
8647 if (!formal || !formal->sym)
8650 if (formal->sym->attr.intent != INTENT_IN)
8651 gfc_error ("Second argument of operator interface at %L must be "
8652 "INTENT(IN)", &sym->declared_at);
8654 if (formal->sym->attr.optional)
8655 gfc_error ("Second argument of operator interface at %L cannot be "
8656 "optional", &sym->declared_at);
8659 gfc_error ("Operator interface at %L must have, at most, two "
8660 "arguments", &sym->declared_at);
8665 /* Examine all of the expressions associated with a program unit,
8666 assign types to all intermediate expressions, make sure that all
8667 assignments are to compatible types and figure out which names
8668 refer to which functions or subroutines. It doesn't check code
8669 block, which is handled by resolve_code. */
8672 resolve_types (gfc_namespace *ns)
8679 gfc_current_ns = ns;
8681 resolve_entries (ns);
8683 resolve_common_blocks (ns->common_root);
8685 resolve_contained_functions (ns);
8687 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8689 for (cl = ns->cl_list; cl; cl = cl->next)
8690 resolve_charlen (cl);
8692 gfc_traverse_ns (ns, resolve_symbol);
8694 resolve_fntype (ns);
8696 for (n = ns->contained; n; n = n->sibling)
8698 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8699 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8700 "also be PURE", n->proc_name->name,
8701 &n->proc_name->declared_at);
8707 gfc_check_interfaces (ns);
8709 gfc_traverse_ns (ns, resolve_values);
8715 for (d = ns->data; d; d = d->next)
8719 gfc_traverse_ns (ns, gfc_formalize_init_value);
8721 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8723 if (ns->common_root != NULL)
8724 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8726 for (eq = ns->equiv; eq; eq = eq->next)
8727 resolve_equivalence (eq);
8729 /* Warn about unused labels. */
8730 if (warn_unused_label)
8731 warn_unused_fortran_label (ns->st_labels);
8733 gfc_resolve_uops (ns->uop_root);
8737 /* Call resolve_code recursively. */
8740 resolve_codes (gfc_namespace *ns)
8744 for (n = ns->contained; n; n = n->sibling)
8747 gfc_current_ns = ns;
8749 /* Set to an out of range value. */
8750 current_entry_id = -1;
8752 bitmap_obstack_initialize (&labels_obstack);
8753 resolve_code (ns->code, ns);
8754 bitmap_obstack_release (&labels_obstack);
8758 /* This function is called after a complete program unit has been compiled.
8759 Its purpose is to examine all of the expressions associated with a program
8760 unit, assign types to all intermediate expressions, make sure that all
8761 assignments are to compatible types and figure out which names refer to
8762 which functions or subroutines. */
8765 gfc_resolve (gfc_namespace *ns)
8767 gfc_namespace *old_ns;
8769 old_ns = gfc_current_ns;
8774 gfc_current_ns = old_ns;