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 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code *head, *current, *tail;
47 struct code_stack *prev;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels;
55 static code_stack *cs_base = NULL;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag = 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr = 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag;
85 /* Resolve types of formal argument lists. These have to be done early so that
86 the formal argument lists of module procedures can be copied to the
87 containing module before the individual procedures are resolved
88 individually. We also resolve argument lists of procedures in interface
89 blocks because they are self-contained scoping units.
91 Since a dummy argument cannot be a non-dummy procedure, the only
92 resort left for untyped names are the IMPLICIT types. */
95 resolve_formal_arglist (gfc_symbol *proc)
97 gfc_formal_arglist *f;
101 if (proc->result != NULL)
106 if (gfc_elemental (proc)
107 || sym->attr.pointer || sym->attr.allocatable
108 || (sym->as && sym->as->rank > 0))
109 proc->attr.always_explicit = 1;
113 for (f = proc->formal; f; f = f->next)
119 /* Alternate return placeholder. */
120 if (gfc_elemental (proc))
121 gfc_error ("Alternate return specifier in elemental subroutine "
122 "'%s' at %L is not allowed", proc->name,
124 if (proc->attr.function)
125 gfc_error ("Alternate return specifier in function "
126 "'%s' at %L is not allowed", proc->name,
131 if (sym->attr.if_source != IFSRC_UNKNOWN)
132 resolve_formal_arglist (sym);
134 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
136 if (gfc_pure (proc) && !gfc_pure (sym))
138 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
139 "also be PURE", sym->name, &sym->declared_at);
143 if (gfc_elemental (proc))
145 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
146 "procedure", &sym->declared_at);
150 if (sym->attr.function
151 && sym->ts.type == BT_UNKNOWN
152 && sym->attr.intrinsic)
154 gfc_intrinsic_sym *isym;
155 isym = gfc_find_function (sym->name);
156 if (isym == NULL || !isym->specific)
158 gfc_error ("Unable to find a specific INTRINSIC procedure "
159 "for the reference '%s' at %L", sym->name,
168 if (sym->ts.type == BT_UNKNOWN)
170 if (!sym->attr.function || sym->result == sym)
171 gfc_set_default_type (sym, 1, sym->ns);
174 gfc_resolve_array_spec (sym->as, 0);
176 /* We can't tell if an array with dimension (:) is assumed or deferred
177 shape until we know if it has the pointer or allocatable attributes.
179 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
180 && !(sym->attr.pointer || sym->attr.allocatable))
182 sym->as->type = AS_ASSUMED_SHAPE;
183 for (i = 0; i < sym->as->rank; i++)
184 sym->as->lower[i] = gfc_int_expr (1);
187 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
188 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
189 || sym->attr.optional)
190 proc->attr.always_explicit = 1;
192 /* If the flavor is unknown at this point, it has to be a variable.
193 A procedure specification would have already set the type. */
195 if (sym->attr.flavor == FL_UNKNOWN)
196 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
198 if (gfc_pure (proc) && !sym->attr.pointer
199 && sym->attr.flavor != FL_PROCEDURE)
201 if (proc->attr.function && sym->attr.intent != INTENT_IN)
202 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
203 "INTENT(IN)", sym->name, proc->name,
206 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
207 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
208 "have its INTENT specified", sym->name, proc->name,
212 if (gfc_elemental (proc))
216 gfc_error ("Argument '%s' of elemental procedure at %L must "
217 "be scalar", sym->name, &sym->declared_at);
221 if (sym->attr.pointer)
223 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
224 "have the POINTER attribute", sym->name,
229 if (sym->attr.flavor == FL_PROCEDURE)
231 gfc_error ("Dummy procedure '%s' not allowed in elemental "
232 "procedure '%s' at %L", sym->name, proc->name,
238 /* Each dummy shall be specified to be scalar. */
239 if (proc->attr.proc == PROC_ST_FUNCTION)
243 gfc_error ("Argument '%s' of statement function at %L must "
244 "be scalar", sym->name, &sym->declared_at);
248 if (sym->ts.type == BT_CHARACTER)
250 gfc_charlen *cl = sym->ts.cl;
251 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
253 gfc_error ("Character-valued argument '%s' of statement "
254 "function at %L must have constant length",
255 sym->name, &sym->declared_at);
265 /* Work function called when searching for symbols that have argument lists
266 associated with them. */
269 find_arglists (gfc_symbol *sym)
271 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
274 resolve_formal_arglist (sym);
278 /* Given a namespace, resolve all formal argument lists within the namespace.
282 resolve_formal_arglists (gfc_namespace *ns)
287 gfc_traverse_ns (ns, find_arglists);
292 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
296 /* If this namespace is not a function or an entry master function,
298 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
299 || sym->attr.entry_master)
302 /* Try to find out of what the return type is. */
303 if (sym->result->ts.type == BT_UNKNOWN)
305 t = gfc_set_default_type (sym->result, 0, ns);
307 if (t == FAILURE && !sym->result->attr.untyped)
309 if (sym->result == sym)
310 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
311 sym->name, &sym->declared_at);
313 gfc_error ("Result '%s' of contained function '%s' at %L has "
314 "no IMPLICIT type", sym->result->name, sym->name,
315 &sym->result->declared_at);
316 sym->result->attr.untyped = 1;
320 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
321 type, lists the only ways a character length value of * can be used:
322 dummy arguments of procedures, named constants, and function results
323 in external functions. Internal function results are not on that list;
324 ergo, not permitted. */
326 if (sym->result->ts.type == BT_CHARACTER)
328 gfc_charlen *cl = sym->result->ts.cl;
329 if (!cl || !cl->length)
330 gfc_error ("Character-valued internal function '%s' at %L must "
331 "not be assumed length", sym->name, &sym->declared_at);
336 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
337 introduce duplicates. */
340 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
342 gfc_formal_arglist *f, *new_arglist;
345 for (; new_args != NULL; new_args = new_args->next)
347 new_sym = new_args->sym;
348 /* See if this arg is already in the formal argument list. */
349 for (f = proc->formal; f; f = f->next)
351 if (new_sym == f->sym)
358 /* Add a new argument. Argument order is not important. */
359 new_arglist = gfc_get_formal_arglist ();
360 new_arglist->sym = new_sym;
361 new_arglist->next = proc->formal;
362 proc->formal = new_arglist;
367 /* Flag the arguments that are not present in all entries. */
370 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
372 gfc_formal_arglist *f, *head;
375 for (f = proc->formal; f; f = f->next)
380 for (new_args = head; new_args; new_args = new_args->next)
382 if (new_args->sym == f->sym)
389 f->sym->attr.not_always_present = 1;
394 /* Resolve alternate entry points. If a symbol has multiple entry points we
395 create a new master symbol for the main routine, and turn the existing
396 symbol into an entry point. */
399 resolve_entries (gfc_namespace *ns)
401 gfc_namespace *old_ns;
405 char name[GFC_MAX_SYMBOL_LEN + 1];
406 static int master_count = 0;
408 if (ns->proc_name == NULL)
411 /* No need to do anything if this procedure doesn't have alternate entry
416 /* We may already have resolved alternate entry points. */
417 if (ns->proc_name->attr.entry_master)
420 /* If this isn't a procedure something has gone horribly wrong. */
421 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
423 /* Remember the current namespace. */
424 old_ns = gfc_current_ns;
428 /* Add the main entry point to the list of entry points. */
429 el = gfc_get_entry_list ();
430 el->sym = ns->proc_name;
432 el->next = ns->entries;
434 ns->proc_name->attr.entry = 1;
436 /* If it is a module function, it needs to be in the right namespace
437 so that gfc_get_fake_result_decl can gather up the results. The
438 need for this arose in get_proc_name, where these beasts were
439 left in their own namespace, to keep prior references linked to
440 the entry declaration.*/
441 if (ns->proc_name->attr.function
442 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
445 /* Do the same for entries where the master is not a module
446 procedure. These are retained in the module namespace because
447 of the module procedure declaration. */
448 for (el = el->next; el; el = el->next)
449 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
450 && el->sym->attr.mod_proc)
454 /* Add an entry statement for it. */
461 /* Create a new symbol for the master function. */
462 /* Give the internal function a unique name (within this file).
463 Also include the function name so the user has some hope of figuring
464 out what is going on. */
465 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
466 master_count++, ns->proc_name->name);
467 gfc_get_ha_symbol (name, &proc);
468 gcc_assert (proc != NULL);
470 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
471 if (ns->proc_name->attr.subroutine)
472 gfc_add_subroutine (&proc->attr, proc->name, NULL);
476 gfc_typespec *ts, *fts;
477 gfc_array_spec *as, *fas;
478 gfc_add_function (&proc->attr, proc->name, NULL);
480 fas = ns->entries->sym->as;
481 fas = fas ? fas : ns->entries->sym->result->as;
482 fts = &ns->entries->sym->result->ts;
483 if (fts->type == BT_UNKNOWN)
484 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
485 for (el = ns->entries->next; el; el = el->next)
487 ts = &el->sym->result->ts;
489 as = as ? as : el->sym->result->as;
490 if (ts->type == BT_UNKNOWN)
491 ts = gfc_get_default_type (el->sym->result, NULL);
493 if (! gfc_compare_types (ts, fts)
494 || (el->sym->result->attr.dimension
495 != ns->entries->sym->result->attr.dimension)
496 || (el->sym->result->attr.pointer
497 != ns->entries->sym->result->attr.pointer))
499 else if (as && fas && ns->entries->sym->result != el->sym->result
500 && gfc_compare_array_spec (as, fas) == 0)
501 gfc_error ("Function %s at %L has entries with mismatched "
502 "array specifications", ns->entries->sym->name,
503 &ns->entries->sym->declared_at);
504 /* The characteristics need to match and thus both need to have
505 the same string length, i.e. both len=*, or both len=4.
506 Having both len=<variable> is also possible, but difficult to
507 check at compile time. */
508 else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
509 && (((ts->cl->length && !fts->cl->length)
510 ||(!ts->cl->length && fts->cl->length))
512 && ts->cl->length->expr_type
513 != fts->cl->length->expr_type)
515 && ts->cl->length->expr_type == EXPR_CONSTANT
516 && mpz_cmp (ts->cl->length->value.integer,
517 fts->cl->length->value.integer) != 0)))
518 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
519 "entries returning variables of different "
520 "string lengths", ns->entries->sym->name,
521 &ns->entries->sym->declared_at);
526 sym = ns->entries->sym->result;
527 /* All result types the same. */
529 if (sym->attr.dimension)
530 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
531 if (sym->attr.pointer)
532 gfc_add_pointer (&proc->attr, NULL);
536 /* Otherwise the result will be passed through a union by
538 proc->attr.mixed_entry_master = 1;
539 for (el = ns->entries; el; el = el->next)
541 sym = el->sym->result;
542 if (sym->attr.dimension)
544 if (el == ns->entries)
545 gfc_error ("FUNCTION result %s can't be an array in "
546 "FUNCTION %s at %L", sym->name,
547 ns->entries->sym->name, &sym->declared_at);
549 gfc_error ("ENTRY result %s can't be an array in "
550 "FUNCTION %s at %L", sym->name,
551 ns->entries->sym->name, &sym->declared_at);
553 else if (sym->attr.pointer)
555 if (el == ns->entries)
556 gfc_error ("FUNCTION result %s can't be a POINTER in "
557 "FUNCTION %s at %L", sym->name,
558 ns->entries->sym->name, &sym->declared_at);
560 gfc_error ("ENTRY result %s can't be a POINTER in "
561 "FUNCTION %s at %L", sym->name,
562 ns->entries->sym->name, &sym->declared_at);
567 if (ts->type == BT_UNKNOWN)
568 ts = gfc_get_default_type (sym, NULL);
572 if (ts->kind == gfc_default_integer_kind)
576 if (ts->kind == gfc_default_real_kind
577 || ts->kind == gfc_default_double_kind)
581 if (ts->kind == gfc_default_complex_kind)
585 if (ts->kind == gfc_default_logical_kind)
589 /* We will issue error elsewhere. */
597 if (el == ns->entries)
598 gfc_error ("FUNCTION result %s can't be of type %s "
599 "in FUNCTION %s at %L", sym->name,
600 gfc_typename (ts), ns->entries->sym->name,
603 gfc_error ("ENTRY result %s can't be of type %s "
604 "in FUNCTION %s at %L", sym->name,
605 gfc_typename (ts), ns->entries->sym->name,
612 proc->attr.access = ACCESS_PRIVATE;
613 proc->attr.entry_master = 1;
615 /* Merge all the entry point arguments. */
616 for (el = ns->entries; el; el = el->next)
617 merge_argument_lists (proc, el->sym->formal);
619 /* Check the master formal arguments for any that are not
620 present in all entry points. */
621 for (el = ns->entries; el; el = el->next)
622 check_argument_lists (proc, el->sym->formal);
624 /* Use the master function for the function body. */
625 ns->proc_name = proc;
627 /* Finalize the new symbols. */
628 gfc_commit_symbols ();
630 /* Restore the original namespace. */
631 gfc_current_ns = old_ns;
636 has_default_initializer (gfc_symbol *der)
640 gcc_assert (der->attr.flavor == FL_DERIVED);
641 for (c = der->components; c; c = c->next)
642 if ((c->ts.type != BT_DERIVED && c->initializer)
643 || (c->ts.type == BT_DERIVED
644 && (!c->pointer && has_default_initializer (c->ts.derived))))
650 /* Resolve common variables. */
652 resolve_common_vars (gfc_symbol *sym, bool named_common)
654 gfc_symbol *csym = sym;
656 for (; csym; csym = csym->common_next)
658 if (csym->value || csym->attr.data)
660 if (!csym->ns->is_block_data)
661 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
662 "but only in BLOCK DATA initialization is "
663 "allowed", csym->name, &csym->declared_at);
664 else if (!named_common)
665 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
666 "in a blank COMMON but initialization is only "
667 "allowed in named common blocks", csym->name,
671 if (csym->ts.type != BT_DERIVED)
674 if (!(csym->ts.derived->attr.sequence
675 || csym->ts.derived->attr.is_bind_c))
676 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
677 "has neither the SEQUENCE nor the BIND(C) "
678 "attribute", csym->name, &csym->declared_at);
679 if (csym->ts.derived->attr.alloc_comp)
680 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
681 "has an ultimate component that is "
682 "allocatable", csym->name, &csym->declared_at);
683 if (has_default_initializer (csym->ts.derived))
684 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
685 "may not have default initializer", csym->name,
690 /* Resolve common blocks. */
692 resolve_common_blocks (gfc_symtree *common_root)
696 if (common_root == NULL)
699 if (common_root->left)
700 resolve_common_blocks (common_root->left);
701 if (common_root->right)
702 resolve_common_blocks (common_root->right);
704 resolve_common_vars (common_root->n.common->head, true);
706 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
710 if (sym->attr.flavor == FL_PARAMETER)
711 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
712 sym->name, &common_root->n.common->where, &sym->declared_at);
714 if (sym->attr.intrinsic)
715 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
716 sym->name, &common_root->n.common->where);
717 else if (sym->attr.result
718 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
719 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
720 "that is also a function result", sym->name,
721 &common_root->n.common->where);
722 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
723 && sym->attr.proc != PROC_ST_FUNCTION)
724 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
725 "that is also a global procedure", sym->name,
726 &common_root->n.common->where);
730 /* Resolve contained function types. Because contained functions can call one
731 another, they have to be worked out before any of the contained procedures
734 The good news is that if a function doesn't already have a type, the only
735 way it can get one is through an IMPLICIT type or a RESULT variable, because
736 by definition contained functions are contained namespace they're contained
737 in, not in a sibling or parent namespace. */
740 resolve_contained_functions (gfc_namespace *ns)
742 gfc_namespace *child;
745 resolve_formal_arglists (ns);
747 for (child = ns->contained; child; child = child->sibling)
749 /* Resolve alternate entry points first. */
750 resolve_entries (child);
752 /* Then check function return types. */
753 resolve_contained_fntype (child->proc_name, child);
754 for (el = child->entries; el; el = el->next)
755 resolve_contained_fntype (el->sym, child);
760 /* Resolve all of the elements of a structure constructor and make sure that
761 the types are correct. */
764 resolve_structure_cons (gfc_expr *expr)
766 gfc_constructor *cons;
772 cons = expr->value.constructor;
773 /* A constructor may have references if it is the result of substituting a
774 parameter variable. In this case we just pull out the component we
777 comp = expr->ref->u.c.sym->components;
779 comp = expr->ts.derived->components;
781 /* See if the user is trying to invoke a structure constructor for one of
782 the iso_c_binding derived types. */
783 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
784 && cons->expr != NULL)
786 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
787 expr->ts.derived->name, &(expr->where));
791 for (; comp; comp = comp->next, cons = cons->next)
798 if (gfc_resolve_expr (cons->expr) == FAILURE)
804 rank = comp->as ? comp->as->rank : 0;
805 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
806 && (comp->allocatable || cons->expr->rank))
808 gfc_error ("The rank of the element in the derived type "
809 "constructor at %L does not match that of the "
810 "component (%d/%d)", &cons->expr->where,
811 cons->expr->rank, rank);
815 /* If we don't have the right type, try to convert it. */
817 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
820 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
821 gfc_error ("The element in the derived type constructor at %L, "
822 "for pointer component '%s', is %s but should be %s",
823 &cons->expr->where, comp->name,
824 gfc_basic_typename (cons->expr->ts.type),
825 gfc_basic_typename (comp->ts.type));
827 t = gfc_convert_type (cons->expr, &comp->ts, 1);
830 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
833 a = gfc_expr_attr (cons->expr);
835 if (!a.pointer && !a.target)
838 gfc_error ("The element in the derived type constructor at %L, "
839 "for pointer component '%s' should be a POINTER or "
840 "a TARGET", &cons->expr->where, comp->name);
848 /****************** Expression name resolution ******************/
850 /* Returns 0 if a symbol was not declared with a type or
851 attribute declaration statement, nonzero otherwise. */
854 was_declared (gfc_symbol *sym)
860 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
863 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
864 || a.optional || a.pointer || a.save || a.target || a.volatile_
865 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
872 /* Determine if a symbol is generic or not. */
875 generic_sym (gfc_symbol *sym)
879 if (sym->attr.generic ||
880 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
883 if (was_declared (sym) || sym->ns->parent == NULL)
886 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
893 return generic_sym (s);
900 /* Determine if a symbol is specific or not. */
903 specific_sym (gfc_symbol *sym)
907 if (sym->attr.if_source == IFSRC_IFBODY
908 || sym->attr.proc == PROC_MODULE
909 || sym->attr.proc == PROC_INTERNAL
910 || sym->attr.proc == PROC_ST_FUNCTION
911 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
912 || sym->attr.external)
915 if (was_declared (sym) || sym->ns->parent == NULL)
918 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
920 return (s == NULL) ? 0 : specific_sym (s);
924 /* Figure out if the procedure is specific, generic or unknown. */
927 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
931 procedure_kind (gfc_symbol *sym)
933 if (generic_sym (sym))
934 return PTYPE_GENERIC;
936 if (specific_sym (sym))
937 return PTYPE_SPECIFIC;
939 return PTYPE_UNKNOWN;
942 /* Check references to assumed size arrays. The flag need_full_assumed_size
943 is nonzero when matching actual arguments. */
945 static int need_full_assumed_size = 0;
948 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
954 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
957 for (ref = e->ref; ref; ref = ref->next)
958 if (ref->type == REF_ARRAY)
959 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
960 last = (ref->u.ar.end[dim] == NULL)
961 && (ref->u.ar.type == DIMEN_ELEMENT);
965 gfc_error ("The upper bound in the last dimension must "
966 "appear in the reference to the assumed size "
967 "array '%s' at %L", sym->name, &e->where);
974 /* Look for bad assumed size array references in argument expressions
975 of elemental and array valued intrinsic procedures. Since this is
976 called from procedure resolution functions, it only recurses at
980 resolve_assumed_size_actual (gfc_expr *e)
985 switch (e->expr_type)
988 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
993 if (resolve_assumed_size_actual (e->value.op.op1)
994 || resolve_assumed_size_actual (e->value.op.op2))
1005 /* Resolve an actual argument list. Most of the time, this is just
1006 resolving the expressions in the list.
1007 The exception is that we sometimes have to decide whether arguments
1008 that look like procedure arguments are really simple variable
1012 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
1015 gfc_symtree *parent_st;
1017 int save_need_full_assumed_size;
1019 for (; arg; arg = arg->next)
1024 /* Check the label is a valid branching target. */
1027 if (arg->label->defined == ST_LABEL_UNKNOWN)
1029 gfc_error ("Label %d referenced at %L is never defined",
1030 arg->label->value, &arg->label->where);
1037 if (e->expr_type == FL_VARIABLE && e->symtree->ambiguous)
1039 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1044 if (e->ts.type != BT_PROCEDURE)
1046 save_need_full_assumed_size = need_full_assumed_size;
1047 if (e->expr_type != FL_VARIABLE)
1048 need_full_assumed_size = 0;
1049 if (gfc_resolve_expr (e) != SUCCESS)
1051 need_full_assumed_size = save_need_full_assumed_size;
1055 /* See if the expression node should really be a variable reference. */
1057 sym = e->symtree->n.sym;
1059 if (sym->attr.flavor == FL_PROCEDURE
1060 || sym->attr.intrinsic
1061 || sym->attr.external)
1065 /* If a procedure is not already determined to be something else
1066 check if it is intrinsic. */
1067 if (!sym->attr.intrinsic
1068 && !(sym->attr.external || sym->attr.use_assoc
1069 || sym->attr.if_source == IFSRC_IFBODY)
1070 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1071 sym->attr.intrinsic = 1;
1073 if (sym->attr.proc == PROC_ST_FUNCTION)
1075 gfc_error ("Statement function '%s' at %L is not allowed as an "
1076 "actual argument", sym->name, &e->where);
1079 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1080 sym->attr.subroutine);
1081 if (sym->attr.intrinsic && actual_ok == 0)
1083 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1084 "actual argument", sym->name, &e->where);
1087 if (sym->attr.contained && !sym->attr.use_assoc
1088 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1090 gfc_error ("Internal procedure '%s' is not allowed as an "
1091 "actual argument at %L", sym->name, &e->where);
1094 if (sym->attr.elemental && !sym->attr.intrinsic)
1096 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1097 "allowed as an actual argument at %L", sym->name,
1101 /* Check if a generic interface has a specific procedure
1102 with the same name before emitting an error. */
1103 if (sym->attr.generic)
1106 for (p = sym->generic; p; p = p->next)
1107 if (strcmp (sym->name, p->sym->name) == 0)
1109 e->symtree = gfc_find_symtree
1110 (p->sym->ns->sym_root, sym->name);
1115 if (p == NULL || e->symtree == NULL)
1116 gfc_error ("GENERIC procedure '%s' is not "
1117 "allowed as an actual argument at %L", sym->name,
1121 /* If the symbol is the function that names the current (or
1122 parent) scope, then we really have a variable reference. */
1124 if (sym->attr.function && sym->result == sym
1125 && (sym->ns->proc_name == sym
1126 || (sym->ns->parent != NULL
1127 && sym->ns->parent->proc_name == sym)))
1130 /* If all else fails, see if we have a specific intrinsic. */
1131 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1133 gfc_intrinsic_sym *isym;
1135 isym = gfc_find_function (sym->name);
1136 if (isym == NULL || !isym->specific)
1138 gfc_error ("Unable to find a specific INTRINSIC procedure "
1139 "for the reference '%s' at %L", sym->name,
1144 sym->attr.intrinsic = 1;
1145 sym->attr.function = 1;
1150 /* See if the name is a module procedure in a parent unit. */
1152 if (was_declared (sym) || sym->ns->parent == NULL)
1155 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1157 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1161 if (parent_st == NULL)
1164 sym = parent_st->n.sym;
1165 e->symtree = parent_st; /* Point to the right thing. */
1167 if (sym->attr.flavor == FL_PROCEDURE
1168 || sym->attr.intrinsic
1169 || sym->attr.external)
1175 e->expr_type = EXPR_VARIABLE;
1177 if (sym->as != NULL)
1179 e->rank = sym->as->rank;
1180 e->ref = gfc_get_ref ();
1181 e->ref->type = REF_ARRAY;
1182 e->ref->u.ar.type = AR_FULL;
1183 e->ref->u.ar.as = sym->as;
1186 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1187 primary.c (match_actual_arg). If above code determines that it
1188 is a variable instead, it needs to be resolved as it was not
1189 done at the beginning of this function. */
1190 save_need_full_assumed_size = need_full_assumed_size;
1191 if (e->expr_type != FL_VARIABLE)
1192 need_full_assumed_size = 0;
1193 if (gfc_resolve_expr (e) != SUCCESS)
1195 need_full_assumed_size = save_need_full_assumed_size;
1198 /* Check argument list functions %VAL, %LOC and %REF. There is
1199 nothing to do for %REF. */
1200 if (arg->name && arg->name[0] == '%')
1202 if (strncmp ("%VAL", arg->name, 4) == 0)
1204 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1206 gfc_error ("By-value argument at %L is not of numeric "
1213 gfc_error ("By-value argument at %L cannot be an array or "
1214 "an array section", &e->where);
1218 /* Intrinsics are still PROC_UNKNOWN here. However,
1219 since same file external procedures are not resolvable
1220 in gfortran, it is a good deal easier to leave them to
1222 if (ptype != PROC_UNKNOWN
1223 && ptype != PROC_DUMMY
1224 && ptype != PROC_EXTERNAL
1225 && ptype != PROC_MODULE)
1227 gfc_error ("By-value argument at %L is not allowed "
1228 "in this context", &e->where);
1233 /* Statement functions have already been excluded above. */
1234 else if (strncmp ("%LOC", arg->name, 4) == 0
1235 && e->ts.type == BT_PROCEDURE)
1237 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1239 gfc_error ("Passing internal procedure at %L by location "
1240 "not allowed", &e->where);
1251 /* Do the checks of the actual argument list that are specific to elemental
1252 procedures. If called with c == NULL, we have a function, otherwise if
1253 expr == NULL, we have a subroutine. */
1256 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1258 gfc_actual_arglist *arg0;
1259 gfc_actual_arglist *arg;
1260 gfc_symbol *esym = NULL;
1261 gfc_intrinsic_sym *isym = NULL;
1263 gfc_intrinsic_arg *iformal = NULL;
1264 gfc_formal_arglist *eformal = NULL;
1265 bool formal_optional = false;
1266 bool set_by_optional = false;
1270 /* Is this an elemental procedure? */
1271 if (expr && expr->value.function.actual != NULL)
1273 if (expr->value.function.esym != NULL
1274 && expr->value.function.esym->attr.elemental)
1276 arg0 = expr->value.function.actual;
1277 esym = expr->value.function.esym;
1279 else if (expr->value.function.isym != NULL
1280 && expr->value.function.isym->elemental)
1282 arg0 = expr->value.function.actual;
1283 isym = expr->value.function.isym;
1288 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1290 arg0 = c->ext.actual;
1291 esym = c->symtree->n.sym;
1296 /* The rank of an elemental is the rank of its array argument(s). */
1297 for (arg = arg0; arg; arg = arg->next)
1299 if (arg->expr != NULL && arg->expr->rank > 0)
1301 rank = arg->expr->rank;
1302 if (arg->expr->expr_type == EXPR_VARIABLE
1303 && arg->expr->symtree->n.sym->attr.optional)
1304 set_by_optional = true;
1306 /* Function specific; set the result rank and shape. */
1310 if (!expr->shape && arg->expr->shape)
1312 expr->shape = gfc_get_shape (rank);
1313 for (i = 0; i < rank; i++)
1314 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1321 /* If it is an array, it shall not be supplied as an actual argument
1322 to an elemental procedure unless an array of the same rank is supplied
1323 as an actual argument corresponding to a nonoptional dummy argument of
1324 that elemental procedure(12.4.1.5). */
1325 formal_optional = false;
1327 iformal = isym->formal;
1329 eformal = esym->formal;
1331 for (arg = arg0; arg; arg = arg->next)
1335 if (eformal->sym && eformal->sym->attr.optional)
1336 formal_optional = true;
1337 eformal = eformal->next;
1339 else if (isym && iformal)
1341 if (iformal->optional)
1342 formal_optional = true;
1343 iformal = iformal->next;
1346 formal_optional = true;
1348 if (pedantic && arg->expr != NULL
1349 && arg->expr->expr_type == EXPR_VARIABLE
1350 && arg->expr->symtree->n.sym->attr.optional
1353 && (set_by_optional || arg->expr->rank != rank)
1354 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1356 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1357 "MISSING, it cannot be the actual argument of an "
1358 "ELEMENTAL procedure unless there is a non-optional "
1359 "argument with the same rank (12.4.1.5)",
1360 arg->expr->symtree->n.sym->name, &arg->expr->where);
1365 for (arg = arg0; arg; arg = arg->next)
1367 if (arg->expr == NULL || arg->expr->rank == 0)
1370 /* Being elemental, the last upper bound of an assumed size array
1371 argument must be present. */
1372 if (resolve_assumed_size_actual (arg->expr))
1375 /* Elemental procedure's array actual arguments must conform. */
1378 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1386 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1387 is an array, the intent inout/out variable needs to be also an array. */
1388 if (rank > 0 && esym && expr == NULL)
1389 for (eformal = esym->formal, arg = arg0; arg && eformal;
1390 arg = arg->next, eformal = eformal->next)
1391 if ((eformal->sym->attr.intent == INTENT_OUT
1392 || eformal->sym->attr.intent == INTENT_INOUT)
1393 && arg->expr && arg->expr->rank == 0)
1395 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1396 "ELEMENTAL subroutine '%s' is a scalar, but another "
1397 "actual argument is an array", &arg->expr->where,
1398 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1399 : "INOUT", eformal->sym->name, esym->name);
1406 /* Go through each actual argument in ACTUAL and see if it can be
1407 implemented as an inlined, non-copying intrinsic. FNSYM is the
1408 function being called, or NULL if not known. */
1411 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1413 gfc_actual_arglist *ap;
1416 for (ap = actual; ap; ap = ap->next)
1418 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1419 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1420 ap->expr->inline_noncopying_intrinsic = 1;
1424 /* This function does the checking of references to global procedures
1425 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1426 77 and 95 standards. It checks for a gsymbol for the name, making
1427 one if it does not already exist. If it already exists, then the
1428 reference being resolved must correspond to the type of gsymbol.
1429 Otherwise, the new symbol is equipped with the attributes of the
1430 reference. The corresponding code that is called in creating
1431 global entities is parse.c. */
1434 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1439 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1441 gsym = gfc_get_gsymbol (sym->name);
1443 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1444 gfc_global_used (gsym, where);
1446 if (gsym->type == GSYM_UNKNOWN)
1449 gsym->where = *where;
1456 /************* Function resolution *************/
1458 /* Resolve a function call known to be generic.
1459 Section 14.1.2.4.1. */
1462 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1466 if (sym->attr.generic)
1468 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1471 expr->value.function.name = s->name;
1472 expr->value.function.esym = s;
1474 if (s->ts.type != BT_UNKNOWN)
1476 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1477 expr->ts = s->result->ts;
1480 expr->rank = s->as->rank;
1481 else if (s->result != NULL && s->result->as != NULL)
1482 expr->rank = s->result->as->rank;
1484 gfc_set_sym_referenced (expr->value.function.esym);
1489 /* TODO: Need to search for elemental references in generic
1493 if (sym->attr.intrinsic)
1494 return gfc_intrinsic_func_interface (expr, 0);
1501 resolve_generic_f (gfc_expr *expr)
1506 sym = expr->symtree->n.sym;
1510 m = resolve_generic_f0 (expr, sym);
1513 else if (m == MATCH_ERROR)
1517 if (sym->ns->parent == NULL)
1519 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1523 if (!generic_sym (sym))
1527 /* Last ditch attempt. See if the reference is to an intrinsic
1528 that possesses a matching interface. 14.1.2.4 */
1529 if (sym && !gfc_intrinsic_name (sym->name, 0))
1531 gfc_error ("There is no specific function for the generic '%s' at %L",
1532 expr->symtree->n.sym->name, &expr->where);
1536 m = gfc_intrinsic_func_interface (expr, 0);
1540 gfc_error ("Generic function '%s' at %L is not consistent with a "
1541 "specific intrinsic interface", expr->symtree->n.sym->name,
1548 /* Resolve a function call known to be specific. */
1551 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1555 /* See if we have an intrinsic interface. */
1557 if (sym->interface != NULL && sym->interface->attr.intrinsic)
1559 gfc_intrinsic_sym *isym;
1560 isym = gfc_find_function (sym->interface->name);
1562 /* Existance of isym should be checked already. */
1566 sym->attr.function = 1;
1567 sym->attr.proc = PROC_EXTERNAL;
1571 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1573 if (sym->attr.dummy)
1575 sym->attr.proc = PROC_DUMMY;
1579 sym->attr.proc = PROC_EXTERNAL;
1583 if (sym->attr.proc == PROC_MODULE
1584 || sym->attr.proc == PROC_ST_FUNCTION
1585 || sym->attr.proc == PROC_INTERNAL)
1588 if (sym->attr.intrinsic)
1590 m = gfc_intrinsic_func_interface (expr, 1);
1594 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1595 "with an intrinsic", sym->name, &expr->where);
1603 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1606 expr->value.function.name = sym->name;
1607 expr->value.function.esym = sym;
1608 if (sym->as != NULL)
1609 expr->rank = sym->as->rank;
1616 resolve_specific_f (gfc_expr *expr)
1621 sym = expr->symtree->n.sym;
1625 m = resolve_specific_f0 (sym, expr);
1628 if (m == MATCH_ERROR)
1631 if (sym->ns->parent == NULL)
1634 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1640 gfc_error ("Unable to resolve the specific function '%s' at %L",
1641 expr->symtree->n.sym->name, &expr->where);
1647 /* Resolve a procedure call not known to be generic nor specific. */
1650 resolve_unknown_f (gfc_expr *expr)
1655 sym = expr->symtree->n.sym;
1657 if (sym->attr.dummy)
1659 sym->attr.proc = PROC_DUMMY;
1660 expr->value.function.name = sym->name;
1664 /* See if we have an intrinsic function reference. */
1666 if (gfc_intrinsic_name (sym->name, 0))
1668 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1673 /* The reference is to an external name. */
1675 sym->attr.proc = PROC_EXTERNAL;
1676 expr->value.function.name = sym->name;
1677 expr->value.function.esym = expr->symtree->n.sym;
1679 if (sym->as != NULL)
1680 expr->rank = sym->as->rank;
1682 /* Type of the expression is either the type of the symbol or the
1683 default type of the symbol. */
1686 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1688 if (sym->ts.type != BT_UNKNOWN)
1692 ts = gfc_get_default_type (sym, sym->ns);
1694 if (ts->type == BT_UNKNOWN)
1696 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1697 sym->name, &expr->where);
1708 /* Return true, if the symbol is an external procedure. */
1710 is_external_proc (gfc_symbol *sym)
1712 if (!sym->attr.dummy && !sym->attr.contained
1713 && !(sym->attr.intrinsic
1714 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1715 && sym->attr.proc != PROC_ST_FUNCTION
1716 && !sym->attr.use_assoc
1724 /* Figure out if a function reference is pure or not. Also set the name
1725 of the function for a potential error message. Return nonzero if the
1726 function is PURE, zero if not. */
1728 pure_stmt_function (gfc_expr *, gfc_symbol *);
1731 pure_function (gfc_expr *e, const char **name)
1737 if (e->symtree != NULL
1738 && e->symtree->n.sym != NULL
1739 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1740 return pure_stmt_function (e, e->symtree->n.sym);
1742 if (e->value.function.esym)
1744 pure = gfc_pure (e->value.function.esym);
1745 *name = e->value.function.esym->name;
1747 else if (e->value.function.isym)
1749 pure = e->value.function.isym->pure
1750 || e->value.function.isym->elemental;
1751 *name = e->value.function.isym->name;
1755 /* Implicit functions are not pure. */
1757 *name = e->value.function.name;
1765 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1766 int *f ATTRIBUTE_UNUSED)
1770 /* Don't bother recursing into other statement functions
1771 since they will be checked individually for purity. */
1772 if (e->expr_type != EXPR_FUNCTION
1774 || e->symtree->n.sym == sym
1775 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1778 return pure_function (e, &name) ? false : true;
1783 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1785 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1790 is_scalar_expr_ptr (gfc_expr *expr)
1792 try retval = SUCCESS;
1797 /* See if we have a gfc_ref, which means we have a substring, array
1798 reference, or a component. */
1799 if (expr->ref != NULL)
1802 while (ref->next != NULL)
1808 if (ref->u.ss.length != NULL
1809 && ref->u.ss.length->length != NULL
1811 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1813 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1815 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1816 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1817 if (end - start + 1 != 1)
1824 if (ref->u.ar.type == AR_ELEMENT)
1826 else if (ref->u.ar.type == AR_FULL)
1828 /* The user can give a full array if the array is of size 1. */
1829 if (ref->u.ar.as != NULL
1830 && ref->u.ar.as->rank == 1
1831 && ref->u.ar.as->type == AS_EXPLICIT
1832 && ref->u.ar.as->lower[0] != NULL
1833 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1834 && ref->u.ar.as->upper[0] != NULL
1835 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1837 /* If we have a character string, we need to check if
1838 its length is one. */
1839 if (expr->ts.type == BT_CHARACTER)
1841 if (expr->ts.cl == NULL
1842 || expr->ts.cl->length == NULL
1843 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1849 /* We have constant lower and upper bounds. If the
1850 difference between is 1, it can be considered a
1852 start = (int) mpz_get_si
1853 (ref->u.ar.as->lower[0]->value.integer);
1854 end = (int) mpz_get_si
1855 (ref->u.ar.as->upper[0]->value.integer);
1856 if (end - start + 1 != 1)
1871 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1873 /* Character string. Make sure it's of length 1. */
1874 if (expr->ts.cl == NULL
1875 || expr->ts.cl->length == NULL
1876 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1879 else if (expr->rank != 0)
1886 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1887 and, in the case of c_associated, set the binding label based on
1891 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1892 gfc_symbol **new_sym)
1894 char name[GFC_MAX_SYMBOL_LEN + 1];
1895 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1896 int optional_arg = 0;
1897 try retval = SUCCESS;
1898 gfc_symbol *args_sym;
1899 gfc_typespec *arg_ts;
1900 gfc_ref *parent_ref;
1903 if (args->expr->expr_type == EXPR_CONSTANT
1904 || args->expr->expr_type == EXPR_OP
1905 || args->expr->expr_type == EXPR_NULL)
1907 gfc_error ("Argument to '%s' at %L is not a variable",
1908 sym->name, &(args->expr->where));
1912 args_sym = args->expr->symtree->n.sym;
1914 /* The typespec for the actual arg should be that stored in the expr
1915 and not necessarily that of the expr symbol (args_sym), because
1916 the actual expression could be a part-ref of the expr symbol. */
1917 arg_ts = &(args->expr->ts);
1919 /* Get the parent reference (if any) for the expression. This happens for
1920 cases such as a%b%c. */
1921 parent_ref = args->expr->ref;
1923 if (parent_ref != NULL)
1925 curr_ref = parent_ref->next;
1926 while (curr_ref != NULL && curr_ref->next != NULL)
1928 parent_ref = curr_ref;
1929 curr_ref = curr_ref->next;
1933 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1934 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1935 the name, etc. Otherwise, the current parent_ref should be correct. */
1936 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1937 parent_ref = curr_ref;
1939 if (parent_ref == args->expr->ref)
1941 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1942 gfc_internal_error ("Unexpected expression reference type in "
1943 "gfc_iso_c_func_interface");
1945 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1947 /* If the user gave two args then they are providing something for
1948 the optional arg (the second cptr). Therefore, set the name and
1949 binding label to the c_associated for two cptrs. Otherwise,
1950 set c_associated to expect one cptr. */
1954 sprintf (name, "%s_2", sym->name);
1955 sprintf (binding_label, "%s_2", sym->binding_label);
1961 sprintf (name, "%s_1", sym->name);
1962 sprintf (binding_label, "%s_1", sym->binding_label);
1966 /* Get a new symbol for the version of c_associated that
1968 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1970 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1971 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1973 sprintf (name, "%s", sym->name);
1974 sprintf (binding_label, "%s", sym->binding_label);
1976 /* Error check the call. */
1977 if (args->next != NULL)
1979 gfc_error_now ("More actual than formal arguments in '%s' "
1980 "call at %L", name, &(args->expr->where));
1983 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1985 /* Make sure we have either the target or pointer attribute. */
1986 if (!(args_sym->attr.target)
1987 && !(args_sym->attr.pointer)
1988 && (parent_ref == NULL ||
1989 !parent_ref->u.c.component->pointer))
1991 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1992 "a TARGET or an associated pointer",
1994 sym->name, &(args->expr->where));
1998 /* See if we have interoperable type and type param. */
1999 if (verify_c_interop (arg_ts,
2000 (parent_ref ? parent_ref->u.c.component->name
2002 &(args->expr->where)) == SUCCESS
2003 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2005 if (args_sym->attr.target == 1)
2007 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2008 has the target attribute and is interoperable. */
2009 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2010 allocatable variable that has the TARGET attribute and
2011 is not an array of zero size. */
2012 if (args_sym->attr.allocatable == 1)
2014 if (args_sym->attr.dimension != 0
2015 && (args_sym->as && args_sym->as->rank == 0))
2017 gfc_error_now ("Allocatable variable '%s' used as a "
2018 "parameter to '%s' at %L must not be "
2019 "an array of zero size",
2020 args_sym->name, sym->name,
2021 &(args->expr->where));
2027 /* A non-allocatable target variable with C
2028 interoperable type and type parameters must be
2030 if (args_sym && args_sym->attr.dimension)
2032 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2034 gfc_error ("Assumed-shape array '%s' at %L "
2035 "cannot be an argument to the "
2036 "procedure '%s' because "
2037 "it is not C interoperable",
2039 &(args->expr->where), sym->name);
2042 else if (args_sym->as->type == AS_DEFERRED)
2044 gfc_error ("Deferred-shape array '%s' at %L "
2045 "cannot be an argument to the "
2046 "procedure '%s' because "
2047 "it is not C interoperable",
2049 &(args->expr->where), sym->name);
2054 /* Make sure it's not a character string. Arrays of
2055 any type should be ok if the variable is of a C
2056 interoperable type. */
2057 if (arg_ts->type == BT_CHARACTER)
2058 if (arg_ts->cl != NULL
2059 && (arg_ts->cl->length == NULL
2060 || arg_ts->cl->length->expr_type
2063 (arg_ts->cl->length->value.integer, 1)
2065 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2067 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2068 "at %L must have a length of 1",
2069 args_sym->name, sym->name,
2070 &(args->expr->where));
2075 else if ((args_sym->attr.pointer == 1 ||
2077 && parent_ref->u.c.component->pointer))
2078 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2080 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2082 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2083 "associated scalar POINTER", args_sym->name,
2084 sym->name, &(args->expr->where));
2090 /* The parameter is not required to be C interoperable. If it
2091 is not C interoperable, it must be a nonpolymorphic scalar
2092 with no length type parameters. It still must have either
2093 the pointer or target attribute, and it can be
2094 allocatable (but must be allocated when c_loc is called). */
2095 if (args->expr->rank != 0
2096 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2098 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2099 "scalar", args_sym->name, sym->name,
2100 &(args->expr->where));
2103 else if (arg_ts->type == BT_CHARACTER
2104 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2106 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2107 "%L must have a length of 1",
2108 args_sym->name, sym->name,
2109 &(args->expr->where));
2114 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2116 if (args_sym->attr.flavor != FL_PROCEDURE)
2118 /* TODO: Update this error message to allow for procedure
2119 pointers once they are implemented. */
2120 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2122 args_sym->name, sym->name,
2123 &(args->expr->where));
2126 else if (args_sym->attr.is_bind_c != 1)
2128 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2130 args_sym->name, sym->name,
2131 &(args->expr->where));
2136 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2141 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2142 "iso_c_binding function: '%s'!\n", sym->name);
2149 /* Resolve a function call, which means resolving the arguments, then figuring
2150 out which entity the name refers to. */
2151 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2152 to INTENT(OUT) or INTENT(INOUT). */
2155 resolve_function (gfc_expr *expr)
2157 gfc_actual_arglist *arg;
2162 procedure_type p = PROC_INTRINSIC;
2166 sym = expr->symtree->n.sym;
2168 if (sym && sym->attr.flavor == FL_VARIABLE)
2170 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2174 if (sym && sym->attr.abstract)
2176 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2177 sym->name, &expr->where);
2181 /* If the procedure is external, check for usage. */
2182 if (sym && is_external_proc (sym))
2183 resolve_global_procedure (sym, &expr->where, 0);
2185 /* Switch off assumed size checking and do this again for certain kinds
2186 of procedure, once the procedure itself is resolved. */
2187 need_full_assumed_size++;
2189 if (expr->symtree && expr->symtree->n.sym)
2190 p = expr->symtree->n.sym->attr.proc;
2192 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2195 /* Need to setup the call to the correct c_associated, depending on
2196 the number of cptrs to user gives to compare. */
2197 if (sym && sym->attr.is_iso_c == 1)
2199 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2203 /* Get the symtree for the new symbol (resolved func).
2204 the old one will be freed later, when it's no longer used. */
2205 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2208 /* Resume assumed_size checking. */
2209 need_full_assumed_size--;
2211 if (sym && sym->ts.type == BT_CHARACTER
2213 && sym->ts.cl->length == NULL
2215 && expr->value.function.esym == NULL
2216 && !sym->attr.contained)
2218 /* Internal procedures are taken care of in resolve_contained_fntype. */
2219 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2220 "be used at %L since it is not a dummy argument",
2221 sym->name, &expr->where);
2225 /* See if function is already resolved. */
2227 if (expr->value.function.name != NULL)
2229 if (expr->ts.type == BT_UNKNOWN)
2235 /* Apply the rules of section 14.1.2. */
2237 switch (procedure_kind (sym))
2240 t = resolve_generic_f (expr);
2243 case PTYPE_SPECIFIC:
2244 t = resolve_specific_f (expr);
2248 t = resolve_unknown_f (expr);
2252 gfc_internal_error ("resolve_function(): bad function type");
2256 /* If the expression is still a function (it might have simplified),
2257 then we check to see if we are calling an elemental function. */
2259 if (expr->expr_type != EXPR_FUNCTION)
2262 temp = need_full_assumed_size;
2263 need_full_assumed_size = 0;
2265 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2268 if (omp_workshare_flag
2269 && expr->value.function.esym
2270 && ! gfc_elemental (expr->value.function.esym))
2272 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2273 "in WORKSHARE construct", expr->value.function.esym->name,
2278 #define GENERIC_ID expr->value.function.isym->id
2279 else if (expr->value.function.actual != NULL
2280 && expr->value.function.isym != NULL
2281 && GENERIC_ID != GFC_ISYM_LBOUND
2282 && GENERIC_ID != GFC_ISYM_LEN
2283 && GENERIC_ID != GFC_ISYM_LOC
2284 && GENERIC_ID != GFC_ISYM_PRESENT)
2286 /* Array intrinsics must also have the last upper bound of an
2287 assumed size array argument. UBOUND and SIZE have to be
2288 excluded from the check if the second argument is anything
2291 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2292 || GENERIC_ID == GFC_ISYM_SIZE;
2294 for (arg = expr->value.function.actual; arg; arg = arg->next)
2296 if (inquiry && arg->next != NULL && arg->next->expr)
2298 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2301 if ((int)mpz_get_si (arg->next->expr->value.integer)
2306 if (arg->expr != NULL
2307 && arg->expr->rank > 0
2308 && resolve_assumed_size_actual (arg->expr))
2314 need_full_assumed_size = temp;
2317 if (!pure_function (expr, &name) && name)
2321 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2322 "FORALL %s", name, &expr->where,
2323 forall_flag == 2 ? "mask" : "block");
2326 else if (gfc_pure (NULL))
2328 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2329 "procedure within a PURE procedure", name, &expr->where);
2334 /* Functions without the RECURSIVE attribution are not allowed to
2335 * call themselves. */
2336 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2338 gfc_symbol *esym, *proc;
2339 esym = expr->value.function.esym;
2340 proc = gfc_current_ns->proc_name;
2343 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2344 "RECURSIVE", name, &expr->where);
2348 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2349 && esym->ns->entries->sym == proc->ns->entries->sym)
2351 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2352 "'%s' is not declared as RECURSIVE",
2353 esym->name, &expr->where, esym->ns->entries->sym->name);
2358 /* Character lengths of use associated functions may contains references to
2359 symbols not referenced from the current program unit otherwise. Make sure
2360 those symbols are marked as referenced. */
2362 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2363 && expr->value.function.esym->attr.use_assoc)
2365 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2369 find_noncopying_intrinsics (expr->value.function.esym,
2370 expr->value.function.actual);
2372 /* Make sure that the expression has a typespec that works. */
2373 if (expr->ts.type == BT_UNKNOWN)
2375 if (expr->symtree->n.sym->result
2376 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2377 expr->ts = expr->symtree->n.sym->result->ts;
2384 /************* Subroutine resolution *************/
2387 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2393 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2394 sym->name, &c->loc);
2395 else if (gfc_pure (NULL))
2396 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2402 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2406 if (sym->attr.generic)
2408 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2411 c->resolved_sym = s;
2412 pure_subroutine (c, s);
2416 /* TODO: Need to search for elemental references in generic interface. */
2419 if (sym->attr.intrinsic)
2420 return gfc_intrinsic_sub_interface (c, 0);
2427 resolve_generic_s (gfc_code *c)
2432 sym = c->symtree->n.sym;
2436 m = resolve_generic_s0 (c, sym);
2439 else if (m == MATCH_ERROR)
2443 if (sym->ns->parent == NULL)
2445 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2449 if (!generic_sym (sym))
2453 /* Last ditch attempt. See if the reference is to an intrinsic
2454 that possesses a matching interface. 14.1.2.4 */
2455 sym = c->symtree->n.sym;
2457 if (!gfc_intrinsic_name (sym->name, 1))
2459 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2460 sym->name, &c->loc);
2464 m = gfc_intrinsic_sub_interface (c, 0);
2468 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2469 "intrinsic subroutine interface", sym->name, &c->loc);
2475 /* Set the name and binding label of the subroutine symbol in the call
2476 expression represented by 'c' to include the type and kind of the
2477 second parameter. This function is for resolving the appropriate
2478 version of c_f_pointer() and c_f_procpointer(). For example, a
2479 call to c_f_pointer() for a default integer pointer could have a
2480 name of c_f_pointer_i4. If no second arg exists, which is an error
2481 for these two functions, it defaults to the generic symbol's name
2482 and binding label. */
2485 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2486 char *name, char *binding_label)
2488 gfc_expr *arg = NULL;
2492 /* The second arg of c_f_pointer and c_f_procpointer determines
2493 the type and kind for the procedure name. */
2494 arg = c->ext.actual->next->expr;
2498 /* Set up the name to have the given symbol's name,
2499 plus the type and kind. */
2500 /* a derived type is marked with the type letter 'u' */
2501 if (arg->ts.type == BT_DERIVED)
2504 kind = 0; /* set the kind as 0 for now */
2508 type = gfc_type_letter (arg->ts.type);
2509 kind = arg->ts.kind;
2512 if (arg->ts.type == BT_CHARACTER)
2513 /* Kind info for character strings not needed. */
2516 sprintf (name, "%s_%c%d", sym->name, type, kind);
2517 /* Set up the binding label as the given symbol's label plus
2518 the type and kind. */
2519 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2523 /* If the second arg is missing, set the name and label as
2524 was, cause it should at least be found, and the missing
2525 arg error will be caught by compare_parameters(). */
2526 sprintf (name, "%s", sym->name);
2527 sprintf (binding_label, "%s", sym->binding_label);
2534 /* Resolve a generic version of the iso_c_binding procedure given
2535 (sym) to the specific one based on the type and kind of the
2536 argument(s). Currently, this function resolves c_f_pointer() and
2537 c_f_procpointer based on the type and kind of the second argument
2538 (FPTR). Other iso_c_binding procedures aren't specially handled.
2539 Upon successfully exiting, c->resolved_sym will hold the resolved
2540 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2544 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2546 gfc_symbol *new_sym;
2547 /* this is fine, since we know the names won't use the max */
2548 char name[GFC_MAX_SYMBOL_LEN + 1];
2549 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2550 /* default to success; will override if find error */
2551 match m = MATCH_YES;
2553 /* Make sure the actual arguments are in the necessary order (based on the
2554 formal args) before resolving. */
2555 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2557 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2558 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2560 set_name_and_label (c, sym, name, binding_label);
2562 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2564 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2566 /* Make sure we got a third arg if the second arg has non-zero
2567 rank. We must also check that the type and rank are
2568 correct since we short-circuit this check in
2569 gfc_procedure_use() (called above to sort actual args). */
2570 if (c->ext.actual->next->expr->rank != 0)
2572 if(c->ext.actual->next->next == NULL
2573 || c->ext.actual->next->next->expr == NULL)
2576 gfc_error ("Missing SHAPE parameter for call to %s "
2577 "at %L", sym->name, &(c->loc));
2579 else if (c->ext.actual->next->next->expr->ts.type
2581 || c->ext.actual->next->next->expr->rank != 1)
2584 gfc_error ("SHAPE parameter for call to %s at %L must "
2585 "be a rank 1 INTEGER array", sym->name,
2592 if (m != MATCH_ERROR)
2594 /* the 1 means to add the optional arg to formal list */
2595 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2597 /* for error reporting, say it's declared where the original was */
2598 new_sym->declared_at = sym->declared_at;
2603 /* no differences for c_loc or c_funloc */
2607 /* set the resolved symbol */
2608 if (m != MATCH_ERROR)
2609 c->resolved_sym = new_sym;
2611 c->resolved_sym = sym;
2617 /* Resolve a subroutine call known to be specific. */
2620 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2624 /* See if we have an intrinsic interface. */
2625 if (sym->interface != NULL && !sym->interface->attr.abstract
2626 && !sym->interface->attr.subroutine)
2628 gfc_intrinsic_sym *isym;
2630 isym = gfc_find_function (sym->interface->name);
2632 /* Existance of isym should be checked already. */
2636 sym->attr.function = 1;
2640 if(sym->attr.is_iso_c)
2642 m = gfc_iso_c_sub_interface (c,sym);
2646 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2648 if (sym->attr.dummy)
2650 sym->attr.proc = PROC_DUMMY;
2654 sym->attr.proc = PROC_EXTERNAL;
2658 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2661 if (sym->attr.intrinsic)
2663 m = gfc_intrinsic_sub_interface (c, 1);
2667 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2668 "with an intrinsic", sym->name, &c->loc);
2676 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2678 c->resolved_sym = sym;
2679 pure_subroutine (c, sym);
2686 resolve_specific_s (gfc_code *c)
2691 sym = c->symtree->n.sym;
2695 m = resolve_specific_s0 (c, sym);
2698 if (m == MATCH_ERROR)
2701 if (sym->ns->parent == NULL)
2704 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2710 sym = c->symtree->n.sym;
2711 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2712 sym->name, &c->loc);
2718 /* Resolve a subroutine call not known to be generic nor specific. */
2721 resolve_unknown_s (gfc_code *c)
2725 sym = c->symtree->n.sym;
2727 if (sym->attr.dummy)
2729 sym->attr.proc = PROC_DUMMY;
2733 /* See if we have an intrinsic function reference. */
2735 if (gfc_intrinsic_name (sym->name, 1))
2737 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2742 /* The reference is to an external name. */
2745 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2747 c->resolved_sym = sym;
2749 pure_subroutine (c, sym);
2755 /* Resolve a subroutine call. Although it was tempting to use the same code
2756 for functions, subroutines and functions are stored differently and this
2757 makes things awkward. */
2760 resolve_call (gfc_code *c)
2763 procedure_type ptype = PROC_INTRINSIC;
2765 if (c->symtree && c->symtree->n.sym
2766 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2768 gfc_error ("'%s' at %L has a type, which is not consistent with "
2769 "the CALL at %L", c->symtree->n.sym->name,
2770 &c->symtree->n.sym->declared_at, &c->loc);
2774 /* If external, check for usage. */
2775 if (c->symtree && is_external_proc (c->symtree->n.sym))
2776 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2778 /* Subroutines without the RECURSIVE attribution are not allowed to
2779 * call themselves. */
2780 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2782 gfc_symbol *csym, *proc;
2783 csym = c->symtree->n.sym;
2784 proc = gfc_current_ns->proc_name;
2787 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2788 "RECURSIVE", csym->name, &c->loc);
2792 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2793 && csym->ns->entries->sym == proc->ns->entries->sym)
2795 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2796 "'%s' is not declared as RECURSIVE",
2797 csym->name, &c->loc, csym->ns->entries->sym->name);
2802 /* Switch off assumed size checking and do this again for certain kinds
2803 of procedure, once the procedure itself is resolved. */
2804 need_full_assumed_size++;
2806 if (c->symtree && c->symtree->n.sym)
2807 ptype = c->symtree->n.sym->attr.proc;
2809 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2812 /* Resume assumed_size checking. */
2813 need_full_assumed_size--;
2816 if (c->resolved_sym == NULL)
2817 switch (procedure_kind (c->symtree->n.sym))
2820 t = resolve_generic_s (c);
2823 case PTYPE_SPECIFIC:
2824 t = resolve_specific_s (c);
2828 t = resolve_unknown_s (c);
2832 gfc_internal_error ("resolve_subroutine(): bad function type");
2835 /* Some checks of elemental subroutine actual arguments. */
2836 if (resolve_elemental_actual (NULL, c) == FAILURE)
2840 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2845 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2846 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2847 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2848 if their shapes do not match. If either op1->shape or op2->shape is
2849 NULL, return SUCCESS. */
2852 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2859 if (op1->shape != NULL && op2->shape != NULL)
2861 for (i = 0; i < op1->rank; i++)
2863 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2865 gfc_error ("Shapes for operands at %L and %L are not conformable",
2866 &op1->where, &op2->where);
2877 /* Resolve an operator expression node. This can involve replacing the
2878 operation with a user defined function call. */
2881 resolve_operator (gfc_expr *e)
2883 gfc_expr *op1, *op2;
2885 bool dual_locus_error;
2888 /* Resolve all subnodes-- give them types. */
2890 switch (e->value.op.operator)
2893 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2896 /* Fall through... */
2899 case INTRINSIC_UPLUS:
2900 case INTRINSIC_UMINUS:
2901 case INTRINSIC_PARENTHESES:
2902 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2907 /* Typecheck the new node. */
2909 op1 = e->value.op.op1;
2910 op2 = e->value.op.op2;
2911 dual_locus_error = false;
2913 if ((op1 && op1->expr_type == EXPR_NULL)
2914 || (op2 && op2->expr_type == EXPR_NULL))
2916 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2920 switch (e->value.op.operator)
2922 case INTRINSIC_UPLUS:
2923 case INTRINSIC_UMINUS:
2924 if (op1->ts.type == BT_INTEGER
2925 || op1->ts.type == BT_REAL
2926 || op1->ts.type == BT_COMPLEX)
2932 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2933 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2936 case INTRINSIC_PLUS:
2937 case INTRINSIC_MINUS:
2938 case INTRINSIC_TIMES:
2939 case INTRINSIC_DIVIDE:
2940 case INTRINSIC_POWER:
2941 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2943 gfc_type_convert_binary (e);
2948 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2949 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2950 gfc_typename (&op2->ts));
2953 case INTRINSIC_CONCAT:
2954 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2956 e->ts.type = BT_CHARACTER;
2957 e->ts.kind = op1->ts.kind;
2962 _("Operands of string concatenation operator at %%L are %s/%s"),
2963 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2969 case INTRINSIC_NEQV:
2970 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2972 e->ts.type = BT_LOGICAL;
2973 e->ts.kind = gfc_kind_max (op1, op2);
2974 if (op1->ts.kind < e->ts.kind)
2975 gfc_convert_type (op1, &e->ts, 2);
2976 else if (op2->ts.kind < e->ts.kind)
2977 gfc_convert_type (op2, &e->ts, 2);
2981 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2982 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2983 gfc_typename (&op2->ts));
2988 if (op1->ts.type == BT_LOGICAL)
2990 e->ts.type = BT_LOGICAL;
2991 e->ts.kind = op1->ts.kind;
2995 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2996 gfc_typename (&op1->ts));
3000 case INTRINSIC_GT_OS:
3002 case INTRINSIC_GE_OS:
3004 case INTRINSIC_LT_OS:
3006 case INTRINSIC_LE_OS:
3007 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3009 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3013 /* Fall through... */
3016 case INTRINSIC_EQ_OS:
3018 case INTRINSIC_NE_OS:
3019 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
3021 e->ts.type = BT_LOGICAL;
3022 e->ts.kind = gfc_default_logical_kind;
3026 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3028 gfc_type_convert_binary (e);
3030 e->ts.type = BT_LOGICAL;
3031 e->ts.kind = gfc_default_logical_kind;
3035 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3037 _("Logicals at %%L must be compared with %s instead of %s"),
3038 (e->value.op.operator == INTRINSIC_EQ
3039 || e->value.op.operator == INTRINSIC_EQ_OS)
3040 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
3043 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3044 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
3045 gfc_typename (&op2->ts));
3049 case INTRINSIC_USER:
3050 if (e->value.op.uop->operator == NULL)
3051 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3052 else if (op2 == NULL)
3053 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3054 e->value.op.uop->name, gfc_typename (&op1->ts));
3056 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3057 e->value.op.uop->name, gfc_typename (&op1->ts),
3058 gfc_typename (&op2->ts));
3062 case INTRINSIC_PARENTHESES:
3064 if (e->ts.type == BT_CHARACTER)
3065 e->ts.cl = op1->ts.cl;
3069 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3072 /* Deal with arrayness of an operand through an operator. */
3076 switch (e->value.op.operator)
3078 case INTRINSIC_PLUS:
3079 case INTRINSIC_MINUS:
3080 case INTRINSIC_TIMES:
3081 case INTRINSIC_DIVIDE:
3082 case INTRINSIC_POWER:
3083 case INTRINSIC_CONCAT:
3087 case INTRINSIC_NEQV:
3089 case INTRINSIC_EQ_OS:
3091 case INTRINSIC_NE_OS:
3093 case INTRINSIC_GT_OS:
3095 case INTRINSIC_GE_OS:
3097 case INTRINSIC_LT_OS:
3099 case INTRINSIC_LE_OS:
3101 if (op1->rank == 0 && op2->rank == 0)
3104 if (op1->rank == 0 && op2->rank != 0)
3106 e->rank = op2->rank;
3108 if (e->shape == NULL)
3109 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3112 if (op1->rank != 0 && op2->rank == 0)
3114 e->rank = op1->rank;
3116 if (e->shape == NULL)
3117 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3120 if (op1->rank != 0 && op2->rank != 0)
3122 if (op1->rank == op2->rank)
3124 e->rank = op1->rank;
3125 if (e->shape == NULL)
3127 t = compare_shapes(op1, op2);
3131 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3136 /* Allow higher level expressions to work. */
3139 /* Try user-defined operators, and otherwise throw an error. */
3140 dual_locus_error = true;
3142 _("Inconsistent ranks for operator at %%L and %%L"));
3149 case INTRINSIC_PARENTHESES:
3151 case INTRINSIC_UPLUS:
3152 case INTRINSIC_UMINUS:
3153 /* Simply copy arrayness attribute */
3154 e->rank = op1->rank;
3156 if (e->shape == NULL)
3157 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3165 /* Attempt to simplify the expression. */
3168 t = gfc_simplify_expr (e, 0);
3169 /* Some calls do not succeed in simplification and return FAILURE
3170 even though there is no error; eg. variable references to
3171 PARAMETER arrays. */
3172 if (!gfc_is_constant_expr (e))
3179 if (gfc_extend_expr (e) == SUCCESS)
3182 if (dual_locus_error)
3183 gfc_error (msg, &op1->where, &op2->where);
3185 gfc_error (msg, &e->where);
3191 /************** Array resolution subroutines **************/
3194 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3197 /* Compare two integer expressions. */
3200 compare_bound (gfc_expr *a, gfc_expr *b)
3204 if (a == NULL || a->expr_type != EXPR_CONSTANT
3205 || b == NULL || b->expr_type != EXPR_CONSTANT)
3208 /* If either of the types isn't INTEGER, we must have
3209 raised an error earlier. */
3211 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3214 i = mpz_cmp (a->value.integer, b->value.integer);
3224 /* Compare an integer expression with an integer. */
3227 compare_bound_int (gfc_expr *a, int b)
3231 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3234 if (a->ts.type != BT_INTEGER)
3235 gfc_internal_error ("compare_bound_int(): Bad expression");
3237 i = mpz_cmp_si (a->value.integer, b);
3247 /* Compare an integer expression with a mpz_t. */
3250 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3254 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3257 if (a->ts.type != BT_INTEGER)
3258 gfc_internal_error ("compare_bound_int(): Bad expression");
3260 i = mpz_cmp (a->value.integer, b);
3270 /* Compute the last value of a sequence given by a triplet.
3271 Return 0 if it wasn't able to compute the last value, or if the
3272 sequence if empty, and 1 otherwise. */
3275 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3276 gfc_expr *stride, mpz_t last)
3280 if (start == NULL || start->expr_type != EXPR_CONSTANT
3281 || end == NULL || end->expr_type != EXPR_CONSTANT
3282 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3285 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3286 || (stride != NULL && stride->ts.type != BT_INTEGER))
3289 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3291 if (compare_bound (start, end) == CMP_GT)
3293 mpz_set (last, end->value.integer);
3297 if (compare_bound_int (stride, 0) == CMP_GT)
3299 /* Stride is positive */
3300 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3305 /* Stride is negative */
3306 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3311 mpz_sub (rem, end->value.integer, start->value.integer);
3312 mpz_tdiv_r (rem, rem, stride->value.integer);
3313 mpz_sub (last, end->value.integer, rem);
3320 /* Compare a single dimension of an array reference to the array
3324 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3328 /* Given start, end and stride values, calculate the minimum and
3329 maximum referenced indexes. */
3331 switch (ar->dimen_type[i])
3337 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3339 gfc_warning ("Array reference at %L is out of bounds "
3340 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3341 mpz_get_si (ar->start[i]->value.integer),
3342 mpz_get_si (as->lower[i]->value.integer), i+1);
3345 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3347 gfc_warning ("Array reference at %L is out of bounds "
3348 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3349 mpz_get_si (ar->start[i]->value.integer),
3350 mpz_get_si (as->upper[i]->value.integer), i+1);
3358 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3359 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3361 comparison comp_start_end = compare_bound (AR_START, AR_END);
3363 /* Check for zero stride, which is not allowed. */
3364 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3366 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3370 /* if start == len || (stride > 0 && start < len)
3371 || (stride < 0 && start > len),
3372 then the array section contains at least one element. In this
3373 case, there is an out-of-bounds access if
3374 (start < lower || start > upper). */
3375 if (compare_bound (AR_START, AR_END) == CMP_EQ
3376 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3377 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3378 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3379 && comp_start_end == CMP_GT))
3381 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3383 gfc_warning ("Lower array reference at %L is out of bounds "
3384 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3385 mpz_get_si (AR_START->value.integer),
3386 mpz_get_si (as->lower[i]->value.integer), i+1);
3389 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3391 gfc_warning ("Lower array reference at %L is out of bounds "
3392 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3393 mpz_get_si (AR_START->value.integer),
3394 mpz_get_si (as->upper[i]->value.integer), i+1);
3399 /* If we can compute the highest index of the array section,
3400 then it also has to be between lower and upper. */
3401 mpz_init (last_value);
3402 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3405 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3407 gfc_warning ("Upper array reference at %L is out of bounds "
3408 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3409 mpz_get_si (last_value),
3410 mpz_get_si (as->lower[i]->value.integer), i+1);
3411 mpz_clear (last_value);
3414 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3416 gfc_warning ("Upper array reference at %L is out of bounds "
3417 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3418 mpz_get_si (last_value),
3419 mpz_get_si (as->upper[i]->value.integer), i+1);
3420 mpz_clear (last_value);
3424 mpz_clear (last_value);
3432 gfc_internal_error ("check_dimension(): Bad array reference");
3439 /* Compare an array reference with an array specification. */
3442 compare_spec_to_ref (gfc_array_ref *ar)
3449 /* TODO: Full array sections are only allowed as actual parameters. */
3450 if (as->type == AS_ASSUMED_SIZE
3451 && (/*ar->type == AR_FULL
3452 ||*/ (ar->type == AR_SECTION
3453 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3455 gfc_error ("Rightmost upper bound of assumed size array section "
3456 "not specified at %L", &ar->where);
3460 if (ar->type == AR_FULL)
3463 if (as->rank != ar->dimen)
3465 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3466 &ar->where, ar->dimen, as->rank);
3470 for (i = 0; i < as->rank; i++)
3471 if (check_dimension (i, ar, as) == FAILURE)
3478 /* Resolve one part of an array index. */
3481 gfc_resolve_index (gfc_expr *index, int check_scalar)
3488 if (gfc_resolve_expr (index) == FAILURE)
3491 if (check_scalar && index->rank != 0)
3493 gfc_error ("Array index at %L must be scalar", &index->where);
3497 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3499 gfc_error ("Array index at %L must be of INTEGER type",
3504 if (index->ts.type == BT_REAL)
3505 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3506 &index->where) == FAILURE)
3509 if (index->ts.kind != gfc_index_integer_kind
3510 || index->ts.type != BT_INTEGER)
3513 ts.type = BT_INTEGER;
3514 ts.kind = gfc_index_integer_kind;
3516 gfc_convert_type_warn (index, &ts, 2, 0);
3522 /* Resolve a dim argument to an intrinsic function. */
3525 gfc_resolve_dim_arg (gfc_expr *dim)
3530 if (gfc_resolve_expr (dim) == FAILURE)
3535 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3540 if (dim->ts.type != BT_INTEGER)
3542 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3546 if (dim->ts.kind != gfc_index_integer_kind)
3550 ts.type = BT_INTEGER;
3551 ts.kind = gfc_index_integer_kind;
3553 gfc_convert_type_warn (dim, &ts, 2, 0);
3559 /* Given an expression that contains array references, update those array
3560 references to point to the right array specifications. While this is
3561 filled in during matching, this information is difficult to save and load
3562 in a module, so we take care of it here.
3564 The idea here is that the original array reference comes from the
3565 base symbol. We traverse the list of reference structures, setting
3566 the stored reference to references. Component references can
3567 provide an additional array specification. */
3570 find_array_spec (gfc_expr *e)
3574 gfc_symbol *derived;
3577 as = e->symtree->n.sym->as;
3580 for (ref = e->ref; ref; ref = ref->next)
3585 gfc_internal_error ("find_array_spec(): Missing spec");
3592 if (derived == NULL)
3593 derived = e->symtree->n.sym->ts.derived;
3595 c = derived->components;
3597 for (; c; c = c->next)
3598 if (c == ref->u.c.component)
3600 /* Track the sequence of component references. */
3601 if (c->ts.type == BT_DERIVED)
3602 derived = c->ts.derived;
3607 gfc_internal_error ("find_array_spec(): Component not found");
3612 gfc_internal_error ("find_array_spec(): unused as(1)");
3623 gfc_internal_error ("find_array_spec(): unused as(2)");
3627 /* Resolve an array reference. */
3630 resolve_array_ref (gfc_array_ref *ar)
3632 int i, check_scalar;
3635 for (i = 0; i < ar->dimen; i++)
3637 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3639 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3641 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3643 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3648 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3652 ar->dimen_type[i] = DIMEN_ELEMENT;
3656 ar->dimen_type[i] = DIMEN_VECTOR;
3657 if (e->expr_type == EXPR_VARIABLE
3658 && e->symtree->n.sym->ts.type == BT_DERIVED)
3659 ar->start[i] = gfc_get_parentheses (e);
3663 gfc_error ("Array index at %L is an array of rank %d",
3664 &ar->c_where[i], e->rank);
3669 /* If the reference type is unknown, figure out what kind it is. */
3671 if (ar->type == AR_UNKNOWN)
3673 ar->type = AR_ELEMENT;
3674 for (i = 0; i < ar->dimen; i++)
3675 if (ar->dimen_type[i] == DIMEN_RANGE
3676 || ar->dimen_type[i] == DIMEN_VECTOR)
3678 ar->type = AR_SECTION;
3683 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3691 resolve_substring (gfc_ref *ref)
3693 if (ref->u.ss.start != NULL)
3695 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3698 if (ref->u.ss.start->ts.type != BT_INTEGER)
3700 gfc_error ("Substring start index at %L must be of type INTEGER",
3701 &ref->u.ss.start->where);
3705 if (ref->u.ss.start->rank != 0)
3707 gfc_error ("Substring start index at %L must be scalar",
3708 &ref->u.ss.start->where);
3712 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3713 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3714 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3716 gfc_error ("Substring start index at %L is less than one",
3717 &ref->u.ss.start->where);
3722 if (ref->u.ss.end != NULL)
3724 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3727 if (ref->u.ss.end->ts.type != BT_INTEGER)
3729 gfc_error ("Substring end index at %L must be of type INTEGER",
3730 &ref->u.ss.end->where);
3734 if (ref->u.ss.end->rank != 0)
3736 gfc_error ("Substring end index at %L must be scalar",
3737 &ref->u.ss.end->where);
3741 if (ref->u.ss.length != NULL
3742 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3743 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3744 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3746 gfc_error ("Substring end index at %L exceeds the string length",
3747 &ref->u.ss.start->where);
3756 /* This function supplies missing substring charlens. */
3759 gfc_resolve_substring_charlen (gfc_expr *e)
3762 gfc_expr *start, *end;
3764 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3765 if (char_ref->type == REF_SUBSTRING)
3771 gcc_assert (char_ref->next == NULL);
3775 if (e->ts.cl->length)
3776 gfc_free_expr (e->ts.cl->length);
3777 else if (e->expr_type == EXPR_VARIABLE
3778 && e->symtree->n.sym->attr.dummy)
3782 e->ts.type = BT_CHARACTER;
3783 e->ts.kind = gfc_default_character_kind;
3787 e->ts.cl = gfc_get_charlen ();
3788 e->ts.cl->next = gfc_current_ns->cl_list;
3789 gfc_current_ns->cl_list = e->ts.cl;
3792 if (char_ref->u.ss.start)
3793 start = gfc_copy_expr (char_ref->u.ss.start);
3795 start = gfc_int_expr (1);
3797 if (char_ref->u.ss.end)
3798 end = gfc_copy_expr (char_ref->u.ss.end);
3799 else if (e->expr_type == EXPR_VARIABLE)
3800 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3807 /* Length = (end - start +1). */
3808 e->ts.cl->length = gfc_subtract (end, start);
3809 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3811 e->ts.cl->length->ts.type = BT_INTEGER;
3812 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3814 /* Make sure that the length is simplified. */
3815 gfc_simplify_expr (e->ts.cl->length, 1);
3816 gfc_resolve_expr (e->ts.cl->length);
3820 /* Resolve subtype references. */
3823 resolve_ref (gfc_expr *expr)
3825 int current_part_dimension, n_components, seen_part_dimension;
3828 for (ref = expr->ref; ref; ref = ref->next)
3829 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3831 find_array_spec (expr);
3835 for (ref = expr->ref; ref; ref = ref->next)
3839 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3847 resolve_substring (ref);
3851 /* Check constraints on part references. */
3853 current_part_dimension = 0;
3854 seen_part_dimension = 0;
3857 for (ref = expr->ref; ref; ref = ref->next)
3862 switch (ref->u.ar.type)
3866 current_part_dimension = 1;
3870 current_part_dimension = 0;
3874 gfc_internal_error ("resolve_ref(): Bad array reference");
3880 if (current_part_dimension || seen_part_dimension)
3882 if (ref->u.c.component->pointer)
3884 gfc_error ("Component to the right of a part reference "
3885 "with nonzero rank must not have the POINTER "
3886 "attribute at %L", &expr->where);
3889 else if (ref->u.c.component->allocatable)
3891 gfc_error ("Component to the right of a part reference "
3892 "with nonzero rank must not have the ALLOCATABLE "
3893 "attribute at %L", &expr->where);
3905 if (((ref->type == REF_COMPONENT && n_components > 1)
3906 || ref->next == NULL)
3907 && current_part_dimension
3908 && seen_part_dimension)
3910 gfc_error ("Two or more part references with nonzero rank must "
3911 "not be specified at %L", &expr->where);
3915 if (ref->type == REF_COMPONENT)
3917 if (current_part_dimension)
3918 seen_part_dimension = 1;
3920 /* reset to make sure */
3921 current_part_dimension = 0;
3929 /* Given an expression, determine its shape. This is easier than it sounds.
3930 Leaves the shape array NULL if it is not possible to determine the shape. */
3933 expression_shape (gfc_expr *e)
3935 mpz_t array[GFC_MAX_DIMENSIONS];
3938 if (e->rank == 0 || e->shape != NULL)
3941 for (i = 0; i < e->rank; i++)
3942 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3945 e->shape = gfc_get_shape (e->rank);
3947 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3952 for (i--; i >= 0; i--)
3953 mpz_clear (array[i]);
3957 /* Given a variable expression node, compute the rank of the expression by
3958 examining the base symbol and any reference structures it may have. */
3961 expression_rank (gfc_expr *e)
3968 if (e->expr_type == EXPR_ARRAY)
3970 /* Constructors can have a rank different from one via RESHAPE(). */
3972 if (e->symtree == NULL)
3978 e->rank = (e->symtree->n.sym->as == NULL)
3979 ? 0 : e->symtree->n.sym->as->rank;
3985 for (ref = e->ref; ref; ref = ref->next)
3987 if (ref->type != REF_ARRAY)
3990 if (ref->u.ar.type == AR_FULL)
3992 rank = ref->u.ar.as->rank;
3996 if (ref->u.ar.type == AR_SECTION)
3998 /* Figure out the rank of the section. */
4000 gfc_internal_error ("expression_rank(): Two array specs");
4002 for (i = 0; i < ref->u.ar.dimen; i++)
4003 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4004 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4014 expression_shape (e);
4018 /* Resolve a variable expression. */
4021 resolve_variable (gfc_expr *e)
4028 if (e->symtree == NULL)
4031 if (e->ref && resolve_ref (e) == FAILURE)
4034 sym = e->symtree->n.sym;
4035 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4037 e->ts.type = BT_PROCEDURE;
4041 if (sym->ts.type != BT_UNKNOWN)
4042 gfc_variable_attr (e, &e->ts);
4045 /* Must be a simple variable reference. */
4046 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4051 if (check_assumed_size_reference (sym, e))
4054 /* Deal with forward references to entries during resolve_code, to
4055 satisfy, at least partially, 12.5.2.5. */
4056 if (gfc_current_ns->entries
4057 && current_entry_id == sym->entry_id
4060 && cs_base->current->op != EXEC_ENTRY)
4062 gfc_entry_list *entry;
4063 gfc_formal_arglist *formal;
4067 /* If the symbol is a dummy... */
4068 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4070 entry = gfc_current_ns->entries;
4073 /* ...test if the symbol is a parameter of previous entries. */
4074 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4075 for (formal = entry->sym->formal; formal; formal = formal->next)
4077 if (formal->sym && sym->name == formal->sym->name)
4081 /* If it has not been seen as a dummy, this is an error. */
4084 if (specification_expr)
4085 gfc_error ("Variable '%s', used in a specification expression"
4086 ", is referenced at %L before the ENTRY statement "
4087 "in which it is a parameter",
4088 sym->name, &cs_base->current->loc);
4090 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4091 "statement in which it is a parameter",
4092 sym->name, &cs_base->current->loc);
4097 /* Now do the same check on the specification expressions. */
4098 specification_expr = 1;
4099 if (sym->ts.type == BT_CHARACTER
4100 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4104 for (n = 0; n < sym->as->rank; n++)
4106 specification_expr = 1;
4107 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4109 specification_expr = 1;
4110 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4113 specification_expr = 0;
4116 /* Update the symbol's entry level. */
4117 sym->entry_id = current_entry_id + 1;
4124 /* Checks to see that the correct symbol has been host associated.
4125 The only situation where this arises is that in which a twice
4126 contained function is parsed after the host association is made.
4127 Therefore, on detecting this, the line is rematched, having got
4128 rid of the existing references and actual_arg_list. */
4130 check_host_association (gfc_expr *e)
4132 gfc_symbol *sym, *old_sym;
4136 bool retval = e->expr_type == EXPR_FUNCTION;
4138 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4141 old_sym = e->symtree->n.sym;
4143 if (old_sym->attr.use_assoc)
4146 if (gfc_current_ns->parent
4147 && old_sym->ns != gfc_current_ns)
4149 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4150 if (sym && old_sym != sym
4151 && sym->attr.flavor == FL_PROCEDURE
4152 && sym->attr.contained)
4154 temp_locus = gfc_current_locus;
4155 gfc_current_locus = e->where;
4157 gfc_buffer_error (1);
4159 gfc_free_ref_list (e->ref);
4164 gfc_free_actual_arglist (e->value.function.actual);
4165 e->value.function.actual = NULL;
4168 if (e->shape != NULL)
4170 for (n = 0; n < e->rank; n++)
4171 mpz_clear (e->shape[n]);
4173 gfc_free (e->shape);
4176 gfc_match_rvalue (&expr);
4178 gfc_buffer_error (0);
4180 gcc_assert (expr && sym == expr->symtree->n.sym);
4186 gfc_current_locus = temp_locus;
4189 /* This might have changed! */
4190 return e->expr_type == EXPR_FUNCTION;
4195 gfc_resolve_character_operator (gfc_expr *e)
4197 gfc_expr *op1 = e->value.op.op1;
4198 gfc_expr *op2 = e->value.op.op2;
4199 gfc_expr *e1 = NULL;
4200 gfc_expr *e2 = NULL;
4202 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4204 if (op1->ts.cl && op1->ts.cl->length)
4205 e1 = gfc_copy_expr (op1->ts.cl->length);
4206 else if (op1->expr_type == EXPR_CONSTANT)
4207 e1 = gfc_int_expr (op1->value.character.length);
4209 if (op2->ts.cl && op2->ts.cl->length)
4210 e2 = gfc_copy_expr (op2->ts.cl->length);
4211 else if (op2->expr_type == EXPR_CONSTANT)
4212 e2 = gfc_int_expr (op2->value.character.length);
4214 e->ts.cl = gfc_get_charlen ();
4215 e->ts.cl->next = gfc_current_ns->cl_list;
4216 gfc_current_ns->cl_list = e->ts.cl;
4221 e->ts.cl->length = gfc_add (e1, e2);
4222 e->ts.cl->length->ts.type = BT_INTEGER;
4223 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4224 gfc_simplify_expr (e->ts.cl->length, 0);
4225 gfc_resolve_expr (e->ts.cl->length);
4231 /* Ensure that an character expression has a charlen and, if possible, a
4232 length expression. */
4235 fixup_charlen (gfc_expr *e)
4237 /* The cases fall through so that changes in expression type and the need
4238 for multiple fixes are picked up. In all circumstances, a charlen should
4239 be available for the middle end to hang a backend_decl on. */
4240 switch (e->expr_type)
4243 gfc_resolve_character_operator (e);
4246 if (e->expr_type == EXPR_ARRAY)
4247 gfc_resolve_character_array_constructor (e);
4249 case EXPR_SUBSTRING:
4250 if (!e->ts.cl && e->ref)
4251 gfc_resolve_substring_charlen (e);
4256 e->ts.cl = gfc_get_charlen ();
4257 e->ts.cl->next = gfc_current_ns->cl_list;
4258 gfc_current_ns->cl_list = e->ts.cl;
4266 /* Resolve an expression. That is, make sure that types of operands agree
4267 with their operators, intrinsic operators are converted to function calls
4268 for overloaded types and unresolved function references are resolved. */
4271 gfc_resolve_expr (gfc_expr *e)
4278 switch (e->expr_type)
4281 t = resolve_operator (e);
4287 if (check_host_association (e))
4288 t = resolve_function (e);
4291 t = resolve_variable (e);
4293 expression_rank (e);
4296 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4297 && e->ref->type != REF_SUBSTRING)
4298 gfc_resolve_substring_charlen (e);
4302 case EXPR_SUBSTRING:
4303 t = resolve_ref (e);
4313 if (resolve_ref (e) == FAILURE)
4316 t = gfc_resolve_array_constructor (e);
4317 /* Also try to expand a constructor. */
4320 expression_rank (e);
4321 gfc_expand_constructor (e);
4324 /* This provides the opportunity for the length of constructors with
4325 character valued function elements to propagate the string length
4326 to the expression. */
4327 if (e->ts.type == BT_CHARACTER)
4328 gfc_resolve_character_array_constructor (e);
4332 case EXPR_STRUCTURE:
4333 t = resolve_ref (e);
4337 t = resolve_structure_cons (e);
4341 t = gfc_simplify_expr (e, 0);
4345 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4348 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4355 /* Resolve an expression from an iterator. They must be scalar and have
4356 INTEGER or (optionally) REAL type. */
4359 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4360 const char *name_msgid)
4362 if (gfc_resolve_expr (expr) == FAILURE)
4365 if (expr->rank != 0)
4367 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4371 if (expr->ts.type != BT_INTEGER)
4373 if (expr->ts.type == BT_REAL)
4376 return gfc_notify_std (GFC_STD_F95_DEL,
4377 "Deleted feature: %s at %L must be integer",
4378 _(name_msgid), &expr->where);
4381 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4388 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4396 /* Resolve the expressions in an iterator structure. If REAL_OK is
4397 false allow only INTEGER type iterators, otherwise allow REAL types. */
4400 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4402 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4406 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4408 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4413 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4414 "Start expression in DO loop") == FAILURE)
4417 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4418 "End expression in DO loop") == FAILURE)
4421 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4422 "Step expression in DO loop") == FAILURE)
4425 if (iter->step->expr_type == EXPR_CONSTANT)
4427 if ((iter->step->ts.type == BT_INTEGER
4428 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4429 || (iter->step->ts.type == BT_REAL
4430 && mpfr_sgn (iter->step->value.real) == 0))
4432 gfc_error ("Step expression in DO loop at %L cannot be zero",
4433 &iter->step->where);
4438 /* Convert start, end, and step to the same type as var. */
4439 if (iter->start->ts.kind != iter->var->ts.kind
4440 || iter->start->ts.type != iter->var->ts.type)
4441 gfc_convert_type (iter->start, &iter->var->ts, 2);
4443 if (iter->end->ts.kind != iter->var->ts.kind
4444 || iter->end->ts.type != iter->var->ts.type)
4445 gfc_convert_type (iter->end, &iter->var->ts, 2);
4447 if (iter->step->ts.kind != iter->var->ts.kind
4448 || iter->step->ts.type != iter->var->ts.type)
4449 gfc_convert_type (iter->step, &iter->var->ts, 2);
4455 /* Traversal function for find_forall_index. f == 2 signals that
4456 that variable itself is not to be checked - only the references. */
4459 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4461 if (expr->expr_type != EXPR_VARIABLE)
4464 /* A scalar assignment */
4465 if (!expr->ref || *f == 1)
4467 if (expr->symtree->n.sym == sym)
4479 /* Check whether the FORALL index appears in the expression or not.
4480 Returns SUCCESS if SYM is found in EXPR. */
4483 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4485 if (gfc_traverse_expr (expr, sym, forall_index, f))
4492 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4493 to be a scalar INTEGER variable. The subscripts and stride are scalar
4494 INTEGERs, and if stride is a constant it must be nonzero.
4495 Furthermore "A subscript or stride in a forall-triplet-spec shall
4496 not contain a reference to any index-name in the
4497 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4500 resolve_forall_iterators (gfc_forall_iterator *it)
4502 gfc_forall_iterator *iter, *iter2;
4504 for (iter = it; iter; iter = iter->next)
4506 if (gfc_resolve_expr (iter->var) == SUCCESS
4507 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4508 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4511 if (gfc_resolve_expr (iter->start) == SUCCESS
4512 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4513 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4514 &iter->start->where);
4515 if (iter->var->ts.kind != iter->start->ts.kind)
4516 gfc_convert_type (iter->start, &iter->var->ts, 2);
4518 if (gfc_resolve_expr (iter->end) == SUCCESS
4519 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4520 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4522 if (iter->var->ts.kind != iter->end->ts.kind)
4523 gfc_convert_type (iter->end, &iter->var->ts, 2);
4525 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4527 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4528 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4529 &iter->stride->where, "INTEGER");
4531 if (iter->stride->expr_type == EXPR_CONSTANT
4532 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4533 gfc_error ("FORALL stride expression at %L cannot be zero",
4534 &iter->stride->where);
4536 if (iter->var->ts.kind != iter->stride->ts.kind)
4537 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4540 for (iter = it; iter; iter = iter->next)
4541 for (iter2 = iter; iter2; iter2 = iter2->next)
4543 if (find_forall_index (iter2->start,
4544 iter->var->symtree->n.sym, 0) == SUCCESS
4545 || find_forall_index (iter2->end,
4546 iter->var->symtree->n.sym, 0) == SUCCESS
4547 || find_forall_index (iter2->stride,
4548 iter->var->symtree->n.sym, 0) == SUCCESS)
4549 gfc_error ("FORALL index '%s' may not appear in triplet "
4550 "specification at %L", iter->var->symtree->name,
4551 &iter2->start->where);
4556 /* Given a pointer to a symbol that is a derived type, see if it's
4557 inaccessible, i.e. if it's defined in another module and the components are
4558 PRIVATE. The search is recursive if necessary. Returns zero if no
4559 inaccessible components are found, nonzero otherwise. */
4562 derived_inaccessible (gfc_symbol *sym)
4566 if (sym->attr.use_assoc && sym->attr.private_comp)
4569 for (c = sym->components; c; c = c->next)
4571 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4579 /* Resolve the argument of a deallocate expression. The expression must be
4580 a pointer or a full array. */
4583 resolve_deallocate_expr (gfc_expr *e)
4585 symbol_attribute attr;
4586 int allocatable, pointer, check_intent_in;
4589 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4590 check_intent_in = 1;
4592 if (gfc_resolve_expr (e) == FAILURE)
4595 if (e->expr_type != EXPR_VARIABLE)
4598 allocatable = e->symtree->n.sym->attr.allocatable;
4599 pointer = e->symtree->n.sym->attr.pointer;
4600 for (ref = e->ref; ref; ref = ref->next)
4603 check_intent_in = 0;
4608 if (ref->u.ar.type != AR_FULL)
4613 allocatable = (ref->u.c.component->as != NULL
4614 && ref->u.c.component->as->type == AS_DEFERRED);
4615 pointer = ref->u.c.component->pointer;
4624 attr = gfc_expr_attr (e);
4626 if (allocatable == 0 && attr.pointer == 0)
4629 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4630 "ALLOCATABLE or a POINTER", &e->where);
4634 && e->symtree->n.sym->attr.intent == INTENT_IN)
4636 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4637 e->symtree->n.sym->name, &e->where);
4645 /* Returns true if the expression e contains a reference to the symbol sym. */
4647 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4649 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
4656 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4658 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
4662 /* Given the expression node e for an allocatable/pointer of derived type to be
4663 allocated, get the expression node to be initialized afterwards (needed for
4664 derived types with default initializers, and derived types with allocatable
4665 components that need nullification.) */
4668 expr_to_initialize (gfc_expr *e)
4674 result = gfc_copy_expr (e);
4676 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4677 for (ref = result->ref; ref; ref = ref->next)
4678 if (ref->type == REF_ARRAY && ref->next == NULL)
4680 ref->u.ar.type = AR_FULL;
4682 for (i = 0; i < ref->u.ar.dimen; i++)
4683 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4685 result->rank = ref->u.ar.dimen;
4693 /* Resolve the expression in an ALLOCATE statement, doing the additional
4694 checks to see whether the expression is OK or not. The expression must
4695 have a trailing array reference that gives the size of the array. */
4698 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4700 int i, pointer, allocatable, dimension, check_intent_in;
4701 symbol_attribute attr;
4702 gfc_ref *ref, *ref2;
4709 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4710 check_intent_in = 1;
4712 if (gfc_resolve_expr (e) == FAILURE)
4715 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4716 sym = code->expr->symtree->n.sym;
4720 /* Make sure the expression is allocatable or a pointer. If it is
4721 pointer, the next-to-last reference must be a pointer. */
4725 if (e->expr_type != EXPR_VARIABLE)
4728 attr = gfc_expr_attr (e);
4729 pointer = attr.pointer;
4730 dimension = attr.dimension;
4734 allocatable = e->symtree->n.sym->attr.allocatable;
4735 pointer = e->symtree->n.sym->attr.pointer;
4736 dimension = e->symtree->n.sym->attr.dimension;
4738 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4740 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4741 "not be allocated in the same statement at %L",
4742 sym->name, &e->where);
4746 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4749 check_intent_in = 0;
4754 if (ref->next != NULL)
4759 allocatable = (ref->u.c.component->as != NULL
4760 && ref->u.c.component->as->type == AS_DEFERRED);
4762 pointer = ref->u.c.component->pointer;
4763 dimension = ref->u.c.component->dimension;
4774 if (allocatable == 0 && pointer == 0)
4776 gfc_error ("Expression in ALLOCATE statement at %L must be "
4777 "ALLOCATABLE or a POINTER", &e->where);
4782 && e->symtree->n.sym->attr.intent == INTENT_IN)
4784 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4785 e->symtree->n.sym->name, &e->where);
4789 /* Add default initializer for those derived types that need them. */
4790 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4792 init_st = gfc_get_code ();
4793 init_st->loc = code->loc;
4794 init_st->op = EXEC_INIT_ASSIGN;
4795 init_st->expr = expr_to_initialize (e);
4796 init_st->expr2 = init_e;
4797 init_st->next = code->next;
4798 code->next = init_st;
4801 if (pointer && dimension == 0)
4804 /* Make sure the next-to-last reference node is an array specification. */
4806 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4808 gfc_error ("Array specification required in ALLOCATE statement "
4809 "at %L", &e->where);
4813 /* Make sure that the array section reference makes sense in the
4814 context of an ALLOCATE specification. */
4818 for (i = 0; i < ar->dimen; i++)
4820 if (ref2->u.ar.type == AR_ELEMENT)
4823 switch (ar->dimen_type[i])
4829 if (ar->start[i] != NULL
4830 && ar->end[i] != NULL
4831 && ar->stride[i] == NULL)
4834 /* Fall Through... */
4838 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4845 for (a = code->ext.alloc_list; a; a = a->next)
4847 sym = a->expr->symtree->n.sym;
4849 /* TODO - check derived type components. */
4850 if (sym->ts.type == BT_DERIVED)
4853 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4854 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4856 gfc_error ("'%s' must not appear an the array specification at "
4857 "%L in the same ALLOCATE statement where it is "
4858 "itself allocated", sym->name, &ar->where);
4868 /************ SELECT CASE resolution subroutines ************/
4870 /* Callback function for our mergesort variant. Determines interval
4871 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4872 op1 > op2. Assumes we're not dealing with the default case.
4873 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4874 There are nine situations to check. */
4877 compare_cases (const gfc_case *op1, const gfc_case *op2)
4881 if (op1->low == NULL) /* op1 = (:L) */
4883 /* op2 = (:N), so overlap. */
4885 /* op2 = (M:) or (M:N), L < M */
4886 if (op2->low != NULL
4887 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
4890 else if (op1->high == NULL) /* op1 = (K:) */
4892 /* op2 = (M:), so overlap. */
4894 /* op2 = (:N) or (M:N), K > N */
4895 if (op2->high != NULL
4896 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
4899 else /* op1 = (K:L) */
4901 if (op2->low == NULL) /* op2 = (:N), K > N */
4902 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
4904 else if (op2->high == NULL) /* op2 = (M:), L < M */
4905 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
4907 else /* op2 = (M:N) */
4911 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
4914 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
4923 /* Merge-sort a double linked case list, detecting overlap in the
4924 process. LIST is the head of the double linked case list before it
4925 is sorted. Returns the head of the sorted list if we don't see any
4926 overlap, or NULL otherwise. */
4929 check_case_overlap (gfc_case *list)
4931 gfc_case *p, *q, *e, *tail;
4932 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4934 /* If the passed list was empty, return immediately. */
4941 /* Loop unconditionally. The only exit from this loop is a return
4942 statement, when we've finished sorting the case list. */
4949 /* Count the number of merges we do in this pass. */
4952 /* Loop while there exists a merge to be done. */
4957 /* Count this merge. */
4960 /* Cut the list in two pieces by stepping INSIZE places
4961 forward in the list, starting from P. */
4964 for (i = 0; i < insize; i++)
4973 /* Now we have two lists. Merge them! */
4974 while (psize > 0 || (qsize > 0 && q != NULL))
4976 /* See from which the next case to merge comes from. */
4979 /* P is empty so the next case must come from Q. */
4984 else if (qsize == 0 || q == NULL)
4993 cmp = compare_cases (p, q);
4996 /* The whole case range for P is less than the
5004 /* The whole case range for Q is greater than
5005 the case range for P. */
5012 /* The cases overlap, or they are the same
5013 element in the list. Either way, we must
5014 issue an error and get the next case from P. */
5015 /* FIXME: Sort P and Q by line number. */
5016 gfc_error ("CASE label at %L overlaps with CASE "
5017 "label at %L", &p->where, &q->where);
5025 /* Add the next element to the merged list. */
5034 /* P has now stepped INSIZE places along, and so has Q. So
5035 they're the same. */
5040 /* If we have done only one merge or none at all, we've
5041 finished sorting the cases. */
5050 /* Otherwise repeat, merging lists twice the size. */
5056 /* Check to see if an expression is suitable for use in a CASE statement.
5057 Makes sure that all case expressions are scalar constants of the same
5058 type. Return FAILURE if anything is wrong. */
5061 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5063 if (e == NULL) return SUCCESS;
5065 if (e->ts.type != case_expr->ts.type)
5067 gfc_error ("Expression in CASE statement at %L must be of type %s",
5068 &e->where, gfc_basic_typename (case_expr->ts.type));
5072 /* C805 (R808) For a given case-construct, each case-value shall be of
5073 the same type as case-expr. For character type, length differences
5074 are allowed, but the kind type parameters shall be the same. */
5076 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5078 gfc_error("Expression in CASE statement at %L must be kind %d",
5079 &e->where, case_expr->ts.kind);
5083 /* Convert the case value kind to that of case expression kind, if needed.
5084 FIXME: Should a warning be issued? */
5085 if (e->ts.kind != case_expr->ts.kind)
5086 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5090 gfc_error ("Expression in CASE statement at %L must be scalar",
5099 /* Given a completely parsed select statement, we:
5101 - Validate all expressions and code within the SELECT.
5102 - Make sure that the selection expression is not of the wrong type.
5103 - Make sure that no case ranges overlap.
5104 - Eliminate unreachable cases and unreachable code resulting from
5105 removing case labels.
5107 The standard does allow unreachable cases, e.g. CASE (5:3). But
5108 they are a hassle for code generation, and to prevent that, we just
5109 cut them out here. This is not necessary for overlapping cases
5110 because they are illegal and we never even try to generate code.
5112 We have the additional caveat that a SELECT construct could have
5113 been a computed GOTO in the source code. Fortunately we can fairly
5114 easily work around that here: The case_expr for a "real" SELECT CASE
5115 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5116 we have to do is make sure that the case_expr is a scalar integer
5120 resolve_select (gfc_code *code)
5123 gfc_expr *case_expr;
5124 gfc_case *cp, *default_case, *tail, *head;
5125 int seen_unreachable;
5131 if (code->expr == NULL)
5133 /* This was actually a computed GOTO statement. */
5134 case_expr = code->expr2;
5135 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5136 gfc_error ("Selection expression in computed GOTO statement "
5137 "at %L must be a scalar integer expression",
5140 /* Further checking is not necessary because this SELECT was built
5141 by the compiler, so it should always be OK. Just move the
5142 case_expr from expr2 to expr so that we can handle computed
5143 GOTOs as normal SELECTs from here on. */
5144 code->expr = code->expr2;
5149 case_expr = code->expr;
5151 type = case_expr->ts.type;
5152 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5154 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5155 &case_expr->where, gfc_typename (&case_expr->ts));
5157 /* Punt. Going on here just produce more garbage error messages. */
5161 if (case_expr->rank != 0)
5163 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5164 "expression", &case_expr->where);
5170 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5171 of the SELECT CASE expression and its CASE values. Walk the lists
5172 of case values, and if we find a mismatch, promote case_expr to
5173 the appropriate kind. */
5175 if (type == BT_LOGICAL || type == BT_INTEGER)
5177 for (body = code->block; body; body = body->block)
5179 /* Walk the case label list. */
5180 for (cp = body->ext.case_list; cp; cp = cp->next)
5182 /* Intercept the DEFAULT case. It does not have a kind. */
5183 if (cp->low == NULL && cp->high == NULL)
5186 /* Unreachable case ranges are discarded, so ignore. */
5187 if (cp->low != NULL && cp->high != NULL
5188 && cp->low != cp->high
5189 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5192 /* FIXME: Should a warning be issued? */
5194 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5195 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5197 if (cp->high != NULL
5198 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5199 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5204 /* Assume there is no DEFAULT case. */
5205 default_case = NULL;
5210 for (body = code->block; body; body = body->block)
5212 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5214 seen_unreachable = 0;
5216 /* Walk the case label list, making sure that all case labels
5218 for (cp = body->ext.case_list; cp; cp = cp->next)
5220 /* Count the number of cases in the whole construct. */
5223 /* Intercept the DEFAULT case. */
5224 if (cp->low == NULL && cp->high == NULL)
5226 if (default_case != NULL)
5228 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5229 "by a second DEFAULT CASE at %L",
5230 &default_case->where, &cp->where);
5241 /* Deal with single value cases and case ranges. Errors are
5242 issued from the validation function. */
5243 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5244 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5250 if (type == BT_LOGICAL
5251 && ((cp->low == NULL || cp->high == NULL)
5252 || cp->low != cp->high))
5254 gfc_error ("Logical range in CASE statement at %L is not "
5255 "allowed", &cp->low->where);
5260 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5263 value = cp->low->value.logical == 0 ? 2 : 1;
5264 if (value & seen_logical)
5266 gfc_error ("constant logical value in CASE statement "
5267 "is repeated at %L",
5272 seen_logical |= value;
5275 if (cp->low != NULL && cp->high != NULL
5276 && cp->low != cp->high
5277 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5279 if (gfc_option.warn_surprising)
5280 gfc_warning ("Range specification at %L can never "
5281 "be matched", &cp->where);
5283 cp->unreachable = 1;
5284 seen_unreachable = 1;
5288 /* If the case range can be matched, it can also overlap with
5289 other cases. To make sure it does not, we put it in a
5290 double linked list here. We sort that with a merge sort
5291 later on to detect any overlapping cases. */
5295 head->right = head->left = NULL;
5300 tail->right->left = tail;
5307 /* It there was a failure in the previous case label, give up
5308 for this case label list. Continue with the next block. */
5312 /* See if any case labels that are unreachable have been seen.
5313 If so, we eliminate them. This is a bit of a kludge because
5314 the case lists for a single case statement (label) is a
5315 single forward linked lists. */
5316 if (seen_unreachable)
5318 /* Advance until the first case in the list is reachable. */
5319 while (body->ext.case_list != NULL
5320 && body->ext.case_list->unreachable)
5322 gfc_case *n = body->ext.case_list;
5323 body->ext.case_list = body->ext.case_list->next;
5325 gfc_free_case_list (n);
5328 /* Strip all other unreachable cases. */
5329 if (body->ext.case_list)
5331 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5333 if (cp->next->unreachable)
5335 gfc_case *n = cp->next;
5336 cp->next = cp->next->next;
5338 gfc_free_case_list (n);
5345 /* See if there were overlapping cases. If the check returns NULL,
5346 there was overlap. In that case we don't do anything. If head
5347 is non-NULL, we prepend the DEFAULT case. The sorted list can
5348 then used during code generation for SELECT CASE constructs with
5349 a case expression of a CHARACTER type. */
5352 head = check_case_overlap (head);
5354 /* Prepend the default_case if it is there. */
5355 if (head != NULL && default_case)
5357 default_case->left = NULL;
5358 default_case->right = head;
5359 head->left = default_case;
5363 /* Eliminate dead blocks that may be the result if we've seen
5364 unreachable case labels for a block. */
5365 for (body = code; body && body->block; body = body->block)
5367 if (body->block->ext.case_list == NULL)
5369 /* Cut the unreachable block from the code chain. */
5370 gfc_code *c = body->block;
5371 body->block = c->block;
5373 /* Kill the dead block, but not the blocks below it. */
5375 gfc_free_statements (c);
5379 /* More than two cases is legal but insane for logical selects.
5380 Issue a warning for it. */
5381 if (gfc_option.warn_surprising && type == BT_LOGICAL
5383 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5388 /* Resolve a transfer statement. This is making sure that:
5389 -- a derived type being transferred has only non-pointer components
5390 -- a derived type being transferred doesn't have private components, unless
5391 it's being transferred from the module where the type was defined
5392 -- we're not trying to transfer a whole assumed size array. */
5395 resolve_transfer (gfc_code *code)
5404 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5407 sym = exp->symtree->n.sym;
5410 /* Go to actual component transferred. */
5411 for (ref = code->expr->ref; ref; ref = ref->next)
5412 if (ref->type == REF_COMPONENT)
5413 ts = &ref->u.c.component->ts;
5415 if (ts->type == BT_DERIVED)
5417 /* Check that transferred derived type doesn't contain POINTER
5419 if (ts->derived->attr.pointer_comp)
5421 gfc_error ("Data transfer element at %L cannot have "
5422 "POINTER components", &code->loc);
5426 if (ts->derived->attr.alloc_comp)
5428 gfc_error ("Data transfer element at %L cannot have "
5429 "ALLOCATABLE components", &code->loc);
5433 if (derived_inaccessible (ts->derived))
5435 gfc_error ("Data transfer element at %L cannot have "
5436 "PRIVATE components",&code->loc);
5441 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5442 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5444 gfc_error ("Data transfer element at %L cannot be a full reference to "
5445 "an assumed-size array", &code->loc);
5451 /*********** Toplevel code resolution subroutines ***********/
5453 /* Find the set of labels that are reachable from this block. We also
5454 record the last statement in each block so that we don't have to do
5455 a linear search to find the END DO statements of the blocks. */
5458 reachable_labels (gfc_code *block)
5465 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5467 /* Collect labels in this block. */
5468 for (c = block; c; c = c->next)
5471 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5473 if (!c->next && cs_base->prev)
5474 cs_base->prev->tail = c;
5477 /* Merge with labels from parent block. */
5480 gcc_assert (cs_base->prev->reachable_labels);
5481 bitmap_ior_into (cs_base->reachable_labels,
5482 cs_base->prev->reachable_labels);
5486 /* Given a branch to a label and a namespace, if the branch is conforming.
5487 The code node describes where the branch is located. */
5490 resolve_branch (gfc_st_label *label, gfc_code *code)
5497 /* Step one: is this a valid branching target? */
5499 if (label->defined == ST_LABEL_UNKNOWN)
5501 gfc_error ("Label %d referenced at %L is never defined", label->value,
5506 if (label->defined != ST_LABEL_TARGET)
5508 gfc_error ("Statement at %L is not a valid branch target statement "
5509 "for the branch statement at %L", &label->where, &code->loc);
5513 /* Step two: make sure this branch is not a branch to itself ;-) */
5515 if (code->here == label)
5517 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5521 /* Step three: See if the label is in the same block as the
5522 branching statement. The hard work has been done by setting up
5523 the bitmap reachable_labels. */
5525 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5527 /* The label is not in an enclosing block, so illegal. This was
5528 allowed in Fortran 66, so we allow it as extension. No
5529 further checks are necessary in this case. */
5530 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5531 "as the GOTO statement at %L", &label->where,
5536 /* Step four: Make sure that the branching target is legal if
5537 the statement is an END {SELECT,IF}. */
5539 for (stack = cs_base; stack; stack = stack->prev)
5540 if (stack->current->next && stack->current->next->here == label)
5543 if (stack && stack->current->next->op == EXEC_NOP)
5545 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5546 "END of construct at %L", &code->loc,
5547 &stack->current->next->loc);
5548 return; /* We know this is not an END DO. */
5551 /* Step five: Make sure that we're not jumping to the end of a DO
5552 loop from within the loop. */
5554 for (stack = cs_base; stack; stack = stack->prev)
5555 if ((stack->current->op == EXEC_DO
5556 || stack->current->op == EXEC_DO_WHILE)
5557 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5559 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5560 "to END of construct at %L", &code->loc,
5568 /* Check whether EXPR1 has the same shape as EXPR2. */
5571 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5573 mpz_t shape[GFC_MAX_DIMENSIONS];
5574 mpz_t shape2[GFC_MAX_DIMENSIONS];
5575 try result = FAILURE;
5578 /* Compare the rank. */
5579 if (expr1->rank != expr2->rank)
5582 /* Compare the size of each dimension. */
5583 for (i=0; i<expr1->rank; i++)
5585 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5588 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5591 if (mpz_cmp (shape[i], shape2[i]))
5595 /* When either of the two expression is an assumed size array, we
5596 ignore the comparison of dimension sizes. */
5601 for (i--; i >= 0; i--)
5603 mpz_clear (shape[i]);
5604 mpz_clear (shape2[i]);
5610 /* Check whether a WHERE assignment target or a WHERE mask expression
5611 has the same shape as the outmost WHERE mask expression. */
5614 resolve_where (gfc_code *code, gfc_expr *mask)
5620 cblock = code->block;
5622 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5623 In case of nested WHERE, only the outmost one is stored. */
5624 if (mask == NULL) /* outmost WHERE */
5626 else /* inner WHERE */
5633 /* Check if the mask-expr has a consistent shape with the
5634 outmost WHERE mask-expr. */
5635 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5636 gfc_error ("WHERE mask at %L has inconsistent shape",
5637 &cblock->expr->where);
5640 /* the assignment statement of a WHERE statement, or the first
5641 statement in where-body-construct of a WHERE construct */
5642 cnext = cblock->next;
5647 /* WHERE assignment statement */
5650 /* Check shape consistent for WHERE assignment target. */
5651 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5652 gfc_error ("WHERE assignment target at %L has "
5653 "inconsistent shape", &cnext->expr->where);
5657 case EXEC_ASSIGN_CALL:
5658 resolve_call (cnext);
5661 /* WHERE or WHERE construct is part of a where-body-construct */
5663 resolve_where (cnext, e);
5667 gfc_error ("Unsupported statement inside WHERE at %L",
5670 /* the next statement within the same where-body-construct */
5671 cnext = cnext->next;
5673 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5674 cblock = cblock->block;
5679 /* Resolve assignment in FORALL construct.
5680 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5681 FORALL index variables. */
5684 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5688 for (n = 0; n < nvar; n++)
5690 gfc_symbol *forall_index;
5692 forall_index = var_expr[n]->symtree->n.sym;
5694 /* Check whether the assignment target is one of the FORALL index
5696 if ((code->expr->expr_type == EXPR_VARIABLE)
5697 && (code->expr->symtree->n.sym == forall_index))
5698 gfc_error ("Assignment to a FORALL index variable at %L",
5699 &code->expr->where);
5702 /* If one of the FORALL index variables doesn't appear in the
5703 assignment target, then there will be a many-to-one
5705 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
5706 gfc_error ("The FORALL with index '%s' cause more than one "
5707 "assignment to this object at %L",
5708 var_expr[n]->symtree->name, &code->expr->where);
5714 /* Resolve WHERE statement in FORALL construct. */
5717 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5718 gfc_expr **var_expr)
5723 cblock = code->block;
5726 /* the assignment statement of a WHERE statement, or the first
5727 statement in where-body-construct of a WHERE construct */
5728 cnext = cblock->next;
5733 /* WHERE assignment statement */
5735 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5738 /* WHERE operator assignment statement */
5739 case EXEC_ASSIGN_CALL:
5740 resolve_call (cnext);
5743 /* WHERE or WHERE construct is part of a where-body-construct */
5745 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5749 gfc_error ("Unsupported statement inside WHERE at %L",
5752 /* the next statement within the same where-body-construct */
5753 cnext = cnext->next;
5755 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5756 cblock = cblock->block;
5761 /* Traverse the FORALL body to check whether the following errors exist:
5762 1. For assignment, check if a many-to-one assignment happens.
5763 2. For WHERE statement, check the WHERE body to see if there is any
5764 many-to-one assignment. */
5767 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5771 c = code->block->next;
5777 case EXEC_POINTER_ASSIGN:
5778 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5781 case EXEC_ASSIGN_CALL:
5785 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5786 there is no need to handle it here. */
5790 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5795 /* The next statement in the FORALL body. */
5801 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5802 gfc_resolve_forall_body to resolve the FORALL body. */
5805 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5807 static gfc_expr **var_expr;
5808 static int total_var = 0;
5809 static int nvar = 0;
5810 gfc_forall_iterator *fa;
5814 /* Start to resolve a FORALL construct */
5815 if (forall_save == 0)
5817 /* Count the total number of FORALL index in the nested FORALL
5818 construct in order to allocate the VAR_EXPR with proper size. */
5820 while ((next != NULL) && (next->op == EXEC_FORALL))
5822 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5824 next = next->block->next;
5827 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5828 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5831 /* The information about FORALL iterator, including FORALL index start, end
5832 and stride. The FORALL index can not appear in start, end or stride. */
5833 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5835 /* Check if any outer FORALL index name is the same as the current
5837 for (i = 0; i < nvar; i++)
5839 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5841 gfc_error ("An outer FORALL construct already has an index "
5842 "with this name %L", &fa->var->where);
5846 /* Record the current FORALL index. */
5847 var_expr[nvar] = gfc_copy_expr (fa->var);
5852 /* Resolve the FORALL body. */
5853 gfc_resolve_forall_body (code, nvar, var_expr);
5855 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5856 gfc_resolve_blocks (code->block, ns);
5858 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5859 for (i = 0; i < total_var; i++)
5860 gfc_free_expr (var_expr[i]);
5862 /* Reset the counters. */
5868 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5871 static void resolve_code (gfc_code *, gfc_namespace *);
5874 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5878 for (; b; b = b->block)
5880 t = gfc_resolve_expr (b->expr);
5881 if (gfc_resolve_expr (b->expr2) == FAILURE)
5887 if (t == SUCCESS && b->expr != NULL
5888 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5889 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5896 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5897 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5902 resolve_branch (b->label, b);
5914 case EXEC_OMP_ATOMIC:
5915 case EXEC_OMP_CRITICAL:
5917 case EXEC_OMP_MASTER:
5918 case EXEC_OMP_ORDERED:
5919 case EXEC_OMP_PARALLEL:
5920 case EXEC_OMP_PARALLEL_DO:
5921 case EXEC_OMP_PARALLEL_SECTIONS:
5922 case EXEC_OMP_PARALLEL_WORKSHARE:
5923 case EXEC_OMP_SECTIONS:
5924 case EXEC_OMP_SINGLE:
5925 case EXEC_OMP_WORKSHARE:
5929 gfc_internal_error ("resolve_block(): Bad block type");
5932 resolve_code (b->next, ns);
5937 /* Does everything to resolve an ordinary assignment. Returns true
5938 if this is an interface asignment. */
5940 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
5950 if (gfc_extend_assign (code, ns) == SUCCESS)
5952 lhs = code->ext.actual->expr;
5953 rhs = code->ext.actual->next->expr;
5954 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5956 gfc_error ("Subroutine '%s' called instead of assignment at "
5957 "%L must be PURE", code->symtree->n.sym->name,
5962 /* Make a temporary rhs when there is a default initializer
5963 and rhs is the same symbol as the lhs. */
5964 if (rhs->expr_type == EXPR_VARIABLE
5965 && rhs->symtree->n.sym->ts.type == BT_DERIVED
5966 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
5967 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
5968 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
5977 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
5978 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
5979 &code->loc) == FAILURE)
5982 /* Handle the case of a BOZ literal on the RHS. */
5983 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
5986 if (gfc_option.warn_surprising)
5987 gfc_warning ("BOZ literal at %L is bitwise transferred "
5988 "non-integer symbol '%s'", &code->loc,
5989 lhs->symtree->n.sym->name);
5991 if (!gfc_convert_boz (rhs, &lhs->ts))
5993 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
5995 if (rc == ARITH_UNDERFLOW)
5996 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
5997 ". This check can be disabled with the option "
5998 "-fno-range-check", &rhs->where);
5999 else if (rc == ARITH_OVERFLOW)
6000 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6001 ". This check can be disabled with the option "
6002 "-fno-range-check", &rhs->where);
6003 else if (rc == ARITH_NAN)
6004 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6005 ". This check can be disabled with the option "
6006 "-fno-range-check", &rhs->where);
6012 if (lhs->ts.type == BT_CHARACTER
6013 && gfc_option.warn_character_truncation)
6015 if (lhs->ts.cl != NULL
6016 && lhs->ts.cl->length != NULL
6017 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6018 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6020 if (rhs->expr_type == EXPR_CONSTANT)
6021 rlen = rhs->value.character.length;
6023 else if (rhs->ts.cl != NULL
6024 && rhs->ts.cl->length != NULL
6025 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6026 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6028 if (rlen && llen && rlen > llen)
6029 gfc_warning_now ("CHARACTER expression will be truncated "
6030 "in assignment (%d/%d) at %L",
6031 llen, rlen, &code->loc);
6034 /* Ensure that a vector index expression for the lvalue is evaluated
6035 to a temporary if the lvalue symbol is referenced in it. */
6038 for (ref = lhs->ref; ref; ref= ref->next)
6039 if (ref->type == REF_ARRAY)
6041 for (n = 0; n < ref->u.ar.dimen; n++)
6042 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6043 && find_sym_in_expr (lhs->symtree->n.sym,
6044 ref->u.ar.start[n]))
6046 = gfc_get_parentheses (ref->u.ar.start[n]);
6050 if (gfc_pure (NULL))
6052 if (gfc_impure_variable (lhs->symtree->n.sym))
6054 gfc_error ("Cannot assign to variable '%s' in PURE "
6056 lhs->symtree->n.sym->name,
6061 if (lhs->ts.type == BT_DERIVED
6062 && lhs->expr_type == EXPR_VARIABLE
6063 && lhs->ts.derived->attr.pointer_comp
6064 && gfc_impure_variable (rhs->symtree->n.sym))
6066 gfc_error ("The impure variable at %L is assigned to "
6067 "a derived type variable with a POINTER "
6068 "component in a PURE procedure (12.6)",
6074 gfc_check_assign (lhs, rhs, 1);
6078 /* Given a block of code, recursively resolve everything pointed to by this
6082 resolve_code (gfc_code *code, gfc_namespace *ns)
6084 int omp_workshare_save;
6090 frame.prev = cs_base;
6094 reachable_labels (code);
6096 for (; code; code = code->next)
6098 frame.current = code;
6099 forall_save = forall_flag;
6101 if (code->op == EXEC_FORALL)
6104 gfc_resolve_forall (code, ns, forall_save);
6107 else if (code->block)
6109 omp_workshare_save = -1;
6112 case EXEC_OMP_PARALLEL_WORKSHARE:
6113 omp_workshare_save = omp_workshare_flag;
6114 omp_workshare_flag = 1;
6115 gfc_resolve_omp_parallel_blocks (code, ns);
6117 case EXEC_OMP_PARALLEL:
6118 case EXEC_OMP_PARALLEL_DO:
6119 case EXEC_OMP_PARALLEL_SECTIONS:
6120 omp_workshare_save = omp_workshare_flag;
6121 omp_workshare_flag = 0;
6122 gfc_resolve_omp_parallel_blocks (code, ns);
6125 gfc_resolve_omp_do_blocks (code, ns);
6127 case EXEC_OMP_WORKSHARE:
6128 omp_workshare_save = omp_workshare_flag;
6129 omp_workshare_flag = 1;
6132 gfc_resolve_blocks (code->block, ns);
6136 if (omp_workshare_save != -1)
6137 omp_workshare_flag = omp_workshare_save;
6140 t = gfc_resolve_expr (code->expr);
6141 forall_flag = forall_save;
6143 if (gfc_resolve_expr (code->expr2) == FAILURE)
6158 /* Keep track of which entry we are up to. */
6159 current_entry_id = code->ext.entry->id;
6163 resolve_where (code, NULL);
6167 if (code->expr != NULL)
6169 if (code->expr->ts.type != BT_INTEGER)
6170 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6171 "INTEGER variable", &code->expr->where);
6172 else if (code->expr->symtree->n.sym->attr.assign != 1)
6173 gfc_error ("Variable '%s' has not been assigned a target "
6174 "label at %L", code->expr->symtree->n.sym->name,
6175 &code->expr->where);
6178 resolve_branch (code->label, code);
6182 if (code->expr != NULL
6183 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6184 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6185 "INTEGER return specifier", &code->expr->where);
6188 case EXEC_INIT_ASSIGN:
6195 if (resolve_ordinary_assign (code, ns))
6200 case EXEC_LABEL_ASSIGN:
6201 if (code->label->defined == ST_LABEL_UNKNOWN)
6202 gfc_error ("Label %d referenced at %L is never defined",
6203 code->label->value, &code->label->where);
6205 && (code->expr->expr_type != EXPR_VARIABLE
6206 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6207 || code->expr->symtree->n.sym->ts.kind
6208 != gfc_default_integer_kind
6209 || code->expr->symtree->n.sym->as != NULL))
6210 gfc_error ("ASSIGN statement at %L requires a scalar "
6211 "default INTEGER variable", &code->expr->where);
6214 case EXEC_POINTER_ASSIGN:
6218 gfc_check_pointer_assign (code->expr, code->expr2);
6221 case EXEC_ARITHMETIC_IF:
6223 && code->expr->ts.type != BT_INTEGER
6224 && code->expr->ts.type != BT_REAL)
6225 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6226 "expression", &code->expr->where);
6228 resolve_branch (code->label, code);
6229 resolve_branch (code->label2, code);
6230 resolve_branch (code->label3, code);
6234 if (t == SUCCESS && code->expr != NULL
6235 && (code->expr->ts.type != BT_LOGICAL
6236 || code->expr->rank != 0))
6237 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6238 &code->expr->where);
6243 resolve_call (code);
6247 /* Select is complicated. Also, a SELECT construct could be
6248 a transformed computed GOTO. */
6249 resolve_select (code);
6253 if (code->ext.iterator != NULL)
6255 gfc_iterator *iter = code->ext.iterator;
6256 if (gfc_resolve_iterator (iter, true) != FAILURE)
6257 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6262 if (code->expr == NULL)
6263 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6265 && (code->expr->rank != 0
6266 || code->expr->ts.type != BT_LOGICAL))
6267 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6268 "a scalar LOGICAL expression", &code->expr->where);
6272 if (t == SUCCESS && code->expr != NULL
6273 && code->expr->ts.type != BT_INTEGER)
6274 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6275 "of type INTEGER", &code->expr->where);
6277 for (a = code->ext.alloc_list; a; a = a->next)
6278 resolve_allocate_expr (a->expr, code);
6282 case EXEC_DEALLOCATE:
6283 if (t == SUCCESS && code->expr != NULL
6284 && code->expr->ts.type != BT_INTEGER)
6286 ("STAT tag in DEALLOCATE statement at %L must be of type "
6287 "INTEGER", &code->expr->where);
6289 for (a = code->ext.alloc_list; a; a = a->next)
6290 resolve_deallocate_expr (a->expr);
6295 if (gfc_resolve_open (code->ext.open) == FAILURE)
6298 resolve_branch (code->ext.open->err, code);
6302 if (gfc_resolve_close (code->ext.close) == FAILURE)
6305 resolve_branch (code->ext.close->err, code);
6308 case EXEC_BACKSPACE:
6312 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6315 resolve_branch (code->ext.filepos->err, code);
6319 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6322 resolve_branch (code->ext.inquire->err, code);
6326 gcc_assert (code->ext.inquire != NULL);
6327 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6330 resolve_branch (code->ext.inquire->err, code);
6335 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6338 resolve_branch (code->ext.dt->err, code);
6339 resolve_branch (code->ext.dt->end, code);
6340 resolve_branch (code->ext.dt->eor, code);
6344 resolve_transfer (code);
6348 resolve_forall_iterators (code->ext.forall_iterator);
6350 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6351 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6352 "expression", &code->expr->where);
6355 case EXEC_OMP_ATOMIC:
6356 case EXEC_OMP_BARRIER:
6357 case EXEC_OMP_CRITICAL:
6358 case EXEC_OMP_FLUSH:
6360 case EXEC_OMP_MASTER:
6361 case EXEC_OMP_ORDERED:
6362 case EXEC_OMP_SECTIONS:
6363 case EXEC_OMP_SINGLE:
6364 case EXEC_OMP_WORKSHARE:
6365 gfc_resolve_omp_directive (code, ns);
6368 case EXEC_OMP_PARALLEL:
6369 case EXEC_OMP_PARALLEL_DO:
6370 case EXEC_OMP_PARALLEL_SECTIONS:
6371 case EXEC_OMP_PARALLEL_WORKSHARE:
6372 omp_workshare_save = omp_workshare_flag;
6373 omp_workshare_flag = 0;
6374 gfc_resolve_omp_directive (code, ns);
6375 omp_workshare_flag = omp_workshare_save;
6379 gfc_internal_error ("resolve_code(): Bad statement code");
6383 cs_base = frame.prev;
6387 /* Resolve initial values and make sure they are compatible with
6391 resolve_values (gfc_symbol *sym)
6393 if (sym->value == NULL)
6396 if (gfc_resolve_expr (sym->value) == FAILURE)
6399 gfc_check_assign_symbol (sym, sym->value);
6403 /* Verify the binding labels for common blocks that are BIND(C). The label
6404 for a BIND(C) common block must be identical in all scoping units in which
6405 the common block is declared. Further, the binding label can not collide
6406 with any other global entity in the program. */
6409 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6411 if (comm_block_tree->n.common->is_bind_c == 1)
6413 gfc_gsymbol *binding_label_gsym;
6414 gfc_gsymbol *comm_name_gsym;
6416 /* See if a global symbol exists by the common block's name. It may
6417 be NULL if the common block is use-associated. */
6418 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6419 comm_block_tree->n.common->name);
6420 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6421 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6422 "with the global entity '%s' at %L",
6423 comm_block_tree->n.common->binding_label,
6424 comm_block_tree->n.common->name,
6425 &(comm_block_tree->n.common->where),
6426 comm_name_gsym->name, &(comm_name_gsym->where));
6427 else if (comm_name_gsym != NULL
6428 && strcmp (comm_name_gsym->name,
6429 comm_block_tree->n.common->name) == 0)
6431 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6433 if (comm_name_gsym->binding_label == NULL)
6434 /* No binding label for common block stored yet; save this one. */
6435 comm_name_gsym->binding_label =
6436 comm_block_tree->n.common->binding_label;
6438 if (strcmp (comm_name_gsym->binding_label,
6439 comm_block_tree->n.common->binding_label) != 0)
6441 /* Common block names match but binding labels do not. */
6442 gfc_error ("Binding label '%s' for common block '%s' at %L "
6443 "does not match the binding label '%s' for common "
6445 comm_block_tree->n.common->binding_label,
6446 comm_block_tree->n.common->name,
6447 &(comm_block_tree->n.common->where),
6448 comm_name_gsym->binding_label,
6449 comm_name_gsym->name,
6450 &(comm_name_gsym->where));
6455 /* There is no binding label (NAME="") so we have nothing further to
6456 check and nothing to add as a global symbol for the label. */
6457 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6460 binding_label_gsym =
6461 gfc_find_gsymbol (gfc_gsym_root,
6462 comm_block_tree->n.common->binding_label);
6463 if (binding_label_gsym == NULL)
6465 /* Need to make a global symbol for the binding label to prevent
6466 it from colliding with another. */
6467 binding_label_gsym =
6468 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6469 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6470 binding_label_gsym->type = GSYM_COMMON;
6474 /* If comm_name_gsym is NULL, the name common block is use
6475 associated and the name could be colliding. */
6476 if (binding_label_gsym->type != GSYM_COMMON)
6477 gfc_error ("Binding label '%s' for common block '%s' at %L "
6478 "collides with the global entity '%s' at %L",
6479 comm_block_tree->n.common->binding_label,
6480 comm_block_tree->n.common->name,
6481 &(comm_block_tree->n.common->where),
6482 binding_label_gsym->name,
6483 &(binding_label_gsym->where));
6484 else if (comm_name_gsym != NULL
6485 && (strcmp (binding_label_gsym->name,
6486 comm_name_gsym->binding_label) != 0)
6487 && (strcmp (binding_label_gsym->sym_name,
6488 comm_name_gsym->name) != 0))
6489 gfc_error ("Binding label '%s' for common block '%s' at %L "
6490 "collides with global entity '%s' at %L",
6491 binding_label_gsym->name, binding_label_gsym->sym_name,
6492 &(comm_block_tree->n.common->where),
6493 comm_name_gsym->name, &(comm_name_gsym->where));
6501 /* Verify any BIND(C) derived types in the namespace so we can report errors
6502 for them once, rather than for each variable declared of that type. */
6505 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6507 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6508 && derived_sym->attr.is_bind_c == 1)
6509 verify_bind_c_derived_type (derived_sym);
6515 /* Verify that any binding labels used in a given namespace do not collide
6516 with the names or binding labels of any global symbols. */
6519 gfc_verify_binding_labels (gfc_symbol *sym)
6523 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6524 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6526 gfc_gsymbol *bind_c_sym;
6528 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6529 if (bind_c_sym != NULL
6530 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6532 if (sym->attr.if_source == IFSRC_DECL
6533 && (bind_c_sym->type != GSYM_SUBROUTINE
6534 && bind_c_sym->type != GSYM_FUNCTION)
6535 && ((sym->attr.contained == 1
6536 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6537 || (sym->attr.use_assoc == 1
6538 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6540 /* Make sure global procedures don't collide with anything. */
6541 gfc_error ("Binding label '%s' at %L collides with the global "
6542 "entity '%s' at %L", sym->binding_label,
6543 &(sym->declared_at), bind_c_sym->name,
6544 &(bind_c_sym->where));
6547 else if (sym->attr.contained == 0
6548 && (sym->attr.if_source == IFSRC_IFBODY
6549 && sym->attr.flavor == FL_PROCEDURE)
6550 && (bind_c_sym->sym_name != NULL
6551 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6553 /* Make sure procedures in interface bodies don't collide. */
6554 gfc_error ("Binding label '%s' in interface body at %L collides "
6555 "with the global entity '%s' at %L",
6557 &(sym->declared_at), bind_c_sym->name,
6558 &(bind_c_sym->where));
6561 else if (sym->attr.contained == 0
6562 && (sym->attr.if_source == IFSRC_UNKNOWN))
6563 if ((sym->attr.use_assoc
6564 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6565 || sym->attr.use_assoc == 0)
6567 gfc_error ("Binding label '%s' at %L collides with global "
6568 "entity '%s' at %L", sym->binding_label,
6569 &(sym->declared_at), bind_c_sym->name,
6570 &(bind_c_sym->where));
6575 /* Clear the binding label to prevent checking multiple times. */
6576 sym->binding_label[0] = '\0';
6578 else if (bind_c_sym == NULL)
6580 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6581 bind_c_sym->where = sym->declared_at;
6582 bind_c_sym->sym_name = sym->name;
6584 if (sym->attr.use_assoc == 1)
6585 bind_c_sym->mod_name = sym->module;
6587 if (sym->ns->proc_name != NULL)
6588 bind_c_sym->mod_name = sym->ns->proc_name->name;
6590 if (sym->attr.contained == 0)
6592 if (sym->attr.subroutine)
6593 bind_c_sym->type = GSYM_SUBROUTINE;
6594 else if (sym->attr.function)
6595 bind_c_sym->type = GSYM_FUNCTION;
6603 /* Resolve an index expression. */
6606 resolve_index_expr (gfc_expr *e)
6608 if (gfc_resolve_expr (e) == FAILURE)
6611 if (gfc_simplify_expr (e, 0) == FAILURE)
6614 if (gfc_specification_expr (e) == FAILURE)
6620 /* Resolve a charlen structure. */
6623 resolve_charlen (gfc_charlen *cl)
6632 specification_expr = 1;
6634 if (resolve_index_expr (cl->length) == FAILURE)
6636 specification_expr = 0;
6640 /* "If the character length parameter value evaluates to a negative
6641 value, the length of character entities declared is zero." */
6642 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6644 gfc_warning_now ("CHARACTER variable has zero length at %L",
6645 &cl->length->where);
6646 gfc_replace_expr (cl->length, gfc_int_expr (0));
6653 /* Test for non-constant shape arrays. */
6656 is_non_constant_shape_array (gfc_symbol *sym)
6662 not_constant = false;
6663 if (sym->as != NULL)
6665 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6666 has not been simplified; parameter array references. Do the
6667 simplification now. */
6668 for (i = 0; i < sym->as->rank; i++)
6670 e = sym->as->lower[i];
6671 if (e && (resolve_index_expr (e) == FAILURE
6672 || !gfc_is_constant_expr (e)))
6673 not_constant = true;
6675 e = sym->as->upper[i];
6676 if (e && (resolve_index_expr (e) == FAILURE
6677 || !gfc_is_constant_expr (e)))
6678 not_constant = true;
6681 return not_constant;
6684 /* Given a symbol and an initialization expression, add code to initialize
6685 the symbol to the function entry. */
6687 build_init_assign (gfc_symbol *sym, gfc_expr *init)
6691 gfc_namespace *ns = sym->ns;
6693 /* Search for the function namespace if this is a contained
6694 function without an explicit result. */
6695 if (sym->attr.function && sym == sym->result
6696 && sym->name != sym->ns->proc_name->name)
6699 for (;ns; ns = ns->sibling)
6700 if (strcmp (ns->proc_name->name, sym->name) == 0)
6706 gfc_free_expr (init);
6710 /* Build an l-value expression for the result. */
6711 lval = gfc_lval_expr_from_sym (sym);
6713 /* Add the code at scope entry. */
6714 init_st = gfc_get_code ();
6715 init_st->next = ns->code;
6718 /* Assign the default initializer to the l-value. */
6719 init_st->loc = sym->declared_at;
6720 init_st->op = EXEC_INIT_ASSIGN;
6721 init_st->expr = lval;
6722 init_st->expr2 = init;
6725 /* Assign the default initializer to a derived type variable or result. */
6728 apply_default_init (gfc_symbol *sym)
6730 gfc_expr *init = NULL;
6732 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6735 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6736 init = gfc_default_initializer (&sym->ts);
6741 build_init_assign (sym, init);
6744 /* Build an initializer for a local integer, real, complex, logical, or
6745 character variable, based on the command line flags finit-local-zero,
6746 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6747 null if the symbol should not have a default initialization. */
6749 build_default_init_expr (gfc_symbol *sym)
6752 gfc_expr *init_expr;
6756 /* These symbols should never have a default initialization. */
6757 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
6758 || sym->attr.external
6760 || sym->attr.pointer
6761 || sym->attr.in_equivalence
6762 || sym->attr.in_common
6765 || sym->attr.cray_pointee
6766 || sym->attr.cray_pointer)
6769 /* Now we'll try to build an initializer expression. */
6770 init_expr = gfc_get_expr ();
6771 init_expr->expr_type = EXPR_CONSTANT;
6772 init_expr->ts.type = sym->ts.type;
6773 init_expr->ts.kind = sym->ts.kind;
6774 init_expr->where = sym->declared_at;
6776 /* We will only initialize integers, reals, complex, logicals, and
6777 characters, and only if the corresponding command-line flags
6778 were set. Otherwise, we free init_expr and return null. */
6779 switch (sym->ts.type)
6782 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
6783 mpz_init_set_si (init_expr->value.integer,
6784 gfc_option.flag_init_integer_value);
6787 gfc_free_expr (init_expr);
6793 mpfr_init (init_expr->value.real);
6794 switch (gfc_option.flag_init_real)
6796 case GFC_INIT_REAL_NAN:
6797 mpfr_set_nan (init_expr->value.real);
6800 case GFC_INIT_REAL_INF:
6801 mpfr_set_inf (init_expr->value.real, 1);
6804 case GFC_INIT_REAL_NEG_INF:
6805 mpfr_set_inf (init_expr->value.real, -1);
6808 case GFC_INIT_REAL_ZERO:
6809 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
6813 gfc_free_expr (init_expr);
6820 mpfr_init (init_expr->value.complex.r);
6821 mpfr_init (init_expr->value.complex.i);
6822 switch (gfc_option.flag_init_real)
6824 case GFC_INIT_REAL_NAN:
6825 mpfr_set_nan (init_expr->value.complex.r);
6826 mpfr_set_nan (init_expr->value.complex.i);
6829 case GFC_INIT_REAL_INF:
6830 mpfr_set_inf (init_expr->value.complex.r, 1);
6831 mpfr_set_inf (init_expr->value.complex.i, 1);
6834 case GFC_INIT_REAL_NEG_INF:
6835 mpfr_set_inf (init_expr->value.complex.r, -1);
6836 mpfr_set_inf (init_expr->value.complex.i, -1);
6839 case GFC_INIT_REAL_ZERO:
6840 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
6841 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
6845 gfc_free_expr (init_expr);
6852 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
6853 init_expr->value.logical = 0;
6854 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
6855 init_expr->value.logical = 1;
6858 gfc_free_expr (init_expr);
6864 /* For characters, the length must be constant in order to
6865 create a default initializer. */
6866 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
6867 && sym->ts.cl->length
6868 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
6870 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
6871 init_expr->value.character.length = char_len;
6872 init_expr->value.character.string = gfc_getmem (char_len+1);
6873 ch = init_expr->value.character.string;
6874 for (i = 0; i < char_len; i++)
6875 *(ch++) = gfc_option.flag_init_character_value;
6879 gfc_free_expr (init_expr);
6885 gfc_free_expr (init_expr);
6891 /* Add an initialization expression to a local variable. */
6893 apply_default_init_local (gfc_symbol *sym)
6895 gfc_expr *init = NULL;
6897 /* The symbol should be a variable or a function return value. */
6898 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6899 || (sym->attr.function && sym->result != sym))
6902 /* Try to build the initializer expression. If we can't initialize
6903 this symbol, then init will be NULL. */
6904 init = build_default_init_expr (sym);
6908 /* For saved variables, we don't want to add an initializer at
6909 function entry, so we just add a static initializer. */
6910 if (sym->attr.save || sym->ns->save_all)
6912 /* Don't clobber an existing initializer! */
6913 gcc_assert (sym->value == NULL);
6918 build_init_assign (sym, init);
6921 /* Resolution of common features of flavors variable and procedure. */
6924 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6926 /* Constraints on deferred shape variable. */
6927 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6929 if (sym->attr.allocatable)
6931 if (sym->attr.dimension)
6932 gfc_error ("Allocatable array '%s' at %L must have "
6933 "a deferred shape", sym->name, &sym->declared_at);
6935 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6936 sym->name, &sym->declared_at);
6940 if (sym->attr.pointer && sym->attr.dimension)
6942 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6943 sym->name, &sym->declared_at);
6950 if (!mp_flag && !sym->attr.allocatable
6951 && !sym->attr.pointer && !sym->attr.dummy)
6953 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6954 sym->name, &sym->declared_at);
6962 /* Additional checks for symbols with flavor variable and derived
6963 type. To be called from resolve_fl_variable. */
6966 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
6968 gcc_assert (sym->ts.type == BT_DERIVED);
6970 /* Check to see if a derived type is blocked from being host
6971 associated by the presence of another class I symbol in the same
6972 namespace. 14.6.1.3 of the standard and the discussion on
6973 comp.lang.fortran. */
6974 if (sym->ns != sym->ts.derived->ns
6975 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6978 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6979 if (s && (s->attr.flavor != FL_DERIVED
6980 || !gfc_compare_derived_types (s, sym->ts.derived)))
6982 gfc_error ("The type '%s' cannot be host associated at %L "
6983 "because it is blocked by an incompatible object "
6984 "of the same name declared at %L",
6985 sym->ts.derived->name, &sym->declared_at,
6991 /* 4th constraint in section 11.3: "If an object of a type for which
6992 component-initialization is specified (R429) appears in the
6993 specification-part of a module and does not have the ALLOCATABLE
6994 or POINTER attribute, the object shall have the SAVE attribute."
6996 The check for initializers is performed with
6997 has_default_initializer because gfc_default_initializer generates
6998 a hidden default for allocatable components. */
6999 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7000 && sym->ns->proc_name->attr.flavor == FL_MODULE
7001 && !sym->ns->save_all && !sym->attr.save
7002 && !sym->attr.pointer && !sym->attr.allocatable
7003 && has_default_initializer (sym->ts.derived))
7005 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7006 "default initialization of a component",
7007 sym->name, &sym->declared_at);
7011 /* Assign default initializer. */
7012 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7013 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7015 sym->value = gfc_default_initializer (&sym->ts);
7022 /* Resolve symbols with flavor variable. */
7025 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7027 int no_init_flag, automatic_flag;
7029 const char *auto_save_msg;
7031 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7034 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7037 /* Set this flag to check that variables are parameters of all entries.
7038 This check is effected by the call to gfc_resolve_expr through
7039 is_non_constant_shape_array. */
7040 specification_expr = 1;
7042 if (sym->ns->proc_name
7043 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7044 || sym->ns->proc_name->attr.is_main_program)
7045 && !sym->attr.use_assoc
7046 && !sym->attr.allocatable
7047 && !sym->attr.pointer
7048 && is_non_constant_shape_array (sym))
7050 /* The shape of a main program or module array needs to be
7052 gfc_error ("The module or main program array '%s' at %L must "
7053 "have constant shape", sym->name, &sym->declared_at);
7054 specification_expr = 0;
7058 if (sym->ts.type == BT_CHARACTER)
7060 /* Make sure that character string variables with assumed length are
7062 e = sym->ts.cl->length;
7063 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7065 gfc_error ("Entity with assumed character length at %L must be a "
7066 "dummy argument or a PARAMETER", &sym->declared_at);
7070 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7072 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7076 if (!gfc_is_constant_expr (e)
7077 && !(e->expr_type == EXPR_VARIABLE
7078 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7079 && sym->ns->proc_name
7080 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7081 || sym->ns->proc_name->attr.is_main_program)
7082 && !sym->attr.use_assoc)
7084 gfc_error ("'%s' at %L must have constant character length "
7085 "in this context", sym->name, &sym->declared_at);
7090 if (sym->value == NULL && sym->attr.referenced)
7091 apply_default_init_local (sym); /* Try to apply a default initialization. */
7093 /* Determine if the symbol may not have an initializer. */
7094 no_init_flag = automatic_flag = 0;
7095 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7096 || sym->attr.intrinsic || sym->attr.result)
7098 else if (sym->attr.dimension && !sym->attr.pointer
7099 && is_non_constant_shape_array (sym))
7101 no_init_flag = automatic_flag = 1;
7103 /* Also, they must not have the SAVE attribute.
7104 SAVE_IMPLICIT is checked below. */
7105 if (sym->attr.save == SAVE_EXPLICIT)
7107 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7112 /* Reject illegal initializers. */
7113 if (!sym->mark && sym->value)
7115 if (sym->attr.allocatable)
7116 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7117 sym->name, &sym->declared_at);
7118 else if (sym->attr.external)
7119 gfc_error ("External '%s' at %L cannot have an initializer",
7120 sym->name, &sym->declared_at);
7121 else if (sym->attr.dummy
7122 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7123 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7124 sym->name, &sym->declared_at);
7125 else if (sym->attr.intrinsic)
7126 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7127 sym->name, &sym->declared_at);
7128 else if (sym->attr.result)
7129 gfc_error ("Function result '%s' at %L cannot have an initializer",
7130 sym->name, &sym->declared_at);
7131 else if (automatic_flag)
7132 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7133 sym->name, &sym->declared_at);
7140 if (sym->ts.type == BT_DERIVED)
7141 return resolve_fl_variable_derived (sym, no_init_flag);
7147 /* Resolve a procedure. */
7150 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7152 gfc_formal_arglist *arg;
7154 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7155 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7156 "interfaces", sym->name, &sym->declared_at);
7158 if (sym->attr.function
7159 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7162 if (sym->ts.type == BT_CHARACTER)
7164 gfc_charlen *cl = sym->ts.cl;
7166 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7167 && resolve_charlen (cl) == FAILURE)
7170 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7172 if (sym->attr.proc == PROC_ST_FUNCTION)
7174 gfc_error ("Character-valued statement function '%s' at %L must "
7175 "have constant length", sym->name, &sym->declared_at);
7179 if (sym->attr.external && sym->formal == NULL
7180 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7182 gfc_error ("Automatic character length function '%s' at %L must "
7183 "have an explicit interface", sym->name,
7190 /* Ensure that derived type for are not of a private type. Internal
7191 module procedures are excluded by 2.2.3.3 - ie. they are not
7192 externally accessible and can access all the objects accessible in
7194 if (!(sym->ns->parent
7195 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7196 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7198 gfc_interface *iface;
7200 for (arg = sym->formal; arg; arg = arg->next)
7203 && arg->sym->ts.type == BT_DERIVED
7204 && !arg->sym->ts.derived->attr.use_assoc
7205 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7206 arg->sym->ts.derived->ns->default_access)
7207 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7208 "PRIVATE type and cannot be a dummy argument"
7209 " of '%s', which is PUBLIC at %L",
7210 arg->sym->name, sym->name, &sym->declared_at)
7213 /* Stop this message from recurring. */
7214 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7219 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7220 PRIVATE to the containing module. */
7221 for (iface = sym->generic; iface; iface = iface->next)
7223 for (arg = iface->sym->formal; arg; arg = arg->next)
7226 && arg->sym->ts.type == BT_DERIVED
7227 && !arg->sym->ts.derived->attr.use_assoc
7228 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7229 arg->sym->ts.derived->ns->default_access)
7230 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7231 "'%s' in PUBLIC interface '%s' at %L "
7232 "takes dummy arguments of '%s' which is "
7233 "PRIVATE", iface->sym->name, sym->name,
7234 &iface->sym->declared_at,
7235 gfc_typename (&arg->sym->ts)) == FAILURE)
7237 /* Stop this message from recurring. */
7238 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7244 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7245 PRIVATE to the containing module. */
7246 for (iface = sym->generic; iface; iface = iface->next)
7248 for (arg = iface->sym->formal; arg; arg = arg->next)
7251 && arg->sym->ts.type == BT_DERIVED
7252 && !arg->sym->ts.derived->attr.use_assoc
7253 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7254 arg->sym->ts.derived->ns->default_access)
7255 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7256 "'%s' in PUBLIC interface '%s' at %L "
7257 "takes dummy arguments of '%s' which is "
7258 "PRIVATE", iface->sym->name, sym->name,
7259 &iface->sym->declared_at,
7260 gfc_typename (&arg->sym->ts)) == FAILURE)
7262 /* Stop this message from recurring. */
7263 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7270 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7272 gfc_error ("Function '%s' at %L cannot have an initializer",
7273 sym->name, &sym->declared_at);
7277 /* An external symbol may not have an initializer because it is taken to be
7279 if (sym->attr.external && sym->value)
7281 gfc_error ("External object '%s' at %L may not have an initializer",
7282 sym->name, &sym->declared_at);
7286 /* An elemental function is required to return a scalar 12.7.1 */
7287 if (sym->attr.elemental && sym->attr.function && sym->as)
7289 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7290 "result", sym->name, &sym->declared_at);
7291 /* Reset so that the error only occurs once. */
7292 sym->attr.elemental = 0;
7296 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7297 char-len-param shall not be array-valued, pointer-valued, recursive
7298 or pure. ....snip... A character value of * may only be used in the
7299 following ways: (i) Dummy arg of procedure - dummy associates with
7300 actual length; (ii) To declare a named constant; or (iii) External
7301 function - but length must be declared in calling scoping unit. */
7302 if (sym->attr.function
7303 && sym->ts.type == BT_CHARACTER
7304 && sym->ts.cl && sym->ts.cl->length == NULL)
7306 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7307 || (sym->attr.recursive) || (sym->attr.pure))
7309 if (sym->as && sym->as->rank)
7310 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7311 "array-valued", sym->name, &sym->declared_at);
7313 if (sym->attr.pointer)
7314 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7315 "pointer-valued", sym->name, &sym->declared_at);
7318 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7319 "pure", sym->name, &sym->declared_at);
7321 if (sym->attr.recursive)
7322 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7323 "recursive", sym->name, &sym->declared_at);
7328 /* Appendix B.2 of the standard. Contained functions give an
7329 error anyway. Fixed-form is likely to be F77/legacy. */
7330 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7331 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7332 "'%s' at %L is obsolescent in fortran 95",
7333 sym->name, &sym->declared_at);
7336 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7338 gfc_formal_arglist *curr_arg;
7339 int has_non_interop_arg = 0;
7341 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7342 sym->common_block) == FAILURE)
7344 /* Clear these to prevent looking at them again if there was an
7346 sym->attr.is_bind_c = 0;
7347 sym->attr.is_c_interop = 0;
7348 sym->ts.is_c_interop = 0;
7352 /* So far, no errors have been found. */
7353 sym->attr.is_c_interop = 1;
7354 sym->ts.is_c_interop = 1;
7357 curr_arg = sym->formal;
7358 while (curr_arg != NULL)
7360 /* Skip implicitly typed dummy args here. */
7361 if (curr_arg->sym->attr.implicit_type == 0)
7362 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7363 /* If something is found to fail, record the fact so we
7364 can mark the symbol for the procedure as not being
7365 BIND(C) to try and prevent multiple errors being
7367 has_non_interop_arg = 1;
7369 curr_arg = curr_arg->next;
7372 /* See if any of the arguments were not interoperable and if so, clear
7373 the procedure symbol to prevent duplicate error messages. */
7374 if (has_non_interop_arg != 0)
7376 sym->attr.is_c_interop = 0;
7377 sym->ts.is_c_interop = 0;
7378 sym->attr.is_bind_c = 0;
7386 /* Resolve the components of a derived type. */
7389 resolve_fl_derived (gfc_symbol *sym)
7392 gfc_dt_list * dt_list;
7395 for (c = sym->components; c != NULL; c = c->next)
7397 if (c->ts.type == BT_CHARACTER)
7399 if (c->ts.cl->length == NULL
7400 || (resolve_charlen (c->ts.cl) == FAILURE)
7401 || !gfc_is_constant_expr (c->ts.cl->length))
7403 gfc_error ("Character length of component '%s' needs to "
7404 "be a constant specification expression at %L",
7406 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7411 if (c->ts.type == BT_DERIVED
7412 && sym->component_access != ACCESS_PRIVATE
7413 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7414 && !c->ts.derived->attr.use_assoc
7415 && !gfc_check_access (c->ts.derived->attr.access,
7416 c->ts.derived->ns->default_access))
7418 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7419 "a component of '%s', which is PUBLIC at %L",
7420 c->name, sym->name, &sym->declared_at);
7424 if (sym->attr.sequence)
7426 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7428 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7429 "not have the SEQUENCE attribute",
7430 c->ts.derived->name, &sym->declared_at);
7435 if (c->ts.type == BT_DERIVED && c->pointer
7436 && c->ts.derived->components == NULL)
7438 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7439 "that has not been declared", c->name, sym->name,
7444 if (c->pointer || c->allocatable || c->as == NULL)
7447 for (i = 0; i < c->as->rank; i++)
7449 if (c->as->lower[i] == NULL
7450 || !gfc_is_constant_expr (c->as->lower[i])
7451 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7452 || c->as->upper[i] == NULL
7453 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7454 || !gfc_is_constant_expr (c->as->upper[i]))
7456 gfc_error ("Component '%s' of '%s' at %L must have "
7457 "constant array bounds",
7458 c->name, sym->name, &c->loc);
7464 /* Add derived type to the derived type list. */
7465 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7466 if (sym == dt_list->derived)
7469 if (dt_list == NULL)
7471 dt_list = gfc_get_dt_list ();
7472 dt_list->next = gfc_derived_types;
7473 dt_list->derived = sym;
7474 gfc_derived_types = dt_list;
7482 resolve_fl_namelist (gfc_symbol *sym)
7487 /* Reject PRIVATE objects in a PUBLIC namelist. */
7488 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7490 for (nl = sym->namelist; nl; nl = nl->next)
7492 if (!nl->sym->attr.use_assoc
7493 && !(sym->ns->parent == nl->sym->ns)
7494 && !(sym->ns->parent
7495 && sym->ns->parent->parent == nl->sym->ns)
7496 && !gfc_check_access(nl->sym->attr.access,
7497 nl->sym->ns->default_access))
7499 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7500 "cannot be member of PUBLIC namelist '%s' at %L",
7501 nl->sym->name, sym->name, &sym->declared_at);
7505 /* Types with private components that came here by USE-association. */
7506 if (nl->sym->ts.type == BT_DERIVED
7507 && derived_inaccessible (nl->sym->ts.derived))
7509 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7510 "components and cannot be member of namelist '%s' at %L",
7511 nl->sym->name, sym->name, &sym->declared_at);
7515 /* Types with private components that are defined in the same module. */
7516 if (nl->sym->ts.type == BT_DERIVED
7517 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7518 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7519 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7520 nl->sym->ns->default_access))
7522 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7523 "cannot be a member of PUBLIC namelist '%s' at %L",
7524 nl->sym->name, sym->name, &sym->declared_at);
7530 for (nl = sym->namelist; nl; nl = nl->next)
7532 /* Reject namelist arrays of assumed shape. */
7533 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7534 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7535 "must not have assumed shape in namelist "
7536 "'%s' at %L", nl->sym->name, sym->name,
7537 &sym->declared_at) == FAILURE)
7540 /* Reject namelist arrays that are not constant shape. */
7541 if (is_non_constant_shape_array (nl->sym))
7543 gfc_error ("NAMELIST array object '%s' must have constant "
7544 "shape in namelist '%s' at %L", nl->sym->name,
7545 sym->name, &sym->declared_at);
7549 /* Namelist objects cannot have allocatable or pointer components. */
7550 if (nl->sym->ts.type != BT_DERIVED)
7553 if (nl->sym->ts.derived->attr.alloc_comp)
7555 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7556 "have ALLOCATABLE components",
7557 nl->sym->name, sym->name, &sym->declared_at);
7561 if (nl->sym->ts.derived->attr.pointer_comp)
7563 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7564 "have POINTER components",
7565 nl->sym->name, sym->name, &sym->declared_at);
7571 /* 14.1.2 A module or internal procedure represent local entities
7572 of the same type as a namelist member and so are not allowed. */
7573 for (nl = sym->namelist; nl; nl = nl->next)
7575 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7578 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7579 if ((nl->sym == sym->ns->proc_name)
7581 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7585 if (nl->sym && nl->sym->name)
7586 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7587 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7589 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7590 "attribute in '%s' at %L", nlsym->name,
7601 resolve_fl_parameter (gfc_symbol *sym)
7603 /* A parameter array's shape needs to be constant. */
7605 && (sym->as->type == AS_DEFERRED
7606 || is_non_constant_shape_array (sym)))
7608 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7609 "or of deferred shape", sym->name, &sym->declared_at);
7613 /* Make sure a parameter that has been implicitly typed still
7614 matches the implicit type, since PARAMETER statements can precede
7615 IMPLICIT statements. */
7616 if (sym->attr.implicit_type
7617 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7619 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7620 "later IMPLICIT type", sym->name, &sym->declared_at);
7624 /* Make sure the types of derived parameters are consistent. This
7625 type checking is deferred until resolution because the type may
7626 refer to a derived type from the host. */
7627 if (sym->ts.type == BT_DERIVED
7628 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7630 gfc_error ("Incompatible derived type in PARAMETER at %L",
7631 &sym->value->where);
7638 /* Do anything necessary to resolve a symbol. Right now, we just
7639 assume that an otherwise unknown symbol is a variable. This sort
7640 of thing commonly happens for symbols in module. */
7643 resolve_symbol (gfc_symbol *sym)
7645 int check_constant, mp_flag;
7646 gfc_symtree *symtree;
7647 gfc_symtree *this_symtree;
7651 if (sym->attr.flavor == FL_UNKNOWN)
7654 /* If we find that a flavorless symbol is an interface in one of the
7655 parent namespaces, find its symtree in this namespace, free the
7656 symbol and set the symtree to point to the interface symbol. */
7657 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7659 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7660 if (symtree && symtree->n.sym->generic)
7662 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7666 gfc_free_symbol (sym);
7667 symtree->n.sym->refs++;
7668 this_symtree->n.sym = symtree->n.sym;
7673 /* Otherwise give it a flavor according to such attributes as
7675 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7676 sym->attr.flavor = FL_VARIABLE;
7679 sym->attr.flavor = FL_PROCEDURE;
7680 if (sym->attr.dimension)
7681 sym->attr.function = 1;
7685 if (sym->attr.procedure && sym->interface
7686 && sym->attr.if_source != IFSRC_DECL)
7688 if (sym->interface->attr.procedure)
7689 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
7690 "in a later PROCEDURE statement", sym->interface->name,
7691 sym->name,&sym->declared_at);
7693 /* Get the attributes from the interface (now resolved). */
7694 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7696 sym->ts = sym->interface->ts;
7697 sym->attr.function = sym->interface->attr.function;
7698 sym->attr.subroutine = sym->interface->attr.subroutine;
7699 copy_formal_args (sym, sym->interface);
7701 else if (sym->interface->name[0] != '\0')
7703 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7704 sym->interface->name, sym->name, &sym->declared_at);
7709 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7712 /* Symbols that are module procedures with results (functions) have
7713 the types and array specification copied for type checking in
7714 procedures that call them, as well as for saving to a module
7715 file. These symbols can't stand the scrutiny that their results
7717 mp_flag = (sym->result != NULL && sym->result != sym);
7720 /* Make sure that the intrinsic is consistent with its internal
7721 representation. This needs to be done before assigning a default
7722 type to avoid spurious warnings. */
7723 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7725 if (gfc_intrinsic_name (sym->name, 0))
7727 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7728 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7729 sym->name, &sym->declared_at);
7731 else if (gfc_intrinsic_name (sym->name, 1))
7733 if (sym->ts.type != BT_UNKNOWN)
7735 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7736 sym->name, &sym->declared_at);
7742 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7747 /* Assign default type to symbols that need one and don't have one. */
7748 if (sym->ts.type == BT_UNKNOWN)
7750 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7751 gfc_set_default_type (sym, 1, NULL);
7753 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7755 /* The specific case of an external procedure should emit an error
7756 in the case that there is no implicit type. */
7758 gfc_set_default_type (sym, sym->attr.external, NULL);
7761 /* Result may be in another namespace. */
7762 resolve_symbol (sym->result);
7764 sym->ts = sym->result->ts;
7765 sym->as = gfc_copy_array_spec (sym->result->as);
7766 sym->attr.dimension = sym->result->attr.dimension;
7767 sym->attr.pointer = sym->result->attr.pointer;
7768 sym->attr.allocatable = sym->result->attr.allocatable;
7773 /* Assumed size arrays and assumed shape arrays must be dummy
7777 && (sym->as->type == AS_ASSUMED_SIZE
7778 || sym->as->type == AS_ASSUMED_SHAPE)
7779 && sym->attr.dummy == 0)
7781 if (sym->as->type == AS_ASSUMED_SIZE)
7782 gfc_error ("Assumed size array at %L must be a dummy argument",
7785 gfc_error ("Assumed shape array at %L must be a dummy argument",
7790 /* Make sure symbols with known intent or optional are really dummy
7791 variable. Because of ENTRY statement, this has to be deferred
7792 until resolution time. */
7794 if (!sym->attr.dummy
7795 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7797 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7801 if (sym->attr.value && !sym->attr.dummy)
7803 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7804 "it is not a dummy argument", sym->name, &sym->declared_at);
7808 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7810 gfc_charlen *cl = sym->ts.cl;
7811 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7813 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7814 "attribute must have constant length",
7815 sym->name, &sym->declared_at);
7819 if (sym->ts.is_c_interop
7820 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7822 gfc_error ("C interoperable character dummy variable '%s' at %L "
7823 "with VALUE attribute must have length one",
7824 sym->name, &sym->declared_at);
7829 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7830 do this for something that was implicitly typed because that is handled
7831 in gfc_set_default_type. Handle dummy arguments and procedure
7832 definitions separately. Also, anything that is use associated is not
7833 handled here but instead is handled in the module it is declared in.
7834 Finally, derived type definitions are allowed to be BIND(C) since that
7835 only implies that they're interoperable, and they are checked fully for
7836 interoperability when a variable is declared of that type. */
7837 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7838 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7839 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7843 /* First, make sure the variable is declared at the
7844 module-level scope (J3/04-007, Section 15.3). */
7845 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7846 sym->attr.in_common == 0)
7848 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7849 "is neither a COMMON block nor declared at the "
7850 "module level scope", sym->name, &(sym->declared_at));
7853 else if (sym->common_head != NULL)
7855 t = verify_com_block_vars_c_interop (sym->common_head);
7859 /* If type() declaration, we need to verify that the components
7860 of the given type are all C interoperable, etc. */
7861 if (sym->ts.type == BT_DERIVED &&
7862 sym->ts.derived->attr.is_c_interop != 1)
7864 /* Make sure the user marked the derived type as BIND(C). If
7865 not, call the verify routine. This could print an error
7866 for the derived type more than once if multiple variables
7867 of that type are declared. */
7868 if (sym->ts.derived->attr.is_bind_c != 1)
7869 verify_bind_c_derived_type (sym->ts.derived);
7873 /* Verify the variable itself as C interoperable if it
7874 is BIND(C). It is not possible for this to succeed if
7875 the verify_bind_c_derived_type failed, so don't have to handle
7876 any error returned by verify_bind_c_derived_type. */
7877 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7883 /* clear the is_bind_c flag to prevent reporting errors more than
7884 once if something failed. */
7885 sym->attr.is_bind_c = 0;
7890 /* If a derived type symbol has reached this point, without its
7891 type being declared, we have an error. Notice that most
7892 conditions that produce undefined derived types have already
7893 been dealt with. However, the likes of:
7894 implicit type(t) (t) ..... call foo (t) will get us here if
7895 the type is not declared in the scope of the implicit
7896 statement. Change the type to BT_UNKNOWN, both because it is so
7897 and to prevent an ICE. */
7898 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
7899 && !sym->ts.derived->attr.zero_comp)
7901 gfc_error ("The derived type '%s' at %L is of type '%s', "
7902 "which has not been defined", sym->name,
7903 &sym->declared_at, sym->ts.derived->name);
7904 sym->ts.type = BT_UNKNOWN;
7908 /* Unless the derived-type declaration is use associated, Fortran 95
7909 does not allow public entries of private derived types.
7910 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7912 if (sym->ts.type == BT_DERIVED
7913 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
7914 && !sym->ts.derived->attr.use_assoc
7915 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7916 && !gfc_check_access (sym->ts.derived->attr.access,
7917 sym->ts.derived->ns->default_access)
7918 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7919 "of PRIVATE derived type '%s'",
7920 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7921 : "variable", sym->name, &sym->declared_at,
7922 sym->ts.derived->name) == FAILURE)
7925 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7926 default initialization is defined (5.1.2.4.4). */
7927 if (sym->ts.type == BT_DERIVED
7929 && sym->attr.intent == INTENT_OUT
7931 && sym->as->type == AS_ASSUMED_SIZE)
7933 for (c = sym->ts.derived->components; c; c = c->next)
7937 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7938 "ASSUMED SIZE and so cannot have a default initializer",
7939 sym->name, &sym->declared_at);
7945 switch (sym->attr.flavor)
7948 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7953 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7958 if (resolve_fl_namelist (sym) == FAILURE)
7963 if (resolve_fl_parameter (sym) == FAILURE)
7971 /* Resolve array specifier. Check as well some constraints
7972 on COMMON blocks. */
7974 check_constant = sym->attr.in_common && !sym->attr.pointer;
7976 /* Set the formal_arg_flag so that check_conflict will not throw
7977 an error for host associated variables in the specification
7978 expression for an array_valued function. */
7979 if (sym->attr.function && sym->as)
7980 formal_arg_flag = 1;
7982 gfc_resolve_array_spec (sym->as, check_constant);
7984 formal_arg_flag = 0;
7986 /* Resolve formal namespaces. */
7987 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7988 gfc_resolve (sym->formal_ns);
7990 /* Check threadprivate restrictions. */
7991 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7992 && (!sym->attr.in_common
7993 && sym->module == NULL
7994 && (sym->ns->proc_name == NULL
7995 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7996 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7998 /* If we have come this far we can apply default-initializers, as
7999 described in 14.7.5, to those variables that have not already
8000 been assigned one. */
8001 if (sym->ts.type == BT_DERIVED
8002 && sym->attr.referenced
8003 && sym->ns == gfc_current_ns
8005 && !sym->attr.allocatable
8006 && !sym->attr.alloc_comp)
8008 symbol_attribute *a = &sym->attr;
8010 if ((!a->save && !a->dummy && !a->pointer
8011 && !a->in_common && !a->use_assoc
8012 && !(a->function && sym != sym->result))
8013 || (a->dummy && a->intent == INTENT_OUT))
8014 apply_default_init (sym);
8019 /************* Resolve DATA statements *************/
8023 gfc_data_value *vnode;
8029 /* Advance the values structure to point to the next value in the data list. */
8032 next_data_value (void)
8035 while (mpz_cmp_ui (values.left, 0) == 0)
8037 if (values.vnode->next == NULL)
8040 values.vnode = values.vnode->next;
8041 mpz_set (values.left, values.vnode->repeat);
8049 check_data_variable (gfc_data_variable *var, locus *where)
8055 ar_type mark = AR_UNKNOWN;
8057 mpz_t section_index[GFC_MAX_DIMENSIONS];
8061 if (gfc_resolve_expr (var->expr) == FAILURE)
8065 mpz_init_set_si (offset, 0);
8068 if (e->expr_type != EXPR_VARIABLE)
8069 gfc_internal_error ("check_data_variable(): Bad expression");
8071 if (e->symtree->n.sym->ns->is_block_data
8072 && !e->symtree->n.sym->attr.in_common)
8074 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8075 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
8078 if (e->ref == NULL && e->symtree->n.sym->as)
8080 gfc_error ("DATA array '%s' at %L must be specified in a previous"
8081 " declaration", e->symtree->n.sym->name, where);
8087 mpz_init_set_ui (size, 1);
8094 /* Find the array section reference. */
8095 for (ref = e->ref; ref; ref = ref->next)
8097 if (ref->type != REF_ARRAY)
8099 if (ref->u.ar.type == AR_ELEMENT)
8105 /* Set marks according to the reference pattern. */
8106 switch (ref->u.ar.type)
8114 /* Get the start position of array section. */
8115 gfc_get_section_index (ar, section_index, &offset);
8123 if (gfc_array_size (e, &size) == FAILURE)
8125 gfc_error ("Nonconstant array section at %L in DATA statement",
8134 while (mpz_cmp_ui (size, 0) > 0)
8136 if (next_data_value () == FAILURE)
8138 gfc_error ("DATA statement at %L has more variables than values",
8144 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
8148 /* If we have more than one element left in the repeat count,
8149 and we have more than one element left in the target variable,
8150 then create a range assignment. */
8151 /* FIXME: Only done for full arrays for now, since array sections
8153 if (mark == AR_FULL && ref && ref->next == NULL
8154 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
8158 if (mpz_cmp (size, values.left) >= 0)
8160 mpz_init_set (range, values.left);
8161 mpz_sub (size, size, values.left);
8162 mpz_set_ui (values.left, 0);
8166 mpz_init_set (range, size);
8167 mpz_sub (values.left, values.left, size);
8168 mpz_set_ui (size, 0);
8171 gfc_assign_data_value_range (var->expr, values.vnode->expr,
8174 mpz_add (offset, offset, range);
8178 /* Assign initial value to symbol. */
8181 mpz_sub_ui (values.left, values.left, 1);
8182 mpz_sub_ui (size, size, 1);
8184 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
8188 if (mark == AR_FULL)
8189 mpz_add_ui (offset, offset, 1);
8191 /* Modify the array section indexes and recalculate the offset
8192 for next element. */
8193 else if (mark == AR_SECTION)
8194 gfc_advance_section (section_index, ar, &offset);
8198 if (mark == AR_SECTION)
8200 for (i = 0; i < ar->dimen; i++)
8201 mpz_clear (section_index[i]);
8211 static try traverse_data_var (gfc_data_variable *, locus *);
8213 /* Iterate over a list of elements in a DATA statement. */
8216 traverse_data_list (gfc_data_variable *var, locus *where)
8219 iterator_stack frame;
8220 gfc_expr *e, *start, *end, *step;
8221 try retval = SUCCESS;
8223 mpz_init (frame.value);
8225 start = gfc_copy_expr (var->iter.start);
8226 end = gfc_copy_expr (var->iter.end);
8227 step = gfc_copy_expr (var->iter.step);
8229 if (gfc_simplify_expr (start, 1) == FAILURE
8230 || start->expr_type != EXPR_CONSTANT)
8232 gfc_error ("iterator start at %L does not simplify", &start->where);
8236 if (gfc_simplify_expr (end, 1) == FAILURE
8237 || end->expr_type != EXPR_CONSTANT)
8239 gfc_error ("iterator end at %L does not simplify", &end->where);
8243 if (gfc_simplify_expr (step, 1) == FAILURE
8244 || step->expr_type != EXPR_CONSTANT)
8246 gfc_error ("iterator step at %L does not simplify", &step->where);
8251 mpz_init_set (trip, end->value.integer);
8252 mpz_sub (trip, trip, start->value.integer);
8253 mpz_add (trip, trip, step->value.integer);
8255 mpz_div (trip, trip, step->value.integer);
8257 mpz_set (frame.value, start->value.integer);
8259 frame.prev = iter_stack;
8260 frame.variable = var->iter.var->symtree;
8261 iter_stack = &frame;
8263 while (mpz_cmp_ui (trip, 0) > 0)
8265 if (traverse_data_var (var->list, where) == FAILURE)
8272 e = gfc_copy_expr (var->expr);
8273 if (gfc_simplify_expr (e, 1) == FAILURE)
8281 mpz_add (frame.value, frame.value, step->value.integer);
8283 mpz_sub_ui (trip, trip, 1);
8288 mpz_clear (frame.value);
8290 gfc_free_expr (start);
8291 gfc_free_expr (end);
8292 gfc_free_expr (step);
8294 iter_stack = frame.prev;
8299 /* Type resolve variables in the variable list of a DATA statement. */
8302 traverse_data_var (gfc_data_variable *var, locus *where)
8306 for (; var; var = var->next)
8308 if (var->expr == NULL)
8309 t = traverse_data_list (var, where);
8311 t = check_data_variable (var, where);
8321 /* Resolve the expressions and iterators associated with a data statement.
8322 This is separate from the assignment checking because data lists should
8323 only be resolved once. */
8326 resolve_data_variables (gfc_data_variable *d)
8328 for (; d; d = d->next)
8330 if (d->list == NULL)
8332 if (gfc_resolve_expr (d->expr) == FAILURE)
8337 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8340 if (resolve_data_variables (d->list) == FAILURE)
8349 /* Resolve a single DATA statement. We implement this by storing a pointer to
8350 the value list into static variables, and then recursively traversing the
8351 variables list, expanding iterators and such. */
8354 resolve_data (gfc_data *d)
8357 if (resolve_data_variables (d->var) == FAILURE)
8360 values.vnode = d->value;
8361 if (d->value == NULL)
8362 mpz_set_ui (values.left, 0);
8364 mpz_set (values.left, d->value->repeat);
8366 if (traverse_data_var (d->var, &d->where) == FAILURE)
8369 /* At this point, we better not have any values left. */
8371 if (next_data_value () == SUCCESS)
8372 gfc_error ("DATA statement at %L has more values than variables",
8377 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8378 accessed by host or use association, is a dummy argument to a pure function,
8379 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8380 is storage associated with any such variable, shall not be used in the
8381 following contexts: (clients of this function). */
8383 /* Determines if a variable is not 'pure', ie not assignable within a pure
8384 procedure. Returns zero if assignment is OK, nonzero if there is a
8387 gfc_impure_variable (gfc_symbol *sym)
8391 if (sym->attr.use_assoc || sym->attr.in_common)
8394 if (sym->ns != gfc_current_ns)
8395 return !sym->attr.function;
8397 proc = sym->ns->proc_name;
8398 if (sym->attr.dummy && gfc_pure (proc)
8399 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8401 proc->attr.function))
8404 /* TODO: Sort out what can be storage associated, if anything, and include
8405 it here. In principle equivalences should be scanned but it does not
8406 seem to be possible to storage associate an impure variable this way. */
8411 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8412 symbol of the current procedure. */
8415 gfc_pure (gfc_symbol *sym)
8417 symbol_attribute attr;
8420 sym = gfc_current_ns->proc_name;
8426 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8430 /* Test whether the current procedure is elemental or not. */
8433 gfc_elemental (gfc_symbol *sym)
8435 symbol_attribute attr;
8438 sym = gfc_current_ns->proc_name;
8443 return attr.flavor == FL_PROCEDURE && attr.elemental;
8447 /* Warn about unused labels. */
8450 warn_unused_fortran_label (gfc_st_label *label)
8455 warn_unused_fortran_label (label->left);
8457 if (label->defined == ST_LABEL_UNKNOWN)
8460 switch (label->referenced)
8462 case ST_LABEL_UNKNOWN:
8463 gfc_warning ("Label %d at %L defined but not used", label->value,
8467 case ST_LABEL_BAD_TARGET:
8468 gfc_warning ("Label %d at %L defined but cannot be used",
8469 label->value, &label->where);
8476 warn_unused_fortran_label (label->right);
8480 /* Returns the sequence type of a symbol or sequence. */
8483 sequence_type (gfc_typespec ts)
8492 if (ts.derived->components == NULL)
8493 return SEQ_NONDEFAULT;
8495 result = sequence_type (ts.derived->components->ts);
8496 for (c = ts.derived->components->next; c; c = c->next)
8497 if (sequence_type (c->ts) != result)
8503 if (ts.kind != gfc_default_character_kind)
8504 return SEQ_NONDEFAULT;
8506 return SEQ_CHARACTER;
8509 if (ts.kind != gfc_default_integer_kind)
8510 return SEQ_NONDEFAULT;
8515 if (!(ts.kind == gfc_default_real_kind
8516 || ts.kind == gfc_default_double_kind))
8517 return SEQ_NONDEFAULT;
8522 if (ts.kind != gfc_default_complex_kind)
8523 return SEQ_NONDEFAULT;
8528 if (ts.kind != gfc_default_logical_kind)
8529 return SEQ_NONDEFAULT;
8534 return SEQ_NONDEFAULT;
8539 /* Resolve derived type EQUIVALENCE object. */
8542 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8545 gfc_component *c = derived->components;
8550 /* Shall not be an object of nonsequence derived type. */
8551 if (!derived->attr.sequence)
8553 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8554 "attribute to be an EQUIVALENCE object", sym->name,
8559 /* Shall not have allocatable components. */
8560 if (derived->attr.alloc_comp)
8562 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8563 "components to be an EQUIVALENCE object",sym->name,
8568 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
8570 gfc_error ("Derived type variable '%s' at %L with default "
8571 "initialization cannot be in EQUIVALENCE with a variable "
8572 "in COMMON", sym->name, &e->where);
8576 for (; c ; c = c->next)
8580 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8583 /* Shall not be an object of sequence derived type containing a pointer
8584 in the structure. */
8587 gfc_error ("Derived type variable '%s' at %L with pointer "
8588 "component(s) cannot be an EQUIVALENCE object",
8589 sym->name, &e->where);
8597 /* Resolve equivalence object.
8598 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8599 an allocatable array, an object of nonsequence derived type, an object of
8600 sequence derived type containing a pointer at any level of component
8601 selection, an automatic object, a function name, an entry name, a result
8602 name, a named constant, a structure component, or a subobject of any of
8603 the preceding objects. A substring shall not have length zero. A
8604 derived type shall not have components with default initialization nor
8605 shall two objects of an equivalence group be initialized.
8606 Either all or none of the objects shall have an protected attribute.
8607 The simple constraints are done in symbol.c(check_conflict) and the rest
8608 are implemented here. */
8611 resolve_equivalence (gfc_equiv *eq)
8614 gfc_symbol *derived;
8615 gfc_symbol *first_sym;
8618 locus *last_where = NULL;
8619 seq_type eq_type, last_eq_type;
8620 gfc_typespec *last_ts;
8621 int object, cnt_protected;
8622 const char *value_name;
8626 last_ts = &eq->expr->symtree->n.sym->ts;
8628 first_sym = eq->expr->symtree->n.sym;
8632 for (object = 1; eq; eq = eq->eq, object++)
8636 e->ts = e->symtree->n.sym->ts;
8637 /* match_varspec might not know yet if it is seeing
8638 array reference or substring reference, as it doesn't
8640 if (e->ref && e->ref->type == REF_ARRAY)
8642 gfc_ref *ref = e->ref;
8643 sym = e->symtree->n.sym;
8645 if (sym->attr.dimension)
8647 ref->u.ar.as = sym->as;
8651 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8652 if (e->ts.type == BT_CHARACTER
8654 && ref->type == REF_ARRAY
8655 && ref->u.ar.dimen == 1
8656 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8657 && ref->u.ar.stride[0] == NULL)
8659 gfc_expr *start = ref->u.ar.start[0];
8660 gfc_expr *end = ref->u.ar.end[0];
8663 /* Optimize away the (:) reference. */
8664 if (start == NULL && end == NULL)
8669 e->ref->next = ref->next;
8674 ref->type = REF_SUBSTRING;
8676 start = gfc_int_expr (1);
8677 ref->u.ss.start = start;
8678 if (end == NULL && e->ts.cl)
8679 end = gfc_copy_expr (e->ts.cl->length);
8680 ref->u.ss.end = end;
8681 ref->u.ss.length = e->ts.cl;
8688 /* Any further ref is an error. */
8691 gcc_assert (ref->type == REF_ARRAY);
8692 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8698 if (gfc_resolve_expr (e) == FAILURE)
8701 sym = e->symtree->n.sym;
8703 if (sym->attr.protected)
8705 if (cnt_protected > 0 && cnt_protected != object)
8707 gfc_error ("Either all or none of the objects in the "
8708 "EQUIVALENCE set at %L shall have the "
8709 "PROTECTED attribute",
8714 /* Shall not equivalence common block variables in a PURE procedure. */
8715 if (sym->ns->proc_name
8716 && sym->ns->proc_name->attr.pure
8717 && sym->attr.in_common)
8719 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8720 "object in the pure procedure '%s'",
8721 sym->name, &e->where, sym->ns->proc_name->name);
8725 /* Shall not be a named constant. */
8726 if (e->expr_type == EXPR_CONSTANT)
8728 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8729 "object", sym->name, &e->where);
8733 derived = e->ts.derived;
8734 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8737 /* Check that the types correspond correctly:
8739 A numeric sequence structure may be equivalenced to another sequence
8740 structure, an object of default integer type, default real type, double
8741 precision real type, default logical type such that components of the
8742 structure ultimately only become associated to objects of the same
8743 kind. A character sequence structure may be equivalenced to an object
8744 of default character kind or another character sequence structure.
8745 Other objects may be equivalenced only to objects of the same type and
8748 /* Identical types are unconditionally OK. */
8749 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8750 goto identical_types;
8752 last_eq_type = sequence_type (*last_ts);
8753 eq_type = sequence_type (sym->ts);
8755 /* Since the pair of objects is not of the same type, mixed or
8756 non-default sequences can be rejected. */
8758 msg = "Sequence %s with mixed components in EQUIVALENCE "
8759 "statement at %L with different type objects";
8761 && last_eq_type == SEQ_MIXED
8762 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8764 || (eq_type == SEQ_MIXED
8765 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8766 &e->where) == FAILURE))
8769 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8770 "statement at %L with objects of different type";
8772 && last_eq_type == SEQ_NONDEFAULT
8773 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8774 last_where) == FAILURE)
8775 || (eq_type == SEQ_NONDEFAULT
8776 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8777 &e->where) == FAILURE))
8780 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8781 "EQUIVALENCE statement at %L";
8782 if (last_eq_type == SEQ_CHARACTER
8783 && eq_type != SEQ_CHARACTER
8784 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8785 &e->where) == FAILURE)
8788 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8789 "EQUIVALENCE statement at %L";
8790 if (last_eq_type == SEQ_NUMERIC
8791 && eq_type != SEQ_NUMERIC
8792 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8793 &e->where) == FAILURE)
8798 last_where = &e->where;
8803 /* Shall not be an automatic array. */
8804 if (e->ref->type == REF_ARRAY
8805 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8807 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8808 "an EQUIVALENCE object", sym->name, &e->where);
8815 /* Shall not be a structure component. */
8816 if (r->type == REF_COMPONENT)
8818 gfc_error ("Structure component '%s' at %L cannot be an "
8819 "EQUIVALENCE object",
8820 r->u.c.component->name, &e->where);
8824 /* A substring shall not have length zero. */
8825 if (r->type == REF_SUBSTRING)
8827 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8829 gfc_error ("Substring at %L has length zero",
8830 &r->u.ss.start->where);
8840 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8843 resolve_fntype (gfc_namespace *ns)
8848 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8851 /* If there are any entries, ns->proc_name is the entry master
8852 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8854 sym = ns->entries->sym;
8856 sym = ns->proc_name;
8857 if (sym->result == sym
8858 && sym->ts.type == BT_UNKNOWN
8859 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8860 && !sym->attr.untyped)
8862 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8863 sym->name, &sym->declared_at);
8864 sym->attr.untyped = 1;
8867 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8868 && !gfc_check_access (sym->ts.derived->attr.access,
8869 sym->ts.derived->ns->default_access)
8870 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8872 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8873 sym->name, &sym->declared_at, sym->ts.derived->name);
8877 for (el = ns->entries->next; el; el = el->next)
8879 if (el->sym->result == el->sym
8880 && el->sym->ts.type == BT_UNKNOWN
8881 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8882 && !el->sym->attr.untyped)
8884 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8885 el->sym->name, &el->sym->declared_at);
8886 el->sym->attr.untyped = 1;
8891 /* 12.3.2.1.1 Defined operators. */
8894 gfc_resolve_uops (gfc_symtree *symtree)
8898 gfc_formal_arglist *formal;
8900 if (symtree == NULL)
8903 gfc_resolve_uops (symtree->left);
8904 gfc_resolve_uops (symtree->right);
8906 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8909 if (!sym->attr.function)
8910 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8911 sym->name, &sym->declared_at);
8913 if (sym->ts.type == BT_CHARACTER
8914 && !(sym->ts.cl && sym->ts.cl->length)
8915 && !(sym->result && sym->result->ts.cl
8916 && sym->result->ts.cl->length))
8917 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8918 "character length", sym->name, &sym->declared_at);
8920 formal = sym->formal;
8921 if (!formal || !formal->sym)
8923 gfc_error ("User operator procedure '%s' at %L must have at least "
8924 "one argument", sym->name, &sym->declared_at);
8928 if (formal->sym->attr.intent != INTENT_IN)
8929 gfc_error ("First argument of operator interface at %L must be "
8930 "INTENT(IN)", &sym->declared_at);
8932 if (formal->sym->attr.optional)
8933 gfc_error ("First argument of operator interface at %L cannot be "
8934 "optional", &sym->declared_at);
8936 formal = formal->next;
8937 if (!formal || !formal->sym)
8940 if (formal->sym->attr.intent != INTENT_IN)
8941 gfc_error ("Second argument of operator interface at %L must be "
8942 "INTENT(IN)", &sym->declared_at);
8944 if (formal->sym->attr.optional)
8945 gfc_error ("Second argument of operator interface at %L cannot be "
8946 "optional", &sym->declared_at);
8949 gfc_error ("Operator interface at %L must have, at most, two "
8950 "arguments", &sym->declared_at);
8955 /* Examine all of the expressions associated with a program unit,
8956 assign types to all intermediate expressions, make sure that all
8957 assignments are to compatible types and figure out which names
8958 refer to which functions or subroutines. It doesn't check code
8959 block, which is handled by resolve_code. */
8962 resolve_types (gfc_namespace *ns)
8969 gfc_current_ns = ns;
8971 resolve_entries (ns);
8973 resolve_common_vars (ns->blank_common.head, false);
8974 resolve_common_blocks (ns->common_root);
8976 resolve_contained_functions (ns);
8978 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8980 for (cl = ns->cl_list; cl; cl = cl->next)
8981 resolve_charlen (cl);
8983 gfc_traverse_ns (ns, resolve_symbol);
8985 resolve_fntype (ns);
8987 for (n = ns->contained; n; n = n->sibling)
8989 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8990 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8991 "also be PURE", n->proc_name->name,
8992 &n->proc_name->declared_at);
8998 gfc_check_interfaces (ns);
9000 gfc_traverse_ns (ns, resolve_values);
9006 for (d = ns->data; d; d = d->next)
9010 gfc_traverse_ns (ns, gfc_formalize_init_value);
9012 gfc_traverse_ns (ns, gfc_verify_binding_labels);
9014 if (ns->common_root != NULL)
9015 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
9017 for (eq = ns->equiv; eq; eq = eq->next)
9018 resolve_equivalence (eq);
9020 /* Warn about unused labels. */
9021 if (warn_unused_label)
9022 warn_unused_fortran_label (ns->st_labels);
9024 gfc_resolve_uops (ns->uop_root);
9028 /* Call resolve_code recursively. */
9031 resolve_codes (gfc_namespace *ns)
9035 for (n = ns->contained; n; n = n->sibling)
9038 gfc_current_ns = ns;
9040 /* Set to an out of range value. */
9041 current_entry_id = -1;
9043 bitmap_obstack_initialize (&labels_obstack);
9044 resolve_code (ns->code, ns);
9045 bitmap_obstack_release (&labels_obstack);
9049 /* This function is called after a complete program unit has been compiled.
9050 Its purpose is to examine all of the expressions associated with a program
9051 unit, assign types to all intermediate expressions, make sure that all
9052 assignments are to compatible types and figure out which names refer to
9053 which functions or subroutines. */
9056 gfc_resolve (gfc_namespace *ns)
9058 gfc_namespace *old_ns;
9060 old_ns = gfc_current_ns;
9065 gfc_current_ns = old_ns;