1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "bitmap.h"
26 #include "gfortran.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
29 #include "data.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
32
33 /* Types used in equivalence statements. */
34
35 enum seq_type
36 {
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 };
39
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
42
43 typedef struct code_stack
44 {
45 struct gfc_code *head, *current;
46 struct code_stack *prev;
47
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
50 blocks. */
51 bitmap reachable_labels;
52 }
53 code_stack;
54
55 static code_stack *cs_base = NULL;
56
57
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
59
60 static int forall_flag;
61 int gfc_do_concurrent_flag;
62
63 /* True when we are resolving an expression that is an actual argument to
64 a procedure. */
65 static bool actual_arg = false;
66 /* True when we are resolving an expression that is the first actual argument
67 to a procedure. */
68 static bool first_actual_arg = false;
69
70
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
72
73 static int omp_workshare_flag;
74
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag = false;
78
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr = false;
81
82 /* The id of the last entry seen. */
83 static int current_entry_id;
84
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack;
87
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument = false;
90
91
92 bool
gfc_is_formal_arg(void)93 gfc_is_formal_arg (void)
94 {
95 return formal_arg_flag;
96 }
97
98 /* Is the symbol host associated? */
99 static bool
is_sym_host_assoc(gfc_symbol * sym,gfc_namespace * ns)100 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101 {
102 for (ns = ns->parent; ns; ns = ns->parent)
103 {
104 if (sym->ns == ns)
105 return true;
106 }
107
108 return false;
109 }
110
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
114
115 static bool
resolve_typespec_used(gfc_typespec * ts,locus * where,const char * name)116 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117 {
118 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
119 {
120 if (where)
121 {
122 if (name)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name, where, ts->u.derived->name);
125 else
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts->u.derived->name, where);
128 }
129
130 return false;
131 }
132
133 return true;
134 }
135
136
137 static bool
check_proc_interface(gfc_symbol * ifc,locus * where)138 check_proc_interface (gfc_symbol *ifc, locus *where)
139 {
140 /* Several checks for F08:C1216. */
141 if (ifc->attr.procedure)
142 {
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc->name, where);
145 return false;
146 }
147 if (ifc->generic)
148 {
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface *gen = ifc->generic;
152 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
153 gen = gen->next;
154 if (!gen)
155 {
156 gfc_error ("Interface %qs at %L may not be generic",
157 ifc->name, where);
158 return false;
159 }
160 }
161 if (ifc->attr.proc == PROC_ST_FUNCTION)
162 {
163 gfc_error ("Interface %qs at %L may not be a statement function",
164 ifc->name, where);
165 return false;
166 }
167 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
168 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
169 ifc->attr.intrinsic = 1;
170 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
171 {
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc->name, where);
174 return false;
175 }
176 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
177 {
178 gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
179 return false;
180 }
181 return true;
182 }
183
184
185 static void resolve_symbol (gfc_symbol *sym);
186
187
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
189
190 static bool
resolve_procedure_interface(gfc_symbol * sym)191 resolve_procedure_interface (gfc_symbol *sym)
192 {
193 gfc_symbol *ifc = sym->ts.interface;
194
195 if (!ifc)
196 return true;
197
198 if (ifc == sym)
199 {
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym->name, &sym->declared_at);
202 return false;
203 }
204 if (!check_proc_interface (ifc, &sym->declared_at))
205 return false;
206
207 if (ifc->attr.if_source || ifc->attr.intrinsic)
208 {
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc);
211 if (ifc->attr.intrinsic)
212 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
213
214 if (ifc->result)
215 {
216 sym->ts = ifc->result->ts;
217 sym->attr.allocatable = ifc->result->attr.allocatable;
218 sym->attr.pointer = ifc->result->attr.pointer;
219 sym->attr.dimension = ifc->result->attr.dimension;
220 sym->attr.class_ok = ifc->result->attr.class_ok;
221 sym->as = gfc_copy_array_spec (ifc->result->as);
222 sym->result = sym;
223 }
224 else
225 {
226 sym->ts = ifc->ts;
227 sym->attr.allocatable = ifc->attr.allocatable;
228 sym->attr.pointer = ifc->attr.pointer;
229 sym->attr.dimension = ifc->attr.dimension;
230 sym->attr.class_ok = ifc->attr.class_ok;
231 sym->as = gfc_copy_array_spec (ifc->as);
232 }
233 sym->ts.interface = ifc;
234 sym->attr.function = ifc->attr.function;
235 sym->attr.subroutine = ifc->attr.subroutine;
236
237 sym->attr.pure = ifc->attr.pure;
238 sym->attr.elemental = ifc->attr.elemental;
239 sym->attr.contiguous = ifc->attr.contiguous;
240 sym->attr.recursive = ifc->attr.recursive;
241 sym->attr.always_explicit = ifc->attr.always_explicit;
242 sym->attr.ext_attr |= ifc->attr.ext_attr;
243 sym->attr.is_bind_c = ifc->attr.is_bind_c;
244 /* Copy char length. */
245 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
246 {
247 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
248 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
249 && !gfc_resolve_expr (sym->ts.u.cl->length))
250 return false;
251 }
252 }
253
254 return true;
255 }
256
257
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
263
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
266
267 static void
resolve_formal_arglist(gfc_symbol * proc)268 resolve_formal_arglist (gfc_symbol *proc)
269 {
270 gfc_formal_arglist *f;
271 gfc_symbol *sym;
272 bool saved_specification_expr;
273 int i;
274
275 if (proc->result != NULL)
276 sym = proc->result;
277 else
278 sym = proc;
279
280 if (gfc_elemental (proc)
281 || sym->attr.pointer || sym->attr.allocatable
282 || (sym->as && sym->as->rank != 0))
283 {
284 proc->attr.always_explicit = 1;
285 sym->attr.always_explicit = 1;
286 }
287
288 formal_arg_flag = true;
289
290 for (f = proc->formal; f; f = f->next)
291 {
292 gfc_array_spec *as;
293
294 sym = f->sym;
295
296 if (sym == NULL)
297 {
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc->name,
302 &proc->declared_at);
303 if (proc->attr.function)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc->name,
306 &proc->declared_at);
307 continue;
308 }
309 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310 && !resolve_procedure_interface (sym))
311 return;
312
313 if (strcmp (proc->name, sym->name) == 0)
314 {
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym->name,
317 &proc->declared_at);
318 return;
319 }
320
321 if (sym->attr.if_source != IFSRC_UNKNOWN)
322 resolve_formal_arglist (sym);
323
324 if (sym->attr.subroutine || sym->attr.external)
325 {
326 if (sym->attr.flavor == FL_UNKNOWN)
327 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328 }
329 else
330 {
331 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 && (!sym->attr.function || sym->result == sym))
333 gfc_set_default_type (sym, 1, sym->ns);
334 }
335
336 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 ? CLASS_DATA (sym)->as : sym->as;
338
339 saved_specification_expr = specification_expr;
340 specification_expr = true;
341 gfc_resolve_array_spec (as, 0);
342 specification_expr = saved_specification_expr;
343
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
346 */
347 if (as && as->rank > 0 && as->type == AS_DEFERRED
348 && ((sym->ts.type != BT_CLASS
349 && !(sym->attr.pointer || sym->attr.allocatable))
350 || (sym->ts.type == BT_CLASS
351 && !(CLASS_DATA (sym)->attr.class_pointer
352 || CLASS_DATA (sym)->attr.allocatable)))
353 && sym->attr.flavor != FL_PROCEDURE)
354 {
355 as->type = AS_ASSUMED_SHAPE;
356 for (i = 0; i < as->rank; i++)
357 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
358 }
359
360 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361 || (as && as->type == AS_ASSUMED_RANK)
362 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 && (CLASS_DATA (sym)->attr.class_pointer
365 || CLASS_DATA (sym)->attr.allocatable
366 || CLASS_DATA (sym)->attr.target))
367 || sym->attr.optional)
368 {
369 proc->attr.always_explicit = 1;
370 if (proc->result)
371 proc->result->attr.always_explicit = 1;
372 }
373
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
376
377 if (sym->attr.flavor == FL_UNKNOWN)
378 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379
380 if (gfc_pure (proc))
381 {
382 if (sym->attr.flavor == FL_PROCEDURE)
383 {
384 /* F08:C1279. */
385 if (!gfc_pure (sym))
386 {
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym->name, &sym->declared_at);
389 continue;
390 }
391 }
392 else if (!sym->attr.pointer)
393 {
394 if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 {
396 if (sym->attr.value)
397 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym->name, proc->name, &sym->declared_at);
401 else
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym->name, proc->name,
404 &sym->declared_at);
405 }
406
407 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 {
409 if (sym->attr.value)
410 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym->name,
413 proc->name, &sym->declared_at);
414 else
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym->name, proc->name,
418 &sym->declared_at);
419 }
420 }
421
422 /* F08:C1278a. */
423 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 {
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym->name, proc->name,
427 &sym->declared_at);
428 continue;
429 }
430 }
431
432 if (proc->attr.implicit_pure)
433 {
434 if (sym->attr.flavor == FL_PROCEDURE)
435 {
436 if (!gfc_pure (sym))
437 proc->attr.implicit_pure = 0;
438 }
439 else if (!sym->attr.pointer)
440 {
441 if (proc->attr.function && sym->attr.intent != INTENT_IN
442 && !sym->value)
443 proc->attr.implicit_pure = 0;
444
445 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 && !sym->value)
447 proc->attr.implicit_pure = 0;
448 }
449 }
450
451 if (gfc_elemental (proc))
452 {
453 /* F08:C1289. */
454 if (sym->attr.codimension
455 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456 && CLASS_DATA (sym)->attr.codimension))
457 {
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym->name, &sym->declared_at);
460 continue;
461 }
462
463 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464 && CLASS_DATA (sym)->as))
465 {
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym->name, &sym->declared_at);
468 continue;
469 }
470
471 if (sym->attr.allocatable
472 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473 && CLASS_DATA (sym)->attr.allocatable))
474 {
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym->name,
477 &sym->declared_at);
478 continue;
479 }
480
481 if (sym->attr.pointer
482 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483 && CLASS_DATA (sym)->attr.class_pointer))
484 {
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym->name,
487 &sym->declared_at);
488 continue;
489 }
490
491 if (sym->attr.flavor == FL_PROCEDURE)
492 {
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym->name, proc->name,
495 &sym->declared_at);
496 continue;
497 }
498
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501 {
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym->name, proc->name,
505 &sym->declared_at);
506 continue;
507 }
508 }
509
510 /* Each dummy shall be specified to be scalar. */
511 if (proc->attr.proc == PROC_ST_FUNCTION)
512 {
513 if (sym->as != NULL)
514 {
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym->name, proc->name,
519 &proc->declared_at);
520 continue;
521 }
522
523 if (sym->ts.type == BT_CHARACTER)
524 {
525 gfc_charlen *cl = sym->ts.u.cl;
526 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 {
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym->name, &sym->declared_at);
531 continue;
532 }
533 }
534 }
535 }
536 formal_arg_flag = false;
537 }
538
539
540 /* Work function called when searching for symbols that have argument lists
541 associated with them. */
542
543 static void
find_arglists(gfc_symbol * sym)544 find_arglists (gfc_symbol *sym)
545 {
546 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
547 || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
548 return;
549
550 resolve_formal_arglist (sym);
551 }
552
553
554 /* Given a namespace, resolve all formal argument lists within the namespace.
555 */
556
557 static void
resolve_formal_arglists(gfc_namespace * ns)558 resolve_formal_arglists (gfc_namespace *ns)
559 {
560 if (ns == NULL)
561 return;
562
563 gfc_traverse_ns (ns, find_arglists);
564 }
565
566
567 static void
resolve_contained_fntype(gfc_symbol * sym,gfc_namespace * ns)568 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
569 {
570 bool t;
571
572 if (sym && sym->attr.flavor == FL_PROCEDURE
573 && sym->ns->parent
574 && sym->ns->parent->proc_name
575 && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
576 && !strcmp (sym->name, sym->ns->parent->proc_name->name))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym->name, &sym->declared_at);
579
580 /* If this namespace is not a function or an entry master function,
581 ignore it. */
582 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
583 || sym->attr.entry_master)
584 return;
585
586 /* Try to find out of what the return type is. */
587 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
588 {
589 t = gfc_set_default_type (sym->result, 0, ns);
590
591 if (!t && !sym->result->attr.untyped)
592 {
593 if (sym->result == sym)
594 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
595 sym->name, &sym->declared_at);
596 else if (!sym->result->attr.proc_pointer)
597 gfc_error ("Result %qs of contained function %qs at %L has "
598 "no IMPLICIT type", sym->result->name, sym->name,
599 &sym->result->declared_at);
600 sym->result->attr.untyped = 1;
601 }
602 }
603
604 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
605 type, lists the only ways a character length value of * can be used:
606 dummy arguments of procedures, named constants, and function results
607 in external functions. Internal function results and results of module
608 procedures are not on this list, ergo, not permitted. */
609
610 if (sym->result->ts.type == BT_CHARACTER)
611 {
612 gfc_charlen *cl = sym->result->ts.u.cl;
613 if ((!cl || !cl->length) && !sym->result->ts.deferred)
614 {
615 /* See if this is a module-procedure and adapt error message
616 accordingly. */
617 bool module_proc;
618 gcc_assert (ns->parent && ns->parent->proc_name);
619 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
620
621 gfc_error (module_proc
622 ? G_("Character-valued module procedure %qs at %L"
623 " must not be assumed length")
624 : G_("Character-valued internal function %qs at %L"
625 " must not be assumed length"),
626 sym->name, &sym->declared_at);
627 }
628 }
629 }
630
631
632 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
633 introduce duplicates. */
634
635 static void
merge_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)636 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
637 {
638 gfc_formal_arglist *f, *new_arglist;
639 gfc_symbol *new_sym;
640
641 for (; new_args != NULL; new_args = new_args->next)
642 {
643 new_sym = new_args->sym;
644 /* See if this arg is already in the formal argument list. */
645 for (f = proc->formal; f; f = f->next)
646 {
647 if (new_sym == f->sym)
648 break;
649 }
650
651 if (f)
652 continue;
653
654 /* Add a new argument. Argument order is not important. */
655 new_arglist = gfc_get_formal_arglist ();
656 new_arglist->sym = new_sym;
657 new_arglist->next = proc->formal;
658 proc->formal = new_arglist;
659 }
660 }
661
662
663 /* Flag the arguments that are not present in all entries. */
664
665 static void
check_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)666 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
667 {
668 gfc_formal_arglist *f, *head;
669 head = new_args;
670
671 for (f = proc->formal; f; f = f->next)
672 {
673 if (f->sym == NULL)
674 continue;
675
676 for (new_args = head; new_args; new_args = new_args->next)
677 {
678 if (new_args->sym == f->sym)
679 break;
680 }
681
682 if (new_args)
683 continue;
684
685 f->sym->attr.not_always_present = 1;
686 }
687 }
688
689
690 /* Resolve alternate entry points. If a symbol has multiple entry points we
691 create a new master symbol for the main routine, and turn the existing
692 symbol into an entry point. */
693
694 static void
resolve_entries(gfc_namespace * ns)695 resolve_entries (gfc_namespace *ns)
696 {
697 gfc_namespace *old_ns;
698 gfc_code *c;
699 gfc_symbol *proc;
700 gfc_entry_list *el;
701 char name[GFC_MAX_SYMBOL_LEN + 1];
702 static int master_count = 0;
703
704 if (ns->proc_name == NULL)
705 return;
706
707 /* No need to do anything if this procedure doesn't have alternate entry
708 points. */
709 if (!ns->entries)
710 return;
711
712 /* We may already have resolved alternate entry points. */
713 if (ns->proc_name->attr.entry_master)
714 return;
715
716 /* If this isn't a procedure something has gone horribly wrong. */
717 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
718
719 /* Remember the current namespace. */
720 old_ns = gfc_current_ns;
721
722 gfc_current_ns = ns;
723
724 /* Add the main entry point to the list of entry points. */
725 el = gfc_get_entry_list ();
726 el->sym = ns->proc_name;
727 el->id = 0;
728 el->next = ns->entries;
729 ns->entries = el;
730 ns->proc_name->attr.entry = 1;
731
732 /* If it is a module function, it needs to be in the right namespace
733 so that gfc_get_fake_result_decl can gather up the results. The
734 need for this arose in get_proc_name, where these beasts were
735 left in their own namespace, to keep prior references linked to
736 the entry declaration.*/
737 if (ns->proc_name->attr.function
738 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
739 el->sym->ns = ns;
740
741 /* Do the same for entries where the master is not a module
742 procedure. These are retained in the module namespace because
743 of the module procedure declaration. */
744 for (el = el->next; el; el = el->next)
745 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
746 && el->sym->attr.mod_proc)
747 el->sym->ns = ns;
748 el = ns->entries;
749
750 /* Add an entry statement for it. */
751 c = gfc_get_code (EXEC_ENTRY);
752 c->ext.entry = el;
753 c->next = ns->code;
754 ns->code = c;
755
756 /* Create a new symbol for the master function. */
757 /* Give the internal function a unique name (within this file).
758 Also include the function name so the user has some hope of figuring
759 out what is going on. */
760 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
761 master_count++, ns->proc_name->name);
762 gfc_get_ha_symbol (name, &proc);
763 gcc_assert (proc != NULL);
764
765 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
766 if (ns->proc_name->attr.subroutine)
767 gfc_add_subroutine (&proc->attr, proc->name, NULL);
768 else
769 {
770 gfc_symbol *sym;
771 gfc_typespec *ts, *fts;
772 gfc_array_spec *as, *fas;
773 gfc_add_function (&proc->attr, proc->name, NULL);
774 proc->result = proc;
775 fas = ns->entries->sym->as;
776 fas = fas ? fas : ns->entries->sym->result->as;
777 fts = &ns->entries->sym->result->ts;
778 if (fts->type == BT_UNKNOWN)
779 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
780 for (el = ns->entries->next; el; el = el->next)
781 {
782 ts = &el->sym->result->ts;
783 as = el->sym->as;
784 as = as ? as : el->sym->result->as;
785 if (ts->type == BT_UNKNOWN)
786 ts = gfc_get_default_type (el->sym->result->name, NULL);
787
788 if (! gfc_compare_types (ts, fts)
789 || (el->sym->result->attr.dimension
790 != ns->entries->sym->result->attr.dimension)
791 || (el->sym->result->attr.pointer
792 != ns->entries->sym->result->attr.pointer))
793 break;
794 else if (as && fas && ns->entries->sym->result != el->sym->result
795 && gfc_compare_array_spec (as, fas) == 0)
796 gfc_error ("Function %s at %L has entries with mismatched "
797 "array specifications", ns->entries->sym->name,
798 &ns->entries->sym->declared_at);
799 /* The characteristics need to match and thus both need to have
800 the same string length, i.e. both len=*, or both len=4.
801 Having both len=<variable> is also possible, but difficult to
802 check at compile time. */
803 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
804 && (((ts->u.cl->length && !fts->u.cl->length)
805 ||(!ts->u.cl->length && fts->u.cl->length))
806 || (ts->u.cl->length
807 && ts->u.cl->length->expr_type
808 != fts->u.cl->length->expr_type)
809 || (ts->u.cl->length
810 && ts->u.cl->length->expr_type == EXPR_CONSTANT
811 && mpz_cmp (ts->u.cl->length->value.integer,
812 fts->u.cl->length->value.integer) != 0)))
813 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
814 "entries returning variables of different "
815 "string lengths", ns->entries->sym->name,
816 &ns->entries->sym->declared_at);
817 }
818
819 if (el == NULL)
820 {
821 sym = ns->entries->sym->result;
822 /* All result types the same. */
823 proc->ts = *fts;
824 if (sym->attr.dimension)
825 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
826 if (sym->attr.pointer)
827 gfc_add_pointer (&proc->attr, NULL);
828 }
829 else
830 {
831 /* Otherwise the result will be passed through a union by
832 reference. */
833 proc->attr.mixed_entry_master = 1;
834 for (el = ns->entries; el; el = el->next)
835 {
836 sym = el->sym->result;
837 if (sym->attr.dimension)
838 {
839 if (el == ns->entries)
840 gfc_error ("FUNCTION result %s can't be an array in "
841 "FUNCTION %s at %L", sym->name,
842 ns->entries->sym->name, &sym->declared_at);
843 else
844 gfc_error ("ENTRY result %s can't be an array in "
845 "FUNCTION %s at %L", sym->name,
846 ns->entries->sym->name, &sym->declared_at);
847 }
848 else if (sym->attr.pointer)
849 {
850 if (el == ns->entries)
851 gfc_error ("FUNCTION result %s can't be a POINTER in "
852 "FUNCTION %s at %L", sym->name,
853 ns->entries->sym->name, &sym->declared_at);
854 else
855 gfc_error ("ENTRY result %s can't be a POINTER in "
856 "FUNCTION %s at %L", sym->name,
857 ns->entries->sym->name, &sym->declared_at);
858 }
859 else
860 {
861 ts = &sym->ts;
862 if (ts->type == BT_UNKNOWN)
863 ts = gfc_get_default_type (sym->name, NULL);
864 switch (ts->type)
865 {
866 case BT_INTEGER:
867 if (ts->kind == gfc_default_integer_kind)
868 sym = NULL;
869 break;
870 case BT_REAL:
871 if (ts->kind == gfc_default_real_kind
872 || ts->kind == gfc_default_double_kind)
873 sym = NULL;
874 break;
875 case BT_COMPLEX:
876 if (ts->kind == gfc_default_complex_kind)
877 sym = NULL;
878 break;
879 case BT_LOGICAL:
880 if (ts->kind == gfc_default_logical_kind)
881 sym = NULL;
882 break;
883 case BT_UNKNOWN:
884 /* We will issue error elsewhere. */
885 sym = NULL;
886 break;
887 default:
888 break;
889 }
890 if (sym)
891 {
892 if (el == ns->entries)
893 gfc_error ("FUNCTION result %s can't be of type %s "
894 "in FUNCTION %s at %L", sym->name,
895 gfc_typename (ts), ns->entries->sym->name,
896 &sym->declared_at);
897 else
898 gfc_error ("ENTRY result %s can't be of type %s "
899 "in FUNCTION %s at %L", sym->name,
900 gfc_typename (ts), ns->entries->sym->name,
901 &sym->declared_at);
902 }
903 }
904 }
905 }
906 }
907 proc->attr.access = ACCESS_PRIVATE;
908 proc->attr.entry_master = 1;
909
910 /* Merge all the entry point arguments. */
911 for (el = ns->entries; el; el = el->next)
912 merge_argument_lists (proc, el->sym->formal);
913
914 /* Check the master formal arguments for any that are not
915 present in all entry points. */
916 for (el = ns->entries; el; el = el->next)
917 check_argument_lists (proc, el->sym->formal);
918
919 /* Use the master function for the function body. */
920 ns->proc_name = proc;
921
922 /* Finalize the new symbols. */
923 gfc_commit_symbols ();
924
925 /* Restore the original namespace. */
926 gfc_current_ns = old_ns;
927 }
928
929
930 /* Resolve common variables. */
931 static void
resolve_common_vars(gfc_common_head * common_block,bool named_common)932 resolve_common_vars (gfc_common_head *common_block, bool named_common)
933 {
934 gfc_symbol *csym = common_block->head;
935
936 for (; csym; csym = csym->common_next)
937 {
938 /* gfc_add_in_common may have been called before, but the reported errors
939 have been ignored to continue parsing.
940 We do the checks again here. */
941 if (!csym->attr.use_assoc)
942 gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
943
944 if (csym->value || csym->attr.data)
945 {
946 if (!csym->ns->is_block_data)
947 gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
948 "but only in BLOCK DATA initialization is "
949 "allowed", csym->name, &csym->declared_at);
950 else if (!named_common)
951 gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
952 "in a blank COMMON but initialization is only "
953 "allowed in named common blocks", csym->name,
954 &csym->declared_at);
955 }
956
957 if (UNLIMITED_POLY (csym))
958 gfc_error_now ("%qs in cannot appear in COMMON at %L "
959 "[F2008:C5100]", csym->name, &csym->declared_at);
960
961 if (csym->ts.type != BT_DERIVED)
962 continue;
963
964 if (!(csym->ts.u.derived->attr.sequence
965 || csym->ts.u.derived->attr.is_bind_c))
966 gfc_error_now ("Derived type variable %qs in COMMON at %L "
967 "has neither the SEQUENCE nor the BIND(C) "
968 "attribute", csym->name, &csym->declared_at);
969 if (csym->ts.u.derived->attr.alloc_comp)
970 gfc_error_now ("Derived type variable %qs in COMMON at %L "
971 "has an ultimate component that is "
972 "allocatable", csym->name, &csym->declared_at);
973 if (gfc_has_default_initializer (csym->ts.u.derived))
974 gfc_error_now ("Derived type variable %qs in COMMON at %L "
975 "may not have default initializer", csym->name,
976 &csym->declared_at);
977
978 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
979 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
980 }
981 }
982
983 /* Resolve common blocks. */
984 static void
resolve_common_blocks(gfc_symtree * common_root)985 resolve_common_blocks (gfc_symtree *common_root)
986 {
987 gfc_symbol *sym;
988 gfc_gsymbol * gsym;
989
990 if (common_root == NULL)
991 return;
992
993 if (common_root->left)
994 resolve_common_blocks (common_root->left);
995 if (common_root->right)
996 resolve_common_blocks (common_root->right);
997
998 resolve_common_vars (common_root->n.common, true);
999
1000 /* The common name is a global name - in Fortran 2003 also if it has a
1001 C binding name, since Fortran 2008 only the C binding name is a global
1002 identifier. */
1003 if (!common_root->n.common->binding_label
1004 || gfc_notification_std (GFC_STD_F2008))
1005 {
1006 gsym = gfc_find_gsymbol (gfc_gsym_root,
1007 common_root->n.common->name);
1008
1009 if (gsym && gfc_notification_std (GFC_STD_F2008)
1010 && gsym->type == GSYM_COMMON
1011 && ((common_root->n.common->binding_label
1012 && (!gsym->binding_label
1013 || strcmp (common_root->n.common->binding_label,
1014 gsym->binding_label) != 0))
1015 || (!common_root->n.common->binding_label
1016 && gsym->binding_label)))
1017 {
1018 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1019 "identifier and must thus have the same binding name "
1020 "as the same-named COMMON block at %L: %s vs %s",
1021 common_root->n.common->name, &common_root->n.common->where,
1022 &gsym->where,
1023 common_root->n.common->binding_label
1024 ? common_root->n.common->binding_label : "(blank)",
1025 gsym->binding_label ? gsym->binding_label : "(blank)");
1026 return;
1027 }
1028
1029 if (gsym && gsym->type != GSYM_COMMON
1030 && !common_root->n.common->binding_label)
1031 {
1032 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1033 "as entity at %L",
1034 common_root->n.common->name, &common_root->n.common->where,
1035 &gsym->where);
1036 return;
1037 }
1038 if (gsym && gsym->type != GSYM_COMMON)
1039 {
1040 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1041 "%L sharing the identifier with global non-COMMON-block "
1042 "entity at %L", common_root->n.common->name,
1043 &common_root->n.common->where, &gsym->where);
1044 return;
1045 }
1046 if (!gsym)
1047 {
1048 gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1049 gsym->type = GSYM_COMMON;
1050 gsym->where = common_root->n.common->where;
1051 gsym->defined = 1;
1052 }
1053 gsym->used = 1;
1054 }
1055
1056 if (common_root->n.common->binding_label)
1057 {
1058 gsym = gfc_find_gsymbol (gfc_gsym_root,
1059 common_root->n.common->binding_label);
1060 if (gsym && gsym->type != GSYM_COMMON)
1061 {
1062 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1063 "global identifier as entity at %L",
1064 &common_root->n.common->where,
1065 common_root->n.common->binding_label, &gsym->where);
1066 return;
1067 }
1068 if (!gsym)
1069 {
1070 gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1071 gsym->type = GSYM_COMMON;
1072 gsym->where = common_root->n.common->where;
1073 gsym->defined = 1;
1074 }
1075 gsym->used = 1;
1076 }
1077
1078 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1079 if (sym == NULL)
1080 return;
1081
1082 if (sym->attr.flavor == FL_PARAMETER)
1083 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1084 sym->name, &common_root->n.common->where, &sym->declared_at);
1085
1086 if (sym->attr.external)
1087 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1088 sym->name, &common_root->n.common->where);
1089
1090 if (sym->attr.intrinsic)
1091 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1092 sym->name, &common_root->n.common->where);
1093 else if (sym->attr.result
1094 || gfc_is_function_return_value (sym, gfc_current_ns))
1095 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1096 "that is also a function result", sym->name,
1097 &common_root->n.common->where);
1098 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1099 && sym->attr.proc != PROC_ST_FUNCTION)
1100 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1101 "that is also a global procedure", sym->name,
1102 &common_root->n.common->where);
1103 }
1104
1105
1106 /* Resolve contained function types. Because contained functions can call one
1107 another, they have to be worked out before any of the contained procedures
1108 can be resolved.
1109
1110 The good news is that if a function doesn't already have a type, the only
1111 way it can get one is through an IMPLICIT type or a RESULT variable, because
1112 by definition contained functions are contained namespace they're contained
1113 in, not in a sibling or parent namespace. */
1114
1115 static void
resolve_contained_functions(gfc_namespace * ns)1116 resolve_contained_functions (gfc_namespace *ns)
1117 {
1118 gfc_namespace *child;
1119 gfc_entry_list *el;
1120
1121 resolve_formal_arglists (ns);
1122
1123 for (child = ns->contained; child; child = child->sibling)
1124 {
1125 /* Resolve alternate entry points first. */
1126 resolve_entries (child);
1127
1128 /* Then check function return types. */
1129 resolve_contained_fntype (child->proc_name, child);
1130 for (el = child->entries; el; el = el->next)
1131 resolve_contained_fntype (el->sym, child);
1132 }
1133 }
1134
1135
1136
1137 /* A Parameterized Derived Type constructor must contain values for
1138 the PDT KIND parameters or they must have a default initializer.
1139 Go through the constructor picking out the KIND expressions,
1140 storing them in 'param_list' and then call gfc_get_pdt_instance
1141 to obtain the PDT instance. */
1142
1143 static gfc_actual_arglist *param_list, *param_tail, *param;
1144
1145 static bool
get_pdt_spec_expr(gfc_component * c,gfc_expr * expr)1146 get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1147 {
1148 param = gfc_get_actual_arglist ();
1149 if (!param_list)
1150 param_list = param_tail = param;
1151 else
1152 {
1153 param_tail->next = param;
1154 param_tail = param_tail->next;
1155 }
1156
1157 param_tail->name = c->name;
1158 if (expr)
1159 param_tail->expr = gfc_copy_expr (expr);
1160 else if (c->initializer)
1161 param_tail->expr = gfc_copy_expr (c->initializer);
1162 else
1163 {
1164 param_tail->spec_type = SPEC_ASSUMED;
1165 if (c->attr.pdt_kind)
1166 {
1167 gfc_error ("The KIND parameter %qs in the PDT constructor "
1168 "at %C has no value", param->name);
1169 return false;
1170 }
1171 }
1172
1173 return true;
1174 }
1175
1176 static bool
get_pdt_constructor(gfc_expr * expr,gfc_constructor ** constr,gfc_symbol * derived)1177 get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1178 gfc_symbol *derived)
1179 {
1180 gfc_constructor *cons = NULL;
1181 gfc_component *comp;
1182 bool t = true;
1183
1184 if (expr && expr->expr_type == EXPR_STRUCTURE)
1185 cons = gfc_constructor_first (expr->value.constructor);
1186 else if (constr)
1187 cons = *constr;
1188 gcc_assert (cons);
1189
1190 comp = derived->components;
1191
1192 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1193 {
1194 if (cons->expr
1195 && cons->expr->expr_type == EXPR_STRUCTURE
1196 && comp->ts.type == BT_DERIVED)
1197 {
1198 t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1199 if (!t)
1200 return t;
1201 }
1202 else if (comp->ts.type == BT_DERIVED)
1203 {
1204 t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1205 if (!t)
1206 return t;
1207 }
1208 else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1209 && derived->attr.pdt_template)
1210 {
1211 t = get_pdt_spec_expr (comp, cons->expr);
1212 if (!t)
1213 return t;
1214 }
1215 }
1216 return t;
1217 }
1218
1219
1220 static bool resolve_fl_derived0 (gfc_symbol *sym);
1221 static bool resolve_fl_struct (gfc_symbol *sym);
1222
1223
1224 /* Resolve all of the elements of a structure constructor and make sure that
1225 the types are correct. The 'init' flag indicates that the given
1226 constructor is an initializer. */
1227
1228 static bool
resolve_structure_cons(gfc_expr * expr,int init)1229 resolve_structure_cons (gfc_expr *expr, int init)
1230 {
1231 gfc_constructor *cons;
1232 gfc_component *comp;
1233 bool t;
1234 symbol_attribute a;
1235
1236 t = true;
1237
1238 if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1239 {
1240 if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1241 resolve_fl_derived0 (expr->ts.u.derived);
1242 else
1243 resolve_fl_struct (expr->ts.u.derived);
1244
1245 /* If this is a Parameterized Derived Type template, find the
1246 instance corresponding to the PDT kind parameters. */
1247 if (expr->ts.u.derived->attr.pdt_template)
1248 {
1249 param_list = NULL;
1250 t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1251 if (!t)
1252 return t;
1253 gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1254
1255 expr->param_list = gfc_copy_actual_arglist (param_list);
1256
1257 if (param_list)
1258 gfc_free_actual_arglist (param_list);
1259
1260 if (!expr->ts.u.derived->attr.pdt_type)
1261 return false;
1262 }
1263 }
1264
1265 cons = gfc_constructor_first (expr->value.constructor);
1266
1267 /* A constructor may have references if it is the result of substituting a
1268 parameter variable. In this case we just pull out the component we
1269 want. */
1270 if (expr->ref)
1271 comp = expr->ref->u.c.sym->components;
1272 else
1273 comp = expr->ts.u.derived->components;
1274
1275 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1276 {
1277 int rank;
1278
1279 if (!cons->expr)
1280 continue;
1281
1282 /* Unions use an EXPR_NULL contrived expression to tell the translation
1283 phase to generate an initializer of the appropriate length.
1284 Ignore it here. */
1285 if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1286 continue;
1287
1288 if (!gfc_resolve_expr (cons->expr))
1289 {
1290 t = false;
1291 continue;
1292 }
1293
1294 rank = comp->as ? comp->as->rank : 0;
1295 if (comp->ts.type == BT_CLASS
1296 && !comp->ts.u.derived->attr.unlimited_polymorphic
1297 && CLASS_DATA (comp)->as)
1298 rank = CLASS_DATA (comp)->as->rank;
1299
1300 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1301 && (comp->attr.allocatable || cons->expr->rank))
1302 {
1303 gfc_error ("The rank of the element in the structure "
1304 "constructor at %L does not match that of the "
1305 "component (%d/%d)", &cons->expr->where,
1306 cons->expr->rank, rank);
1307 t = false;
1308 }
1309
1310 /* If we don't have the right type, try to convert it. */
1311
1312 if (!comp->attr.proc_pointer &&
1313 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1314 {
1315 if (strcmp (comp->name, "_extends") == 0)
1316 {
1317 /* Can afford to be brutal with the _extends initializer.
1318 The derived type can get lost because it is PRIVATE
1319 but it is not usage constrained by the standard. */
1320 cons->expr->ts = comp->ts;
1321 }
1322 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1323 {
1324 gfc_error ("The element in the structure constructor at %L, "
1325 "for pointer component %qs, is %s but should be %s",
1326 &cons->expr->where, comp->name,
1327 gfc_basic_typename (cons->expr->ts.type),
1328 gfc_basic_typename (comp->ts.type));
1329 t = false;
1330 }
1331 else
1332 {
1333 bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1334 if (t)
1335 t = t2;
1336 }
1337 }
1338
1339 /* For strings, the length of the constructor should be the same as
1340 the one of the structure, ensure this if the lengths are known at
1341 compile time and when we are dealing with PARAMETER or structure
1342 constructors. */
1343 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1344 && comp->ts.u.cl->length
1345 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1346 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1347 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1348 && cons->expr->rank != 0
1349 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1350 comp->ts.u.cl->length->value.integer) != 0)
1351 {
1352 if (cons->expr->expr_type == EXPR_VARIABLE
1353 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1354 {
1355 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1356 to make use of the gfc_resolve_character_array_constructor
1357 machinery. The expression is later simplified away to
1358 an array of string literals. */
1359 gfc_expr *para = cons->expr;
1360 cons->expr = gfc_get_expr ();
1361 cons->expr->ts = para->ts;
1362 cons->expr->where = para->where;
1363 cons->expr->expr_type = EXPR_ARRAY;
1364 cons->expr->rank = para->rank;
1365 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1366 gfc_constructor_append_expr (&cons->expr->value.constructor,
1367 para, &cons->expr->where);
1368 }
1369
1370 if (cons->expr->expr_type == EXPR_ARRAY)
1371 {
1372 /* Rely on the cleanup of the namespace to deal correctly with
1373 the old charlen. (There was a block here that attempted to
1374 remove the charlen but broke the chain in so doing.) */
1375 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1376 cons->expr->ts.u.cl->length_from_typespec = true;
1377 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1378 gfc_resolve_character_array_constructor (cons->expr);
1379 }
1380 }
1381
1382 if (cons->expr->expr_type == EXPR_NULL
1383 && !(comp->attr.pointer || comp->attr.allocatable
1384 || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1385 || (comp->ts.type == BT_CLASS
1386 && (CLASS_DATA (comp)->attr.class_pointer
1387 || CLASS_DATA (comp)->attr.allocatable))))
1388 {
1389 t = false;
1390 gfc_error ("The NULL in the structure constructor at %L is "
1391 "being applied to component %qs, which is neither "
1392 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1393 comp->name);
1394 }
1395
1396 if (comp->attr.proc_pointer && comp->ts.interface)
1397 {
1398 /* Check procedure pointer interface. */
1399 gfc_symbol *s2 = NULL;
1400 gfc_component *c2;
1401 const char *name;
1402 char err[200];
1403
1404 c2 = gfc_get_proc_ptr_comp (cons->expr);
1405 if (c2)
1406 {
1407 s2 = c2->ts.interface;
1408 name = c2->name;
1409 }
1410 else if (cons->expr->expr_type == EXPR_FUNCTION)
1411 {
1412 s2 = cons->expr->symtree->n.sym->result;
1413 name = cons->expr->symtree->n.sym->result->name;
1414 }
1415 else if (cons->expr->expr_type != EXPR_NULL)
1416 {
1417 s2 = cons->expr->symtree->n.sym;
1418 name = cons->expr->symtree->n.sym->name;
1419 }
1420
1421 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1422 err, sizeof (err), NULL, NULL))
1423 {
1424 gfc_error_opt (OPT_Wargument_mismatch,
1425 "Interface mismatch for procedure-pointer "
1426 "component %qs in structure constructor at %L:"
1427 " %s", comp->name, &cons->expr->where, err);
1428 return false;
1429 }
1430 }
1431
1432 if (!comp->attr.pointer || comp->attr.proc_pointer
1433 || cons->expr->expr_type == EXPR_NULL)
1434 continue;
1435
1436 a = gfc_expr_attr (cons->expr);
1437
1438 if (!a.pointer && !a.target)
1439 {
1440 t = false;
1441 gfc_error ("The element in the structure constructor at %L, "
1442 "for pointer component %qs should be a POINTER or "
1443 "a TARGET", &cons->expr->where, comp->name);
1444 }
1445
1446 if (init)
1447 {
1448 /* F08:C461. Additional checks for pointer initialization. */
1449 if (a.allocatable)
1450 {
1451 t = false;
1452 gfc_error ("Pointer initialization target at %L "
1453 "must not be ALLOCATABLE", &cons->expr->where);
1454 }
1455 if (!a.save)
1456 {
1457 t = false;
1458 gfc_error ("Pointer initialization target at %L "
1459 "must have the SAVE attribute", &cons->expr->where);
1460 }
1461 }
1462
1463 /* F2003, C1272 (3). */
1464 bool impure = cons->expr->expr_type == EXPR_VARIABLE
1465 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1466 || gfc_is_coindexed (cons->expr));
1467 if (impure && gfc_pure (NULL))
1468 {
1469 t = false;
1470 gfc_error ("Invalid expression in the structure constructor for "
1471 "pointer component %qs at %L in PURE procedure",
1472 comp->name, &cons->expr->where);
1473 }
1474
1475 if (impure)
1476 gfc_unset_implicit_pure (NULL);
1477 }
1478
1479 return t;
1480 }
1481
1482
1483 /****************** Expression name resolution ******************/
1484
1485 /* Returns 0 if a symbol was not declared with a type or
1486 attribute declaration statement, nonzero otherwise. */
1487
1488 static int
was_declared(gfc_symbol * sym)1489 was_declared (gfc_symbol *sym)
1490 {
1491 symbol_attribute a;
1492
1493 a = sym->attr;
1494
1495 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1496 return 1;
1497
1498 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1499 || a.optional || a.pointer || a.save || a.target || a.volatile_
1500 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1501 || a.asynchronous || a.codimension)
1502 return 1;
1503
1504 return 0;
1505 }
1506
1507
1508 /* Determine if a symbol is generic or not. */
1509
1510 static int
generic_sym(gfc_symbol * sym)1511 generic_sym (gfc_symbol *sym)
1512 {
1513 gfc_symbol *s;
1514
1515 if (sym->attr.generic ||
1516 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1517 return 1;
1518
1519 if (was_declared (sym) || sym->ns->parent == NULL)
1520 return 0;
1521
1522 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1523
1524 if (s != NULL)
1525 {
1526 if (s == sym)
1527 return 0;
1528 else
1529 return generic_sym (s);
1530 }
1531
1532 return 0;
1533 }
1534
1535
1536 /* Determine if a symbol is specific or not. */
1537
1538 static int
specific_sym(gfc_symbol * sym)1539 specific_sym (gfc_symbol *sym)
1540 {
1541 gfc_symbol *s;
1542
1543 if (sym->attr.if_source == IFSRC_IFBODY
1544 || sym->attr.proc == PROC_MODULE
1545 || sym->attr.proc == PROC_INTERNAL
1546 || sym->attr.proc == PROC_ST_FUNCTION
1547 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1548 || sym->attr.external)
1549 return 1;
1550
1551 if (was_declared (sym) || sym->ns->parent == NULL)
1552 return 0;
1553
1554 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1555
1556 return (s == NULL) ? 0 : specific_sym (s);
1557 }
1558
1559
1560 /* Figure out if the procedure is specific, generic or unknown. */
1561
1562 enum proc_type
1563 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1564
1565 static proc_type
procedure_kind(gfc_symbol * sym)1566 procedure_kind (gfc_symbol *sym)
1567 {
1568 if (generic_sym (sym))
1569 return PTYPE_GENERIC;
1570
1571 if (specific_sym (sym))
1572 return PTYPE_SPECIFIC;
1573
1574 return PTYPE_UNKNOWN;
1575 }
1576
1577 /* Check references to assumed size arrays. The flag need_full_assumed_size
1578 is nonzero when matching actual arguments. */
1579
1580 static int need_full_assumed_size = 0;
1581
1582 static bool
check_assumed_size_reference(gfc_symbol * sym,gfc_expr * e)1583 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1584 {
1585 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1586 return false;
1587
1588 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1589 What should it be? */
1590 if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1591 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1592 && (e->ref->u.ar.type == AR_FULL))
1593 {
1594 gfc_error ("The upper bound in the last dimension must "
1595 "appear in the reference to the assumed size "
1596 "array %qs at %L", sym->name, &e->where);
1597 return true;
1598 }
1599 return false;
1600 }
1601
1602
1603 /* Look for bad assumed size array references in argument expressions
1604 of elemental and array valued intrinsic procedures. Since this is
1605 called from procedure resolution functions, it only recurses at
1606 operators. */
1607
1608 static bool
resolve_assumed_size_actual(gfc_expr * e)1609 resolve_assumed_size_actual (gfc_expr *e)
1610 {
1611 if (e == NULL)
1612 return false;
1613
1614 switch (e->expr_type)
1615 {
1616 case EXPR_VARIABLE:
1617 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1618 return true;
1619 break;
1620
1621 case EXPR_OP:
1622 if (resolve_assumed_size_actual (e->value.op.op1)
1623 || resolve_assumed_size_actual (e->value.op.op2))
1624 return true;
1625 break;
1626
1627 default:
1628 break;
1629 }
1630 return false;
1631 }
1632
1633
1634 /* Check a generic procedure, passed as an actual argument, to see if
1635 there is a matching specific name. If none, it is an error, and if
1636 more than one, the reference is ambiguous. */
1637 static int
count_specific_procs(gfc_expr * e)1638 count_specific_procs (gfc_expr *e)
1639 {
1640 int n;
1641 gfc_interface *p;
1642 gfc_symbol *sym;
1643
1644 n = 0;
1645 sym = e->symtree->n.sym;
1646
1647 for (p = sym->generic; p; p = p->next)
1648 if (strcmp (sym->name, p->sym->name) == 0)
1649 {
1650 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1651 sym->name);
1652 n++;
1653 }
1654
1655 if (n > 1)
1656 gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1657 &e->where);
1658
1659 if (n == 0)
1660 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1661 "argument at %L", sym->name, &e->where);
1662
1663 return n;
1664 }
1665
1666
1667 /* See if a call to sym could possibly be a not allowed RECURSION because of
1668 a missing RECURSIVE declaration. This means that either sym is the current
1669 context itself, or sym is the parent of a contained procedure calling its
1670 non-RECURSIVE containing procedure.
1671 This also works if sym is an ENTRY. */
1672
1673 static bool
is_illegal_recursion(gfc_symbol * sym,gfc_namespace * context)1674 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1675 {
1676 gfc_symbol* proc_sym;
1677 gfc_symbol* context_proc;
1678 gfc_namespace* real_context;
1679
1680 if (sym->attr.flavor == FL_PROGRAM
1681 || gfc_fl_struct (sym->attr.flavor))
1682 return false;
1683
1684 /* If we've got an ENTRY, find real procedure. */
1685 if (sym->attr.entry && sym->ns->entries)
1686 proc_sym = sym->ns->entries->sym;
1687 else
1688 proc_sym = sym;
1689
1690 /* If sym is RECURSIVE, all is well of course. */
1691 if (proc_sym->attr.recursive || flag_recursive)
1692 return false;
1693
1694 /* Find the context procedure's "real" symbol if it has entries.
1695 We look for a procedure symbol, so recurse on the parents if we don't
1696 find one (like in case of a BLOCK construct). */
1697 for (real_context = context; ; real_context = real_context->parent)
1698 {
1699 /* We should find something, eventually! */
1700 gcc_assert (real_context);
1701
1702 context_proc = (real_context->entries ? real_context->entries->sym
1703 : real_context->proc_name);
1704
1705 /* In some special cases, there may not be a proc_name, like for this
1706 invalid code:
1707 real(bad_kind()) function foo () ...
1708 when checking the call to bad_kind ().
1709 In these cases, we simply return here and assume that the
1710 call is ok. */
1711 if (!context_proc)
1712 return false;
1713
1714 if (context_proc->attr.flavor != FL_LABEL)
1715 break;
1716 }
1717
1718 /* A call from sym's body to itself is recursion, of course. */
1719 if (context_proc == proc_sym)
1720 return true;
1721
1722 /* The same is true if context is a contained procedure and sym the
1723 containing one. */
1724 if (context_proc->attr.contained)
1725 {
1726 gfc_symbol* parent_proc;
1727
1728 gcc_assert (context->parent);
1729 parent_proc = (context->parent->entries ? context->parent->entries->sym
1730 : context->parent->proc_name);
1731
1732 if (parent_proc == proc_sym)
1733 return true;
1734 }
1735
1736 return false;
1737 }
1738
1739
1740 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1741 its typespec and formal argument list. */
1742
1743 bool
gfc_resolve_intrinsic(gfc_symbol * sym,locus * loc)1744 gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1745 {
1746 gfc_intrinsic_sym* isym = NULL;
1747 const char* symstd;
1748
1749 if (sym->formal)
1750 return true;
1751
1752 /* Already resolved. */
1753 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1754 return true;
1755
1756 /* We already know this one is an intrinsic, so we don't call
1757 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1758 gfc_find_subroutine directly to check whether it is a function or
1759 subroutine. */
1760
1761 if (sym->intmod_sym_id && sym->attr.subroutine)
1762 {
1763 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1764 isym = gfc_intrinsic_subroutine_by_id (id);
1765 }
1766 else if (sym->intmod_sym_id)
1767 {
1768 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1769 isym = gfc_intrinsic_function_by_id (id);
1770 }
1771 else if (!sym->attr.subroutine)
1772 isym = gfc_find_function (sym->name);
1773
1774 if (isym && !sym->attr.subroutine)
1775 {
1776 if (sym->ts.type != BT_UNKNOWN && warn_surprising
1777 && !sym->attr.implicit_type)
1778 gfc_warning (OPT_Wsurprising,
1779 "Type specified for intrinsic function %qs at %L is"
1780 " ignored", sym->name, &sym->declared_at);
1781
1782 if (!sym->attr.function &&
1783 !gfc_add_function(&sym->attr, sym->name, loc))
1784 return false;
1785
1786 sym->ts = isym->ts;
1787 }
1788 else if (isym || (isym = gfc_find_subroutine (sym->name)))
1789 {
1790 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1791 {
1792 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1793 " specifier", sym->name, &sym->declared_at);
1794 return false;
1795 }
1796
1797 if (!sym->attr.subroutine &&
1798 !gfc_add_subroutine(&sym->attr, sym->name, loc))
1799 return false;
1800 }
1801 else
1802 {
1803 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1804 &sym->declared_at);
1805 return false;
1806 }
1807
1808 gfc_copy_formal_args_intr (sym, isym, NULL);
1809
1810 sym->attr.pure = isym->pure;
1811 sym->attr.elemental = isym->elemental;
1812
1813 /* Check it is actually available in the standard settings. */
1814 if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1815 {
1816 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1817 "available in the current standard settings but %s. Use "
1818 "an appropriate %<-std=*%> option or enable "
1819 "%<-fall-intrinsics%> in order to use it.",
1820 sym->name, &sym->declared_at, symstd);
1821 return false;
1822 }
1823
1824 return true;
1825 }
1826
1827
1828 /* Resolve a procedure expression, like passing it to a called procedure or as
1829 RHS for a procedure pointer assignment. */
1830
1831 static bool
resolve_procedure_expression(gfc_expr * expr)1832 resolve_procedure_expression (gfc_expr* expr)
1833 {
1834 gfc_symbol* sym;
1835
1836 if (expr->expr_type != EXPR_VARIABLE)
1837 return true;
1838 gcc_assert (expr->symtree);
1839
1840 sym = expr->symtree->n.sym;
1841
1842 if (sym->attr.intrinsic)
1843 gfc_resolve_intrinsic (sym, &expr->where);
1844
1845 if (sym->attr.flavor != FL_PROCEDURE
1846 || (sym->attr.function && sym->result == sym))
1847 return true;
1848
1849 /* A non-RECURSIVE procedure that is used as procedure expression within its
1850 own body is in danger of being called recursively. */
1851 if (is_illegal_recursion (sym, gfc_current_ns))
1852 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1853 " itself recursively. Declare it RECURSIVE or use"
1854 " %<-frecursive%>", sym->name, &expr->where);
1855
1856 return true;
1857 }
1858
1859
1860 /* Resolve an actual argument list. Most of the time, this is just
1861 resolving the expressions in the list.
1862 The exception is that we sometimes have to decide whether arguments
1863 that look like procedure arguments are really simple variable
1864 references. */
1865
1866 static bool
resolve_actual_arglist(gfc_actual_arglist * arg,procedure_type ptype,bool no_formal_args)1867 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1868 bool no_formal_args)
1869 {
1870 gfc_symbol *sym;
1871 gfc_symtree *parent_st;
1872 gfc_expr *e;
1873 gfc_component *comp;
1874 int save_need_full_assumed_size;
1875 bool return_value = false;
1876 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
1877
1878 actual_arg = true;
1879 first_actual_arg = true;
1880
1881 for (; arg; arg = arg->next)
1882 {
1883 e = arg->expr;
1884 if (e == NULL)
1885 {
1886 /* Check the label is a valid branching target. */
1887 if (arg->label)
1888 {
1889 if (arg->label->defined == ST_LABEL_UNKNOWN)
1890 {
1891 gfc_error ("Label %d referenced at %L is never defined",
1892 arg->label->value, &arg->label->where);
1893 goto cleanup;
1894 }
1895 }
1896 first_actual_arg = false;
1897 continue;
1898 }
1899
1900 if (e->expr_type == EXPR_VARIABLE
1901 && e->symtree->n.sym->attr.generic
1902 && no_formal_args
1903 && count_specific_procs (e) != 1)
1904 goto cleanup;
1905
1906 if (e->ts.type != BT_PROCEDURE)
1907 {
1908 save_need_full_assumed_size = need_full_assumed_size;
1909 if (e->expr_type != EXPR_VARIABLE)
1910 need_full_assumed_size = 0;
1911 if (!gfc_resolve_expr (e))
1912 goto cleanup;
1913 need_full_assumed_size = save_need_full_assumed_size;
1914 goto argument_list;
1915 }
1916
1917 /* See if the expression node should really be a variable reference. */
1918
1919 sym = e->symtree->n.sym;
1920
1921 if (sym->attr.flavor == FL_PROCEDURE
1922 || sym->attr.intrinsic
1923 || sym->attr.external)
1924 {
1925 int actual_ok;
1926
1927 /* If a procedure is not already determined to be something else
1928 check if it is intrinsic. */
1929 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1930 sym->attr.intrinsic = 1;
1931
1932 if (sym->attr.proc == PROC_ST_FUNCTION)
1933 {
1934 gfc_error ("Statement function %qs at %L is not allowed as an "
1935 "actual argument", sym->name, &e->where);
1936 }
1937
1938 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1939 sym->attr.subroutine);
1940 if (sym->attr.intrinsic && actual_ok == 0)
1941 {
1942 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1943 "actual argument", sym->name, &e->where);
1944 }
1945
1946 if (sym->attr.contained && !sym->attr.use_assoc
1947 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1948 {
1949 if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
1950 " used as actual argument at %L",
1951 sym->name, &e->where))
1952 goto cleanup;
1953 }
1954
1955 if (sym->attr.elemental && !sym->attr.intrinsic)
1956 {
1957 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1958 "allowed as an actual argument at %L", sym->name,
1959 &e->where);
1960 }
1961
1962 /* Check if a generic interface has a specific procedure
1963 with the same name before emitting an error. */
1964 if (sym->attr.generic && count_specific_procs (e) != 1)
1965 goto cleanup;
1966
1967 /* Just in case a specific was found for the expression. */
1968 sym = e->symtree->n.sym;
1969
1970 /* If the symbol is the function that names the current (or
1971 parent) scope, then we really have a variable reference. */
1972
1973 if (gfc_is_function_return_value (sym, sym->ns))
1974 goto got_variable;
1975
1976 /* If all else fails, see if we have a specific intrinsic. */
1977 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1978 {
1979 gfc_intrinsic_sym *isym;
1980
1981 isym = gfc_find_function (sym->name);
1982 if (isym == NULL || !isym->specific)
1983 {
1984 gfc_error ("Unable to find a specific INTRINSIC procedure "
1985 "for the reference %qs at %L", sym->name,
1986 &e->where);
1987 goto cleanup;
1988 }
1989 sym->ts = isym->ts;
1990 sym->attr.intrinsic = 1;
1991 sym->attr.function = 1;
1992 }
1993
1994 if (!gfc_resolve_expr (e))
1995 goto cleanup;
1996 goto argument_list;
1997 }
1998
1999 /* See if the name is a module procedure in a parent unit. */
2000
2001 if (was_declared (sym) || sym->ns->parent == NULL)
2002 goto got_variable;
2003
2004 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2005 {
2006 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2007 goto cleanup;
2008 }
2009
2010 if (parent_st == NULL)
2011 goto got_variable;
2012
2013 sym = parent_st->n.sym;
2014 e->symtree = parent_st; /* Point to the right thing. */
2015
2016 if (sym->attr.flavor == FL_PROCEDURE
2017 || sym->attr.intrinsic
2018 || sym->attr.external)
2019 {
2020 if (!gfc_resolve_expr (e))
2021 goto cleanup;
2022 goto argument_list;
2023 }
2024
2025 got_variable:
2026 e->expr_type = EXPR_VARIABLE;
2027 e->ts = sym->ts;
2028 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2029 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2030 && CLASS_DATA (sym)->as))
2031 {
2032 e->rank = sym->ts.type == BT_CLASS
2033 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
2034 e->ref = gfc_get_ref ();
2035 e->ref->type = REF_ARRAY;
2036 e->ref->u.ar.type = AR_FULL;
2037 e->ref->u.ar.as = sym->ts.type == BT_CLASS
2038 ? CLASS_DATA (sym)->as : sym->as;
2039 }
2040
2041 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2042 primary.c (match_actual_arg). If above code determines that it
2043 is a variable instead, it needs to be resolved as it was not
2044 done at the beginning of this function. */
2045 save_need_full_assumed_size = need_full_assumed_size;
2046 if (e->expr_type != EXPR_VARIABLE)
2047 need_full_assumed_size = 0;
2048 if (!gfc_resolve_expr (e))
2049 goto cleanup;
2050 need_full_assumed_size = save_need_full_assumed_size;
2051
2052 argument_list:
2053 /* Check argument list functions %VAL, %LOC and %REF. There is
2054 nothing to do for %REF. */
2055 if (arg->name && arg->name[0] == '%')
2056 {
2057 if (strncmp ("%VAL", arg->name, 4) == 0)
2058 {
2059 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2060 {
2061 gfc_error ("By-value argument at %L is not of numeric "
2062 "type", &e->where);
2063 goto cleanup;
2064 }
2065
2066 if (e->rank)
2067 {
2068 gfc_error ("By-value argument at %L cannot be an array or "
2069 "an array section", &e->where);
2070 goto cleanup;
2071 }
2072
2073 /* Intrinsics are still PROC_UNKNOWN here. However,
2074 since same file external procedures are not resolvable
2075 in gfortran, it is a good deal easier to leave them to
2076 intrinsic.c. */
2077 if (ptype != PROC_UNKNOWN
2078 && ptype != PROC_DUMMY
2079 && ptype != PROC_EXTERNAL
2080 && ptype != PROC_MODULE)
2081 {
2082 gfc_error ("By-value argument at %L is not allowed "
2083 "in this context", &e->where);
2084 goto cleanup;
2085 }
2086 }
2087
2088 /* Statement functions have already been excluded above. */
2089 else if (strncmp ("%LOC", arg->name, 4) == 0
2090 && e->ts.type == BT_PROCEDURE)
2091 {
2092 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2093 {
2094 gfc_error ("Passing internal procedure at %L by location "
2095 "not allowed", &e->where);
2096 goto cleanup;
2097 }
2098 }
2099 }
2100
2101 comp = gfc_get_proc_ptr_comp(e);
2102 if (e->expr_type == EXPR_VARIABLE
2103 && comp && comp->attr.elemental)
2104 {
2105 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2106 "allowed as an actual argument at %L", comp->name,
2107 &e->where);
2108 }
2109
2110 /* Fortran 2008, C1237. */
2111 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2112 && gfc_has_ultimate_pointer (e))
2113 {
2114 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2115 "component", &e->where);
2116 goto cleanup;
2117 }
2118
2119 first_actual_arg = false;
2120 }
2121
2122 return_value = true;
2123
2124 cleanup:
2125 actual_arg = actual_arg_sav;
2126 first_actual_arg = first_actual_arg_sav;
2127
2128 return return_value;
2129 }
2130
2131
2132 /* Do the checks of the actual argument list that are specific to elemental
2133 procedures. If called with c == NULL, we have a function, otherwise if
2134 expr == NULL, we have a subroutine. */
2135
2136 static bool
resolve_elemental_actual(gfc_expr * expr,gfc_code * c)2137 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2138 {
2139 gfc_actual_arglist *arg0;
2140 gfc_actual_arglist *arg;
2141 gfc_symbol *esym = NULL;
2142 gfc_intrinsic_sym *isym = NULL;
2143 gfc_expr *e = NULL;
2144 gfc_intrinsic_arg *iformal = NULL;
2145 gfc_formal_arglist *eformal = NULL;
2146 bool formal_optional = false;
2147 bool set_by_optional = false;
2148 int i;
2149 int rank = 0;
2150
2151 /* Is this an elemental procedure? */
2152 if (expr && expr->value.function.actual != NULL)
2153 {
2154 if (expr->value.function.esym != NULL
2155 && expr->value.function.esym->attr.elemental)
2156 {
2157 arg0 = expr->value.function.actual;
2158 esym = expr->value.function.esym;
2159 }
2160 else if (expr->value.function.isym != NULL
2161 && expr->value.function.isym->elemental)
2162 {
2163 arg0 = expr->value.function.actual;
2164 isym = expr->value.function.isym;
2165 }
2166 else
2167 return true;
2168 }
2169 else if (c && c->ext.actual != NULL)
2170 {
2171 arg0 = c->ext.actual;
2172
2173 if (c->resolved_sym)
2174 esym = c->resolved_sym;
2175 else
2176 esym = c->symtree->n.sym;
2177 gcc_assert (esym);
2178
2179 if (!esym->attr.elemental)
2180 return true;
2181 }
2182 else
2183 return true;
2184
2185 /* The rank of an elemental is the rank of its array argument(s). */
2186 for (arg = arg0; arg; arg = arg->next)
2187 {
2188 if (arg->expr != NULL && arg->expr->rank != 0)
2189 {
2190 rank = arg->expr->rank;
2191 if (arg->expr->expr_type == EXPR_VARIABLE
2192 && arg->expr->symtree->n.sym->attr.optional)
2193 set_by_optional = true;
2194
2195 /* Function specific; set the result rank and shape. */
2196 if (expr)
2197 {
2198 expr->rank = rank;
2199 if (!expr->shape && arg->expr->shape)
2200 {
2201 expr->shape = gfc_get_shape (rank);
2202 for (i = 0; i < rank; i++)
2203 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2204 }
2205 }
2206 break;
2207 }
2208 }
2209
2210 /* If it is an array, it shall not be supplied as an actual argument
2211 to an elemental procedure unless an array of the same rank is supplied
2212 as an actual argument corresponding to a nonoptional dummy argument of
2213 that elemental procedure(12.4.1.5). */
2214 formal_optional = false;
2215 if (isym)
2216 iformal = isym->formal;
2217 else
2218 eformal = esym->formal;
2219
2220 for (arg = arg0; arg; arg = arg->next)
2221 {
2222 if (eformal)
2223 {
2224 if (eformal->sym && eformal->sym->attr.optional)
2225 formal_optional = true;
2226 eformal = eformal->next;
2227 }
2228 else if (isym && iformal)
2229 {
2230 if (iformal->optional)
2231 formal_optional = true;
2232 iformal = iformal->next;
2233 }
2234 else if (isym)
2235 formal_optional = true;
2236
2237 if (pedantic && arg->expr != NULL
2238 && arg->expr->expr_type == EXPR_VARIABLE
2239 && arg->expr->symtree->n.sym->attr.optional
2240 && formal_optional
2241 && arg->expr->rank
2242 && (set_by_optional || arg->expr->rank != rank)
2243 && !(isym && isym->id == GFC_ISYM_CONVERSION))
2244 {
2245 gfc_warning (OPT_Wpedantic,
2246 "%qs at %L is an array and OPTIONAL; IF IT IS "
2247 "MISSING, it cannot be the actual argument of an "
2248 "ELEMENTAL procedure unless there is a non-optional "
2249 "argument with the same rank (12.4.1.5)",
2250 arg->expr->symtree->n.sym->name, &arg->expr->where);
2251 }
2252 }
2253
2254 for (arg = arg0; arg; arg = arg->next)
2255 {
2256 if (arg->expr == NULL || arg->expr->rank == 0)
2257 continue;
2258
2259 /* Being elemental, the last upper bound of an assumed size array
2260 argument must be present. */
2261 if (resolve_assumed_size_actual (arg->expr))
2262 return false;
2263
2264 /* Elemental procedure's array actual arguments must conform. */
2265 if (e != NULL)
2266 {
2267 if (!gfc_check_conformance (arg->expr, e, "elemental procedure"))
2268 return false;
2269 }
2270 else
2271 e = arg->expr;
2272 }
2273
2274 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2275 is an array, the intent inout/out variable needs to be also an array. */
2276 if (rank > 0 && esym && expr == NULL)
2277 for (eformal = esym->formal, arg = arg0; arg && eformal;
2278 arg = arg->next, eformal = eformal->next)
2279 if ((eformal->sym->attr.intent == INTENT_OUT
2280 || eformal->sym->attr.intent == INTENT_INOUT)
2281 && arg->expr && arg->expr->rank == 0)
2282 {
2283 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2284 "ELEMENTAL subroutine %qs is a scalar, but another "
2285 "actual argument is an array", &arg->expr->where,
2286 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2287 : "INOUT", eformal->sym->name, esym->name);
2288 return false;
2289 }
2290 return true;
2291 }
2292
2293
2294 /* This function does the checking of references to global procedures
2295 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2296 77 and 95 standards. It checks for a gsymbol for the name, making
2297 one if it does not already exist. If it already exists, then the
2298 reference being resolved must correspond to the type of gsymbol.
2299 Otherwise, the new symbol is equipped with the attributes of the
2300 reference. The corresponding code that is called in creating
2301 global entities is parse.c.
2302
2303 In addition, for all but -std=legacy, the gsymbols are used to
2304 check the interfaces of external procedures from the same file.
2305 The namespace of the gsymbol is resolved and then, once this is
2306 done the interface is checked. */
2307
2308
2309 static bool
not_in_recursive(gfc_symbol * sym,gfc_namespace * gsym_ns)2310 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2311 {
2312 if (!gsym_ns->proc_name->attr.recursive)
2313 return true;
2314
2315 if (sym->ns == gsym_ns)
2316 return false;
2317
2318 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2319 return false;
2320
2321 return true;
2322 }
2323
2324 static bool
not_entry_self_reference(gfc_symbol * sym,gfc_namespace * gsym_ns)2325 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2326 {
2327 if (gsym_ns->entries)
2328 {
2329 gfc_entry_list *entry = gsym_ns->entries;
2330
2331 for (; entry; entry = entry->next)
2332 {
2333 if (strcmp (sym->name, entry->sym->name) == 0)
2334 {
2335 if (strcmp (gsym_ns->proc_name->name,
2336 sym->ns->proc_name->name) == 0)
2337 return false;
2338
2339 if (sym->ns->parent
2340 && strcmp (gsym_ns->proc_name->name,
2341 sym->ns->parent->proc_name->name) == 0)
2342 return false;
2343 }
2344 }
2345 }
2346 return true;
2347 }
2348
2349
2350 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2351
2352 bool
gfc_explicit_interface_required(gfc_symbol * sym,char * errmsg,int err_len)2353 gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2354 {
2355 gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2356
2357 for ( ; arg; arg = arg->next)
2358 {
2359 if (!arg->sym)
2360 continue;
2361
2362 if (arg->sym->attr.allocatable) /* (2a) */
2363 {
2364 strncpy (errmsg, _("allocatable argument"), err_len);
2365 return true;
2366 }
2367 else if (arg->sym->attr.asynchronous)
2368 {
2369 strncpy (errmsg, _("asynchronous argument"), err_len);
2370 return true;
2371 }
2372 else if (arg->sym->attr.optional)
2373 {
2374 strncpy (errmsg, _("optional argument"), err_len);
2375 return true;
2376 }
2377 else if (arg->sym->attr.pointer)
2378 {
2379 strncpy (errmsg, _("pointer argument"), err_len);
2380 return true;
2381 }
2382 else if (arg->sym->attr.target)
2383 {
2384 strncpy (errmsg, _("target argument"), err_len);
2385 return true;
2386 }
2387 else if (arg->sym->attr.value)
2388 {
2389 strncpy (errmsg, _("value argument"), err_len);
2390 return true;
2391 }
2392 else if (arg->sym->attr.volatile_)
2393 {
2394 strncpy (errmsg, _("volatile argument"), err_len);
2395 return true;
2396 }
2397 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2398 {
2399 strncpy (errmsg, _("assumed-shape argument"), err_len);
2400 return true;
2401 }
2402 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2403 {
2404 strncpy (errmsg, _("assumed-rank argument"), err_len);
2405 return true;
2406 }
2407 else if (arg->sym->attr.codimension) /* (2c) */
2408 {
2409 strncpy (errmsg, _("coarray argument"), err_len);
2410 return true;
2411 }
2412 else if (false) /* (2d) TODO: parametrized derived type */
2413 {
2414 strncpy (errmsg, _("parametrized derived type argument"), err_len);
2415 return true;
2416 }
2417 else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2418 {
2419 strncpy (errmsg, _("polymorphic argument"), err_len);
2420 return true;
2421 }
2422 else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2423 {
2424 strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2425 return true;
2426 }
2427 else if (arg->sym->ts.type == BT_ASSUMED)
2428 {
2429 /* As assumed-type is unlimited polymorphic (cf. above).
2430 See also TS 29113, Note 6.1. */
2431 strncpy (errmsg, _("assumed-type argument"), err_len);
2432 return true;
2433 }
2434 }
2435
2436 if (sym->attr.function)
2437 {
2438 gfc_symbol *res = sym->result ? sym->result : sym;
2439
2440 if (res->attr.dimension) /* (3a) */
2441 {
2442 strncpy (errmsg, _("array result"), err_len);
2443 return true;
2444 }
2445 else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2446 {
2447 strncpy (errmsg, _("pointer or allocatable result"), err_len);
2448 return true;
2449 }
2450 else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2451 && res->ts.u.cl->length
2452 && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2453 {
2454 strncpy (errmsg, _("result with non-constant character length"), err_len);
2455 return true;
2456 }
2457 }
2458
2459 if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2460 {
2461 strncpy (errmsg, _("elemental procedure"), err_len);
2462 return true;
2463 }
2464 else if (sym->attr.is_bind_c) /* (5) */
2465 {
2466 strncpy (errmsg, _("bind(c) procedure"), err_len);
2467 return true;
2468 }
2469
2470 return false;
2471 }
2472
2473
2474 static void
resolve_global_procedure(gfc_symbol * sym,locus * where,gfc_actual_arglist ** actual,int sub)2475 resolve_global_procedure (gfc_symbol *sym, locus *where,
2476 gfc_actual_arglist **actual, int sub)
2477 {
2478 gfc_gsymbol * gsym;
2479 gfc_namespace *ns;
2480 enum gfc_symbol_type type;
2481 char reason[200];
2482
2483 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2484
2485 gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2486 sym->binding_label != NULL);
2487
2488 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2489 gfc_global_used (gsym, where);
2490
2491 if ((sym->attr.if_source == IFSRC_UNKNOWN
2492 || sym->attr.if_source == IFSRC_IFBODY)
2493 && gsym->type != GSYM_UNKNOWN
2494 && !gsym->binding_label
2495 && gsym->ns
2496 && gsym->ns->proc_name
2497 && not_in_recursive (sym, gsym->ns)
2498 && not_entry_self_reference (sym, gsym->ns))
2499 {
2500 gfc_symbol *def_sym;
2501 def_sym = gsym->ns->proc_name;
2502
2503 /* Resolve the gsymbol namespace if needed. */
2504 if (gsym->ns->resolved != -1)
2505 {
2506 if (!gsym->ns->resolved)
2507 {
2508 gfc_dt_list *old_dt_list;
2509
2510 /* Stash away derived types so that the backend_decls
2511 do not get mixed up. */
2512 old_dt_list = gfc_derived_types;
2513 gfc_derived_types = NULL;
2514
2515 gfc_resolve (gsym->ns);
2516
2517 /* Store the new derived types with the global namespace. */
2518 if (gfc_derived_types)
2519 gsym->ns->derived_types = gfc_derived_types;
2520
2521 /* Restore the derived types of this namespace. */
2522 gfc_derived_types = old_dt_list;
2523 }
2524
2525 /* Make sure that translation for the gsymbol occurs before
2526 the procedure currently being resolved. */
2527 ns = gfc_global_ns_list;
2528 for (; ns && ns != gsym->ns; ns = ns->sibling)
2529 {
2530 if (ns->sibling == gsym->ns)
2531 {
2532 ns->sibling = gsym->ns->sibling;
2533 gsym->ns->sibling = gfc_global_ns_list;
2534 gfc_global_ns_list = gsym->ns;
2535 break;
2536 }
2537 }
2538
2539 /* This can happen if a binding name has been specified. */
2540 if (gsym->binding_label && gsym->sym_name != def_sym->name)
2541 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2542
2543 if (def_sym->attr.entry_master || def_sym->attr.entry)
2544 {
2545 gfc_entry_list *entry;
2546 for (entry = gsym->ns->entries; entry; entry = entry->next)
2547 if (strcmp (entry->sym->name, sym->name) == 0)
2548 {
2549 def_sym = entry->sym;
2550 break;
2551 }
2552 }
2553 }
2554 if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2555 {
2556 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2557 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2558 gfc_typename (&def_sym->ts));
2559 goto done;
2560 }
2561
2562 if (sym->attr.if_source == IFSRC_UNKNOWN
2563 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2564 {
2565 gfc_error ("Explicit interface required for %qs at %L: %s",
2566 sym->name, &sym->declared_at, reason);
2567 goto done;
2568 }
2569
2570 if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU))
2571 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2572 gfc_errors_to_warnings (true);
2573
2574 if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2575 reason, sizeof(reason), NULL, NULL))
2576 {
2577 gfc_error_opt (OPT_Wargument_mismatch,
2578 "Interface mismatch in global procedure %qs at %L:"
2579 " %s", sym->name, &sym->declared_at, reason);
2580 goto done;
2581 }
2582
2583 if (!pedantic
2584 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2585 && !(gfc_option.warn_std & GFC_STD_GNU)))
2586 gfc_errors_to_warnings (true);
2587
2588 if (sym->attr.if_source != IFSRC_IFBODY)
2589 gfc_procedure_use (def_sym, actual, where);
2590 }
2591
2592 done:
2593 gfc_errors_to_warnings (false);
2594
2595 if (gsym->type == GSYM_UNKNOWN)
2596 {
2597 gsym->type = type;
2598 gsym->where = *where;
2599 }
2600
2601 gsym->used = 1;
2602 }
2603
2604
2605 /************* Function resolution *************/
2606
2607 /* Resolve a function call known to be generic.
2608 Section 14.1.2.4.1. */
2609
2610 static match
resolve_generic_f0(gfc_expr * expr,gfc_symbol * sym)2611 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2612 {
2613 gfc_symbol *s;
2614
2615 if (sym->attr.generic)
2616 {
2617 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2618 if (s != NULL)
2619 {
2620 expr->value.function.name = s->name;
2621 expr->value.function.esym = s;
2622
2623 if (s->ts.type != BT_UNKNOWN)
2624 expr->ts = s->ts;
2625 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2626 expr->ts = s->result->ts;
2627
2628 if (s->as != NULL)
2629 expr->rank = s->as->rank;
2630 else if (s->result != NULL && s->result->as != NULL)
2631 expr->rank = s->result->as->rank;
2632
2633 gfc_set_sym_referenced (expr->value.function.esym);
2634
2635 return MATCH_YES;
2636 }
2637
2638 /* TODO: Need to search for elemental references in generic
2639 interface. */
2640 }
2641
2642 if (sym->attr.intrinsic)
2643 return gfc_intrinsic_func_interface (expr, 0);
2644
2645 return MATCH_NO;
2646 }
2647
2648
2649 static bool
resolve_generic_f(gfc_expr * expr)2650 resolve_generic_f (gfc_expr *expr)
2651 {
2652 gfc_symbol *sym;
2653 match m;
2654 gfc_interface *intr = NULL;
2655
2656 sym = expr->symtree->n.sym;
2657
2658 for (;;)
2659 {
2660 m = resolve_generic_f0 (expr, sym);
2661 if (m == MATCH_YES)
2662 return true;
2663 else if (m == MATCH_ERROR)
2664 return false;
2665
2666 generic:
2667 if (!intr)
2668 for (intr = sym->generic; intr; intr = intr->next)
2669 if (gfc_fl_struct (intr->sym->attr.flavor))
2670 break;
2671
2672 if (sym->ns->parent == NULL)
2673 break;
2674 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2675
2676 if (sym == NULL)
2677 break;
2678 if (!generic_sym (sym))
2679 goto generic;
2680 }
2681
2682 /* Last ditch attempt. See if the reference is to an intrinsic
2683 that possesses a matching interface. 14.1.2.4 */
2684 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2685 {
2686 if (gfc_init_expr_flag)
2687 gfc_error ("Function %qs in initialization expression at %L "
2688 "must be an intrinsic function",
2689 expr->symtree->n.sym->name, &expr->where);
2690 else
2691 gfc_error ("There is no specific function for the generic %qs "
2692 "at %L", expr->symtree->n.sym->name, &expr->where);
2693 return false;
2694 }
2695
2696 if (intr)
2697 {
2698 if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2699 NULL, false))
2700 return false;
2701 if (!gfc_use_derived (expr->ts.u.derived))
2702 return false;
2703 return resolve_structure_cons (expr, 0);
2704 }
2705
2706 m = gfc_intrinsic_func_interface (expr, 0);
2707 if (m == MATCH_YES)
2708 return true;
2709
2710 if (m == MATCH_NO)
2711 gfc_error ("Generic function %qs at %L is not consistent with a "
2712 "specific intrinsic interface", expr->symtree->n.sym->name,
2713 &expr->where);
2714
2715 return false;
2716 }
2717
2718
2719 /* Resolve a function call known to be specific. */
2720
2721 static match
resolve_specific_f0(gfc_symbol * sym,gfc_expr * expr)2722 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2723 {
2724 match m;
2725
2726 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2727 {
2728 if (sym->attr.dummy)
2729 {
2730 sym->attr.proc = PROC_DUMMY;
2731 goto found;
2732 }
2733
2734 sym->attr.proc = PROC_EXTERNAL;
2735 goto found;
2736 }
2737
2738 if (sym->attr.proc == PROC_MODULE
2739 || sym->attr.proc == PROC_ST_FUNCTION
2740 || sym->attr.proc == PROC_INTERNAL)
2741 goto found;
2742
2743 if (sym->attr.intrinsic)
2744 {
2745 m = gfc_intrinsic_func_interface (expr, 1);
2746 if (m == MATCH_YES)
2747 return MATCH_YES;
2748 if (m == MATCH_NO)
2749 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2750 "with an intrinsic", sym->name, &expr->where);
2751
2752 return MATCH_ERROR;
2753 }
2754
2755 return MATCH_NO;
2756
2757 found:
2758 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2759
2760 if (sym->result)
2761 expr->ts = sym->result->ts;
2762 else
2763 expr->ts = sym->ts;
2764 expr->value.function.name = sym->name;
2765 expr->value.function.esym = sym;
2766 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2767 error(s). */
2768 if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2769 return MATCH_ERROR;
2770 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2771 expr->rank = CLASS_DATA (sym)->as->rank;
2772 else if (sym->as != NULL)
2773 expr->rank = sym->as->rank;
2774
2775 return MATCH_YES;
2776 }
2777
2778
2779 static bool
resolve_specific_f(gfc_expr * expr)2780 resolve_specific_f (gfc_expr *expr)
2781 {
2782 gfc_symbol *sym;
2783 match m;
2784
2785 sym = expr->symtree->n.sym;
2786
2787 for (;;)
2788 {
2789 m = resolve_specific_f0 (sym, expr);
2790 if (m == MATCH_YES)
2791 return true;
2792 if (m == MATCH_ERROR)
2793 return false;
2794
2795 if (sym->ns->parent == NULL)
2796 break;
2797
2798 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2799
2800 if (sym == NULL)
2801 break;
2802 }
2803
2804 gfc_error ("Unable to resolve the specific function %qs at %L",
2805 expr->symtree->n.sym->name, &expr->where);
2806
2807 return true;
2808 }
2809
2810 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2811 candidates in CANDIDATES_LEN. */
2812
2813 static void
lookup_function_fuzzy_find_candidates(gfc_symtree * sym,char ** & candidates,size_t & candidates_len)2814 lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
2815 char **&candidates,
2816 size_t &candidates_len)
2817 {
2818 gfc_symtree *p;
2819
2820 if (sym == NULL)
2821 return;
2822 if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
2823 && sym->n.sym->attr.flavor == FL_PROCEDURE)
2824 vec_push (candidates, candidates_len, sym->name);
2825
2826 p = sym->left;
2827 if (p)
2828 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2829
2830 p = sym->right;
2831 if (p)
2832 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2833 }
2834
2835
2836 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2837
2838 const char*
gfc_lookup_function_fuzzy(const char * fn,gfc_symtree * symroot)2839 gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
2840 {
2841 char **candidates = NULL;
2842 size_t candidates_len = 0;
2843 lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
2844 return gfc_closest_fuzzy_match (fn, candidates);
2845 }
2846
2847
2848 /* Resolve a procedure call not known to be generic nor specific. */
2849
2850 static bool
resolve_unknown_f(gfc_expr * expr)2851 resolve_unknown_f (gfc_expr *expr)
2852 {
2853 gfc_symbol *sym;
2854 gfc_typespec *ts;
2855
2856 sym = expr->symtree->n.sym;
2857
2858 if (sym->attr.dummy)
2859 {
2860 sym->attr.proc = PROC_DUMMY;
2861 expr->value.function.name = sym->name;
2862 goto set_type;
2863 }
2864
2865 /* See if we have an intrinsic function reference. */
2866
2867 if (gfc_is_intrinsic (sym, 0, expr->where))
2868 {
2869 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2870 return true;
2871 return false;
2872 }
2873
2874 /* The reference is to an external name. */
2875
2876 sym->attr.proc = PROC_EXTERNAL;
2877 expr->value.function.name = sym->name;
2878 expr->value.function.esym = expr->symtree->n.sym;
2879
2880 if (sym->as != NULL)
2881 expr->rank = sym->as->rank;
2882
2883 /* Type of the expression is either the type of the symbol or the
2884 default type of the symbol. */
2885
2886 set_type:
2887 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2888
2889 if (sym->ts.type != BT_UNKNOWN)
2890 expr->ts = sym->ts;
2891 else
2892 {
2893 ts = gfc_get_default_type (sym->name, sym->ns);
2894
2895 if (ts->type == BT_UNKNOWN)
2896 {
2897 const char *guessed
2898 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
2899 if (guessed)
2900 gfc_error ("Function %qs at %L has no IMPLICIT type"
2901 "; did you mean %qs?",
2902 sym->name, &expr->where, guessed);
2903 else
2904 gfc_error ("Function %qs at %L has no IMPLICIT type",
2905 sym->name, &expr->where);
2906 return false;
2907 }
2908 else
2909 expr->ts = *ts;
2910 }
2911
2912 return true;
2913 }
2914
2915
2916 /* Return true, if the symbol is an external procedure. */
2917 static bool
is_external_proc(gfc_symbol * sym)2918 is_external_proc (gfc_symbol *sym)
2919 {
2920 if (!sym->attr.dummy && !sym->attr.contained
2921 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
2922 && sym->attr.proc != PROC_ST_FUNCTION
2923 && !sym->attr.proc_pointer
2924 && !sym->attr.use_assoc
2925 && sym->name)
2926 return true;
2927
2928 return false;
2929 }
2930
2931
2932 /* Figure out if a function reference is pure or not. Also set the name
2933 of the function for a potential error message. Return nonzero if the
2934 function is PURE, zero if not. */
2935 static int
2936 pure_stmt_function (gfc_expr *, gfc_symbol *);
2937
2938 static int
pure_function(gfc_expr * e,const char ** name)2939 pure_function (gfc_expr *e, const char **name)
2940 {
2941 int pure;
2942 gfc_component *comp;
2943
2944 *name = NULL;
2945
2946 if (e->symtree != NULL
2947 && e->symtree->n.sym != NULL
2948 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2949 return pure_stmt_function (e, e->symtree->n.sym);
2950
2951 comp = gfc_get_proc_ptr_comp (e);
2952 if (comp)
2953 {
2954 pure = gfc_pure (comp->ts.interface);
2955 *name = comp->name;
2956 }
2957 else if (e->value.function.esym)
2958 {
2959 pure = gfc_pure (e->value.function.esym);
2960 *name = e->value.function.esym->name;
2961 }
2962 else if (e->value.function.isym)
2963 {
2964 pure = e->value.function.isym->pure
2965 || e->value.function.isym->elemental;
2966 *name = e->value.function.isym->name;
2967 }
2968 else
2969 {
2970 /* Implicit functions are not pure. */
2971 pure = 0;
2972 *name = e->value.function.name;
2973 }
2974
2975 return pure;
2976 }
2977
2978
2979 static bool
impure_stmt_fcn(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)2980 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2981 int *f ATTRIBUTE_UNUSED)
2982 {
2983 const char *name;
2984
2985 /* Don't bother recursing into other statement functions
2986 since they will be checked individually for purity. */
2987 if (e->expr_type != EXPR_FUNCTION
2988 || !e->symtree
2989 || e->symtree->n.sym == sym
2990 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2991 return false;
2992
2993 return pure_function (e, &name) ? false : true;
2994 }
2995
2996
2997 static int
pure_stmt_function(gfc_expr * e,gfc_symbol * sym)2998 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2999 {
3000 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3001 }
3002
3003
3004 /* Check if an impure function is allowed in the current context. */
3005
check_pure_function(gfc_expr * e)3006 static bool check_pure_function (gfc_expr *e)
3007 {
3008 const char *name = NULL;
3009 if (!pure_function (e, &name) && name)
3010 {
3011 if (forall_flag)
3012 {
3013 gfc_error ("Reference to impure function %qs at %L inside a "
3014 "FORALL %s", name, &e->where,
3015 forall_flag == 2 ? "mask" : "block");
3016 return false;
3017 }
3018 else if (gfc_do_concurrent_flag)
3019 {
3020 gfc_error ("Reference to impure function %qs at %L inside a "
3021 "DO CONCURRENT %s", name, &e->where,
3022 gfc_do_concurrent_flag == 2 ? "mask" : "block");
3023 return false;
3024 }
3025 else if (gfc_pure (NULL))
3026 {
3027 gfc_error ("Reference to impure function %qs at %L "
3028 "within a PURE procedure", name, &e->where);
3029 return false;
3030 }
3031 gfc_unset_implicit_pure (NULL);
3032 }
3033 return true;
3034 }
3035
3036
3037 /* Update current procedure's array_outer_dependency flag, considering
3038 a call to procedure SYM. */
3039
3040 static void
update_current_proc_array_outer_dependency(gfc_symbol * sym)3041 update_current_proc_array_outer_dependency (gfc_symbol *sym)
3042 {
3043 /* Check to see if this is a sibling function that has not yet
3044 been resolved. */
3045 gfc_namespace *sibling = gfc_current_ns->sibling;
3046 for (; sibling; sibling = sibling->sibling)
3047 {
3048 if (sibling->proc_name == sym)
3049 {
3050 gfc_resolve (sibling);
3051 break;
3052 }
3053 }
3054
3055 /* If SYM has references to outer arrays, so has the procedure calling
3056 SYM. If SYM is a procedure pointer, we can assume the worst. */
3057 if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3058 && gfc_current_ns->proc_name)
3059 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3060 }
3061
3062
3063 /* Resolve a function call, which means resolving the arguments, then figuring
3064 out which entity the name refers to. */
3065
3066 static bool
resolve_function(gfc_expr * expr)3067 resolve_function (gfc_expr *expr)
3068 {
3069 gfc_actual_arglist *arg;
3070 gfc_symbol *sym;
3071 bool t;
3072 int temp;
3073 procedure_type p = PROC_INTRINSIC;
3074 bool no_formal_args;
3075
3076 sym = NULL;
3077 if (expr->symtree)
3078 sym = expr->symtree->n.sym;
3079
3080 /* If this is a procedure pointer component, it has already been resolved. */
3081 if (gfc_is_proc_ptr_comp (expr))
3082 return true;
3083
3084 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3085 another caf_get. */
3086 if (sym && sym->attr.intrinsic
3087 && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3088 || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3089 return true;
3090
3091 if (sym && sym->attr.intrinsic
3092 && !gfc_resolve_intrinsic (sym, &expr->where))
3093 return false;
3094
3095 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3096 {
3097 gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3098 return false;
3099 }
3100
3101 /* If this ia a deferred TBP with an abstract interface (which may
3102 of course be referenced), expr->value.function.esym will be set. */
3103 if (sym && sym->attr.abstract && !expr->value.function.esym)
3104 {
3105 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3106 sym->name, &expr->where);
3107 return false;
3108 }
3109
3110 /* Switch off assumed size checking and do this again for certain kinds
3111 of procedure, once the procedure itself is resolved. */
3112 need_full_assumed_size++;
3113
3114 if (expr->symtree && expr->symtree->n.sym)
3115 p = expr->symtree->n.sym->attr.proc;
3116
3117 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3118 inquiry_argument = true;
3119 no_formal_args = sym && is_external_proc (sym)
3120 && gfc_sym_get_dummy_args (sym) == NULL;
3121
3122 if (!resolve_actual_arglist (expr->value.function.actual,
3123 p, no_formal_args))
3124 {
3125 inquiry_argument = false;
3126 return false;
3127 }
3128
3129 inquiry_argument = false;
3130
3131 /* Resume assumed_size checking. */
3132 need_full_assumed_size--;
3133
3134 /* If the procedure is external, check for usage. */
3135 if (sym && is_external_proc (sym))
3136 resolve_global_procedure (sym, &expr->where,
3137 &expr->value.function.actual, 0);
3138
3139 if (sym && sym->ts.type == BT_CHARACTER
3140 && sym->ts.u.cl
3141 && sym->ts.u.cl->length == NULL
3142 && !sym->attr.dummy
3143 && !sym->ts.deferred
3144 && expr->value.function.esym == NULL
3145 && !sym->attr.contained)
3146 {
3147 /* Internal procedures are taken care of in resolve_contained_fntype. */
3148 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3149 "be used at %L since it is not a dummy argument",
3150 sym->name, &expr->where);
3151 return false;
3152 }
3153
3154 /* See if function is already resolved. */
3155
3156 if (expr->value.function.name != NULL
3157 || expr->value.function.isym != NULL)
3158 {
3159 if (expr->ts.type == BT_UNKNOWN)
3160 expr->ts = sym->ts;
3161 t = true;
3162 }
3163 else
3164 {
3165 /* Apply the rules of section 14.1.2. */
3166
3167 switch (procedure_kind (sym))
3168 {
3169 case PTYPE_GENERIC:
3170 t = resolve_generic_f (expr);
3171 break;
3172
3173 case PTYPE_SPECIFIC:
3174 t = resolve_specific_f (expr);
3175 break;
3176
3177 case PTYPE_UNKNOWN:
3178 t = resolve_unknown_f (expr);
3179 break;
3180
3181 default:
3182 gfc_internal_error ("resolve_function(): bad function type");
3183 }
3184 }
3185
3186 /* If the expression is still a function (it might have simplified),
3187 then we check to see if we are calling an elemental function. */
3188
3189 if (expr->expr_type != EXPR_FUNCTION)
3190 return t;
3191
3192 temp = need_full_assumed_size;
3193 need_full_assumed_size = 0;
3194
3195 if (!resolve_elemental_actual (expr, NULL))
3196 return false;
3197
3198 if (omp_workshare_flag
3199 && expr->value.function.esym
3200 && ! gfc_elemental (expr->value.function.esym))
3201 {
3202 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3203 "in WORKSHARE construct", expr->value.function.esym->name,
3204 &expr->where);
3205 t = false;
3206 }
3207
3208 #define GENERIC_ID expr->value.function.isym->id
3209 else if (expr->value.function.actual != NULL
3210 && expr->value.function.isym != NULL
3211 && GENERIC_ID != GFC_ISYM_LBOUND
3212 && GENERIC_ID != GFC_ISYM_LCOBOUND
3213 && GENERIC_ID != GFC_ISYM_UCOBOUND
3214 && GENERIC_ID != GFC_ISYM_LEN
3215 && GENERIC_ID != GFC_ISYM_LOC
3216 && GENERIC_ID != GFC_ISYM_C_LOC
3217 && GENERIC_ID != GFC_ISYM_PRESENT)
3218 {
3219 /* Array intrinsics must also have the last upper bound of an
3220 assumed size array argument. UBOUND and SIZE have to be
3221 excluded from the check if the second argument is anything
3222 than a constant. */
3223
3224 for (arg = expr->value.function.actual; arg; arg = arg->next)
3225 {
3226 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3227 && arg == expr->value.function.actual
3228 && arg->next != NULL && arg->next->expr)
3229 {
3230 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3231 break;
3232
3233 if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0)
3234 break;
3235
3236 if ((int)mpz_get_si (arg->next->expr->value.integer)
3237 < arg->expr->rank)
3238 break;
3239 }
3240
3241 if (arg->expr != NULL
3242 && arg->expr->rank > 0
3243 && resolve_assumed_size_actual (arg->expr))
3244 return false;
3245 }
3246 }
3247 #undef GENERIC_ID
3248
3249 need_full_assumed_size = temp;
3250
3251 if (!check_pure_function(expr))
3252 t = false;
3253
3254 /* Functions without the RECURSIVE attribution are not allowed to
3255 * call themselves. */
3256 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3257 {
3258 gfc_symbol *esym;
3259 esym = expr->value.function.esym;
3260
3261 if (is_illegal_recursion (esym, gfc_current_ns))
3262 {
3263 if (esym->attr.entry && esym->ns->entries)
3264 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3265 " function %qs is not RECURSIVE",
3266 esym->name, &expr->where, esym->ns->entries->sym->name);
3267 else
3268 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3269 " is not RECURSIVE", esym->name, &expr->where);
3270
3271 t = false;
3272 }
3273 }
3274
3275 /* Character lengths of use associated functions may contains references to
3276 symbols not referenced from the current program unit otherwise. Make sure
3277 those symbols are marked as referenced. */
3278
3279 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3280 && expr->value.function.esym->attr.use_assoc)
3281 {
3282 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3283 }
3284
3285 /* Make sure that the expression has a typespec that works. */
3286 if (expr->ts.type == BT_UNKNOWN)
3287 {
3288 if (expr->symtree->n.sym->result
3289 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3290 && !expr->symtree->n.sym->result->attr.proc_pointer)
3291 expr->ts = expr->symtree->n.sym->result->ts;
3292 }
3293
3294 if (!expr->ref && !expr->value.function.isym)
3295 {
3296 if (expr->value.function.esym)
3297 update_current_proc_array_outer_dependency (expr->value.function.esym);
3298 else
3299 update_current_proc_array_outer_dependency (sym);
3300 }
3301 else if (expr->ref)
3302 /* typebound procedure: Assume the worst. */
3303 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3304
3305 return t;
3306 }
3307
3308
3309 /************* Subroutine resolution *************/
3310
3311 static bool
pure_subroutine(gfc_symbol * sym,const char * name,locus * loc)3312 pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3313 {
3314 if (gfc_pure (sym))
3315 return true;
3316
3317 if (forall_flag)
3318 {
3319 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3320 name, loc);
3321 return false;
3322 }
3323 else if (gfc_do_concurrent_flag)
3324 {
3325 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3326 "PURE", name, loc);
3327 return false;
3328 }
3329 else if (gfc_pure (NULL))
3330 {
3331 gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3332 return false;
3333 }
3334
3335 gfc_unset_implicit_pure (NULL);
3336 return true;
3337 }
3338
3339
3340 static match
resolve_generic_s0(gfc_code * c,gfc_symbol * sym)3341 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3342 {
3343 gfc_symbol *s;
3344
3345 if (sym->attr.generic)
3346 {
3347 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3348 if (s != NULL)
3349 {
3350 c->resolved_sym = s;
3351 if (!pure_subroutine (s, s->name, &c->loc))
3352 return MATCH_ERROR;
3353 return MATCH_YES;
3354 }
3355
3356 /* TODO: Need to search for elemental references in generic interface. */
3357 }
3358
3359 if (sym->attr.intrinsic)
3360 return gfc_intrinsic_sub_interface (c, 0);
3361
3362 return MATCH_NO;
3363 }
3364
3365
3366 static bool
resolve_generic_s(gfc_code * c)3367 resolve_generic_s (gfc_code *c)
3368 {
3369 gfc_symbol *sym;
3370 match m;
3371
3372 sym = c->symtree->n.sym;
3373
3374 for (;;)
3375 {
3376 m = resolve_generic_s0 (c, sym);
3377 if (m == MATCH_YES)
3378 return true;
3379 else if (m == MATCH_ERROR)
3380 return false;
3381
3382 generic:
3383 if (sym->ns->parent == NULL)
3384 break;
3385 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3386
3387 if (sym == NULL)
3388 break;
3389 if (!generic_sym (sym))
3390 goto generic;
3391 }
3392
3393 /* Last ditch attempt. See if the reference is to an intrinsic
3394 that possesses a matching interface. 14.1.2.4 */
3395 sym = c->symtree->n.sym;
3396
3397 if (!gfc_is_intrinsic (sym, 1, c->loc))
3398 {
3399 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3400 sym->name, &c->loc);
3401 return false;
3402 }
3403
3404 m = gfc_intrinsic_sub_interface (c, 0);
3405 if (m == MATCH_YES)
3406 return true;
3407 if (m == MATCH_NO)
3408 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3409 "intrinsic subroutine interface", sym->name, &c->loc);
3410
3411 return false;
3412 }
3413
3414
3415 /* Resolve a subroutine call known to be specific. */
3416
3417 static match
resolve_specific_s0(gfc_code * c,gfc_symbol * sym)3418 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3419 {
3420 match m;
3421
3422 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3423 {
3424 if (sym->attr.dummy)
3425 {
3426 sym->attr.proc = PROC_DUMMY;
3427 goto found;
3428 }
3429
3430 sym->attr.proc = PROC_EXTERNAL;
3431 goto found;
3432 }
3433
3434 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3435 goto found;
3436
3437 if (sym->attr.intrinsic)
3438 {
3439 m = gfc_intrinsic_sub_interface (c, 1);
3440 if (m == MATCH_YES)
3441 return MATCH_YES;
3442 if (m == MATCH_NO)
3443 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3444 "with an intrinsic", sym->name, &c->loc);
3445
3446 return MATCH_ERROR;
3447 }
3448
3449 return MATCH_NO;
3450
3451 found:
3452 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3453
3454 c->resolved_sym = sym;
3455 if (!pure_subroutine (sym, sym->name, &c->loc))
3456 return MATCH_ERROR;
3457
3458 return MATCH_YES;
3459 }
3460
3461
3462 static bool
resolve_specific_s(gfc_code * c)3463 resolve_specific_s (gfc_code *c)
3464 {
3465 gfc_symbol *sym;
3466 match m;
3467
3468 sym = c->symtree->n.sym;
3469
3470 for (;;)
3471 {
3472 m = resolve_specific_s0 (c, sym);
3473 if (m == MATCH_YES)
3474 return true;
3475 if (m == MATCH_ERROR)
3476 return false;
3477
3478 if (sym->ns->parent == NULL)
3479 break;
3480
3481 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3482
3483 if (sym == NULL)
3484 break;
3485 }
3486
3487 sym = c->symtree->n.sym;
3488 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3489 sym->name, &c->loc);
3490
3491 return false;
3492 }
3493
3494
3495 /* Resolve a subroutine call not known to be generic nor specific. */
3496
3497 static bool
resolve_unknown_s(gfc_code * c)3498 resolve_unknown_s (gfc_code *c)
3499 {
3500 gfc_symbol *sym;
3501
3502 sym = c->symtree->n.sym;
3503
3504 if (sym->attr.dummy)
3505 {
3506 sym->attr.proc = PROC_DUMMY;
3507 goto found;
3508 }
3509
3510 /* See if we have an intrinsic function reference. */
3511
3512 if (gfc_is_intrinsic (sym, 1, c->loc))
3513 {
3514 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3515 return true;
3516 return false;
3517 }
3518
3519 /* The reference is to an external name. */
3520
3521 found:
3522 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3523
3524 c->resolved_sym = sym;
3525
3526 return pure_subroutine (sym, sym->name, &c->loc);
3527 }
3528
3529
3530 /* Resolve a subroutine call. Although it was tempting to use the same code
3531 for functions, subroutines and functions are stored differently and this
3532 makes things awkward. */
3533
3534 static bool
resolve_call(gfc_code * c)3535 resolve_call (gfc_code *c)
3536 {
3537 bool t;
3538 procedure_type ptype = PROC_INTRINSIC;
3539 gfc_symbol *csym, *sym;
3540 bool no_formal_args;
3541
3542 csym = c->symtree ? c->symtree->n.sym : NULL;
3543
3544 if (csym && csym->ts.type != BT_UNKNOWN)
3545 {
3546 gfc_error ("%qs at %L has a type, which is not consistent with "
3547 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3548 return false;
3549 }
3550
3551 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3552 {
3553 gfc_symtree *st;
3554 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3555 sym = st ? st->n.sym : NULL;
3556 if (sym && csym != sym
3557 && sym->ns == gfc_current_ns
3558 && sym->attr.flavor == FL_PROCEDURE
3559 && sym->attr.contained)
3560 {
3561 sym->refs++;
3562 if (csym->attr.generic)
3563 c->symtree->n.sym = sym;
3564 else
3565 c->symtree = st;
3566 csym = c->symtree->n.sym;
3567 }
3568 }
3569
3570 /* If this ia a deferred TBP, c->expr1 will be set. */
3571 if (!c->expr1 && csym)
3572 {
3573 if (csym->attr.abstract)
3574 {
3575 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3576 csym->name, &c->loc);
3577 return false;
3578 }
3579
3580 /* Subroutines without the RECURSIVE attribution are not allowed to
3581 call themselves. */
3582 if (is_illegal_recursion (csym, gfc_current_ns))
3583 {
3584 if (csym->attr.entry && csym->ns->entries)
3585 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3586 "as subroutine %qs is not RECURSIVE",
3587 csym->name, &c->loc, csym->ns->entries->sym->name);
3588 else
3589 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3590 "as it is not RECURSIVE", csym->name, &c->loc);
3591
3592 t = false;
3593 }
3594 }
3595
3596 /* Switch off assumed size checking and do this again for certain kinds
3597 of procedure, once the procedure itself is resolved. */
3598 need_full_assumed_size++;
3599
3600 if (csym)
3601 ptype = csym->attr.proc;
3602
3603 no_formal_args = csym && is_external_proc (csym)
3604 && gfc_sym_get_dummy_args (csym) == NULL;
3605 if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3606 return false;
3607
3608 /* Resume assumed_size checking. */
3609 need_full_assumed_size--;
3610
3611 /* If external, check for usage. */
3612 if (csym && is_external_proc (csym))
3613 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3614
3615 t = true;
3616 if (c->resolved_sym == NULL)
3617 {
3618 c->resolved_isym = NULL;
3619 switch (procedure_kind (csym))
3620 {
3621 case PTYPE_GENERIC:
3622 t = resolve_generic_s (c);
3623 break;
3624
3625 case PTYPE_SPECIFIC:
3626 t = resolve_specific_s (c);
3627 break;
3628
3629 case PTYPE_UNKNOWN:
3630 t = resolve_unknown_s (c);
3631 break;
3632
3633 default:
3634 gfc_internal_error ("resolve_subroutine(): bad function type");
3635 }
3636 }
3637
3638 /* Some checks of elemental subroutine actual arguments. */
3639 if (!resolve_elemental_actual (NULL, c))
3640 return false;
3641
3642 if (!c->expr1)
3643 update_current_proc_array_outer_dependency (csym);
3644 else
3645 /* Typebound procedure: Assume the worst. */
3646 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3647
3648 return t;
3649 }
3650
3651
3652 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3653 op1->shape and op2->shape are non-NULL return true if their shapes
3654 match. If both op1->shape and op2->shape are non-NULL return false
3655 if their shapes do not match. If either op1->shape or op2->shape is
3656 NULL, return true. */
3657
3658 static bool
compare_shapes(gfc_expr * op1,gfc_expr * op2)3659 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3660 {
3661 bool t;
3662 int i;
3663
3664 t = true;
3665
3666 if (op1->shape != NULL && op2->shape != NULL)
3667 {
3668 for (i = 0; i < op1->rank; i++)
3669 {
3670 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3671 {
3672 gfc_error ("Shapes for operands at %L and %L are not conformable",
3673 &op1->where, &op2->where);
3674 t = false;
3675 break;
3676 }
3677 }
3678 }
3679
3680 return t;
3681 }
3682
3683 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3684 For example A .AND. B becomes IAND(A, B). */
3685 static gfc_expr *
logical_to_bitwise(gfc_expr * e)3686 logical_to_bitwise (gfc_expr *e)
3687 {
3688 gfc_expr *tmp, *op1, *op2;
3689 gfc_isym_id isym;
3690 gfc_actual_arglist *args = NULL;
3691
3692 gcc_assert (e->expr_type == EXPR_OP);
3693
3694 isym = GFC_ISYM_NONE;
3695 op1 = e->value.op.op1;
3696 op2 = e->value.op.op2;
3697
3698 switch (e->value.op.op)
3699 {
3700 case INTRINSIC_NOT:
3701 isym = GFC_ISYM_NOT;
3702 break;
3703 case INTRINSIC_AND:
3704 isym = GFC_ISYM_IAND;
3705 break;
3706 case INTRINSIC_OR:
3707 isym = GFC_ISYM_IOR;
3708 break;
3709 case INTRINSIC_NEQV:
3710 isym = GFC_ISYM_IEOR;
3711 break;
3712 case INTRINSIC_EQV:
3713 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3714 Change the old expression to NEQV, which will get replaced by IEOR,
3715 and wrap it in NOT. */
3716 tmp = gfc_copy_expr (e);
3717 tmp->value.op.op = INTRINSIC_NEQV;
3718 tmp = logical_to_bitwise (tmp);
3719 isym = GFC_ISYM_NOT;
3720 op1 = tmp;
3721 op2 = NULL;
3722 break;
3723 default:
3724 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3725 }
3726
3727 /* Inherit the original operation's operands as arguments. */
3728 args = gfc_get_actual_arglist ();
3729 args->expr = op1;
3730 if (op2)
3731 {
3732 args->next = gfc_get_actual_arglist ();
3733 args->next->expr = op2;
3734 }
3735
3736 /* Convert the expression to a function call. */
3737 e->expr_type = EXPR_FUNCTION;
3738 e->value.function.actual = args;
3739 e->value.function.isym = gfc_intrinsic_function_by_id (isym);
3740 e->value.function.name = e->value.function.isym->name;
3741 e->value.function.esym = NULL;
3742
3743 /* Make up a pre-resolved function call symtree if we need to. */
3744 if (!e->symtree || !e->symtree->n.sym)
3745 {
3746 gfc_symbol *sym;
3747 gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
3748 sym = e->symtree->n.sym;
3749 sym->result = sym;
3750 sym->attr.flavor = FL_PROCEDURE;
3751 sym->attr.function = 1;
3752 sym->attr.elemental = 1;
3753 sym->attr.pure = 1;
3754 sym->attr.referenced = 1;
3755 gfc_intrinsic_symbol (sym);
3756 gfc_commit_symbol (sym);
3757 }
3758
3759 args->name = e->value.function.isym->formal->name;
3760 if (e->value.function.isym->formal->next)
3761 args->next->name = e->value.function.isym->formal->next->name;
3762
3763 return e;
3764 }
3765
3766 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3767 candidates in CANDIDATES_LEN. */
3768 static void
lookup_uop_fuzzy_find_candidates(gfc_symtree * uop,char ** & candidates,size_t & candidates_len)3769 lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
3770 char **&candidates,
3771 size_t &candidates_len)
3772 {
3773 gfc_symtree *p;
3774
3775 if (uop == NULL)
3776 return;
3777
3778 /* Not sure how to properly filter here. Use all for a start.
3779 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3780 these as i suppose they don't make terribly sense. */
3781
3782 if (uop->n.uop->op != NULL)
3783 vec_push (candidates, candidates_len, uop->name);
3784
3785 p = uop->left;
3786 if (p)
3787 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3788
3789 p = uop->right;
3790 if (p)
3791 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3792 }
3793
3794 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3795
3796 static const char*
lookup_uop_fuzzy(const char * op,gfc_symtree * uop)3797 lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
3798 {
3799 char **candidates = NULL;
3800 size_t candidates_len = 0;
3801 lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
3802 return gfc_closest_fuzzy_match (op, candidates);
3803 }
3804
3805
3806 /* Resolve an operator expression node. This can involve replacing the
3807 operation with a user defined function call. */
3808
3809 static bool
resolve_operator(gfc_expr * e)3810 resolve_operator (gfc_expr *e)
3811 {
3812 gfc_expr *op1, *op2;
3813 char msg[200];
3814 bool dual_locus_error;
3815 bool t;
3816
3817 /* Resolve all subnodes-- give them types. */
3818
3819 switch (e->value.op.op)
3820 {
3821 default:
3822 if (!gfc_resolve_expr (e->value.op.op2))
3823 return false;
3824
3825 /* Fall through. */
3826
3827 case INTRINSIC_NOT:
3828 case INTRINSIC_UPLUS:
3829 case INTRINSIC_UMINUS:
3830 case INTRINSIC_PARENTHESES:
3831 if (!gfc_resolve_expr (e->value.op.op1))
3832 return false;
3833 break;
3834 }
3835
3836 /* Typecheck the new node. */
3837
3838 op1 = e->value.op.op1;
3839 op2 = e->value.op.op2;
3840 dual_locus_error = false;
3841
3842 if ((op1 && op1->expr_type == EXPR_NULL)
3843 || (op2 && op2->expr_type == EXPR_NULL))
3844 {
3845 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3846 goto bad_op;
3847 }
3848
3849 switch (e->value.op.op)
3850 {
3851 case INTRINSIC_UPLUS:
3852 case INTRINSIC_UMINUS:
3853 if (op1->ts.type == BT_INTEGER
3854 || op1->ts.type == BT_REAL
3855 || op1->ts.type == BT_COMPLEX)
3856 {
3857 e->ts = op1->ts;
3858 break;
3859 }
3860
3861 sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3862 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3863 goto bad_op;
3864
3865 case INTRINSIC_PLUS:
3866 case INTRINSIC_MINUS:
3867 case INTRINSIC_TIMES:
3868 case INTRINSIC_DIVIDE:
3869 case INTRINSIC_POWER:
3870 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3871 {
3872 gfc_type_convert_binary (e, 1);
3873 break;
3874 }
3875
3876 if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
3877 sprintf (msg,
3878 _("Unexpected derived-type entities in binary intrinsic "
3879 "numeric operator %%<%s%%> at %%L"),
3880 gfc_op2string (e->value.op.op));
3881 else
3882 sprintf (msg,
3883 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3884 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3885 gfc_typename (&op2->ts));
3886 goto bad_op;
3887
3888 case INTRINSIC_CONCAT:
3889 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3890 && op1->ts.kind == op2->ts.kind)
3891 {
3892 e->ts.type = BT_CHARACTER;
3893 e->ts.kind = op1->ts.kind;
3894 break;
3895 }
3896
3897 sprintf (msg,
3898 _("Operands of string concatenation operator at %%L are %s/%s"),
3899 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3900 goto bad_op;
3901
3902 case INTRINSIC_AND:
3903 case INTRINSIC_OR:
3904 case INTRINSIC_EQV:
3905 case INTRINSIC_NEQV:
3906 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3907 {
3908 e->ts.type = BT_LOGICAL;
3909 e->ts.kind = gfc_kind_max (op1, op2);
3910 if (op1->ts.kind < e->ts.kind)
3911 gfc_convert_type (op1, &e->ts, 2);
3912 else if (op2->ts.kind < e->ts.kind)
3913 gfc_convert_type (op2, &e->ts, 2);
3914 break;
3915 }
3916
3917 /* Logical ops on integers become bitwise ops with -fdec. */
3918 else if (flag_dec
3919 && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
3920 {
3921 e->ts.type = BT_INTEGER;
3922 e->ts.kind = gfc_kind_max (op1, op2);
3923 if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
3924 gfc_convert_type (op1, &e->ts, 1);
3925 if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
3926 gfc_convert_type (op2, &e->ts, 1);
3927 e = logical_to_bitwise (e);
3928 break;
3929 }
3930
3931 sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3932 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3933 gfc_typename (&op2->ts));
3934
3935 goto bad_op;
3936
3937 case INTRINSIC_NOT:
3938 /* Logical ops on integers become bitwise ops with -fdec. */
3939 if (flag_dec && op1->ts.type == BT_INTEGER)
3940 {
3941 e->ts.type = BT_INTEGER;
3942 e->ts.kind = op1->ts.kind;
3943 e = logical_to_bitwise (e);
3944 break;
3945 }
3946
3947 if (op1->ts.type == BT_LOGICAL)
3948 {
3949 e->ts.type = BT_LOGICAL;
3950 e->ts.kind = op1->ts.kind;
3951 break;
3952 }
3953
3954 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3955 gfc_typename (&op1->ts));
3956 goto bad_op;
3957
3958 case INTRINSIC_GT:
3959 case INTRINSIC_GT_OS:
3960 case INTRINSIC_GE:
3961 case INTRINSIC_GE_OS:
3962 case INTRINSIC_LT:
3963 case INTRINSIC_LT_OS:
3964 case INTRINSIC_LE:
3965 case INTRINSIC_LE_OS:
3966 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3967 {
3968 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3969 goto bad_op;
3970 }
3971
3972 /* Fall through. */
3973
3974 case INTRINSIC_EQ:
3975 case INTRINSIC_EQ_OS:
3976 case INTRINSIC_NE:
3977 case INTRINSIC_NE_OS:
3978 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3979 && op1->ts.kind == op2->ts.kind)
3980 {
3981 e->ts.type = BT_LOGICAL;
3982 e->ts.kind = gfc_default_logical_kind;
3983 break;
3984 }
3985
3986 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3987 {
3988 gfc_type_convert_binary (e, 1);
3989
3990 e->ts.type = BT_LOGICAL;
3991 e->ts.kind = gfc_default_logical_kind;
3992
3993 if (warn_compare_reals)
3994 {
3995 gfc_intrinsic_op op = e->value.op.op;
3996
3997 /* Type conversion has made sure that the types of op1 and op2
3998 agree, so it is only necessary to check the first one. */
3999 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4000 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4001 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4002 {
4003 const char *msg;
4004
4005 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4006 msg = "Equality comparison for %s at %L";
4007 else
4008 msg = "Inequality comparison for %s at %L";
4009
4010 gfc_warning (OPT_Wcompare_reals, msg,
4011 gfc_typename (&op1->ts), &op1->where);
4012 }
4013 }
4014
4015 break;
4016 }
4017
4018 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4019 sprintf (msg,
4020 _("Logicals at %%L must be compared with %s instead of %s"),
4021 (e->value.op.op == INTRINSIC_EQ
4022 || e->value.op.op == INTRINSIC_EQ_OS)
4023 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4024 else
4025 sprintf (msg,
4026 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4027 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
4028 gfc_typename (&op2->ts));
4029
4030 goto bad_op;
4031
4032 case INTRINSIC_USER:
4033 if (e->value.op.uop->op == NULL)
4034 {
4035 const char *name = e->value.op.uop->name;
4036 const char *guessed;
4037 guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4038 if (guessed)
4039 sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4040 name, guessed);
4041 else
4042 sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
4043 }
4044 else if (op2 == NULL)
4045 sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
4046 e->value.op.uop->name, gfc_typename (&op1->ts));
4047 else
4048 {
4049 sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4050 e->value.op.uop->name, gfc_typename (&op1->ts),
4051 gfc_typename (&op2->ts));
4052 e->value.op.uop->op->sym->attr.referenced = 1;
4053 }
4054
4055 goto bad_op;
4056
4057 case INTRINSIC_PARENTHESES:
4058 e->ts = op1->ts;
4059 if (e->ts.type == BT_CHARACTER)
4060 e->ts.u.cl = op1->ts.u.cl;
4061 break;
4062
4063 default:
4064 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4065 }
4066
4067 /* Deal with arrayness of an operand through an operator. */
4068
4069 t = true;
4070
4071 switch (e->value.op.op)
4072 {
4073 case INTRINSIC_PLUS:
4074 case INTRINSIC_MINUS:
4075 case INTRINSIC_TIMES:
4076 case INTRINSIC_DIVIDE:
4077 case INTRINSIC_POWER:
4078 case INTRINSIC_CONCAT:
4079 case INTRINSIC_AND:
4080 case INTRINSIC_OR:
4081 case INTRINSIC_EQV:
4082 case INTRINSIC_NEQV:
4083 case INTRINSIC_EQ:
4084 case INTRINSIC_EQ_OS:
4085 case INTRINSIC_NE:
4086 case INTRINSIC_NE_OS:
4087 case INTRINSIC_GT:
4088 case INTRINSIC_GT_OS:
4089 case INTRINSIC_GE:
4090 case INTRINSIC_GE_OS:
4091 case INTRINSIC_LT:
4092 case INTRINSIC_LT_OS:
4093 case INTRINSIC_LE:
4094 case INTRINSIC_LE_OS:
4095
4096 if (op1->rank == 0 && op2->rank == 0)
4097 e->rank = 0;
4098
4099 if (op1->rank == 0 && op2->rank != 0)
4100 {
4101 e->rank = op2->rank;
4102
4103 if (e->shape == NULL)
4104 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4105 }
4106
4107 if (op1->rank != 0 && op2->rank == 0)
4108 {
4109 e->rank = op1->rank;
4110
4111 if (e->shape == NULL)
4112 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4113 }
4114
4115 if (op1->rank != 0 && op2->rank != 0)
4116 {
4117 if (op1->rank == op2->rank)
4118 {
4119 e->rank = op1->rank;
4120 if (e->shape == NULL)
4121 {
4122 t = compare_shapes (op1, op2);
4123 if (!t)
4124 e->shape = NULL;
4125 else
4126 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4127 }
4128 }
4129 else
4130 {
4131 /* Allow higher level expressions to work. */
4132 e->rank = 0;
4133
4134 /* Try user-defined operators, and otherwise throw an error. */
4135 dual_locus_error = true;
4136 sprintf (msg,
4137 _("Inconsistent ranks for operator at %%L and %%L"));
4138 goto bad_op;
4139 }
4140 }
4141
4142 break;
4143
4144 case INTRINSIC_PARENTHESES:
4145 case INTRINSIC_NOT:
4146 case INTRINSIC_UPLUS:
4147 case INTRINSIC_UMINUS:
4148 /* Simply copy arrayness attribute */
4149 e->rank = op1->rank;
4150
4151 if (e->shape == NULL)
4152 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4153
4154 break;
4155
4156 default:
4157 break;
4158 }
4159
4160 /* Attempt to simplify the expression. */
4161 if (t)
4162 {
4163 t = gfc_simplify_expr (e, 0);
4164 /* Some calls do not succeed in simplification and return false
4165 even though there is no error; e.g. variable references to
4166 PARAMETER arrays. */
4167 if (!gfc_is_constant_expr (e))
4168 t = true;
4169 }
4170 return t;
4171
4172 bad_op:
4173
4174 {
4175 match m = gfc_extend_expr (e);
4176 if (m == MATCH_YES)
4177 return true;
4178 if (m == MATCH_ERROR)
4179 return false;
4180 }
4181
4182 if (dual_locus_error)
4183 gfc_error (msg, &op1->where, &op2->where);
4184 else
4185 gfc_error (msg, &e->where);
4186
4187 return false;
4188 }
4189
4190
4191 /************** Array resolution subroutines **************/
4192
4193 enum compare_result
4194 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
4195
4196 /* Compare two integer expressions. */
4197
4198 static compare_result
compare_bound(gfc_expr * a,gfc_expr * b)4199 compare_bound (gfc_expr *a, gfc_expr *b)
4200 {
4201 int i;
4202
4203 if (a == NULL || a->expr_type != EXPR_CONSTANT
4204 || b == NULL || b->expr_type != EXPR_CONSTANT)
4205 return CMP_UNKNOWN;
4206
4207 /* If either of the types isn't INTEGER, we must have
4208 raised an error earlier. */
4209
4210 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4211 return CMP_UNKNOWN;
4212
4213 i = mpz_cmp (a->value.integer, b->value.integer);
4214
4215 if (i < 0)
4216 return CMP_LT;
4217 if (i > 0)
4218 return CMP_GT;
4219 return CMP_EQ;
4220 }
4221
4222
4223 /* Compare an integer expression with an integer. */
4224
4225 static compare_result
compare_bound_int(gfc_expr * a,int b)4226 compare_bound_int (gfc_expr *a, int b)
4227 {
4228 int i;
4229
4230 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4231 return CMP_UNKNOWN;
4232
4233 if (a->ts.type != BT_INTEGER)
4234 gfc_internal_error ("compare_bound_int(): Bad expression");
4235
4236 i = mpz_cmp_si (a->value.integer, b);
4237
4238 if (i < 0)
4239 return CMP_LT;
4240 if (i > 0)
4241 return CMP_GT;
4242 return CMP_EQ;
4243 }
4244
4245
4246 /* Compare an integer expression with a mpz_t. */
4247
4248 static compare_result
compare_bound_mpz_t(gfc_expr * a,mpz_t b)4249 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4250 {
4251 int i;
4252
4253 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4254 return CMP_UNKNOWN;
4255
4256 if (a->ts.type != BT_INTEGER)
4257 gfc_internal_error ("compare_bound_int(): Bad expression");
4258
4259 i = mpz_cmp (a->value.integer, b);
4260
4261 if (i < 0)
4262 return CMP_LT;
4263 if (i > 0)
4264 return CMP_GT;
4265 return CMP_EQ;
4266 }
4267
4268
4269 /* Compute the last value of a sequence given by a triplet.
4270 Return 0 if it wasn't able to compute the last value, or if the
4271 sequence if empty, and 1 otherwise. */
4272
4273 static int
compute_last_value_for_triplet(gfc_expr * start,gfc_expr * end,gfc_expr * stride,mpz_t last)4274 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4275 gfc_expr *stride, mpz_t last)
4276 {
4277 mpz_t rem;
4278
4279 if (start == NULL || start->expr_type != EXPR_CONSTANT
4280 || end == NULL || end->expr_type != EXPR_CONSTANT
4281 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4282 return 0;
4283
4284 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4285 || (stride != NULL && stride->ts.type != BT_INTEGER))
4286 return 0;
4287
4288 if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
4289 {
4290 if (compare_bound (start, end) == CMP_GT)
4291 return 0;
4292 mpz_set (last, end->value.integer);
4293 return 1;
4294 }
4295
4296 if (compare_bound_int (stride, 0) == CMP_GT)
4297 {
4298 /* Stride is positive */
4299 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4300 return 0;
4301 }
4302 else
4303 {
4304 /* Stride is negative */
4305 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4306 return 0;
4307 }
4308
4309 mpz_init (rem);
4310 mpz_sub (rem, end->value.integer, start->value.integer);
4311 mpz_tdiv_r (rem, rem, stride->value.integer);
4312 mpz_sub (last, end->value.integer, rem);
4313 mpz_clear (rem);
4314
4315 return 1;
4316 }
4317
4318
4319 /* Compare a single dimension of an array reference to the array
4320 specification. */
4321
4322 static bool
check_dimension(int i,gfc_array_ref * ar,gfc_array_spec * as)4323 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4324 {
4325 mpz_t last_value;
4326
4327 if (ar->dimen_type[i] == DIMEN_STAR)
4328 {
4329 gcc_assert (ar->stride[i] == NULL);
4330 /* This implies [*] as [*:] and [*:3] are not possible. */
4331 if (ar->start[i] == NULL)
4332 {
4333 gcc_assert (ar->end[i] == NULL);
4334 return true;
4335 }
4336 }
4337
4338 /* Given start, end and stride values, calculate the minimum and
4339 maximum referenced indexes. */
4340
4341 switch (ar->dimen_type[i])
4342 {
4343 case DIMEN_VECTOR:
4344 case DIMEN_THIS_IMAGE:
4345 break;
4346
4347 case DIMEN_STAR:
4348 case DIMEN_ELEMENT:
4349 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4350 {
4351 if (i < as->rank)
4352 gfc_warning (0, "Array reference at %L is out of bounds "
4353 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4354 mpz_get_si (ar->start[i]->value.integer),
4355 mpz_get_si (as->lower[i]->value.integer), i+1);
4356 else
4357 gfc_warning (0, "Array reference at %L is out of bounds "
4358 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4359 mpz_get_si (ar->start[i]->value.integer),
4360 mpz_get_si (as->lower[i]->value.integer),
4361 i + 1 - as->rank);
4362 return true;
4363 }
4364 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4365 {
4366 if (i < as->rank)
4367 gfc_warning (0, "Array reference at %L is out of bounds "
4368 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4369 mpz_get_si (ar->start[i]->value.integer),
4370 mpz_get_si (as->upper[i]->value.integer), i+1);
4371 else
4372 gfc_warning (0, "Array reference at %L is out of bounds "
4373 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4374 mpz_get_si (ar->start[i]->value.integer),
4375 mpz_get_si (as->upper[i]->value.integer),
4376 i + 1 - as->rank);
4377 return true;
4378 }
4379
4380 break;
4381
4382 case DIMEN_RANGE:
4383 {
4384 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4385 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4386
4387 compare_result comp_start_end = compare_bound (AR_START, AR_END);
4388
4389 /* Check for zero stride, which is not allowed. */
4390 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4391 {
4392 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4393 return false;
4394 }
4395
4396 /* if start == len || (stride > 0 && start < len)
4397 || (stride < 0 && start > len),
4398 then the array section contains at least one element. In this
4399 case, there is an out-of-bounds access if
4400 (start < lower || start > upper). */
4401 if (compare_bound (AR_START, AR_END) == CMP_EQ
4402 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4403 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4404 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4405 && comp_start_end == CMP_GT))
4406 {
4407 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4408 {
4409 gfc_warning (0, "Lower array reference at %L is out of bounds "
4410 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4411 mpz_get_si (AR_START->value.integer),
4412 mpz_get_si (as->lower[i]->value.integer), i+1);
4413 return true;
4414 }
4415 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4416 {
4417 gfc_warning (0, "Lower array reference at %L is out of bounds "
4418 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4419 mpz_get_si (AR_START->value.integer),
4420 mpz_get_si (as->upper[i]->value.integer), i+1);
4421 return true;
4422 }
4423 }
4424
4425 /* If we can compute the highest index of the array section,
4426 then it also has to be between lower and upper. */
4427 mpz_init (last_value);
4428 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4429 last_value))
4430 {
4431 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4432 {
4433 gfc_warning (0, "Upper array reference at %L is out of bounds "
4434 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4435 mpz_get_si (last_value),
4436 mpz_get_si (as->lower[i]->value.integer), i+1);
4437 mpz_clear (last_value);
4438 return true;
4439 }
4440 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4441 {
4442 gfc_warning (0, "Upper array reference at %L is out of bounds "
4443 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4444 mpz_get_si (last_value),
4445 mpz_get_si (as->upper[i]->value.integer), i+1);
4446 mpz_clear (last_value);
4447 return true;
4448 }
4449 }
4450 mpz_clear (last_value);
4451
4452 #undef AR_START
4453 #undef AR_END
4454 }
4455 break;
4456
4457 default:
4458 gfc_internal_error ("check_dimension(): Bad array reference");
4459 }
4460
4461 return true;
4462 }
4463
4464
4465 /* Compare an array reference with an array specification. */
4466
4467 static bool
compare_spec_to_ref(gfc_array_ref * ar)4468 compare_spec_to_ref (gfc_array_ref *ar)
4469 {
4470 gfc_array_spec *as;
4471 int i;
4472
4473 as = ar->as;
4474 i = as->rank - 1;
4475 /* TODO: Full array sections are only allowed as actual parameters. */
4476 if (as->type == AS_ASSUMED_SIZE
4477 && (/*ar->type == AR_FULL
4478 ||*/ (ar->type == AR_SECTION
4479 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4480 {
4481 gfc_error ("Rightmost upper bound of assumed size array section "
4482 "not specified at %L", &ar->where);
4483 return false;
4484 }
4485
4486 if (ar->type == AR_FULL)
4487 return true;
4488
4489 if (as->rank != ar->dimen)
4490 {
4491 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4492 &ar->where, ar->dimen, as->rank);
4493 return false;
4494 }
4495
4496 /* ar->codimen == 0 is a local array. */
4497 if (as->corank != ar->codimen && ar->codimen != 0)
4498 {
4499 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4500 &ar->where, ar->codimen, as->corank);
4501 return false;
4502 }
4503
4504 for (i = 0; i < as->rank; i++)
4505 if (!check_dimension (i, ar, as))
4506 return false;
4507
4508 /* Local access has no coarray spec. */
4509 if (ar->codimen != 0)
4510 for (i = as->rank; i < as->rank + as->corank; i++)
4511 {
4512 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4513 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4514 {
4515 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4516 i + 1 - as->rank, &ar->where);
4517 return false;
4518 }
4519 if (!check_dimension (i, ar, as))
4520 return false;
4521 }
4522
4523 return true;
4524 }
4525
4526
4527 /* Resolve one part of an array index. */
4528
4529 static bool
gfc_resolve_index_1(gfc_expr * index,int check_scalar,int force_index_integer_kind)4530 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4531 int force_index_integer_kind)
4532 {
4533 gfc_typespec ts;
4534
4535 if (index == NULL)
4536 return true;
4537
4538 if (!gfc_resolve_expr (index))
4539 return false;
4540
4541 if (check_scalar && index->rank != 0)
4542 {
4543 gfc_error ("Array index at %L must be scalar", &index->where);
4544 return false;
4545 }
4546
4547 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4548 {
4549 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4550 &index->where, gfc_basic_typename (index->ts.type));
4551 return false;
4552 }
4553
4554 if (index->ts.type == BT_REAL)
4555 if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4556 &index->where))
4557 return false;
4558
4559 if ((index->ts.kind != gfc_index_integer_kind
4560 && force_index_integer_kind)
4561 || index->ts.type != BT_INTEGER)
4562 {
4563 gfc_clear_ts (&ts);
4564 ts.type = BT_INTEGER;
4565 ts.kind = gfc_index_integer_kind;
4566
4567 gfc_convert_type_warn (index, &ts, 2, 0);
4568 }
4569
4570 return true;
4571 }
4572
4573 /* Resolve one part of an array index. */
4574
4575 bool
gfc_resolve_index(gfc_expr * index,int check_scalar)4576 gfc_resolve_index (gfc_expr *index, int check_scalar)
4577 {
4578 return gfc_resolve_index_1 (index, check_scalar, 1);
4579 }
4580
4581 /* Resolve a dim argument to an intrinsic function. */
4582
4583 bool
gfc_resolve_dim_arg(gfc_expr * dim)4584 gfc_resolve_dim_arg (gfc_expr *dim)
4585 {
4586 if (dim == NULL)
4587 return true;
4588
4589 if (!gfc_resolve_expr (dim))
4590 return false;
4591
4592 if (dim->rank != 0)
4593 {
4594 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4595 return false;
4596
4597 }
4598
4599 if (dim->ts.type != BT_INTEGER)
4600 {
4601 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4602 return false;
4603 }
4604
4605 if (dim->ts.kind != gfc_index_integer_kind)
4606 {
4607 gfc_typespec ts;
4608
4609 gfc_clear_ts (&ts);
4610 ts.type = BT_INTEGER;
4611 ts.kind = gfc_index_integer_kind;
4612
4613 gfc_convert_type_warn (dim, &ts, 2, 0);
4614 }
4615
4616 return true;
4617 }
4618
4619 /* Given an expression that contains array references, update those array
4620 references to point to the right array specifications. While this is
4621 filled in during matching, this information is difficult to save and load
4622 in a module, so we take care of it here.
4623
4624 The idea here is that the original array reference comes from the
4625 base symbol. We traverse the list of reference structures, setting
4626 the stored reference to references. Component references can
4627 provide an additional array specification. */
4628
4629 static void
find_array_spec(gfc_expr * e)4630 find_array_spec (gfc_expr *e)
4631 {
4632 gfc_array_spec *as;
4633 gfc_component *c;
4634 gfc_ref *ref;
4635 bool class_as = false;
4636
4637 if (e->symtree->n.sym->ts.type == BT_CLASS)
4638 {
4639 as = CLASS_DATA (e->symtree->n.sym)->as;
4640 class_as = true;
4641 }
4642 else
4643 as = e->symtree->n.sym->as;
4644
4645 for (ref = e->ref; ref; ref = ref->next)
4646 switch (ref->type)
4647 {
4648 case REF_ARRAY:
4649 if (as == NULL)
4650 gfc_internal_error ("find_array_spec(): Missing spec");
4651
4652 ref->u.ar.as = as;
4653 as = NULL;
4654 break;
4655
4656 case REF_COMPONENT:
4657 c = ref->u.c.component;
4658 if (c->attr.dimension)
4659 {
4660 if (as != NULL && !(class_as && as == c->as))
4661 gfc_internal_error ("find_array_spec(): unused as(1)");
4662 as = c->as;
4663 }
4664
4665 break;
4666
4667 case REF_SUBSTRING:
4668 break;
4669 }
4670
4671 if (as != NULL)
4672 gfc_internal_error ("find_array_spec(): unused as(2)");
4673 }
4674
4675
4676 /* Resolve an array reference. */
4677
4678 static bool
resolve_array_ref(gfc_array_ref * ar)4679 resolve_array_ref (gfc_array_ref *ar)
4680 {
4681 int i, check_scalar;
4682 gfc_expr *e;
4683
4684 for (i = 0; i < ar->dimen + ar->codimen; i++)
4685 {
4686 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4687
4688 /* Do not force gfc_index_integer_kind for the start. We can
4689 do fine with any integer kind. This avoids temporary arrays
4690 created for indexing with a vector. */
4691 if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
4692 return false;
4693 if (!gfc_resolve_index (ar->end[i], check_scalar))
4694 return false;
4695 if (!gfc_resolve_index (ar->stride[i], check_scalar))
4696 return false;
4697
4698 e = ar->start[i];
4699
4700 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4701 switch (e->rank)
4702 {
4703 case 0:
4704 ar->dimen_type[i] = DIMEN_ELEMENT;
4705 break;
4706
4707 case 1:
4708 ar->dimen_type[i] = DIMEN_VECTOR;
4709 if (e->expr_type == EXPR_VARIABLE
4710 && e->symtree->n.sym->ts.type == BT_DERIVED)
4711 ar->start[i] = gfc_get_parentheses (e);
4712 break;
4713
4714 default:
4715 gfc_error ("Array index at %L is an array of rank %d",
4716 &ar->c_where[i], e->rank);
4717 return false;
4718 }
4719
4720 /* Fill in the upper bound, which may be lower than the
4721 specified one for something like a(2:10:5), which is
4722 identical to a(2:7:5). Only relevant for strides not equal
4723 to one. Don't try a division by zero. */
4724 if (ar->dimen_type[i] == DIMEN_RANGE
4725 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4726 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4727 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4728 {
4729 mpz_t size, end;
4730
4731 if (gfc_ref_dimen_size (ar, i, &size, &end))
4732 {
4733 if (ar->end[i] == NULL)
4734 {
4735 ar->end[i] =
4736 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4737 &ar->where);
4738 mpz_set (ar->end[i]->value.integer, end);
4739 }
4740 else if (ar->end[i]->ts.type == BT_INTEGER
4741 && ar->end[i]->expr_type == EXPR_CONSTANT)
4742 {
4743 mpz_set (ar->end[i]->value.integer, end);
4744 }
4745 else
4746 gcc_unreachable ();
4747
4748 mpz_clear (size);
4749 mpz_clear (end);
4750 }
4751 }
4752 }
4753
4754 if (ar->type == AR_FULL)
4755 {
4756 if (ar->as->rank == 0)
4757 ar->type = AR_ELEMENT;
4758
4759 /* Make sure array is the same as array(:,:), this way
4760 we don't need to special case all the time. */
4761 ar->dimen = ar->as->rank;
4762 for (i = 0; i < ar->dimen; i++)
4763 {
4764 ar->dimen_type[i] = DIMEN_RANGE;
4765
4766 gcc_assert (ar->start[i] == NULL);
4767 gcc_assert (ar->end[i] == NULL);
4768 gcc_assert (ar->stride[i] == NULL);
4769 }
4770 }
4771
4772 /* If the reference type is unknown, figure out what kind it is. */
4773
4774 if (ar->type == AR_UNKNOWN)
4775 {
4776 ar->type = AR_ELEMENT;
4777 for (i = 0; i < ar->dimen; i++)
4778 if (ar->dimen_type[i] == DIMEN_RANGE
4779 || ar->dimen_type[i] == DIMEN_VECTOR)
4780 {
4781 ar->type = AR_SECTION;
4782 break;
4783 }
4784 }
4785
4786 if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
4787 return false;
4788
4789 if (ar->as->corank && ar->codimen == 0)
4790 {
4791 int n;
4792 ar->codimen = ar->as->corank;
4793 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4794 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4795 }
4796
4797 return true;
4798 }
4799
4800
4801 static bool
resolve_substring(gfc_ref * ref)4802 resolve_substring (gfc_ref *ref)
4803 {
4804 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4805
4806 if (ref->u.ss.start != NULL)
4807 {
4808 if (!gfc_resolve_expr (ref->u.ss.start))
4809 return false;
4810
4811 if (ref->u.ss.start->ts.type != BT_INTEGER)
4812 {
4813 gfc_error ("Substring start index at %L must be of type INTEGER",
4814 &ref->u.ss.start->where);
4815 return false;
4816 }
4817
4818 if (ref->u.ss.start->rank != 0)
4819 {
4820 gfc_error ("Substring start index at %L must be scalar",
4821 &ref->u.ss.start->where);
4822 return false;
4823 }
4824
4825 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4826 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4827 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4828 {
4829 gfc_error ("Substring start index at %L is less than one",
4830 &ref->u.ss.start->where);
4831 return false;
4832 }
4833 }
4834
4835 if (ref->u.ss.end != NULL)
4836 {
4837 if (!gfc_resolve_expr (ref->u.ss.end))
4838 return false;
4839
4840 if (ref->u.ss.end->ts.type != BT_INTEGER)
4841 {
4842 gfc_error ("Substring end index at %L must be of type INTEGER",
4843 &ref->u.ss.end->where);
4844 return false;
4845 }
4846
4847 if (ref->u.ss.end->rank != 0)
4848 {
4849 gfc_error ("Substring end index at %L must be scalar",
4850 &ref->u.ss.end->where);
4851 return false;
4852 }
4853
4854 if (ref->u.ss.length != NULL
4855 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4856 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4857 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4858 {
4859 gfc_error ("Substring end index at %L exceeds the string length",
4860 &ref->u.ss.start->where);
4861 return false;
4862 }
4863
4864 if (compare_bound_mpz_t (ref->u.ss.end,
4865 gfc_integer_kinds[k].huge) == CMP_GT
4866 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4867 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4868 {
4869 gfc_error ("Substring end index at %L is too large",
4870 &ref->u.ss.end->where);
4871 return false;
4872 }
4873 }
4874
4875 return true;
4876 }
4877
4878
4879 /* This function supplies missing substring charlens. */
4880
4881 void
gfc_resolve_substring_charlen(gfc_expr * e)4882 gfc_resolve_substring_charlen (gfc_expr *e)
4883 {
4884 gfc_ref *char_ref;
4885 gfc_expr *start, *end;
4886 gfc_typespec *ts = NULL;
4887 mpz_t diff;
4888
4889 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4890 {
4891 if (char_ref->type == REF_SUBSTRING)
4892 break;
4893 if (char_ref->type == REF_COMPONENT)
4894 ts = &char_ref->u.c.component->ts;
4895 }
4896
4897 if (!char_ref)
4898 return;
4899
4900 gcc_assert (char_ref->next == NULL);
4901
4902 if (e->ts.u.cl)
4903 {
4904 if (e->ts.u.cl->length)
4905 gfc_free_expr (e->ts.u.cl->length);
4906 else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
4907 return;
4908 }
4909
4910 e->ts.type = BT_CHARACTER;
4911 e->ts.kind = gfc_default_character_kind;
4912
4913 if (!e->ts.u.cl)
4914 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4915
4916 if (char_ref->u.ss.start)
4917 start = gfc_copy_expr (char_ref->u.ss.start);
4918 else
4919 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
4920
4921 if (char_ref->u.ss.end)
4922 end = gfc_copy_expr (char_ref->u.ss.end);
4923 else if (e->expr_type == EXPR_VARIABLE)
4924 {
4925 if (!ts)
4926 ts = &e->symtree->n.sym->ts;
4927 end = gfc_copy_expr (ts->u.cl->length);
4928 }
4929 else
4930 end = NULL;
4931
4932 if (!start || !end)
4933 {
4934 gfc_free_expr (start);
4935 gfc_free_expr (end);
4936 return;
4937 }
4938
4939 /* Length = (end - start + 1).
4940 Check first whether it has a constant length. */
4941 if (gfc_dep_difference (end, start, &diff))
4942 {
4943 gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
4944 &e->where);
4945
4946 mpz_add_ui (len->value.integer, diff, 1);
4947 mpz_clear (diff);
4948 e->ts.u.cl->length = len;
4949 /* The check for length < 0 is handled below */
4950 }
4951 else
4952 {
4953 e->ts.u.cl->length = gfc_subtract (end, start);
4954 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4955 gfc_get_int_expr (gfc_charlen_int_kind,
4956 NULL, 1));
4957 }
4958
4959 /* F2008, 6.4.1: Both the starting point and the ending point shall
4960 be within the range 1, 2, ..., n unless the starting point exceeds
4961 the ending point, in which case the substring has length zero. */
4962
4963 if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
4964 mpz_set_si (e->ts.u.cl->length->value.integer, 0);
4965
4966 e->ts.u.cl->length->ts.type = BT_INTEGER;
4967 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4968
4969 /* Make sure that the length is simplified. */
4970 gfc_simplify_expr (e->ts.u.cl->length, 1);
4971 gfc_resolve_expr (e->ts.u.cl->length);
4972 }
4973
4974
4975 /* Resolve subtype references. */
4976
4977 static bool
resolve_ref(gfc_expr * expr)4978 resolve_ref (gfc_expr *expr)
4979 {
4980 int current_part_dimension, n_components, seen_part_dimension;
4981 gfc_ref *ref;
4982
4983 for (ref = expr->ref; ref; ref = ref->next)
4984 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4985 {
4986 find_array_spec (expr);
4987 break;
4988 }
4989
4990 for (ref = expr->ref; ref; ref = ref->next)
4991 switch (ref->type)
4992 {
4993 case REF_ARRAY:
4994 if (!resolve_array_ref (&ref->u.ar))
4995 return false;
4996 break;
4997
4998 case REF_COMPONENT:
4999 break;
5000
5001 case REF_SUBSTRING:
5002 if (!resolve_substring (ref))
5003 return false;
5004 break;
5005 }
5006
5007 /* Check constraints on part references. */
5008
5009 current_part_dimension = 0;
5010 seen_part_dimension = 0;
5011 n_components = 0;
5012
5013 for (ref = expr->ref; ref; ref = ref->next)
5014 {
5015 switch (ref->type)
5016 {
5017 case REF_ARRAY:
5018 switch (ref->u.ar.type)
5019 {
5020 case AR_FULL:
5021 /* Coarray scalar. */
5022 if (ref->u.ar.as->rank == 0)
5023 {
5024 current_part_dimension = 0;
5025 break;
5026 }
5027 /* Fall through. */
5028 case AR_SECTION:
5029 current_part_dimension = 1;
5030 break;
5031
5032 case AR_ELEMENT:
5033 current_part_dimension = 0;
5034 break;
5035
5036 case AR_UNKNOWN:
5037 gfc_internal_error ("resolve_ref(): Bad array reference");
5038 }
5039
5040 break;
5041
5042 case REF_COMPONENT:
5043 if (current_part_dimension || seen_part_dimension)
5044 {
5045 /* F03:C614. */
5046 if (ref->u.c.component->attr.pointer
5047 || ref->u.c.component->attr.proc_pointer
5048 || (ref->u.c.component->ts.type == BT_CLASS
5049 && CLASS_DATA (ref->u.c.component)->attr.pointer))
5050 {
5051 gfc_error ("Component to the right of a part reference "
5052 "with nonzero rank must not have the POINTER "
5053 "attribute at %L", &expr->where);
5054 return false;
5055 }
5056 else if (ref->u.c.component->attr.allocatable
5057 || (ref->u.c.component->ts.type == BT_CLASS
5058 && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5059
5060 {
5061 gfc_error ("Component to the right of a part reference "
5062 "with nonzero rank must not have the ALLOCATABLE "
5063 "attribute at %L", &expr->where);
5064 return false;
5065 }
5066 }
5067
5068 n_components++;
5069 break;
5070
5071 case REF_SUBSTRING:
5072 break;
5073 }
5074
5075 if (((ref->type == REF_COMPONENT && n_components > 1)
5076 || ref->next == NULL)
5077 && current_part_dimension
5078 && seen_part_dimension)
5079 {
5080 gfc_error ("Two or more part references with nonzero rank must "
5081 "not be specified at %L", &expr->where);
5082 return false;
5083 }
5084
5085 if (ref->type == REF_COMPONENT)
5086 {
5087 if (current_part_dimension)
5088 seen_part_dimension = 1;
5089
5090 /* reset to make sure */
5091 current_part_dimension = 0;
5092 }
5093 }
5094
5095 return true;
5096 }
5097
5098
5099 /* Given an expression, determine its shape. This is easier than it sounds.
5100 Leaves the shape array NULL if it is not possible to determine the shape. */
5101
5102 static void
expression_shape(gfc_expr * e)5103 expression_shape (gfc_expr *e)
5104 {
5105 mpz_t array[GFC_MAX_DIMENSIONS];
5106 int i;
5107
5108 if (e->rank <= 0 || e->shape != NULL)
5109 return;
5110
5111 for (i = 0; i < e->rank; i++)
5112 if (!gfc_array_dimen_size (e, i, &array[i]))
5113 goto fail;
5114
5115 e->shape = gfc_get_shape (e->rank);
5116
5117 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5118
5119 return;
5120
5121 fail:
5122 for (i--; i >= 0; i--)
5123 mpz_clear (array[i]);
5124 }
5125
5126
5127 /* Given a variable expression node, compute the rank of the expression by
5128 examining the base symbol and any reference structures it may have. */
5129
5130 void
expression_rank(gfc_expr * e)5131 expression_rank (gfc_expr *e)
5132 {
5133 gfc_ref *ref;
5134 int i, rank;
5135
5136 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5137 could lead to serious confusion... */
5138 gcc_assert (e->expr_type != EXPR_COMPCALL);
5139
5140 if (e->ref == NULL)
5141 {
5142 if (e->expr_type == EXPR_ARRAY)
5143 goto done;
5144 /* Constructors can have a rank different from one via RESHAPE(). */
5145
5146 if (e->symtree == NULL)
5147 {
5148 e->rank = 0;
5149 goto done;
5150 }
5151
5152 e->rank = (e->symtree->n.sym->as == NULL)
5153 ? 0 : e->symtree->n.sym->as->rank;
5154 goto done;
5155 }
5156
5157 rank = 0;
5158
5159 for (ref = e->ref; ref; ref = ref->next)
5160 {
5161 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5162 && ref->u.c.component->attr.function && !ref->next)
5163 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5164
5165 if (ref->type != REF_ARRAY)
5166 continue;
5167
5168 if (ref->u.ar.type == AR_FULL)
5169 {
5170 rank = ref->u.ar.as->rank;
5171 break;
5172 }
5173
5174 if (ref->u.ar.type == AR_SECTION)
5175 {
5176 /* Figure out the rank of the section. */
5177 if (rank != 0)
5178 gfc_internal_error ("expression_rank(): Two array specs");
5179
5180 for (i = 0; i < ref->u.ar.dimen; i++)
5181 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5182 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5183 rank++;
5184
5185 break;
5186 }
5187 }
5188
5189 e->rank = rank;
5190
5191 done:
5192 expression_shape (e);
5193 }
5194
5195
5196 static void
add_caf_get_intrinsic(gfc_expr * e)5197 add_caf_get_intrinsic (gfc_expr *e)
5198 {
5199 gfc_expr *wrapper, *tmp_expr;
5200 gfc_ref *ref;
5201 int n;
5202
5203 for (ref = e->ref; ref; ref = ref->next)
5204 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5205 break;
5206 if (ref == NULL)
5207 return;
5208
5209 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5210 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
5211 return;
5212
5213 tmp_expr = XCNEW (gfc_expr);
5214 *tmp_expr = *e;
5215 wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
5216 "caf_get", tmp_expr->where, 1, tmp_expr);
5217 wrapper->ts = e->ts;
5218 wrapper->rank = e->rank;
5219 if (e->rank)
5220 wrapper->shape = gfc_copy_shape (e->shape, e->rank);
5221 *e = *wrapper;
5222 free (wrapper);
5223 }
5224
5225
5226 static void
remove_caf_get_intrinsic(gfc_expr * e)5227 remove_caf_get_intrinsic (gfc_expr *e)
5228 {
5229 gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
5230 && e->value.function.isym->id == GFC_ISYM_CAF_GET);
5231 gfc_expr *e2 = e->value.function.actual->expr;
5232 e->value.function.actual->expr = NULL;
5233 gfc_free_actual_arglist (e->value.function.actual);
5234 gfc_free_shape (&e->shape, e->rank);
5235 *e = *e2;
5236 free (e2);
5237 }
5238
5239
5240 /* Resolve a variable expression. */
5241
5242 static bool
resolve_variable(gfc_expr * e)5243 resolve_variable (gfc_expr *e)
5244 {
5245 gfc_symbol *sym;
5246 bool t;
5247
5248 t = true;
5249
5250 if (e->symtree == NULL)
5251 return false;
5252 sym = e->symtree->n.sym;
5253
5254 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5255 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5256 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
5257 {
5258 if (!actual_arg || inquiry_argument)
5259 {
5260 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5261 "be used as actual argument", sym->name, &e->where);
5262 return false;
5263 }
5264 }
5265 /* TS 29113, 407b. */
5266 else if (e->ts.type == BT_ASSUMED)
5267 {
5268 if (!actual_arg)
5269 {
5270 gfc_error ("Assumed-type variable %s at %L may only be used "
5271 "as actual argument", sym->name, &e->where);
5272 return false;
5273 }
5274 else if (inquiry_argument && !first_actual_arg)
5275 {
5276 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5277 for all inquiry functions in resolve_function; the reason is
5278 that the function-name resolution happens too late in that
5279 function. */
5280 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5281 "an inquiry function shall be the first argument",
5282 sym->name, &e->where);
5283 return false;
5284 }
5285 }
5286 /* TS 29113, C535b. */
5287 else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
5288 && CLASS_DATA (sym)->as
5289 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5290 || (sym->ts.type != BT_CLASS && sym->as
5291 && sym->as->type == AS_ASSUMED_RANK))
5292 {
5293 if (!actual_arg)
5294 {
5295 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5296 "actual argument", sym->name, &e->where);
5297 return false;
5298 }
5299 else if (inquiry_argument && !first_actual_arg)
5300 {
5301 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5302 for all inquiry functions in resolve_function; the reason is
5303 that the function-name resolution happens too late in that
5304 function. */
5305 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5306 "to an inquiry function shall be the first argument",
5307 sym->name, &e->where);
5308 return false;
5309 }
5310 }
5311
5312 if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
5313 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5314 && e->ref->next == NULL))
5315 {
5316 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5317 "a subobject reference", sym->name, &e->ref->u.ar.where);
5318 return false;
5319 }
5320 /* TS 29113, 407b. */
5321 else if (e->ts.type == BT_ASSUMED && e->ref
5322 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5323 && e->ref->next == NULL))
5324 {
5325 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5326 "reference", sym->name, &e->ref->u.ar.where);
5327 return false;
5328 }
5329
5330 /* TS 29113, C535b. */
5331 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5332 && CLASS_DATA (sym)->as
5333 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5334 || (sym->ts.type != BT_CLASS && sym->as
5335 && sym->as->type == AS_ASSUMED_RANK))
5336 && e->ref
5337 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5338 && e->ref->next == NULL))
5339 {
5340 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5341 "reference", sym->name, &e->ref->u.ar.where);
5342 return false;
5343 }
5344
5345 /* For variables that are used in an associate (target => object) where
5346 the object's basetype is array valued while the target is scalar,
5347 the ts' type of the component refs is still array valued, which
5348 can't be translated that way. */
5349 if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
5350 && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
5351 && CLASS_DATA (sym->assoc->target)->as)
5352 {
5353 gfc_ref *ref = e->ref;
5354 while (ref)
5355 {
5356 switch (ref->type)
5357 {
5358 case REF_COMPONENT:
5359 ref->u.c.sym = sym->ts.u.derived;
5360 /* Stop the loop. */
5361 ref = NULL;
5362 break;
5363 default:
5364 ref = ref->next;
5365 break;
5366 }
5367 }
5368 }
5369
5370 /* If this is an associate-name, it may be parsed with an array reference
5371 in error even though the target is scalar. Fail directly in this case.
5372 TODO Understand why class scalar expressions must be excluded. */
5373 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5374 {
5375 if (sym->ts.type == BT_CLASS)
5376 gfc_fix_class_refs (e);
5377 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5378 return false;
5379 else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
5380 {
5381 /* This can happen because the parser did not detect that the
5382 associate name is an array and the expression had no array
5383 part_ref. */
5384 gfc_ref *ref = gfc_get_ref ();
5385 ref->type = REF_ARRAY;
5386 ref->u.ar = *gfc_get_array_ref();
5387 ref->u.ar.type = AR_FULL;
5388 if (sym->as)
5389 {
5390 ref->u.ar.as = sym->as;
5391 ref->u.ar.dimen = sym->as->rank;
5392 }
5393 ref->next = e->ref;
5394 e->ref = ref;
5395 }
5396 }
5397
5398 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5399 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5400
5401 /* On the other hand, the parser may not have known this is an array;
5402 in this case, we have to add a FULL reference. */
5403 if (sym->assoc && sym->attr.dimension && !e->ref)
5404 {
5405 e->ref = gfc_get_ref ();
5406 e->ref->type = REF_ARRAY;
5407 e->ref->u.ar.type = AR_FULL;
5408 e->ref->u.ar.dimen = 0;
5409 }
5410
5411 /* Like above, but for class types, where the checking whether an array
5412 ref is present is more complicated. Furthermore make sure not to add
5413 the full array ref to _vptr or _len refs. */
5414 if (sym->assoc && sym->ts.type == BT_CLASS
5415 && CLASS_DATA (sym)->attr.dimension
5416 && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5417 {
5418 gfc_ref *ref, *newref;
5419
5420 newref = gfc_get_ref ();
5421 newref->type = REF_ARRAY;
5422 newref->u.ar.type = AR_FULL;
5423 newref->u.ar.dimen = 0;
5424 /* Because this is an associate var and the first ref either is a ref to
5425 the _data component or not, no traversal of the ref chain is
5426 needed. The array ref needs to be inserted after the _data ref,
5427 or when that is not present, which may happend for polymorphic
5428 types, then at the first position. */
5429 ref = e->ref;
5430 if (!ref)
5431 e->ref = newref;
5432 else if (ref->type == REF_COMPONENT
5433 && strcmp ("_data", ref->u.c.component->name) == 0)
5434 {
5435 if (!ref->next || ref->next->type != REF_ARRAY)
5436 {
5437 newref->next = ref->next;
5438 ref->next = newref;
5439 }
5440 else
5441 /* Array ref present already. */
5442 gfc_free_ref_list (newref);
5443 }
5444 else if (ref->type == REF_ARRAY)
5445 /* Array ref present already. */
5446 gfc_free_ref_list (newref);
5447 else
5448 {
5449 newref->next = ref;
5450 e->ref = newref;
5451 }
5452 }
5453
5454 if (e->ref && !resolve_ref (e))
5455 return false;
5456
5457 if (sym->attr.flavor == FL_PROCEDURE
5458 && (!sym->attr.function
5459 || (sym->attr.function && sym->result
5460 && sym->result->attr.proc_pointer
5461 && !sym->result->attr.function)))
5462 {
5463 e->ts.type = BT_PROCEDURE;
5464 goto resolve_procedure;
5465 }
5466
5467 if (sym->ts.type != BT_UNKNOWN)
5468 gfc_variable_attr (e, &e->ts);
5469 else if (sym->attr.flavor == FL_PROCEDURE
5470 && sym->attr.function && sym->result
5471 && sym->result->ts.type != BT_UNKNOWN
5472 && sym->result->attr.proc_pointer)
5473 e->ts = sym->result->ts;
5474 else
5475 {
5476 /* Must be a simple variable reference. */
5477 if (!gfc_set_default_type (sym, 1, sym->ns))
5478 return false;
5479 e->ts = sym->ts;
5480 }
5481
5482 if (check_assumed_size_reference (sym, e))
5483 return false;
5484
5485 /* Deal with forward references to entries during gfc_resolve_code, to
5486 satisfy, at least partially, 12.5.2.5. */
5487 if (gfc_current_ns->entries
5488 && current_entry_id == sym->entry_id
5489 && cs_base
5490 && cs_base->current
5491 && cs_base->current->op != EXEC_ENTRY)
5492 {
5493 gfc_entry_list *entry;
5494 gfc_formal_arglist *formal;
5495 int n;
5496 bool seen, saved_specification_expr;
5497
5498 /* If the symbol is a dummy... */
5499 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5500 {
5501 entry = gfc_current_ns->entries;
5502 seen = false;
5503
5504 /* ...test if the symbol is a parameter of previous entries. */
5505 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5506 for (formal = entry->sym->formal; formal; formal = formal->next)
5507 {
5508 if (formal->sym && sym->name == formal->sym->name)
5509 {
5510 seen = true;
5511 break;
5512 }
5513 }
5514
5515 /* If it has not been seen as a dummy, this is an error. */
5516 if (!seen)
5517 {
5518 if (specification_expr)
5519 gfc_error ("Variable %qs, used in a specification expression"
5520 ", is referenced at %L before the ENTRY statement "
5521 "in which it is a parameter",
5522 sym->name, &cs_base->current->loc);
5523 else
5524 gfc_error ("Variable %qs is used at %L before the ENTRY "
5525 "statement in which it is a parameter",
5526 sym->name, &cs_base->current->loc);
5527 t = false;
5528 }
5529 }
5530
5531 /* Now do the same check on the specification expressions. */
5532 saved_specification_expr = specification_expr;
5533 specification_expr = true;
5534 if (sym->ts.type == BT_CHARACTER
5535 && !gfc_resolve_expr (sym->ts.u.cl->length))
5536 t = false;
5537
5538 if (sym->as)
5539 for (n = 0; n < sym->as->rank; n++)
5540 {
5541 if (!gfc_resolve_expr (sym->as->lower[n]))
5542 t = false;
5543 if (!gfc_resolve_expr (sym->as->upper[n]))
5544 t = false;
5545 }
5546 specification_expr = saved_specification_expr;
5547
5548 if (t)
5549 /* Update the symbol's entry level. */
5550 sym->entry_id = current_entry_id + 1;
5551 }
5552
5553 /* If a symbol has been host_associated mark it. This is used latter,
5554 to identify if aliasing is possible via host association. */
5555 if (sym->attr.flavor == FL_VARIABLE
5556 && gfc_current_ns->parent
5557 && (gfc_current_ns->parent == sym->ns
5558 || (gfc_current_ns->parent->parent
5559 && gfc_current_ns->parent->parent == sym->ns)))
5560 sym->attr.host_assoc = 1;
5561
5562 if (gfc_current_ns->proc_name
5563 && sym->attr.dimension
5564 && (sym->ns != gfc_current_ns
5565 || sym->attr.use_assoc
5566 || sym->attr.in_common))
5567 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
5568
5569 resolve_procedure:
5570 if (t && !resolve_procedure_expression (e))
5571 t = false;
5572
5573 /* F2008, C617 and C1229. */
5574 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5575 && gfc_is_coindexed (e))
5576 {
5577 gfc_ref *ref, *ref2 = NULL;
5578
5579 for (ref = e->ref; ref; ref = ref->next)
5580 {
5581 if (ref->type == REF_COMPONENT)
5582 ref2 = ref;
5583 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5584 break;
5585 }
5586
5587 for ( ; ref; ref = ref->next)
5588 if (ref->type == REF_COMPONENT)
5589 break;
5590
5591 /* Expression itself is not coindexed object. */
5592 if (ref && e->ts.type == BT_CLASS)
5593 {
5594 gfc_error ("Polymorphic subobject of coindexed object at %L",
5595 &e->where);
5596 t = false;
5597 }
5598
5599 /* Expression itself is coindexed object. */
5600 if (ref == NULL)
5601 {
5602 gfc_component *c;
5603 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5604 for ( ; c; c = c->next)
5605 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5606 {
5607 gfc_error ("Coindexed object with polymorphic allocatable "
5608 "subcomponent at %L", &e->where);
5609 t = false;
5610 break;
5611 }
5612 }
5613 }
5614
5615 if (t)
5616 expression_rank (e);
5617
5618 if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
5619 add_caf_get_intrinsic (e);
5620
5621 /* Simplify cases where access to a parameter array results in a
5622 single constant. Suppress errors since those will have been
5623 issued before, as warnings. */
5624 if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
5625 {
5626 gfc_push_suppress_errors ();
5627 gfc_simplify_expr (e, 1);
5628 gfc_pop_suppress_errors ();
5629 }
5630
5631 return t;
5632 }
5633
5634
5635 /* Checks to see that the correct symbol has been host associated.
5636 The only situations where this arises are:
5637 (i) That in which a twice contained function is parsed after
5638 the host association is made. On detecting this, change
5639 the symbol in the expression and convert the array reference
5640 into an actual arglist if the old symbol is a variable; or
5641 (ii) That in which an external function is typed but not declared
5642 explcitly to be external. Here, the old symbol is changed
5643 from a variable to an external function. */
5644 static bool
check_host_association(gfc_expr * e)5645 check_host_association (gfc_expr *e)
5646 {
5647 gfc_symbol *sym, *old_sym;
5648 gfc_symtree *st;
5649 int n;
5650 gfc_ref *ref;
5651 gfc_actual_arglist *arg, *tail = NULL;
5652 bool retval = e->expr_type == EXPR_FUNCTION;
5653
5654 /* If the expression is the result of substitution in
5655 interface.c(gfc_extend_expr) because there is no way in
5656 which the host association can be wrong. */
5657 if (e->symtree == NULL
5658 || e->symtree->n.sym == NULL
5659 || e->user_operator)
5660 return retval;
5661
5662 old_sym = e->symtree->n.sym;
5663
5664 if (gfc_current_ns->parent
5665 && old_sym->ns != gfc_current_ns)
5666 {
5667 /* Use the 'USE' name so that renamed module symbols are
5668 correctly handled. */
5669 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5670
5671 if (sym && old_sym != sym
5672 && sym->ts.type == old_sym->ts.type
5673 && sym->attr.flavor == FL_PROCEDURE
5674 && sym->attr.contained)
5675 {
5676 /* Clear the shape, since it might not be valid. */
5677 gfc_free_shape (&e->shape, e->rank);
5678
5679 /* Give the expression the right symtree! */
5680 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5681 gcc_assert (st != NULL);
5682
5683 if (old_sym->attr.flavor == FL_PROCEDURE
5684 || e->expr_type == EXPR_FUNCTION)
5685 {
5686 /* Original was function so point to the new symbol, since
5687 the actual argument list is already attached to the
5688 expression. */
5689 e->value.function.esym = NULL;
5690 e->symtree = st;
5691 }
5692 else
5693 {
5694 /* Original was variable so convert array references into
5695 an actual arglist. This does not need any checking now
5696 since resolve_function will take care of it. */
5697 e->value.function.actual = NULL;
5698 e->expr_type = EXPR_FUNCTION;
5699 e->symtree = st;
5700
5701 /* Ambiguity will not arise if the array reference is not
5702 the last reference. */
5703 for (ref = e->ref; ref; ref = ref->next)
5704 if (ref->type == REF_ARRAY && ref->next == NULL)
5705 break;
5706
5707 gcc_assert (ref->type == REF_ARRAY);
5708
5709 /* Grab the start expressions from the array ref and
5710 copy them into actual arguments. */
5711 for (n = 0; n < ref->u.ar.dimen; n++)
5712 {
5713 arg = gfc_get_actual_arglist ();
5714 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5715 if (e->value.function.actual == NULL)
5716 tail = e->value.function.actual = arg;
5717 else
5718 {
5719 tail->next = arg;
5720 tail = arg;
5721 }
5722 }
5723
5724 /* Dump the reference list and set the rank. */
5725 gfc_free_ref_list (e->ref);
5726 e->ref = NULL;
5727 e->rank = sym->as ? sym->as->rank : 0;
5728 }
5729
5730 gfc_resolve_expr (e);
5731 sym->refs++;
5732 }
5733 /* This case corresponds to a call, from a block or a contained
5734 procedure, to an external function, which has not been declared
5735 as being external in the main program but has been typed. */
5736 else if (sym && old_sym != sym
5737 && !e->ref
5738 && sym->ts.type == BT_UNKNOWN
5739 && old_sym->ts.type != BT_UNKNOWN
5740 && sym->attr.flavor == FL_PROCEDURE
5741 && old_sym->attr.flavor == FL_VARIABLE
5742 && sym->ns->parent == old_sym->ns
5743 && sym->ns->proc_name
5744 && (sym->ns->proc_name->attr.flavor == FL_LABEL
5745 || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
5746 {
5747 old_sym->attr.flavor = FL_PROCEDURE;
5748 old_sym->attr.external = 1;
5749 old_sym->attr.function = 1;
5750 old_sym->result = old_sym;
5751 gfc_resolve_expr (e);
5752 }
5753 }
5754 /* This might have changed! */
5755 return e->expr_type == EXPR_FUNCTION;
5756 }
5757
5758
5759 static void
gfc_resolve_character_operator(gfc_expr * e)5760 gfc_resolve_character_operator (gfc_expr *e)
5761 {
5762 gfc_expr *op1 = e->value.op.op1;
5763 gfc_expr *op2 = e->value.op.op2;
5764 gfc_expr *e1 = NULL;
5765 gfc_expr *e2 = NULL;
5766
5767 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5768
5769 if (op1->ts.u.cl && op1->ts.u.cl->length)
5770 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5771 else if (op1->expr_type == EXPR_CONSTANT)
5772 e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
5773 op1->value.character.length);
5774
5775 if (op2->ts.u.cl && op2->ts.u.cl->length)
5776 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5777 else if (op2->expr_type == EXPR_CONSTANT)
5778 e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
5779 op2->value.character.length);
5780
5781 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5782
5783 if (!e1 || !e2)
5784 {
5785 gfc_free_expr (e1);
5786 gfc_free_expr (e2);
5787
5788 return;
5789 }
5790
5791 e->ts.u.cl->length = gfc_add (e1, e2);
5792 e->ts.u.cl->length->ts.type = BT_INTEGER;
5793 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5794 gfc_simplify_expr (e->ts.u.cl->length, 0);
5795 gfc_resolve_expr (e->ts.u.cl->length);
5796
5797 return;
5798 }
5799
5800
5801 /* Ensure that an character expression has a charlen and, if possible, a
5802 length expression. */
5803
5804 static void
fixup_charlen(gfc_expr * e)5805 fixup_charlen (gfc_expr *e)
5806 {
5807 /* The cases fall through so that changes in expression type and the need
5808 for multiple fixes are picked up. In all circumstances, a charlen should
5809 be available for the middle end to hang a backend_decl on. */
5810 switch (e->expr_type)
5811 {
5812 case EXPR_OP:
5813 gfc_resolve_character_operator (e);
5814 /* FALLTHRU */
5815
5816 case EXPR_ARRAY:
5817 if (e->expr_type == EXPR_ARRAY)
5818 gfc_resolve_character_array_constructor (e);
5819 /* FALLTHRU */
5820
5821 case EXPR_SUBSTRING:
5822 if (!e->ts.u.cl && e->ref)
5823 gfc_resolve_substring_charlen (e);
5824 /* FALLTHRU */
5825
5826 default:
5827 if (!e->ts.u.cl)
5828 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5829
5830 break;
5831 }
5832 }
5833
5834
5835 /* Update an actual argument to include the passed-object for type-bound
5836 procedures at the right position. */
5837
5838 static gfc_actual_arglist*
update_arglist_pass(gfc_actual_arglist * lst,gfc_expr * po,unsigned argpos,const char * name)5839 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5840 const char *name)
5841 {
5842 gcc_assert (argpos > 0);
5843
5844 if (argpos == 1)
5845 {
5846 gfc_actual_arglist* result;
5847
5848 result = gfc_get_actual_arglist ();
5849 result->expr = po;
5850 result->next = lst;
5851 if (name)
5852 result->name = name;
5853
5854 return result;
5855 }
5856
5857 if (lst)
5858 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5859 else
5860 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5861 return lst;
5862 }
5863
5864
5865 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5866
5867 static gfc_expr*
extract_compcall_passed_object(gfc_expr * e)5868 extract_compcall_passed_object (gfc_expr* e)
5869 {
5870 gfc_expr* po;
5871
5872 gcc_assert (e->expr_type == EXPR_COMPCALL);
5873
5874 if (e->value.compcall.base_object)
5875 po = gfc_copy_expr (e->value.compcall.base_object);
5876 else
5877 {
5878 po = gfc_get_expr ();
5879 po->expr_type = EXPR_VARIABLE;
5880 po->symtree = e->symtree;
5881 po->ref = gfc_copy_ref (e->ref);
5882 po->where = e->where;
5883 }
5884
5885 if (!gfc_resolve_expr (po))
5886 return NULL;
5887
5888 return po;
5889 }
5890
5891
5892 /* Update the arglist of an EXPR_COMPCALL expression to include the
5893 passed-object. */
5894
5895 static bool
update_compcall_arglist(gfc_expr * e)5896 update_compcall_arglist (gfc_expr* e)
5897 {
5898 gfc_expr* po;
5899 gfc_typebound_proc* tbp;
5900
5901 tbp = e->value.compcall.tbp;
5902
5903 if (tbp->error)
5904 return false;
5905
5906 po = extract_compcall_passed_object (e);
5907 if (!po)
5908 return false;
5909
5910 if (tbp->nopass || e->value.compcall.ignore_pass)
5911 {
5912 gfc_free_expr (po);
5913 return true;
5914 }
5915
5916 if (tbp->pass_arg_num <= 0)
5917 return false;
5918
5919 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5920 tbp->pass_arg_num,
5921 tbp->pass_arg);
5922
5923 return true;
5924 }
5925
5926
5927 /* Extract the passed object from a PPC call (a copy of it). */
5928
5929 static gfc_expr*
extract_ppc_passed_object(gfc_expr * e)5930 extract_ppc_passed_object (gfc_expr *e)
5931 {
5932 gfc_expr *po;
5933 gfc_ref **ref;
5934
5935 po = gfc_get_expr ();
5936 po->expr_type = EXPR_VARIABLE;
5937 po->symtree = e->symtree;
5938 po->ref = gfc_copy_ref (e->ref);
5939 po->where = e->where;
5940
5941 /* Remove PPC reference. */
5942 ref = &po->ref;
5943 while ((*ref)->next)
5944 ref = &(*ref)->next;
5945 gfc_free_ref_list (*ref);
5946 *ref = NULL;
5947
5948 if (!gfc_resolve_expr (po))
5949 return NULL;
5950
5951 return po;
5952 }
5953
5954
5955 /* Update the actual arglist of a procedure pointer component to include the
5956 passed-object. */
5957
5958 static bool
update_ppc_arglist(gfc_expr * e)5959 update_ppc_arglist (gfc_expr* e)
5960 {
5961 gfc_expr* po;
5962 gfc_component *ppc;
5963 gfc_typebound_proc* tb;
5964
5965 ppc = gfc_get_proc_ptr_comp (e);
5966 if (!ppc)
5967 return false;
5968
5969 tb = ppc->tb;
5970
5971 if (tb->error)
5972 return false;
5973 else if (tb->nopass)
5974 return true;
5975
5976 po = extract_ppc_passed_object (e);
5977 if (!po)
5978 return false;
5979
5980 /* F08:R739. */
5981 if (po->rank != 0)
5982 {
5983 gfc_error ("Passed-object at %L must be scalar", &e->where);
5984 return false;
5985 }
5986
5987 /* F08:C611. */
5988 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5989 {
5990 gfc_error ("Base object for procedure-pointer component call at %L is of"
5991 " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
5992 return false;
5993 }
5994
5995 gcc_assert (tb->pass_arg_num > 0);
5996 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5997 tb->pass_arg_num,
5998 tb->pass_arg);
5999
6000 return true;
6001 }
6002
6003
6004 /* Check that the object a TBP is called on is valid, i.e. it must not be
6005 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6006
6007 static bool
check_typebound_baseobject(gfc_expr * e)6008 check_typebound_baseobject (gfc_expr* e)
6009 {
6010 gfc_expr* base;
6011 bool return_value = false;
6012
6013 base = extract_compcall_passed_object (e);
6014 if (!base)
6015 return false;
6016
6017 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
6018
6019 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
6020 return false;
6021
6022 /* F08:C611. */
6023 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
6024 {
6025 gfc_error ("Base object for type-bound procedure call at %L is of"
6026 " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
6027 goto cleanup;
6028 }
6029
6030 /* F08:C1230. If the procedure called is NOPASS,
6031 the base object must be scalar. */
6032 if (e->value.compcall.tbp->nopass && base->rank != 0)
6033 {
6034 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6035 " be scalar", &e->where);
6036 goto cleanup;
6037 }
6038
6039 return_value = true;
6040
6041 cleanup:
6042 gfc_free_expr (base);
6043 return return_value;
6044 }
6045
6046
6047 /* Resolve a call to a type-bound procedure, either function or subroutine,
6048 statically from the data in an EXPR_COMPCALL expression. The adapted
6049 arglist and the target-procedure symtree are returned. */
6050
6051 static bool
resolve_typebound_static(gfc_expr * e,gfc_symtree ** target,gfc_actual_arglist ** actual)6052 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
6053 gfc_actual_arglist** actual)
6054 {
6055 gcc_assert (e->expr_type == EXPR_COMPCALL);
6056 gcc_assert (!e->value.compcall.tbp->is_generic);
6057
6058 /* Update the actual arglist for PASS. */
6059 if (!update_compcall_arglist (e))
6060 return false;
6061
6062 *actual = e->value.compcall.actual;
6063 *target = e->value.compcall.tbp->u.specific;
6064
6065 gfc_free_ref_list (e->ref);
6066 e->ref = NULL;
6067 e->value.compcall.actual = NULL;
6068
6069 /* If we find a deferred typebound procedure, check for derived types
6070 that an overriding typebound procedure has not been missed. */
6071 if (e->value.compcall.name
6072 && !e->value.compcall.tbp->non_overridable
6073 && e->value.compcall.base_object
6074 && e->value.compcall.base_object->ts.type == BT_DERIVED)
6075 {
6076 gfc_symtree *st;
6077 gfc_symbol *derived;
6078
6079 /* Use the derived type of the base_object. */
6080 derived = e->value.compcall.base_object->ts.u.derived;
6081 st = NULL;
6082
6083 /* If necessary, go through the inheritance chain. */
6084 while (!st && derived)
6085 {
6086 /* Look for the typebound procedure 'name'. */
6087 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
6088 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
6089 e->value.compcall.name);
6090 if (!st)
6091 derived = gfc_get_derived_super_type (derived);
6092 }
6093
6094 /* Now find the specific name in the derived type namespace. */
6095 if (st && st->n.tb && st->n.tb->u.specific)
6096 gfc_find_sym_tree (st->n.tb->u.specific->name,
6097 derived->ns, 1, &st);
6098 if (st)
6099 *target = st;
6100 }
6101 return true;
6102 }
6103
6104
6105 /* Get the ultimate declared type from an expression. In addition,
6106 return the last class/derived type reference and the copy of the
6107 reference list. If check_types is set true, derived types are
6108 identified as well as class references. */
6109 static gfc_symbol*
get_declared_from_expr(gfc_ref ** class_ref,gfc_ref ** new_ref,gfc_expr * e,bool check_types)6110 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
6111 gfc_expr *e, bool check_types)
6112 {
6113 gfc_symbol *declared;
6114 gfc_ref *ref;
6115
6116 declared = NULL;
6117 if (class_ref)
6118 *class_ref = NULL;
6119 if (new_ref)
6120 *new_ref = gfc_copy_ref (e->ref);
6121
6122 for (ref = e->ref; ref; ref = ref->next)
6123 {
6124 if (ref->type != REF_COMPONENT)
6125 continue;
6126
6127 if ((ref->u.c.component->ts.type == BT_CLASS
6128 || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
6129 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
6130 {
6131 declared = ref->u.c.component->ts.u.derived;
6132 if (class_ref)
6133 *class_ref = ref;
6134 }
6135 }
6136
6137 if (declared == NULL)
6138 declared = e->symtree->n.sym->ts.u.derived;
6139
6140 return declared;
6141 }
6142
6143
6144 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6145 which of the specific bindings (if any) matches the arglist and transform
6146 the expression into a call of that binding. */
6147
6148 static bool
resolve_typebound_generic_call(gfc_expr * e,const char ** name)6149 resolve_typebound_generic_call (gfc_expr* e, const char **name)
6150 {
6151 gfc_typebound_proc* genproc;
6152 const char* genname;
6153 gfc_symtree *st;
6154 gfc_symbol *derived;
6155
6156 gcc_assert (e->expr_type == EXPR_COMPCALL);
6157 genname = e->value.compcall.name;
6158 genproc = e->value.compcall.tbp;
6159
6160 if (!genproc->is_generic)
6161 return true;
6162
6163 /* Try the bindings on this type and in the inheritance hierarchy. */
6164 for (; genproc; genproc = genproc->overridden)
6165 {
6166 gfc_tbp_generic* g;
6167
6168 gcc_assert (genproc->is_generic);
6169 for (g = genproc->u.generic; g; g = g->next)
6170 {
6171 gfc_symbol* target;
6172 gfc_actual_arglist* args;
6173 bool matches;
6174
6175 gcc_assert (g->specific);
6176
6177 if (g->specific->error)
6178 continue;
6179
6180 target = g->specific->u.specific->n.sym;
6181
6182 /* Get the right arglist by handling PASS/NOPASS. */
6183 args = gfc_copy_actual_arglist (e->value.compcall.actual);
6184 if (!g->specific->nopass)
6185 {
6186 gfc_expr* po;
6187 po = extract_compcall_passed_object (e);
6188 if (!po)
6189 {
6190 gfc_free_actual_arglist (args);
6191 return false;
6192 }
6193
6194 gcc_assert (g->specific->pass_arg_num > 0);
6195 gcc_assert (!g->specific->error);
6196 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
6197 g->specific->pass_arg);
6198 }
6199 resolve_actual_arglist (args, target->attr.proc,
6200 is_external_proc (target)
6201 && gfc_sym_get_dummy_args (target) == NULL);
6202
6203 /* Check if this arglist matches the formal. */
6204 matches = gfc_arglist_matches_symbol (&args, target);
6205
6206 /* Clean up and break out of the loop if we've found it. */
6207 gfc_free_actual_arglist (args);
6208 if (matches)
6209 {
6210 e->value.compcall.tbp = g->specific;
6211 genname = g->specific_st->name;
6212 /* Pass along the name for CLASS methods, where the vtab
6213 procedure pointer component has to be referenced. */
6214 if (name)
6215 *name = genname;
6216 goto success;
6217 }
6218 }
6219 }
6220
6221 /* Nothing matching found! */
6222 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6223 " %qs at %L", genname, &e->where);
6224 return false;
6225
6226 success:
6227 /* Make sure that we have the right specific instance for the name. */
6228 derived = get_declared_from_expr (NULL, NULL, e, true);
6229
6230 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
6231 if (st)
6232 e->value.compcall.tbp = st->n.tb;
6233
6234 return true;
6235 }
6236
6237
6238 /* Resolve a call to a type-bound subroutine. */
6239
6240 static bool
resolve_typebound_call(gfc_code * c,const char ** name,bool * overridable)6241 resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
6242 {
6243 gfc_actual_arglist* newactual;
6244 gfc_symtree* target;
6245
6246 /* Check that's really a SUBROUTINE. */
6247 if (!c->expr1->value.compcall.tbp->subroutine)
6248 {
6249 gfc_error ("%qs at %L should be a SUBROUTINE",
6250 c->expr1->value.compcall.name, &c->loc);
6251 return false;
6252 }
6253
6254 if (!check_typebound_baseobject (c->expr1))
6255 return false;
6256
6257 /* Pass along the name for CLASS methods, where the vtab
6258 procedure pointer component has to be referenced. */
6259 if (name)
6260 *name = c->expr1->value.compcall.name;
6261
6262 if (!resolve_typebound_generic_call (c->expr1, name))
6263 return false;
6264
6265 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6266 if (overridable)
6267 *overridable = !c->expr1->value.compcall.tbp->non_overridable;
6268
6269 /* Transform into an ordinary EXEC_CALL for now. */
6270
6271 if (!resolve_typebound_static (c->expr1, &target, &newactual))
6272 return false;
6273
6274 c->ext.actual = newactual;
6275 c->symtree = target;
6276 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
6277
6278 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
6279
6280 gfc_free_expr (c->expr1);
6281 c->expr1 = gfc_get_expr ();
6282 c->expr1->expr_type = EXPR_FUNCTION;
6283 c->expr1->symtree = target;
6284 c->expr1->where = c->loc;
6285
6286 return resolve_call (c);
6287 }
6288
6289
6290 /* Resolve a component-call expression. */
6291 static bool
resolve_compcall(gfc_expr * e,const char ** name)6292 resolve_compcall (gfc_expr* e, const char **name)
6293 {
6294 gfc_actual_arglist* newactual;
6295 gfc_symtree* target;
6296
6297 /* Check that's really a FUNCTION. */
6298 if (!e->value.compcall.tbp->function)
6299 {
6300 gfc_error ("%qs at %L should be a FUNCTION",
6301 e->value.compcall.name, &e->where);
6302 return false;
6303 }
6304
6305 /* These must not be assign-calls! */
6306 gcc_assert (!e->value.compcall.assign);
6307
6308 if (!check_typebound_baseobject (e))
6309 return false;
6310
6311 /* Pass along the name for CLASS methods, where the vtab
6312 procedure pointer component has to be referenced. */
6313 if (name)
6314 *name = e->value.compcall.name;
6315
6316 if (!resolve_typebound_generic_call (e, name))
6317 return false;
6318 gcc_assert (!e->value.compcall.tbp->is_generic);
6319
6320 /* Take the rank from the function's symbol. */
6321 if (e->value.compcall.tbp->u.specific->n.sym->as)
6322 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
6323
6324 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6325 arglist to the TBP's binding target. */
6326
6327 if (!resolve_typebound_static (e, &target, &newactual))
6328 return false;
6329
6330 e->value.function.actual = newactual;
6331 e->value.function.name = NULL;
6332 e->value.function.esym = target->n.sym;
6333 e->value.function.isym = NULL;
6334 e->symtree = target;
6335 e->ts = target->n.sym->ts;
6336 e->expr_type = EXPR_FUNCTION;
6337
6338 /* Resolution is not necessary if this is a class subroutine; this
6339 function only has to identify the specific proc. Resolution of
6340 the call will be done next in resolve_typebound_call. */
6341 return gfc_resolve_expr (e);
6342 }
6343
6344
6345 static bool resolve_fl_derived (gfc_symbol *sym);
6346
6347
6348 /* Resolve a typebound function, or 'method'. First separate all
6349 the non-CLASS references by calling resolve_compcall directly. */
6350
6351 static bool
resolve_typebound_function(gfc_expr * e)6352 resolve_typebound_function (gfc_expr* e)
6353 {
6354 gfc_symbol *declared;
6355 gfc_component *c;
6356 gfc_ref *new_ref;
6357 gfc_ref *class_ref;
6358 gfc_symtree *st;
6359 const char *name;
6360 gfc_typespec ts;
6361 gfc_expr *expr;
6362 bool overridable;
6363
6364 st = e->symtree;
6365
6366 /* Deal with typebound operators for CLASS objects. */
6367 expr = e->value.compcall.base_object;
6368 overridable = !e->value.compcall.tbp->non_overridable;
6369 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
6370 {
6371 /* If the base_object is not a variable, the corresponding actual
6372 argument expression must be stored in e->base_expression so
6373 that the corresponding tree temporary can be used as the base
6374 object in gfc_conv_procedure_call. */
6375 if (expr->expr_type != EXPR_VARIABLE)
6376 {
6377 gfc_actual_arglist *args;
6378
6379 for (args= e->value.function.actual; args; args = args->next)
6380 {
6381 if (expr == args->expr)
6382 expr = args->expr;
6383 }
6384 }
6385
6386 /* Since the typebound operators are generic, we have to ensure
6387 that any delays in resolution are corrected and that the vtab
6388 is present. */
6389 ts = expr->ts;
6390 declared = ts.u.derived;
6391 c = gfc_find_component (declared, "_vptr", true, true, NULL);
6392 if (c->ts.u.derived == NULL)
6393 c->ts.u.derived = gfc_find_derived_vtab (declared);
6394
6395 if (!resolve_compcall (e, &name))
6396 return false;
6397
6398 /* Use the generic name if it is there. */
6399 name = name ? name : e->value.function.esym->name;
6400 e->symtree = expr->symtree;
6401 e->ref = gfc_copy_ref (expr->ref);
6402 get_declared_from_expr (&class_ref, NULL, e, false);
6403
6404 /* Trim away the extraneous references that emerge from nested
6405 use of interface.c (extend_expr). */
6406 if (class_ref && class_ref->next)
6407 {
6408 gfc_free_ref_list (class_ref->next);
6409 class_ref->next = NULL;
6410 }
6411 else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
6412 {
6413 gfc_free_ref_list (e->ref);
6414 e->ref = NULL;
6415 }
6416
6417 gfc_add_vptr_component (e);
6418 gfc_add_component_ref (e, name);
6419 e->value.function.esym = NULL;
6420 if (expr->expr_type != EXPR_VARIABLE)
6421 e->base_expr = expr;
6422 return true;
6423 }
6424
6425 if (st == NULL)
6426 return resolve_compcall (e, NULL);
6427
6428 if (!resolve_ref (e))
6429 return false;
6430
6431 /* Get the CLASS declared type. */
6432 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
6433
6434 if (!resolve_fl_derived (declared))
6435 return false;
6436
6437 /* Weed out cases of the ultimate component being a derived type. */
6438 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
6439 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6440 {
6441 gfc_free_ref_list (new_ref);
6442 return resolve_compcall (e, NULL);
6443 }
6444
6445 c = gfc_find_component (declared, "_data", true, true, NULL);
6446 declared = c->ts.u.derived;
6447
6448 /* Treat the call as if it is a typebound procedure, in order to roll
6449 out the correct name for the specific function. */
6450 if (!resolve_compcall (e, &name))
6451 {
6452 gfc_free_ref_list (new_ref);
6453 return false;
6454 }
6455 ts = e->ts;
6456
6457 if (overridable)
6458 {
6459 /* Convert the expression to a procedure pointer component call. */
6460 e->value.function.esym = NULL;
6461 e->symtree = st;
6462
6463 if (new_ref)
6464 e->ref = new_ref;
6465
6466 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6467 gfc_add_vptr_component (e);
6468 gfc_add_component_ref (e, name);
6469
6470 /* Recover the typespec for the expression. This is really only
6471 necessary for generic procedures, where the additional call
6472 to gfc_add_component_ref seems to throw the collection of the
6473 correct typespec. */
6474 e->ts = ts;
6475 }
6476 else if (new_ref)
6477 gfc_free_ref_list (new_ref);
6478
6479 return true;
6480 }
6481
6482 /* Resolve a typebound subroutine, or 'method'. First separate all
6483 the non-CLASS references by calling resolve_typebound_call
6484 directly. */
6485
6486 static bool
resolve_typebound_subroutine(gfc_code * code)6487 resolve_typebound_subroutine (gfc_code *code)
6488 {
6489 gfc_symbol *declared;
6490 gfc_component *c;
6491 gfc_ref *new_ref;
6492 gfc_ref *class_ref;
6493 gfc_symtree *st;
6494 const char *name;
6495 gfc_typespec ts;
6496 gfc_expr *expr;
6497 bool overridable;
6498
6499 st = code->expr1->symtree;
6500
6501 /* Deal with typebound operators for CLASS objects. */
6502 expr = code->expr1->value.compcall.base_object;
6503 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6504 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6505 {
6506 /* If the base_object is not a variable, the corresponding actual
6507 argument expression must be stored in e->base_expression so
6508 that the corresponding tree temporary can be used as the base
6509 object in gfc_conv_procedure_call. */
6510 if (expr->expr_type != EXPR_VARIABLE)
6511 {
6512 gfc_actual_arglist *args;
6513
6514 args= code->expr1->value.function.actual;
6515 for (; args; args = args->next)
6516 if (expr == args->expr)
6517 expr = args->expr;
6518 }
6519
6520 /* Since the typebound operators are generic, we have to ensure
6521 that any delays in resolution are corrected and that the vtab
6522 is present. */
6523 declared = expr->ts.u.derived;
6524 c = gfc_find_component (declared, "_vptr", true, true, NULL);
6525 if (c->ts.u.derived == NULL)
6526 c->ts.u.derived = gfc_find_derived_vtab (declared);
6527
6528 if (!resolve_typebound_call (code, &name, NULL))
6529 return false;
6530
6531 /* Use the generic name if it is there. */
6532 name = name ? name : code->expr1->value.function.esym->name;
6533 code->expr1->symtree = expr->symtree;
6534 code->expr1->ref = gfc_copy_ref (expr->ref);
6535
6536 /* Trim away the extraneous references that emerge from nested
6537 use of interface.c (extend_expr). */
6538 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6539 if (class_ref && class_ref->next)
6540 {
6541 gfc_free_ref_list (class_ref->next);
6542 class_ref->next = NULL;
6543 }
6544 else if (code->expr1->ref && !class_ref)
6545 {
6546 gfc_free_ref_list (code->expr1->ref);
6547 code->expr1->ref = NULL;
6548 }
6549
6550 /* Now use the procedure in the vtable. */
6551 gfc_add_vptr_component (code->expr1);
6552 gfc_add_component_ref (code->expr1, name);
6553 code->expr1->value.function.esym = NULL;
6554 if (expr->expr_type != EXPR_VARIABLE)
6555 code->expr1->base_expr = expr;
6556 return true;
6557 }
6558
6559 if (st == NULL)
6560 return resolve_typebound_call (code, NULL, NULL);
6561
6562 if (!resolve_ref (code->expr1))
6563 return false;
6564
6565 /* Get the CLASS declared type. */
6566 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6567
6568 /* Weed out cases of the ultimate component being a derived type. */
6569 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
6570 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6571 {
6572 gfc_free_ref_list (new_ref);
6573 return resolve_typebound_call (code, NULL, NULL);
6574 }
6575
6576 if (!resolve_typebound_call (code, &name, &overridable))
6577 {
6578 gfc_free_ref_list (new_ref);
6579 return false;
6580 }
6581 ts = code->expr1->ts;
6582
6583 if (overridable)
6584 {
6585 /* Convert the expression to a procedure pointer component call. */
6586 code->expr1->value.function.esym = NULL;
6587 code->expr1->symtree = st;
6588
6589 if (new_ref)
6590 code->expr1->ref = new_ref;
6591
6592 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6593 gfc_add_vptr_component (code->expr1);
6594 gfc_add_component_ref (code->expr1, name);
6595
6596 /* Recover the typespec for the expression. This is really only
6597 necessary for generic procedures, where the additional call
6598 to gfc_add_component_ref seems to throw the collection of the
6599 correct typespec. */
6600 code->expr1->ts = ts;
6601 }
6602 else if (new_ref)
6603 gfc_free_ref_list (new_ref);
6604
6605 return true;
6606 }
6607
6608
6609 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6610
6611 static bool
resolve_ppc_call(gfc_code * c)6612 resolve_ppc_call (gfc_code* c)
6613 {
6614 gfc_component *comp;
6615
6616 comp = gfc_get_proc_ptr_comp (c->expr1);
6617 gcc_assert (comp != NULL);
6618
6619 c->resolved_sym = c->expr1->symtree->n.sym;
6620 c->expr1->expr_type = EXPR_VARIABLE;
6621
6622 if (!comp->attr.subroutine)
6623 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6624
6625 if (!resolve_ref (c->expr1))
6626 return false;
6627
6628 if (!update_ppc_arglist (c->expr1))
6629 return false;
6630
6631 c->ext.actual = c->expr1->value.compcall.actual;
6632
6633 if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6634 !(comp->ts.interface
6635 && comp->ts.interface->formal)))
6636 return false;
6637
6638 if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
6639 return false;
6640
6641 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6642
6643 return true;
6644 }
6645
6646
6647 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6648
6649 static bool
resolve_expr_ppc(gfc_expr * e)6650 resolve_expr_ppc (gfc_expr* e)
6651 {
6652 gfc_component *comp;
6653
6654 comp = gfc_get_proc_ptr_comp (e);
6655 gcc_assert (comp != NULL);
6656
6657 /* Convert to EXPR_FUNCTION. */
6658 e->expr_type = EXPR_FUNCTION;
6659 e->value.function.isym = NULL;
6660 e->value.function.actual = e->value.compcall.actual;
6661 e->ts = comp->ts;
6662 if (comp->as != NULL)
6663 e->rank = comp->as->rank;
6664
6665 if (!comp->attr.function)
6666 gfc_add_function (&comp->attr, comp->name, &e->where);
6667
6668 if (!resolve_ref (e))
6669 return false;
6670
6671 if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6672 !(comp->ts.interface
6673 && comp->ts.interface->formal)))
6674 return false;
6675
6676 if (!update_ppc_arglist (e))
6677 return false;
6678
6679 if (!check_pure_function(e))
6680 return false;
6681
6682 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6683
6684 return true;
6685 }
6686
6687
6688 static bool
gfc_is_expandable_expr(gfc_expr * e)6689 gfc_is_expandable_expr (gfc_expr *e)
6690 {
6691 gfc_constructor *con;
6692
6693 if (e->expr_type == EXPR_ARRAY)
6694 {
6695 /* Traverse the constructor looking for variables that are flavor
6696 parameter. Parameters must be expanded since they are fully used at
6697 compile time. */
6698 con = gfc_constructor_first (e->value.constructor);
6699 for (; con; con = gfc_constructor_next (con))
6700 {
6701 if (con->expr->expr_type == EXPR_VARIABLE
6702 && con->expr->symtree
6703 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6704 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6705 return true;
6706 if (con->expr->expr_type == EXPR_ARRAY
6707 && gfc_is_expandable_expr (con->expr))
6708 return true;
6709 }
6710 }
6711
6712 return false;
6713 }
6714
6715
6716 /* Sometimes variables in specification expressions of the result
6717 of module procedures in submodules wind up not being the 'real'
6718 dummy. Find this, if possible, in the namespace of the first
6719 formal argument. */
6720
6721 static void
fixup_unique_dummy(gfc_expr * e)6722 fixup_unique_dummy (gfc_expr *e)
6723 {
6724 gfc_symtree *st = NULL;
6725 gfc_symbol *s = NULL;
6726
6727 if (e->symtree->n.sym->ns->proc_name
6728 && e->symtree->n.sym->ns->proc_name->formal)
6729 s = e->symtree->n.sym->ns->proc_name->formal->sym;
6730
6731 if (s != NULL)
6732 st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
6733
6734 if (st != NULL
6735 && st->n.sym != NULL
6736 && st->n.sym->attr.dummy)
6737 e->symtree = st;
6738 }
6739
6740 /* Resolve an expression. That is, make sure that types of operands agree
6741 with their operators, intrinsic operators are converted to function calls
6742 for overloaded types and unresolved function references are resolved. */
6743
6744 bool
gfc_resolve_expr(gfc_expr * e)6745 gfc_resolve_expr (gfc_expr *e)
6746 {
6747 bool t;
6748 bool inquiry_save, actual_arg_save, first_actual_arg_save;
6749
6750 if (e == NULL)
6751 return true;
6752
6753 /* inquiry_argument only applies to variables. */
6754 inquiry_save = inquiry_argument;
6755 actual_arg_save = actual_arg;
6756 first_actual_arg_save = first_actual_arg;
6757
6758 if (e->expr_type != EXPR_VARIABLE)
6759 {
6760 inquiry_argument = false;
6761 actual_arg = false;
6762 first_actual_arg = false;
6763 }
6764 else if (e->symtree != NULL
6765 && *e->symtree->name == '@'
6766 && e->symtree->n.sym->attr.dummy)
6767 {
6768 /* Deal with submodule specification expressions that are not
6769 found to be referenced in module.c(read_cleanup). */
6770 fixup_unique_dummy (e);
6771 }
6772
6773 switch (e->expr_type)
6774 {
6775 case EXPR_OP:
6776 t = resolve_operator (e);
6777 break;
6778
6779 case EXPR_FUNCTION:
6780 case EXPR_VARIABLE:
6781
6782 if (check_host_association (e))
6783 t = resolve_function (e);
6784 else
6785 t = resolve_variable (e);
6786
6787 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6788 && e->ref->type != REF_SUBSTRING)
6789 gfc_resolve_substring_charlen (e);
6790
6791 break;
6792
6793 case EXPR_COMPCALL:
6794 t = resolve_typebound_function (e);
6795 break;
6796
6797 case EXPR_SUBSTRING:
6798 t = resolve_ref (e);
6799 break;
6800
6801 case EXPR_CONSTANT:
6802 case EXPR_NULL:
6803 t = true;
6804 break;
6805
6806 case EXPR_PPC:
6807 t = resolve_expr_ppc (e);
6808 break;
6809
6810 case EXPR_ARRAY:
6811 t = false;
6812 if (!resolve_ref (e))
6813 break;
6814
6815 t = gfc_resolve_array_constructor (e);
6816 /* Also try to expand a constructor. */
6817 if (t)
6818 {
6819 expression_rank (e);
6820 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6821 gfc_expand_constructor (e, false);
6822 }
6823
6824 /* This provides the opportunity for the length of constructors with
6825 character valued function elements to propagate the string length
6826 to the expression. */
6827 if (t && e->ts.type == BT_CHARACTER)
6828 {
6829 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6830 here rather then add a duplicate test for it above. */
6831 gfc_expand_constructor (e, false);
6832 t = gfc_resolve_character_array_constructor (e);
6833 }
6834
6835 break;
6836
6837 case EXPR_STRUCTURE:
6838 t = resolve_ref (e);
6839 if (!t)
6840 break;
6841
6842 t = resolve_structure_cons (e, 0);
6843 if (!t)
6844 break;
6845
6846 t = gfc_simplify_expr (e, 0);
6847 break;
6848
6849 default:
6850 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6851 }
6852
6853 if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
6854 fixup_charlen (e);
6855
6856 inquiry_argument = inquiry_save;
6857 actual_arg = actual_arg_save;
6858 first_actual_arg = first_actual_arg_save;
6859
6860 return t;
6861 }
6862
6863
6864 /* Resolve an expression from an iterator. They must be scalar and have
6865 INTEGER or (optionally) REAL type. */
6866
6867 static bool
gfc_resolve_iterator_expr(gfc_expr * expr,bool real_ok,const char * name_msgid)6868 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6869 const char *name_msgid)
6870 {
6871 if (!gfc_resolve_expr (expr))
6872 return false;
6873
6874 if (expr->rank != 0)
6875 {
6876 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6877 return false;
6878 }
6879
6880 if (expr->ts.type != BT_INTEGER)
6881 {
6882 if (expr->ts.type == BT_REAL)
6883 {
6884 if (real_ok)
6885 return gfc_notify_std (GFC_STD_F95_DEL,
6886 "%s at %L must be integer",
6887 _(name_msgid), &expr->where);
6888 else
6889 {
6890 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6891 &expr->where);
6892 return false;
6893 }
6894 }
6895 else
6896 {
6897 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6898 return false;
6899 }
6900 }
6901 return true;
6902 }
6903
6904
6905 /* Resolve the expressions in an iterator structure. If REAL_OK is
6906 false allow only INTEGER type iterators, otherwise allow REAL types.
6907 Set own_scope to true for ac-implied-do and data-implied-do as those
6908 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6909
6910 bool
gfc_resolve_iterator(gfc_iterator * iter,bool real_ok,bool own_scope)6911 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
6912 {
6913 if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
6914 return false;
6915
6916 if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
6917 _("iterator variable")))
6918 return false;
6919
6920 if (!gfc_resolve_iterator_expr (iter->start, real_ok,
6921 "Start expression in DO loop"))
6922 return false;
6923
6924 if (!gfc_resolve_iterator_expr (iter->end, real_ok,
6925 "End expression in DO loop"))
6926 return false;
6927
6928 if (!gfc_resolve_iterator_expr (iter->step, real_ok,
6929 "Step expression in DO loop"))
6930 return false;
6931
6932 /* Convert start, end, and step to the same type as var. */
6933 if (iter->start->ts.kind != iter->var->ts.kind
6934 || iter->start->ts.type != iter->var->ts.type)
6935 gfc_convert_type (iter->start, &iter->var->ts, 1);
6936
6937 if (iter->end->ts.kind != iter->var->ts.kind
6938 || iter->end->ts.type != iter->var->ts.type)
6939 gfc_convert_type (iter->end, &iter->var->ts, 1);
6940
6941 if (iter->step->ts.kind != iter->var->ts.kind
6942 || iter->step->ts.type != iter->var->ts.type)
6943 gfc_convert_type (iter->step, &iter->var->ts, 1);
6944
6945 if (iter->step->expr_type == EXPR_CONSTANT)
6946 {
6947 if ((iter->step->ts.type == BT_INTEGER
6948 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6949 || (iter->step->ts.type == BT_REAL
6950 && mpfr_sgn (iter->step->value.real) == 0))
6951 {
6952 gfc_error ("Step expression in DO loop at %L cannot be zero",
6953 &iter->step->where);
6954 return false;
6955 }
6956 }
6957
6958 if (iter->start->expr_type == EXPR_CONSTANT
6959 && iter->end->expr_type == EXPR_CONSTANT
6960 && iter->step->expr_type == EXPR_CONSTANT)
6961 {
6962 int sgn, cmp;
6963 if (iter->start->ts.type == BT_INTEGER)
6964 {
6965 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6966 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6967 }
6968 else
6969 {
6970 sgn = mpfr_sgn (iter->step->value.real);
6971 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6972 }
6973 if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
6974 gfc_warning (OPT_Wzerotrip,
6975 "DO loop at %L will be executed zero times",
6976 &iter->step->where);
6977 }
6978
6979 if (iter->end->expr_type == EXPR_CONSTANT
6980 && iter->end->ts.type == BT_INTEGER
6981 && iter->step->expr_type == EXPR_CONSTANT
6982 && iter->step->ts.type == BT_INTEGER
6983 && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
6984 || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
6985 {
6986 bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
6987 int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
6988
6989 if (is_step_positive
6990 && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
6991 gfc_warning (OPT_Wundefined_do_loop,
6992 "DO loop at %L is undefined as it overflows",
6993 &iter->step->where);
6994 else if (!is_step_positive
6995 && mpz_cmp (iter->end->value.integer,
6996 gfc_integer_kinds[k].min_int) == 0)
6997 gfc_warning (OPT_Wundefined_do_loop,
6998 "DO loop at %L is undefined as it underflows",
6999 &iter->step->where);
7000 }
7001
7002 return true;
7003 }
7004
7005
7006 /* Traversal function for find_forall_index. f == 2 signals that
7007 that variable itself is not to be checked - only the references. */
7008
7009 static bool
forall_index(gfc_expr * expr,gfc_symbol * sym,int * f)7010 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
7011 {
7012 if (expr->expr_type != EXPR_VARIABLE)
7013 return false;
7014
7015 /* A scalar assignment */
7016 if (!expr->ref || *f == 1)
7017 {
7018 if (expr->symtree->n.sym == sym)
7019 return true;
7020 else
7021 return false;
7022 }
7023
7024 if (*f == 2)
7025 *f = 1;
7026 return false;
7027 }
7028
7029
7030 /* Check whether the FORALL index appears in the expression or not.
7031 Returns true if SYM is found in EXPR. */
7032
7033 bool
find_forall_index(gfc_expr * expr,gfc_symbol * sym,int f)7034 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
7035 {
7036 if (gfc_traverse_expr (expr, sym, forall_index, f))
7037 return true;
7038 else
7039 return false;
7040 }
7041
7042
7043 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7044 to be a scalar INTEGER variable. The subscripts and stride are scalar
7045 INTEGERs, and if stride is a constant it must be nonzero.
7046 Furthermore "A subscript or stride in a forall-triplet-spec shall
7047 not contain a reference to any index-name in the
7048 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7049
7050 static void
resolve_forall_iterators(gfc_forall_iterator * it)7051 resolve_forall_iterators (gfc_forall_iterator *it)
7052 {
7053 gfc_forall_iterator *iter, *iter2;
7054
7055 for (iter = it; iter; iter = iter->next)
7056 {
7057 if (gfc_resolve_expr (iter->var)
7058 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
7059 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7060 &iter->var->where);
7061
7062 if (gfc_resolve_expr (iter->start)
7063 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
7064 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7065 &iter->start->where);
7066 if (iter->var->ts.kind != iter->start->ts.kind)
7067 gfc_convert_type (iter->start, &iter->var->ts, 1);
7068
7069 if (gfc_resolve_expr (iter->end)
7070 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
7071 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7072 &iter->end->where);
7073 if (iter->var->ts.kind != iter->end->ts.kind)
7074 gfc_convert_type (iter->end, &iter->var->ts, 1);
7075
7076 if (gfc_resolve_expr (iter->stride))
7077 {
7078 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
7079 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7080 &iter->stride->where, "INTEGER");
7081
7082 if (iter->stride->expr_type == EXPR_CONSTANT
7083 && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
7084 gfc_error ("FORALL stride expression at %L cannot be zero",
7085 &iter->stride->where);
7086 }
7087 if (iter->var->ts.kind != iter->stride->ts.kind)
7088 gfc_convert_type (iter->stride, &iter->var->ts, 1);
7089 }
7090
7091 for (iter = it; iter; iter = iter->next)
7092 for (iter2 = iter; iter2; iter2 = iter2->next)
7093 {
7094 if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
7095 || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
7096 || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
7097 gfc_error ("FORALL index %qs may not appear in triplet "
7098 "specification at %L", iter->var->symtree->name,
7099 &iter2->start->where);
7100 }
7101 }
7102
7103
7104 /* Given a pointer to a symbol that is a derived type, see if it's
7105 inaccessible, i.e. if it's defined in another module and the components are
7106 PRIVATE. The search is recursive if necessary. Returns zero if no
7107 inaccessible components are found, nonzero otherwise. */
7108
7109 static int
derived_inaccessible(gfc_symbol * sym)7110 derived_inaccessible (gfc_symbol *sym)
7111 {
7112 gfc_component *c;
7113
7114 if (sym->attr.use_assoc && sym->attr.private_comp)
7115 return 1;
7116
7117 for (c = sym->components; c; c = c->next)
7118 {
7119 /* Prevent an infinite loop through this function. */
7120 if (c->ts.type == BT_DERIVED && c->attr.pointer
7121 && sym == c->ts.u.derived)
7122 continue;
7123
7124 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
7125 return 1;
7126 }
7127
7128 return 0;
7129 }
7130
7131
7132 /* Resolve the argument of a deallocate expression. The expression must be
7133 a pointer or a full array. */
7134
7135 static bool
resolve_deallocate_expr(gfc_expr * e)7136 resolve_deallocate_expr (gfc_expr *e)
7137 {
7138 symbol_attribute attr;
7139 int allocatable, pointer;
7140 gfc_ref *ref;
7141 gfc_symbol *sym;
7142 gfc_component *c;
7143 bool unlimited;
7144
7145 if (!gfc_resolve_expr (e))
7146 return false;
7147
7148 if (e->expr_type != EXPR_VARIABLE)
7149 goto bad;
7150
7151 sym = e->symtree->n.sym;
7152 unlimited = UNLIMITED_POLY(sym);
7153
7154 if (sym->ts.type == BT_CLASS)
7155 {
7156 allocatable = CLASS_DATA (sym)->attr.allocatable;
7157 pointer = CLASS_DATA (sym)->attr.class_pointer;
7158 }
7159 else
7160 {
7161 allocatable = sym->attr.allocatable;
7162 pointer = sym->attr.pointer;
7163 }
7164 for (ref = e->ref; ref; ref = ref->next)
7165 {
7166 switch (ref->type)
7167 {
7168 case REF_ARRAY:
7169 if (ref->u.ar.type != AR_FULL
7170 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
7171 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
7172 allocatable = 0;
7173 break;
7174
7175 case REF_COMPONENT:
7176 c = ref->u.c.component;
7177 if (c->ts.type == BT_CLASS)
7178 {
7179 allocatable = CLASS_DATA (c)->attr.allocatable;
7180 pointer = CLASS_DATA (c)->attr.class_pointer;
7181 }
7182 else
7183 {
7184 allocatable = c->attr.allocatable;
7185 pointer = c->attr.pointer;
7186 }
7187 break;
7188
7189 case REF_SUBSTRING:
7190 allocatable = 0;
7191 break;
7192 }
7193 }
7194
7195 attr = gfc_expr_attr (e);
7196
7197 if (allocatable == 0 && attr.pointer == 0 && !unlimited)
7198 {
7199 bad:
7200 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7201 &e->where);
7202 return false;
7203 }
7204
7205 /* F2008, C644. */
7206 if (gfc_is_coindexed (e))
7207 {
7208 gfc_error ("Coindexed allocatable object at %L", &e->where);
7209 return false;
7210 }
7211
7212 if (pointer
7213 && !gfc_check_vardef_context (e, true, true, false,
7214 _("DEALLOCATE object")))
7215 return false;
7216 if (!gfc_check_vardef_context (e, false, true, false,
7217 _("DEALLOCATE object")))
7218 return false;
7219
7220 return true;
7221 }
7222
7223
7224 /* Returns true if the expression e contains a reference to the symbol sym. */
7225 static bool
sym_in_expr(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)7226 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
7227 {
7228 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
7229 return true;
7230
7231 return false;
7232 }
7233
7234 bool
gfc_find_sym_in_expr(gfc_symbol * sym,gfc_expr * e)7235 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
7236 {
7237 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
7238 }
7239
7240
7241 /* Given the expression node e for an allocatable/pointer of derived type to be
7242 allocated, get the expression node to be initialized afterwards (needed for
7243 derived types with default initializers, and derived types with allocatable
7244 components that need nullification.) */
7245
7246 gfc_expr *
gfc_expr_to_initialize(gfc_expr * e)7247 gfc_expr_to_initialize (gfc_expr *e)
7248 {
7249 gfc_expr *result;
7250 gfc_ref *ref;
7251 int i;
7252
7253 result = gfc_copy_expr (e);
7254
7255 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7256 for (ref = result->ref; ref; ref = ref->next)
7257 if (ref->type == REF_ARRAY && ref->next == NULL)
7258 {
7259 if (ref->u.ar.dimen == 0
7260 && ref->u.ar.as && ref->u.ar.as->corank)
7261 return result;
7262
7263 ref->u.ar.type = AR_FULL;
7264
7265 for (i = 0; i < ref->u.ar.dimen; i++)
7266 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
7267
7268 break;
7269 }
7270
7271 gfc_free_shape (&result->shape, result->rank);
7272
7273 /* Recalculate rank, shape, etc. */
7274 gfc_resolve_expr (result);
7275 return result;
7276 }
7277
7278
7279 /* If the last ref of an expression is an array ref, return a copy of the
7280 expression with that one removed. Otherwise, a copy of the original
7281 expression. This is used for allocate-expressions and pointer assignment
7282 LHS, where there may be an array specification that needs to be stripped
7283 off when using gfc_check_vardef_context. */
7284
7285 static gfc_expr*
remove_last_array_ref(gfc_expr * e)7286 remove_last_array_ref (gfc_expr* e)
7287 {
7288 gfc_expr* e2;
7289 gfc_ref** r;
7290
7291 e2 = gfc_copy_expr (e);
7292 for (r = &e2->ref; *r; r = &(*r)->next)
7293 if ((*r)->type == REF_ARRAY && !(*r)->next)
7294 {
7295 gfc_free_ref_list (*r);
7296 *r = NULL;
7297 break;
7298 }
7299
7300 return e2;
7301 }
7302
7303
7304 /* Used in resolve_allocate_expr to check that a allocation-object and
7305 a source-expr are conformable. This does not catch all possible
7306 cases; in particular a runtime checking is needed. */
7307
7308 static bool
conformable_arrays(gfc_expr * e1,gfc_expr * e2)7309 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
7310 {
7311 gfc_ref *tail;
7312 for (tail = e2->ref; tail && tail->next; tail = tail->next);
7313
7314 /* First compare rank. */
7315 if ((tail && e1->rank != tail->u.ar.as->rank)
7316 || (!tail && e1->rank != e2->rank))
7317 {
7318 gfc_error ("Source-expr at %L must be scalar or have the "
7319 "same rank as the allocate-object at %L",
7320 &e1->where, &e2->where);
7321 return false;
7322 }
7323
7324 if (e1->shape)
7325 {
7326 int i;
7327 mpz_t s;
7328
7329 mpz_init (s);
7330
7331 for (i = 0; i < e1->rank; i++)
7332 {
7333 if (tail->u.ar.start[i] == NULL)
7334 break;
7335
7336 if (tail->u.ar.end[i])
7337 {
7338 mpz_set (s, tail->u.ar.end[i]->value.integer);
7339 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
7340 mpz_add_ui (s, s, 1);
7341 }
7342 else
7343 {
7344 mpz_set (s, tail->u.ar.start[i]->value.integer);
7345 }
7346
7347 if (mpz_cmp (e1->shape[i], s) != 0)
7348 {
7349 gfc_error ("Source-expr at %L and allocate-object at %L must "
7350 "have the same shape", &e1->where, &e2->where);
7351 mpz_clear (s);
7352 return false;
7353 }
7354 }
7355
7356 mpz_clear (s);
7357 }
7358
7359 return true;
7360 }
7361
7362
7363 /* Resolve the expression in an ALLOCATE statement, doing the additional
7364 checks to see whether the expression is OK or not. The expression must
7365 have a trailing array reference that gives the size of the array. */
7366
7367 static bool
resolve_allocate_expr(gfc_expr * e,gfc_code * code,bool * array_alloc_wo_spec)7368 resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
7369 {
7370 int i, pointer, allocatable, dimension, is_abstract;
7371 int codimension;
7372 bool coindexed;
7373 bool unlimited;
7374 symbol_attribute attr;
7375 gfc_ref *ref, *ref2;
7376 gfc_expr *e2;
7377 gfc_array_ref *ar;
7378 gfc_symbol *sym = NULL;
7379 gfc_alloc *a;
7380 gfc_component *c;
7381 bool t;
7382
7383 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7384 checking of coarrays. */
7385 for (ref = e->ref; ref; ref = ref->next)
7386 if (ref->next == NULL)
7387 break;
7388
7389 if (ref && ref->type == REF_ARRAY)
7390 ref->u.ar.in_allocate = true;
7391
7392 if (!gfc_resolve_expr (e))
7393 goto failure;
7394
7395 /* Make sure the expression is allocatable or a pointer. If it is
7396 pointer, the next-to-last reference must be a pointer. */
7397
7398 ref2 = NULL;
7399 if (e->symtree)
7400 sym = e->symtree->n.sym;
7401
7402 /* Check whether ultimate component is abstract and CLASS. */
7403 is_abstract = 0;
7404
7405 /* Is the allocate-object unlimited polymorphic? */
7406 unlimited = UNLIMITED_POLY(e);
7407
7408 if (e->expr_type != EXPR_VARIABLE)
7409 {
7410 allocatable = 0;
7411 attr = gfc_expr_attr (e);
7412 pointer = attr.pointer;
7413 dimension = attr.dimension;
7414 codimension = attr.codimension;
7415 }
7416 else
7417 {
7418 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
7419 {
7420 allocatable = CLASS_DATA (sym)->attr.allocatable;
7421 pointer = CLASS_DATA (sym)->attr.class_pointer;
7422 dimension = CLASS_DATA (sym)->attr.dimension;
7423 codimension = CLASS_DATA (sym)->attr.codimension;
7424 is_abstract = CLASS_DATA (sym)->attr.abstract;
7425 }
7426 else
7427 {
7428 allocatable = sym->attr.allocatable;
7429 pointer = sym->attr.pointer;
7430 dimension = sym->attr.dimension;
7431 codimension = sym->attr.codimension;
7432 }
7433
7434 coindexed = false;
7435
7436 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
7437 {
7438 switch (ref->type)
7439 {
7440 case REF_ARRAY:
7441 if (ref->u.ar.codimen > 0)
7442 {
7443 int n;
7444 for (n = ref->u.ar.dimen;
7445 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
7446 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
7447 {
7448 coindexed = true;
7449 break;
7450 }
7451 }
7452
7453 if (ref->next != NULL)
7454 pointer = 0;
7455 break;
7456
7457 case REF_COMPONENT:
7458 /* F2008, C644. */
7459 if (coindexed)
7460 {
7461 gfc_error ("Coindexed allocatable object at %L",
7462 &e->where);
7463 goto failure;
7464 }
7465
7466 c = ref->u.c.component;
7467 if (c->ts.type == BT_CLASS)
7468 {
7469 allocatable = CLASS_DATA (c)->attr.allocatable;
7470 pointer = CLASS_DATA (c)->attr.class_pointer;
7471 dimension = CLASS_DATA (c)->attr.dimension;
7472 codimension = CLASS_DATA (c)->attr.codimension;
7473 is_abstract = CLASS_DATA (c)->attr.abstract;
7474 }
7475 else
7476 {
7477 allocatable = c->attr.allocatable;
7478 pointer = c->attr.pointer;
7479 dimension = c->attr.dimension;
7480 codimension = c->attr.codimension;
7481 is_abstract = c->attr.abstract;
7482 }
7483 break;
7484
7485 case REF_SUBSTRING:
7486 allocatable = 0;
7487 pointer = 0;
7488 break;
7489 }
7490 }
7491 }
7492
7493 /* Check for F08:C628. */
7494 if (allocatable == 0 && pointer == 0 && !unlimited)
7495 {
7496 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7497 &e->where);
7498 goto failure;
7499 }
7500
7501 /* Some checks for the SOURCE tag. */
7502 if (code->expr3)
7503 {
7504 /* Check F03:C631. */
7505 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
7506 {
7507 gfc_error ("Type of entity at %L is type incompatible with "
7508 "source-expr at %L", &e->where, &code->expr3->where);
7509 goto failure;
7510 }
7511
7512 /* Check F03:C632 and restriction following Note 6.18. */
7513 if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
7514 goto failure;
7515
7516 /* Check F03:C633. */
7517 if (code->expr3->ts.kind != e->ts.kind && !unlimited)
7518 {
7519 gfc_error ("The allocate-object at %L and the source-expr at %L "
7520 "shall have the same kind type parameter",
7521 &e->where, &code->expr3->where);
7522 goto failure;
7523 }
7524
7525 /* Check F2008, C642. */
7526 if (code->expr3->ts.type == BT_DERIVED
7527 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
7528 || (code->expr3->ts.u.derived->from_intmod
7529 == INTMOD_ISO_FORTRAN_ENV
7530 && code->expr3->ts.u.derived->intmod_sym_id
7531 == ISOFORTRAN_LOCK_TYPE)))
7532 {
7533 gfc_error ("The source-expr at %L shall neither be of type "
7534 "LOCK_TYPE nor have a LOCK_TYPE component if "
7535 "allocate-object at %L is a coarray",
7536 &code->expr3->where, &e->where);
7537 goto failure;
7538 }
7539
7540 /* Check TS18508, C702/C703. */
7541 if (code->expr3->ts.type == BT_DERIVED
7542 && ((codimension && gfc_expr_attr (code->expr3).event_comp)
7543 || (code->expr3->ts.u.derived->from_intmod
7544 == INTMOD_ISO_FORTRAN_ENV
7545 && code->expr3->ts.u.derived->intmod_sym_id
7546 == ISOFORTRAN_EVENT_TYPE)))
7547 {
7548 gfc_error ("The source-expr at %L shall neither be of type "
7549 "EVENT_TYPE nor have a EVENT_TYPE component if "
7550 "allocate-object at %L is a coarray",
7551 &code->expr3->where, &e->where);
7552 goto failure;
7553 }
7554 }
7555
7556 /* Check F08:C629. */
7557 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7558 && !code->expr3)
7559 {
7560 gcc_assert (e->ts.type == BT_CLASS);
7561 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7562 "type-spec or source-expr", sym->name, &e->where);
7563 goto failure;
7564 }
7565
7566 /* Check F08:C632. */
7567 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
7568 && !UNLIMITED_POLY (e))
7569 {
7570 int cmp;
7571
7572 if (!e->ts.u.cl->length)
7573 goto failure;
7574
7575 cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7576 code->ext.alloc.ts.u.cl->length);
7577 if (cmp == 1 || cmp == -1 || cmp == -3)
7578 {
7579 gfc_error ("Allocating %s at %L with type-spec requires the same "
7580 "character-length parameter as in the declaration",
7581 sym->name, &e->where);
7582 goto failure;
7583 }
7584 }
7585
7586 /* In the variable definition context checks, gfc_expr_attr is used
7587 on the expression. This is fooled by the array specification
7588 present in e, thus we have to eliminate that one temporarily. */
7589 e2 = remove_last_array_ref (e);
7590 t = true;
7591 if (t && pointer)
7592 t = gfc_check_vardef_context (e2, true, true, false,
7593 _("ALLOCATE object"));
7594 if (t)
7595 t = gfc_check_vardef_context (e2, false, true, false,
7596 _("ALLOCATE object"));
7597 gfc_free_expr (e2);
7598 if (!t)
7599 goto failure;
7600
7601 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7602 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7603 {
7604 /* For class arrays, the initialization with SOURCE is done
7605 using _copy and trans_call. It is convenient to exploit that
7606 when the allocated type is different from the declared type but
7607 no SOURCE exists by setting expr3. */
7608 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7609 }
7610 else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
7611 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7612 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7613 {
7614 /* We have to zero initialize the integer variable. */
7615 code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
7616 }
7617
7618 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
7619 {
7620 /* Make sure the vtab symbol is present when
7621 the module variables are generated. */
7622 gfc_typespec ts = e->ts;
7623 if (code->expr3)
7624 ts = code->expr3->ts;
7625 else if (code->ext.alloc.ts.type == BT_DERIVED)
7626 ts = code->ext.alloc.ts;
7627
7628 /* Finding the vtab also publishes the type's symbol. Therefore this
7629 statement is necessary. */
7630 gfc_find_derived_vtab (ts.u.derived);
7631 }
7632 else if (unlimited && !UNLIMITED_POLY (code->expr3))
7633 {
7634 /* Again, make sure the vtab symbol is present when
7635 the module variables are generated. */
7636 gfc_typespec *ts = NULL;
7637 if (code->expr3)
7638 ts = &code->expr3->ts;
7639 else
7640 ts = &code->ext.alloc.ts;
7641
7642 gcc_assert (ts);
7643
7644 /* Finding the vtab also publishes the type's symbol. Therefore this
7645 statement is necessary. */
7646 gfc_find_vtab (ts);
7647 }
7648
7649 if (dimension == 0 && codimension == 0)
7650 goto success;
7651
7652 /* Make sure the last reference node is an array specification. */
7653
7654 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7655 || (dimension && ref2->u.ar.dimen == 0))
7656 {
7657 /* F08:C633. */
7658 if (code->expr3)
7659 {
7660 if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
7661 "in ALLOCATE statement at %L", &e->where))
7662 goto failure;
7663 if (code->expr3->rank != 0)
7664 *array_alloc_wo_spec = true;
7665 else
7666 {
7667 gfc_error ("Array specification or array-valued SOURCE= "
7668 "expression required in ALLOCATE statement at %L",
7669 &e->where);
7670 goto failure;
7671 }
7672 }
7673 else
7674 {
7675 gfc_error ("Array specification required in ALLOCATE statement "
7676 "at %L", &e->where);
7677 goto failure;
7678 }
7679 }
7680
7681 /* Make sure that the array section reference makes sense in the
7682 context of an ALLOCATE specification. */
7683
7684 ar = &ref2->u.ar;
7685
7686 if (codimension)
7687 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7688 {
7689 switch (ar->dimen_type[i])
7690 {
7691 case DIMEN_THIS_IMAGE:
7692 gfc_error ("Coarray specification required in ALLOCATE statement "
7693 "at %L", &e->where);
7694 goto failure;
7695
7696 case DIMEN_RANGE:
7697 if (ar->start[i] == 0 || ar->end[i] == 0)
7698 {
7699 /* If ar->stride[i] is NULL, we issued a previous error. */
7700 if (ar->stride[i] == NULL)
7701 gfc_error ("Bad array specification in ALLOCATE statement "
7702 "at %L", &e->where);
7703 goto failure;
7704 }
7705 else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
7706 {
7707 gfc_error ("Upper cobound is less than lower cobound at %L",
7708 &ar->start[i]->where);
7709 goto failure;
7710 }
7711 break;
7712
7713 case DIMEN_ELEMENT:
7714 if (ar->start[i]->expr_type == EXPR_CONSTANT)
7715 {
7716 gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
7717 if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
7718 {
7719 gfc_error ("Upper cobound is less than lower cobound "
7720 " of 1 at %L", &ar->start[i]->where);
7721 goto failure;
7722 }
7723 }
7724 break;
7725
7726 case DIMEN_STAR:
7727 break;
7728
7729 default:
7730 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7731 &e->where);
7732 goto failure;
7733
7734 }
7735 }
7736 for (i = 0; i < ar->dimen; i++)
7737 {
7738 if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
7739 goto check_symbols;
7740
7741 switch (ar->dimen_type[i])
7742 {
7743 case DIMEN_ELEMENT:
7744 break;
7745
7746 case DIMEN_RANGE:
7747 if (ar->start[i] != NULL
7748 && ar->end[i] != NULL
7749 && ar->stride[i] == NULL)
7750 break;
7751
7752 /* Fall through. */
7753
7754 case DIMEN_UNKNOWN:
7755 case DIMEN_VECTOR:
7756 case DIMEN_STAR:
7757 case DIMEN_THIS_IMAGE:
7758 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7759 &e->where);
7760 goto failure;
7761 }
7762
7763 check_symbols:
7764 for (a = code->ext.alloc.list; a; a = a->next)
7765 {
7766 sym = a->expr->symtree->n.sym;
7767
7768 /* TODO - check derived type components. */
7769 if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
7770 continue;
7771
7772 if ((ar->start[i] != NULL
7773 && gfc_find_sym_in_expr (sym, ar->start[i]))
7774 || (ar->end[i] != NULL
7775 && gfc_find_sym_in_expr (sym, ar->end[i])))
7776 {
7777 gfc_error ("%qs must not appear in the array specification at "
7778 "%L in the same ALLOCATE statement where it is "
7779 "itself allocated", sym->name, &ar->where);
7780 goto failure;
7781 }
7782 }
7783 }
7784
7785 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7786 {
7787 if (ar->dimen_type[i] == DIMEN_ELEMENT
7788 || ar->dimen_type[i] == DIMEN_RANGE)
7789 {
7790 if (i == (ar->dimen + ar->codimen - 1))
7791 {
7792 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7793 "statement at %L", &e->where);
7794 goto failure;
7795 }
7796 continue;
7797 }
7798
7799 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7800 && ar->stride[i] == NULL)
7801 break;
7802
7803 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7804 &e->where);
7805 goto failure;
7806 }
7807
7808 success:
7809 return true;
7810
7811 failure:
7812 return false;
7813 }
7814
7815
7816 static void
resolve_allocate_deallocate(gfc_code * code,const char * fcn)7817 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7818 {
7819 gfc_expr *stat, *errmsg, *pe, *qe;
7820 gfc_alloc *a, *p, *q;
7821
7822 stat = code->expr1;
7823 errmsg = code->expr2;
7824
7825 /* Check the stat variable. */
7826 if (stat)
7827 {
7828 gfc_check_vardef_context (stat, false, false, false,
7829 _("STAT variable"));
7830
7831 if ((stat->ts.type != BT_INTEGER
7832 && !(stat->ref && (stat->ref->type == REF_ARRAY
7833 || stat->ref->type == REF_COMPONENT)))
7834 || stat->rank > 0)
7835 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7836 "variable", &stat->where);
7837
7838 for (p = code->ext.alloc.list; p; p = p->next)
7839 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7840 {
7841 gfc_ref *ref1, *ref2;
7842 bool found = true;
7843
7844 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7845 ref1 = ref1->next, ref2 = ref2->next)
7846 {
7847 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7848 continue;
7849 if (ref1->u.c.component->name != ref2->u.c.component->name)
7850 {
7851 found = false;
7852 break;
7853 }
7854 }
7855
7856 if (found)
7857 {
7858 gfc_error ("Stat-variable at %L shall not be %sd within "
7859 "the same %s statement", &stat->where, fcn, fcn);
7860 break;
7861 }
7862 }
7863 }
7864
7865 /* Check the errmsg variable. */
7866 if (errmsg)
7867 {
7868 if (!stat)
7869 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7870 &errmsg->where);
7871
7872 gfc_check_vardef_context (errmsg, false, false, false,
7873 _("ERRMSG variable"));
7874
7875 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
7876 F18:R930 errmsg-variable is scalar-default-char-variable
7877 F18:R906 default-char-variable is variable
7878 F18:C906 default-char-variable shall be default character. */
7879 if ((errmsg->ts.type != BT_CHARACTER
7880 && !(errmsg->ref
7881 && (errmsg->ref->type == REF_ARRAY
7882 || errmsg->ref->type == REF_COMPONENT)))
7883 || errmsg->rank > 0
7884 || errmsg->ts.kind != gfc_default_character_kind)
7885 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
7886 "variable", &errmsg->where);
7887
7888 for (p = code->ext.alloc.list; p; p = p->next)
7889 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7890 {
7891 gfc_ref *ref1, *ref2;
7892 bool found = true;
7893
7894 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7895 ref1 = ref1->next, ref2 = ref2->next)
7896 {
7897 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7898 continue;
7899 if (ref1->u.c.component->name != ref2->u.c.component->name)
7900 {
7901 found = false;
7902 break;
7903 }
7904 }
7905
7906 if (found)
7907 {
7908 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7909 "the same %s statement", &errmsg->where, fcn, fcn);
7910 break;
7911 }
7912 }
7913 }
7914
7915 /* Check that an allocate-object appears only once in the statement. */
7916
7917 for (p = code->ext.alloc.list; p; p = p->next)
7918 {
7919 pe = p->expr;
7920 for (q = p->next; q; q = q->next)
7921 {
7922 qe = q->expr;
7923 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7924 {
7925 /* This is a potential collision. */
7926 gfc_ref *pr = pe->ref;
7927 gfc_ref *qr = qe->ref;
7928
7929 /* Follow the references until
7930 a) They start to differ, in which case there is no error;
7931 you can deallocate a%b and a%c in a single statement
7932 b) Both of them stop, which is an error
7933 c) One of them stops, which is also an error. */
7934 while (1)
7935 {
7936 if (pr == NULL && qr == NULL)
7937 {
7938 gfc_error ("Allocate-object at %L also appears at %L",
7939 &pe->where, &qe->where);
7940 break;
7941 }
7942 else if (pr != NULL && qr == NULL)
7943 {
7944 gfc_error ("Allocate-object at %L is subobject of"
7945 " object at %L", &pe->where, &qe->where);
7946 break;
7947 }
7948 else if (pr == NULL && qr != NULL)
7949 {
7950 gfc_error ("Allocate-object at %L is subobject of"
7951 " object at %L", &qe->where, &pe->where);
7952 break;
7953 }
7954 /* Here, pr != NULL && qr != NULL */
7955 gcc_assert(pr->type == qr->type);
7956 if (pr->type == REF_ARRAY)
7957 {
7958 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7959 which are legal. */
7960 gcc_assert (qr->type == REF_ARRAY);
7961
7962 if (pr->next && qr->next)
7963 {
7964 int i;
7965 gfc_array_ref *par = &(pr->u.ar);
7966 gfc_array_ref *qar = &(qr->u.ar);
7967
7968 for (i=0; i<par->dimen; i++)
7969 {
7970 if ((par->start[i] != NULL
7971 || qar->start[i] != NULL)
7972 && gfc_dep_compare_expr (par->start[i],
7973 qar->start[i]) != 0)
7974 goto break_label;
7975 }
7976 }
7977 }
7978 else
7979 {
7980 if (pr->u.c.component->name != qr->u.c.component->name)
7981 break;
7982 }
7983
7984 pr = pr->next;
7985 qr = qr->next;
7986 }
7987 break_label:
7988 ;
7989 }
7990 }
7991 }
7992
7993 if (strcmp (fcn, "ALLOCATE") == 0)
7994 {
7995 bool arr_alloc_wo_spec = false;
7996
7997 /* Resolving the expr3 in the loop over all objects to allocate would
7998 execute loop invariant code for each loop item. Therefore do it just
7999 once here. */
8000 if (code->expr3 && code->expr3->mold
8001 && code->expr3->ts.type == BT_DERIVED)
8002 {
8003 /* Default initialization via MOLD (non-polymorphic). */
8004 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
8005 if (rhs != NULL)
8006 {
8007 gfc_resolve_expr (rhs);
8008 gfc_free_expr (code->expr3);
8009 code->expr3 = rhs;
8010 }
8011 }
8012 for (a = code->ext.alloc.list; a; a = a->next)
8013 resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
8014
8015 if (arr_alloc_wo_spec && code->expr3)
8016 {
8017 /* Mark the allocate to have to take the array specification
8018 from the expr3. */
8019 code->ext.alloc.arr_spec_from_expr3 = 1;
8020 }
8021 }
8022 else
8023 {
8024 for (a = code->ext.alloc.list; a; a = a->next)
8025 resolve_deallocate_expr (a->expr);
8026 }
8027 }
8028
8029
8030 /************ SELECT CASE resolution subroutines ************/
8031
8032 /* Callback function for our mergesort variant. Determines interval
8033 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8034 op1 > op2. Assumes we're not dealing with the default case.
8035 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8036 There are nine situations to check. */
8037
8038 static int
compare_cases(const gfc_case * op1,const gfc_case * op2)8039 compare_cases (const gfc_case *op1, const gfc_case *op2)
8040 {
8041 int retval;
8042
8043 if (op1->low == NULL) /* op1 = (:L) */
8044 {
8045 /* op2 = (:N), so overlap. */
8046 retval = 0;
8047 /* op2 = (M:) or (M:N), L < M */
8048 if (op2->low != NULL
8049 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8050 retval = -1;
8051 }
8052 else if (op1->high == NULL) /* op1 = (K:) */
8053 {
8054 /* op2 = (M:), so overlap. */
8055 retval = 0;
8056 /* op2 = (:N) or (M:N), K > N */
8057 if (op2->high != NULL
8058 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8059 retval = 1;
8060 }
8061 else /* op1 = (K:L) */
8062 {
8063 if (op2->low == NULL) /* op2 = (:N), K > N */
8064 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8065 ? 1 : 0;
8066 else if (op2->high == NULL) /* op2 = (M:), L < M */
8067 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8068 ? -1 : 0;
8069 else /* op2 = (M:N) */
8070 {
8071 retval = 0;
8072 /* L < M */
8073 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8074 retval = -1;
8075 /* K > N */
8076 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8077 retval = 1;
8078 }
8079 }
8080
8081 return retval;
8082 }
8083
8084
8085 /* Merge-sort a double linked case list, detecting overlap in the
8086 process. LIST is the head of the double linked case list before it
8087 is sorted. Returns the head of the sorted list if we don't see any
8088 overlap, or NULL otherwise. */
8089
8090 static gfc_case *
check_case_overlap(gfc_case * list)8091 check_case_overlap (gfc_case *list)
8092 {
8093 gfc_case *p, *q, *e, *tail;
8094 int insize, nmerges, psize, qsize, cmp, overlap_seen;
8095
8096 /* If the passed list was empty, return immediately. */
8097 if (!list)
8098 return NULL;
8099
8100 overlap_seen = 0;
8101 insize = 1;
8102
8103 /* Loop unconditionally. The only exit from this loop is a return
8104 statement, when we've finished sorting the case list. */
8105 for (;;)
8106 {
8107 p = list;
8108 list = NULL;
8109 tail = NULL;
8110
8111 /* Count the number of merges we do in this pass. */
8112 nmerges = 0;
8113
8114 /* Loop while there exists a merge to be done. */
8115 while (p)
8116 {
8117 int i;
8118
8119 /* Count this merge. */
8120 nmerges++;
8121
8122 /* Cut the list in two pieces by stepping INSIZE places
8123 forward in the list, starting from P. */
8124 psize = 0;
8125 q = p;
8126 for (i = 0; i < insize; i++)
8127 {
8128 psize++;
8129 q = q->right;
8130 if (!q)
8131 break;
8132 }
8133 qsize = insize;
8134
8135 /* Now we have two lists. Merge them! */
8136 while (psize > 0 || (qsize > 0 && q != NULL))
8137 {
8138 /* See from which the next case to merge comes from. */
8139 if (psize == 0)
8140 {
8141 /* P is empty so the next case must come from Q. */
8142 e = q;
8143 q = q->right;
8144 qsize--;
8145 }
8146 else if (qsize == 0 || q == NULL)
8147 {
8148 /* Q is empty. */
8149 e = p;
8150 p = p->right;
8151 psize--;
8152 }
8153 else
8154 {
8155 cmp = compare_cases (p, q);
8156 if (cmp < 0)
8157 {
8158 /* The whole case range for P is less than the
8159 one for Q. */
8160 e = p;
8161 p = p->right;
8162 psize--;
8163 }
8164 else if (cmp > 0)
8165 {
8166 /* The whole case range for Q is greater than
8167 the case range for P. */
8168 e = q;
8169 q = q->right;
8170 qsize--;
8171 }
8172 else
8173 {
8174 /* The cases overlap, or they are the same
8175 element in the list. Either way, we must
8176 issue an error and get the next case from P. */
8177 /* FIXME: Sort P and Q by line number. */
8178 gfc_error ("CASE label at %L overlaps with CASE "
8179 "label at %L", &p->where, &q->where);
8180 overlap_seen = 1;
8181 e = p;
8182 p = p->right;
8183 psize--;
8184 }
8185 }
8186
8187 /* Add the next element to the merged list. */
8188 if (tail)
8189 tail->right = e;
8190 else
8191 list = e;
8192 e->left = tail;
8193 tail = e;
8194 }
8195
8196 /* P has now stepped INSIZE places along, and so has Q. So
8197 they're the same. */
8198 p = q;
8199 }
8200 tail->right = NULL;
8201
8202 /* If we have done only one merge or none at all, we've
8203 finished sorting the cases. */
8204 if (nmerges <= 1)
8205 {
8206 if (!overlap_seen)
8207 return list;
8208 else
8209 return NULL;
8210 }
8211
8212 /* Otherwise repeat, merging lists twice the size. */
8213 insize *= 2;
8214 }
8215 }
8216
8217
8218 /* Check to see if an expression is suitable for use in a CASE statement.
8219 Makes sure that all case expressions are scalar constants of the same
8220 type. Return false if anything is wrong. */
8221
8222 static bool
validate_case_label_expr(gfc_expr * e,gfc_expr * case_expr)8223 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
8224 {
8225 if (e == NULL) return true;
8226
8227 if (e->ts.type != case_expr->ts.type)
8228 {
8229 gfc_error ("Expression in CASE statement at %L must be of type %s",
8230 &e->where, gfc_basic_typename (case_expr->ts.type));
8231 return false;
8232 }
8233
8234 /* C805 (R808) For a given case-construct, each case-value shall be of
8235 the same type as case-expr. For character type, length differences
8236 are allowed, but the kind type parameters shall be the same. */
8237
8238 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
8239 {
8240 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8241 &e->where, case_expr->ts.kind);
8242 return false;
8243 }
8244
8245 /* Convert the case value kind to that of case expression kind,
8246 if needed */
8247
8248 if (e->ts.kind != case_expr->ts.kind)
8249 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
8250
8251 if (e->rank != 0)
8252 {
8253 gfc_error ("Expression in CASE statement at %L must be scalar",
8254 &e->where);
8255 return false;
8256 }
8257
8258 return true;
8259 }
8260
8261
8262 /* Given a completely parsed select statement, we:
8263
8264 - Validate all expressions and code within the SELECT.
8265 - Make sure that the selection expression is not of the wrong type.
8266 - Make sure that no case ranges overlap.
8267 - Eliminate unreachable cases and unreachable code resulting from
8268 removing case labels.
8269
8270 The standard does allow unreachable cases, e.g. CASE (5:3). But
8271 they are a hassle for code generation, and to prevent that, we just
8272 cut them out here. This is not necessary for overlapping cases
8273 because they are illegal and we never even try to generate code.
8274
8275 We have the additional caveat that a SELECT construct could have
8276 been a computed GOTO in the source code. Fortunately we can fairly
8277 easily work around that here: The case_expr for a "real" SELECT CASE
8278 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8279 we have to do is make sure that the case_expr is a scalar integer
8280 expression. */
8281
8282 static void
resolve_select(gfc_code * code,bool select_type)8283 resolve_select (gfc_code *code, bool select_type)
8284 {
8285 gfc_code *body;
8286 gfc_expr *case_expr;
8287 gfc_case *cp, *default_case, *tail, *head;
8288 int seen_unreachable;
8289 int seen_logical;
8290 int ncases;
8291 bt type;
8292 bool t;
8293
8294 if (code->expr1 == NULL)
8295 {
8296 /* This was actually a computed GOTO statement. */
8297 case_expr = code->expr2;
8298 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
8299 gfc_error ("Selection expression in computed GOTO statement "
8300 "at %L must be a scalar integer expression",
8301 &case_expr->where);
8302
8303 /* Further checking is not necessary because this SELECT was built
8304 by the compiler, so it should always be OK. Just move the
8305 case_expr from expr2 to expr so that we can handle computed
8306 GOTOs as normal SELECTs from here on. */
8307 code->expr1 = code->expr2;
8308 code->expr2 = NULL;
8309 return;
8310 }
8311
8312 case_expr = code->expr1;
8313 type = case_expr->ts.type;
8314
8315 /* F08:C830. */
8316 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
8317 {
8318 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8319 &case_expr->where, gfc_typename (&case_expr->ts));
8320
8321 /* Punt. Going on here just produce more garbage error messages. */
8322 return;
8323 }
8324
8325 /* F08:R842. */
8326 if (!select_type && case_expr->rank != 0)
8327 {
8328 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8329 "expression", &case_expr->where);
8330
8331 /* Punt. */
8332 return;
8333 }
8334
8335 /* Raise a warning if an INTEGER case value exceeds the range of
8336 the case-expr. Later, all expressions will be promoted to the
8337 largest kind of all case-labels. */
8338
8339 if (type == BT_INTEGER)
8340 for (body = code->block; body; body = body->block)
8341 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8342 {
8343 if (cp->low
8344 && gfc_check_integer_range (cp->low->value.integer,
8345 case_expr->ts.kind) != ARITH_OK)
8346 gfc_warning (0, "Expression in CASE statement at %L is "
8347 "not in the range of %s", &cp->low->where,
8348 gfc_typename (&case_expr->ts));
8349
8350 if (cp->high
8351 && cp->low != cp->high
8352 && gfc_check_integer_range (cp->high->value.integer,
8353 case_expr->ts.kind) != ARITH_OK)
8354 gfc_warning (0, "Expression in CASE statement at %L is "
8355 "not in the range of %s", &cp->high->where,
8356 gfc_typename (&case_expr->ts));
8357 }
8358
8359 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8360 of the SELECT CASE expression and its CASE values. Walk the lists
8361 of case values, and if we find a mismatch, promote case_expr to
8362 the appropriate kind. */
8363
8364 if (type == BT_LOGICAL || type == BT_INTEGER)
8365 {
8366 for (body = code->block; body; body = body->block)
8367 {
8368 /* Walk the case label list. */
8369 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8370 {
8371 /* Intercept the DEFAULT case. It does not have a kind. */
8372 if (cp->low == NULL && cp->high == NULL)
8373 continue;
8374
8375 /* Unreachable case ranges are discarded, so ignore. */
8376 if (cp->low != NULL && cp->high != NULL
8377 && cp->low != cp->high
8378 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8379 continue;
8380
8381 if (cp->low != NULL
8382 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
8383 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
8384
8385 if (cp->high != NULL
8386 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
8387 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
8388 }
8389 }
8390 }
8391
8392 /* Assume there is no DEFAULT case. */
8393 default_case = NULL;
8394 head = tail = NULL;
8395 ncases = 0;
8396 seen_logical = 0;
8397
8398 for (body = code->block; body; body = body->block)
8399 {
8400 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8401 t = true;
8402 seen_unreachable = 0;
8403
8404 /* Walk the case label list, making sure that all case labels
8405 are legal. */
8406 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8407 {
8408 /* Count the number of cases in the whole construct. */
8409 ncases++;
8410
8411 /* Intercept the DEFAULT case. */
8412 if (cp->low == NULL && cp->high == NULL)
8413 {
8414 if (default_case != NULL)
8415 {
8416 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8417 "by a second DEFAULT CASE at %L",
8418 &default_case->where, &cp->where);
8419 t = false;
8420 break;
8421 }
8422 else
8423 {
8424 default_case = cp;
8425 continue;
8426 }
8427 }
8428
8429 /* Deal with single value cases and case ranges. Errors are
8430 issued from the validation function. */
8431 if (!validate_case_label_expr (cp->low, case_expr)
8432 || !validate_case_label_expr (cp->high, case_expr))
8433 {
8434 t = false;
8435 break;
8436 }
8437
8438 if (type == BT_LOGICAL
8439 && ((cp->low == NULL || cp->high == NULL)
8440 || cp->low != cp->high))
8441 {
8442 gfc_error ("Logical range in CASE statement at %L is not "
8443 "allowed", &cp->low->where);
8444 t = false;
8445 break;
8446 }
8447
8448 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
8449 {
8450 int value;
8451 value = cp->low->value.logical == 0 ? 2 : 1;
8452 if (value & seen_logical)
8453 {
8454 gfc_error ("Constant logical value in CASE statement "
8455 "is repeated at %L",
8456 &cp->low->where);
8457 t = false;
8458 break;
8459 }
8460 seen_logical |= value;
8461 }
8462
8463 if (cp->low != NULL && cp->high != NULL
8464 && cp->low != cp->high
8465 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8466 {
8467 if (warn_surprising)
8468 gfc_warning (OPT_Wsurprising,
8469 "Range specification at %L can never be matched",
8470 &cp->where);
8471
8472 cp->unreachable = 1;
8473 seen_unreachable = 1;
8474 }
8475 else
8476 {
8477 /* If the case range can be matched, it can also overlap with
8478 other cases. To make sure it does not, we put it in a
8479 double linked list here. We sort that with a merge sort
8480 later on to detect any overlapping cases. */
8481 if (!head)
8482 {
8483 head = tail = cp;
8484 head->right = head->left = NULL;
8485 }
8486 else
8487 {
8488 tail->right = cp;
8489 tail->right->left = tail;
8490 tail = tail->right;
8491 tail->right = NULL;
8492 }
8493 }
8494 }
8495
8496 /* It there was a failure in the previous case label, give up
8497 for this case label list. Continue with the next block. */
8498 if (!t)
8499 continue;
8500
8501 /* See if any case labels that are unreachable have been seen.
8502 If so, we eliminate them. This is a bit of a kludge because
8503 the case lists for a single case statement (label) is a
8504 single forward linked lists. */
8505 if (seen_unreachable)
8506 {
8507 /* Advance until the first case in the list is reachable. */
8508 while (body->ext.block.case_list != NULL
8509 && body->ext.block.case_list->unreachable)
8510 {
8511 gfc_case *n = body->ext.block.case_list;
8512 body->ext.block.case_list = body->ext.block.case_list->next;
8513 n->next = NULL;
8514 gfc_free_case_list (n);
8515 }
8516
8517 /* Strip all other unreachable cases. */
8518 if (body->ext.block.case_list)
8519 {
8520 for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
8521 {
8522 if (cp->next->unreachable)
8523 {
8524 gfc_case *n = cp->next;
8525 cp->next = cp->next->next;
8526 n->next = NULL;
8527 gfc_free_case_list (n);
8528 }
8529 }
8530 }
8531 }
8532 }
8533
8534 /* See if there were overlapping cases. If the check returns NULL,
8535 there was overlap. In that case we don't do anything. If head
8536 is non-NULL, we prepend the DEFAULT case. The sorted list can
8537 then used during code generation for SELECT CASE constructs with
8538 a case expression of a CHARACTER type. */
8539 if (head)
8540 {
8541 head = check_case_overlap (head);
8542
8543 /* Prepend the default_case if it is there. */
8544 if (head != NULL && default_case)
8545 {
8546 default_case->left = NULL;
8547 default_case->right = head;
8548 head->left = default_case;
8549 }
8550 }
8551
8552 /* Eliminate dead blocks that may be the result if we've seen
8553 unreachable case labels for a block. */
8554 for (body = code; body && body->block; body = body->block)
8555 {
8556 if (body->block->ext.block.case_list == NULL)
8557 {
8558 /* Cut the unreachable block from the code chain. */
8559 gfc_code *c = body->block;
8560 body->block = c->block;
8561
8562 /* Kill the dead block, but not the blocks below it. */
8563 c->block = NULL;
8564 gfc_free_statements (c);
8565 }
8566 }
8567
8568 /* More than two cases is legal but insane for logical selects.
8569 Issue a warning for it. */
8570 if (warn_surprising && type == BT_LOGICAL && ncases > 2)
8571 gfc_warning (OPT_Wsurprising,
8572 "Logical SELECT CASE block at %L has more that two cases",
8573 &code->loc);
8574 }
8575
8576
8577 /* Check if a derived type is extensible. */
8578
8579 bool
gfc_type_is_extensible(gfc_symbol * sym)8580 gfc_type_is_extensible (gfc_symbol *sym)
8581 {
8582 return !(sym->attr.is_bind_c || sym->attr.sequence
8583 || (sym->attr.is_class
8584 && sym->components->ts.u.derived->attr.unlimited_polymorphic));
8585 }
8586
8587
8588 static void
8589 resolve_types (gfc_namespace *ns);
8590
8591 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8592 correct as well as possibly the array-spec. */
8593
8594 static void
resolve_assoc_var(gfc_symbol * sym,bool resolve_target)8595 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
8596 {
8597 gfc_expr* target;
8598
8599 gcc_assert (sym->assoc);
8600 gcc_assert (sym->attr.flavor == FL_VARIABLE);
8601
8602 /* If this is for SELECT TYPE, the target may not yet be set. In that
8603 case, return. Resolution will be called later manually again when
8604 this is done. */
8605 target = sym->assoc->target;
8606 if (!target)
8607 return;
8608 gcc_assert (!sym->assoc->dangling);
8609
8610 if (resolve_target && !gfc_resolve_expr (target))
8611 return;
8612
8613 /* For variable targets, we get some attributes from the target. */
8614 if (target->expr_type == EXPR_VARIABLE)
8615 {
8616 gfc_symbol* tsym;
8617
8618 gcc_assert (target->symtree);
8619 tsym = target->symtree->n.sym;
8620
8621 sym->attr.asynchronous = tsym->attr.asynchronous;
8622 sym->attr.volatile_ = tsym->attr.volatile_;
8623
8624 sym->attr.target = tsym->attr.target
8625 || gfc_expr_attr (target).pointer;
8626 if (is_subref_array (target))
8627 sym->attr.subref_array_pointer = 1;
8628 }
8629
8630 if (target->expr_type == EXPR_NULL)
8631 {
8632 gfc_error ("Selector at %L cannot be NULL()", &target->where);
8633 return;
8634 }
8635 else if (target->ts.type == BT_UNKNOWN)
8636 {
8637 gfc_error ("Selector at %L has no type", &target->where);
8638 return;
8639 }
8640
8641 /* Get type if this was not already set. Note that it can be
8642 some other type than the target in case this is a SELECT TYPE
8643 selector! So we must not update when the type is already there. */
8644 if (sym->ts.type == BT_UNKNOWN)
8645 sym->ts = target->ts;
8646
8647 gcc_assert (sym->ts.type != BT_UNKNOWN);
8648
8649 /* See if this is a valid association-to-variable. */
8650 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
8651 && !gfc_has_vector_subscript (target));
8652
8653 /* Finally resolve if this is an array or not. */
8654 if (sym->attr.dimension && target->rank == 0)
8655 {
8656 /* primary.c makes the assumption that a reference to an associate
8657 name followed by a left parenthesis is an array reference. */
8658 if (sym->ts.type != BT_CHARACTER)
8659 gfc_error ("Associate-name %qs at %L is used as array",
8660 sym->name, &sym->declared_at);
8661 sym->attr.dimension = 0;
8662 return;
8663 }
8664
8665
8666 /* We cannot deal with class selectors that need temporaries. */
8667 if (target->ts.type == BT_CLASS
8668 && gfc_ref_needs_temporary_p (target->ref))
8669 {
8670 gfc_error ("CLASS selector at %L needs a temporary which is not "
8671 "yet implemented", &target->where);
8672 return;
8673 }
8674
8675 if (target->ts.type == BT_CLASS)
8676 gfc_fix_class_refs (target);
8677
8678 if (target->rank != 0)
8679 {
8680 gfc_array_spec *as;
8681 /* The rank may be incorrectly guessed at parsing, therefore make sure
8682 it is corrected now. */
8683 if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed))
8684 {
8685 if (!sym->as)
8686 sym->as = gfc_get_array_spec ();
8687 as = sym->as;
8688 as->rank = target->rank;
8689 as->type = AS_DEFERRED;
8690 as->corank = gfc_get_corank (target);
8691 sym->attr.dimension = 1;
8692 if (as->corank != 0)
8693 sym->attr.codimension = 1;
8694 }
8695 }
8696 else
8697 {
8698 /* target's rank is 0, but the type of the sym is still array valued,
8699 which has to be corrected. */
8700 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
8701 {
8702 gfc_array_spec *as;
8703 symbol_attribute attr;
8704 /* The associated variable's type is still the array type
8705 correct this now. */
8706 gfc_typespec *ts = &target->ts;
8707 gfc_ref *ref;
8708 gfc_component *c;
8709 for (ref = target->ref; ref != NULL; ref = ref->next)
8710 {
8711 switch (ref->type)
8712 {
8713 case REF_COMPONENT:
8714 ts = &ref->u.c.component->ts;
8715 break;
8716 case REF_ARRAY:
8717 if (ts->type == BT_CLASS)
8718 ts = &ts->u.derived->components->ts;
8719 break;
8720 default:
8721 break;
8722 }
8723 }
8724 /* Create a scalar instance of the current class type. Because the
8725 rank of a class array goes into its name, the type has to be
8726 rebuild. The alternative of (re-)setting just the attributes
8727 and as in the current type, destroys the type also in other
8728 places. */
8729 as = NULL;
8730 sym->ts = *ts;
8731 sym->ts.type = BT_CLASS;
8732 attr = CLASS_DATA (sym)->attr;
8733 attr.class_ok = 0;
8734 attr.associate_var = 1;
8735 attr.dimension = attr.codimension = 0;
8736 attr.class_pointer = 1;
8737 if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
8738 gcc_unreachable ();
8739 /* Make sure the _vptr is set. */
8740 c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
8741 if (c->ts.u.derived == NULL)
8742 c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
8743 CLASS_DATA (sym)->attr.pointer = 1;
8744 CLASS_DATA (sym)->attr.class_pointer = 1;
8745 gfc_set_sym_referenced (sym->ts.u.derived);
8746 gfc_commit_symbol (sym->ts.u.derived);
8747 /* _vptr now has the _vtab in it, change it to the _vtype. */
8748 if (c->ts.u.derived->attr.vtab)
8749 c->ts.u.derived = c->ts.u.derived->ts.u.derived;
8750 c->ts.u.derived->ns->types_resolved = 0;
8751 resolve_types (c->ts.u.derived->ns);
8752 }
8753 }
8754
8755 /* Mark this as an associate variable. */
8756 sym->attr.associate_var = 1;
8757
8758 /* Fix up the type-spec for CHARACTER types. */
8759 if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
8760 {
8761 if (!sym->ts.u.cl)
8762 sym->ts.u.cl = target->ts.u.cl;
8763
8764 if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE
8765 && target->symtree->n.sym->attr.dummy
8766 && sym->ts.u.cl == target->ts.u.cl)
8767 {
8768 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
8769 sym->ts.deferred = 1;
8770 }
8771
8772 if (!sym->ts.u.cl->length
8773 && !sym->ts.deferred
8774 && target->expr_type == EXPR_CONSTANT)
8775 {
8776 sym->ts.u.cl->length =
8777 gfc_get_int_expr (gfc_charlen_int_kind, NULL,
8778 target->value.character.length);
8779 }
8780 else if ((!sym->ts.u.cl->length
8781 || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8782 && target->expr_type != EXPR_VARIABLE)
8783 {
8784 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
8785 sym->ts.deferred = 1;
8786
8787 /* This is reset in trans-stmt.c after the assignment
8788 of the target expression to the associate name. */
8789 sym->attr.allocatable = 1;
8790 }
8791 }
8792
8793 /* If the target is a good class object, so is the associate variable. */
8794 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
8795 sym->attr.class_ok = 1;
8796 }
8797
8798
8799 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8800 array reference, where necessary. The symbols are artificial and so
8801 the dimension attribute and arrayspec can also be set. In addition,
8802 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8803 This is corrected here as well.*/
8804
8805 static void
fixup_array_ref(gfc_expr ** expr1,gfc_expr * expr2,int rank,gfc_ref * ref)8806 fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
8807 int rank, gfc_ref *ref)
8808 {
8809 gfc_ref *nref = (*expr1)->ref;
8810 gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
8811 gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL;
8812 (*expr1)->rank = rank;
8813 if (sym1->ts.type == BT_CLASS)
8814 {
8815 if ((*expr1)->ts.type != BT_CLASS)
8816 (*expr1)->ts = sym1->ts;
8817
8818 CLASS_DATA (sym1)->attr.dimension = 1;
8819 if (CLASS_DATA (sym1)->as == NULL && sym2)
8820 CLASS_DATA (sym1)->as
8821 = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
8822 }
8823 else
8824 {
8825 sym1->attr.dimension = 1;
8826 if (sym1->as == NULL && sym2)
8827 sym1->as = gfc_copy_array_spec (sym2->as);
8828 }
8829
8830 for (; nref; nref = nref->next)
8831 if (nref->next == NULL)
8832 break;
8833
8834 if (ref && nref && nref->type != REF_ARRAY)
8835 nref->next = gfc_copy_ref (ref);
8836 else if (ref && !nref)
8837 (*expr1)->ref = gfc_copy_ref (ref);
8838 }
8839
8840
8841 static gfc_expr *
build_loc_call(gfc_expr * sym_expr)8842 build_loc_call (gfc_expr *sym_expr)
8843 {
8844 gfc_expr *loc_call;
8845 loc_call = gfc_get_expr ();
8846 loc_call->expr_type = EXPR_FUNCTION;
8847 gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
8848 loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
8849 loc_call->symtree->n.sym->attr.intrinsic = 1;
8850 loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
8851 gfc_commit_symbol (loc_call->symtree->n.sym);
8852 loc_call->ts.type = BT_INTEGER;
8853 loc_call->ts.kind = gfc_index_integer_kind;
8854 loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
8855 loc_call->value.function.actual = gfc_get_actual_arglist ();
8856 loc_call->value.function.actual->expr = sym_expr;
8857 loc_call->where = sym_expr->where;
8858 return loc_call;
8859 }
8860
8861 /* Resolve a SELECT TYPE statement. */
8862
8863 static void
resolve_select_type(gfc_code * code,gfc_namespace * old_ns)8864 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8865 {
8866 gfc_symbol *selector_type;
8867 gfc_code *body, *new_st, *if_st, *tail;
8868 gfc_code *class_is = NULL, *default_case = NULL;
8869 gfc_case *c;
8870 gfc_symtree *st;
8871 char name[GFC_MAX_SYMBOL_LEN];
8872 gfc_namespace *ns;
8873 int error = 0;
8874 int rank = 0;
8875 gfc_ref* ref = NULL;
8876 gfc_expr *selector_expr = NULL;
8877
8878 ns = code->ext.block.ns;
8879 gfc_resolve (ns);
8880
8881 /* Check for F03:C813. */
8882 if (code->expr1->ts.type != BT_CLASS
8883 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8884 {
8885 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8886 "at %L", &code->loc);
8887 return;
8888 }
8889
8890 if (!code->expr1->symtree->n.sym->attr.class_ok)
8891 return;
8892
8893 if (code->expr2)
8894 {
8895 if (code->expr1->symtree->n.sym->attr.untyped)
8896 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8897 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8898
8899 if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
8900 CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
8901
8902 /* F2008: C803 The selector expression must not be coindexed. */
8903 if (gfc_is_coindexed (code->expr2))
8904 {
8905 gfc_error ("Selector at %L must not be coindexed",
8906 &code->expr2->where);
8907 return;
8908 }
8909
8910 }
8911 else
8912 {
8913 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8914
8915 if (gfc_is_coindexed (code->expr1))
8916 {
8917 gfc_error ("Selector at %L must not be coindexed",
8918 &code->expr1->where);
8919 return;
8920 }
8921 }
8922
8923 /* Loop over TYPE IS / CLASS IS cases. */
8924 for (body = code->block; body; body = body->block)
8925 {
8926 c = body->ext.block.case_list;
8927
8928 if (!error)
8929 {
8930 /* Check for repeated cases. */
8931 for (tail = code->block; tail; tail = tail->block)
8932 {
8933 gfc_case *d = tail->ext.block.case_list;
8934 if (tail == body)
8935 break;
8936
8937 if (c->ts.type == d->ts.type
8938 && ((c->ts.type == BT_DERIVED
8939 && c->ts.u.derived && d->ts.u.derived
8940 && !strcmp (c->ts.u.derived->name,
8941 d->ts.u.derived->name))
8942 || c->ts.type == BT_UNKNOWN
8943 || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8944 && c->ts.kind == d->ts.kind)))
8945 {
8946 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
8947 &c->where, &d->where);
8948 return;
8949 }
8950 }
8951 }
8952
8953 /* Check F03:C815. */
8954 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8955 && !selector_type->attr.unlimited_polymorphic
8956 && !gfc_type_is_extensible (c->ts.u.derived))
8957 {
8958 gfc_error ("Derived type %qs at %L must be extensible",
8959 c->ts.u.derived->name, &c->where);
8960 error++;
8961 continue;
8962 }
8963
8964 /* Check F03:C816. */
8965 if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
8966 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
8967 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
8968 {
8969 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8970 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8971 c->ts.u.derived->name, &c->where, selector_type->name);
8972 else
8973 gfc_error ("Unexpected intrinsic type %qs at %L",
8974 gfc_basic_typename (c->ts.type), &c->where);
8975 error++;
8976 continue;
8977 }
8978
8979 /* Check F03:C814. */
8980 if (c->ts.type == BT_CHARACTER
8981 && (c->ts.u.cl->length != NULL || c->ts.deferred))
8982 {
8983 gfc_error ("The type-spec at %L shall specify that each length "
8984 "type parameter is assumed", &c->where);
8985 error++;
8986 continue;
8987 }
8988
8989 /* Intercept the DEFAULT case. */
8990 if (c->ts.type == BT_UNKNOWN)
8991 {
8992 /* Check F03:C818. */
8993 if (default_case)
8994 {
8995 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8996 "by a second DEFAULT CASE at %L",
8997 &default_case->ext.block.case_list->where, &c->where);
8998 error++;
8999 continue;
9000 }
9001
9002 default_case = body;
9003 }
9004 }
9005
9006 if (error > 0)
9007 return;
9008
9009 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9010 target if present. If there are any EXIT statements referring to the
9011 SELECT TYPE construct, this is no problem because the gfc_code
9012 reference stays the same and EXIT is equally possible from the BLOCK
9013 it is changed to. */
9014 code->op = EXEC_BLOCK;
9015 if (code->expr2)
9016 {
9017 gfc_association_list* assoc;
9018
9019 assoc = gfc_get_association_list ();
9020 assoc->st = code->expr1->symtree;
9021 assoc->target = gfc_copy_expr (code->expr2);
9022 assoc->target->where = code->expr2->where;
9023 /* assoc->variable will be set by resolve_assoc_var. */
9024
9025 code->ext.block.assoc = assoc;
9026 code->expr1->symtree->n.sym->assoc = assoc;
9027
9028 resolve_assoc_var (code->expr1->symtree->n.sym, false);
9029 }
9030 else
9031 code->ext.block.assoc = NULL;
9032
9033 /* Ensure that the selector rank and arrayspec are available to
9034 correct expressions in which they might be missing. */
9035 if (code->expr2 && code->expr2->rank)
9036 {
9037 rank = code->expr2->rank;
9038 for (ref = code->expr2->ref; ref; ref = ref->next)
9039 if (ref->next == NULL)
9040 break;
9041 if (ref && ref->type == REF_ARRAY)
9042 ref = gfc_copy_ref (ref);
9043
9044 /* Fixup expr1 if necessary. */
9045 if (rank)
9046 fixup_array_ref (&code->expr1, code->expr2, rank, ref);
9047 }
9048 else if (code->expr1->rank)
9049 {
9050 rank = code->expr1->rank;
9051 for (ref = code->expr1->ref; ref; ref = ref->next)
9052 if (ref->next == NULL)
9053 break;
9054 if (ref && ref->type == REF_ARRAY)
9055 ref = gfc_copy_ref (ref);
9056 }
9057
9058 /* Add EXEC_SELECT to switch on type. */
9059 new_st = gfc_get_code (code->op);
9060 new_st->expr1 = code->expr1;
9061 new_st->expr2 = code->expr2;
9062 new_st->block = code->block;
9063 code->expr1 = code->expr2 = NULL;
9064 code->block = NULL;
9065 if (!ns->code)
9066 ns->code = new_st;
9067 else
9068 ns->code->next = new_st;
9069 code = new_st;
9070 code->op = EXEC_SELECT_TYPE;
9071
9072 /* Use the intrinsic LOC function to generate an integer expression
9073 for the vtable of the selector. Note that the rank of the selector
9074 expression has to be set to zero. */
9075 gfc_add_vptr_component (code->expr1);
9076 code->expr1->rank = 0;
9077 code->expr1 = build_loc_call (code->expr1);
9078 selector_expr = code->expr1->value.function.actual->expr;
9079
9080 /* Loop over TYPE IS / CLASS IS cases. */
9081 for (body = code->block; body; body = body->block)
9082 {
9083 gfc_symbol *vtab;
9084 gfc_expr *e;
9085 c = body->ext.block.case_list;
9086
9087 /* Generate an index integer expression for address of the
9088 TYPE/CLASS vtable and store it in c->low. The hash expression
9089 is stored in c->high and is used to resolve intrinsic cases. */
9090 if (c->ts.type != BT_UNKNOWN)
9091 {
9092 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9093 {
9094 vtab = gfc_find_derived_vtab (c->ts.u.derived);
9095 gcc_assert (vtab);
9096 c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
9097 c->ts.u.derived->hash_value);
9098 }
9099 else
9100 {
9101 vtab = gfc_find_vtab (&c->ts);
9102 gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
9103 e = CLASS_DATA (vtab)->initializer;
9104 c->high = gfc_copy_expr (e);
9105 if (c->high->ts.kind != gfc_integer_4_kind)
9106 {
9107 gfc_typespec ts;
9108 ts.kind = gfc_integer_4_kind;
9109 ts.type = BT_INTEGER;
9110 gfc_convert_type_warn (c->high, &ts, 2, 0);
9111 }
9112 }
9113
9114 e = gfc_lval_expr_from_sym (vtab);
9115 c->low = build_loc_call (e);
9116 }
9117 else
9118 continue;
9119
9120 /* Associate temporary to selector. This should only be done
9121 when this case is actually true, so build a new ASSOCIATE
9122 that does precisely this here (instead of using the
9123 'global' one). */
9124
9125 if (c->ts.type == BT_CLASS)
9126 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
9127 else if (c->ts.type == BT_DERIVED)
9128 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
9129 else if (c->ts.type == BT_CHARACTER)
9130 {
9131 HOST_WIDE_INT charlen = 0;
9132 if (c->ts.u.cl && c->ts.u.cl->length
9133 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9134 charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
9135 snprintf (name, sizeof (name),
9136 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
9137 gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
9138 }
9139 else
9140 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
9141 c->ts.kind);
9142
9143 st = gfc_find_symtree (ns->sym_root, name);
9144 gcc_assert (st->n.sym->assoc);
9145 st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
9146 st->n.sym->assoc->target->where = selector_expr->where;
9147 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
9148 {
9149 gfc_add_data_component (st->n.sym->assoc->target);
9150 /* Fixup the target expression if necessary. */
9151 if (rank)
9152 fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
9153 }
9154
9155 new_st = gfc_get_code (EXEC_BLOCK);
9156 new_st->ext.block.ns = gfc_build_block_ns (ns);
9157 new_st->ext.block.ns->code = body->next;
9158 body->next = new_st;
9159
9160 /* Chain in the new list only if it is marked as dangling. Otherwise
9161 there is a CASE label overlap and this is already used. Just ignore,
9162 the error is diagnosed elsewhere. */
9163 if (st->n.sym->assoc->dangling)
9164 {
9165 new_st->ext.block.assoc = st->n.sym->assoc;
9166 st->n.sym->assoc->dangling = 0;
9167 }
9168
9169 resolve_assoc_var (st->n.sym, false);
9170 }
9171
9172 /* Take out CLASS IS cases for separate treatment. */
9173 body = code;
9174 while (body && body->block)
9175 {
9176 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
9177 {
9178 /* Add to class_is list. */
9179 if (class_is == NULL)
9180 {
9181 class_is = body->block;
9182 tail = class_is;
9183 }
9184 else
9185 {
9186 for (tail = class_is; tail->block; tail = tail->block) ;
9187 tail->block = body->block;
9188 tail = tail->block;
9189 }
9190 /* Remove from EXEC_SELECT list. */
9191 body->block = body->block->block;
9192 tail->block = NULL;
9193 }
9194 else
9195 body = body->block;
9196 }
9197
9198 if (class_is)
9199 {
9200 gfc_symbol *vtab;
9201
9202 if (!default_case)
9203 {
9204 /* Add a default case to hold the CLASS IS cases. */
9205 for (tail = code; tail->block; tail = tail->block) ;
9206 tail->block = gfc_get_code (EXEC_SELECT_TYPE);
9207 tail = tail->block;
9208 tail->ext.block.case_list = gfc_get_case ();
9209 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
9210 tail->next = NULL;
9211 default_case = tail;
9212 }
9213
9214 /* More than one CLASS IS block? */
9215 if (class_is->block)
9216 {
9217 gfc_code **c1,*c2;
9218 bool swapped;
9219 /* Sort CLASS IS blocks by extension level. */
9220 do
9221 {
9222 swapped = false;
9223 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
9224 {
9225 c2 = (*c1)->block;
9226 /* F03:C817 (check for doubles). */
9227 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
9228 == c2->ext.block.case_list->ts.u.derived->hash_value)
9229 {
9230 gfc_error ("Double CLASS IS block in SELECT TYPE "
9231 "statement at %L",
9232 &c2->ext.block.case_list->where);
9233 return;
9234 }
9235 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
9236 < c2->ext.block.case_list->ts.u.derived->attr.extension)
9237 {
9238 /* Swap. */
9239 (*c1)->block = c2->block;
9240 c2->block = *c1;
9241 *c1 = c2;
9242 swapped = true;
9243 }
9244 }
9245 }
9246 while (swapped);
9247 }
9248
9249 /* Generate IF chain. */
9250 if_st = gfc_get_code (EXEC_IF);
9251 new_st = if_st;
9252 for (body = class_is; body; body = body->block)
9253 {
9254 new_st->block = gfc_get_code (EXEC_IF);
9255 new_st = new_st->block;
9256 /* Set up IF condition: Call _gfortran_is_extension_of. */
9257 new_st->expr1 = gfc_get_expr ();
9258 new_st->expr1->expr_type = EXPR_FUNCTION;
9259 new_st->expr1->ts.type = BT_LOGICAL;
9260 new_st->expr1->ts.kind = 4;
9261 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
9262 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
9263 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
9264 /* Set up arguments. */
9265 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
9266 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
9267 new_st->expr1->value.function.actual->expr->where = code->loc;
9268 new_st->expr1->where = code->loc;
9269 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
9270 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
9271 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
9272 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
9273 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
9274 new_st->expr1->value.function.actual->next->expr->where = code->loc;
9275 new_st->next = body->next;
9276 }
9277 if (default_case->next)
9278 {
9279 new_st->block = gfc_get_code (EXEC_IF);
9280 new_st = new_st->block;
9281 new_st->next = default_case->next;
9282 }
9283
9284 /* Replace CLASS DEFAULT code by the IF chain. */
9285 default_case->next = if_st;
9286 }
9287
9288 /* Resolve the internal code. This can not be done earlier because
9289 it requires that the sym->assoc of selectors is set already. */
9290 gfc_current_ns = ns;
9291 gfc_resolve_blocks (code->block, gfc_current_ns);
9292 gfc_current_ns = old_ns;
9293
9294 if (ref)
9295 free (ref);
9296 }
9297
9298
9299 /* Resolve a transfer statement. This is making sure that:
9300 -- a derived type being transferred has only non-pointer components
9301 -- a derived type being transferred doesn't have private components, unless
9302 it's being transferred from the module where the type was defined
9303 -- we're not trying to transfer a whole assumed size array. */
9304
9305 static void
resolve_transfer(gfc_code * code)9306 resolve_transfer (gfc_code *code)
9307 {
9308 gfc_typespec *ts;
9309 gfc_symbol *sym, *derived;
9310 gfc_ref *ref;
9311 gfc_expr *exp;
9312 bool write = false;
9313 bool formatted = false;
9314 gfc_dt *dt = code->ext.dt;
9315 gfc_symbol *dtio_sub = NULL;
9316
9317 exp = code->expr1;
9318
9319 while (exp != NULL && exp->expr_type == EXPR_OP
9320 && exp->value.op.op == INTRINSIC_PARENTHESES)
9321 exp = exp->value.op.op1;
9322
9323 if (exp && exp->expr_type == EXPR_NULL
9324 && code->ext.dt)
9325 {
9326 gfc_error ("Invalid context for NULL () intrinsic at %L",
9327 &exp->where);
9328 return;
9329 }
9330
9331 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
9332 && exp->expr_type != EXPR_FUNCTION
9333 && exp->expr_type != EXPR_STRUCTURE))
9334 return;
9335
9336 /* If we are reading, the variable will be changed. Note that
9337 code->ext.dt may be NULL if the TRANSFER is related to
9338 an INQUIRE statement -- but in this case, we are not reading, either. */
9339 if (dt && dt->dt_io_kind->value.iokind == M_READ
9340 && !gfc_check_vardef_context (exp, false, false, false,
9341 _("item in READ")))
9342 return;
9343
9344 ts = exp->expr_type == EXPR_STRUCTURE ? &exp->ts : &exp->symtree->n.sym->ts;
9345
9346 /* Go to actual component transferred. */
9347 for (ref = exp->ref; ref; ref = ref->next)
9348 if (ref->type == REF_COMPONENT)
9349 ts = &ref->u.c.component->ts;
9350
9351 if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
9352 && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
9353 {
9354 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
9355 derived = ts->u.derived;
9356 else
9357 derived = ts->u.derived->components->ts.u.derived;
9358
9359 /* Determine when to use the formatted DTIO procedure. */
9360 if (dt && (dt->format_expr || dt->format_label))
9361 formatted = true;
9362
9363 write = dt->dt_io_kind->value.iokind == M_WRITE
9364 || dt->dt_io_kind->value.iokind == M_PRINT;
9365 dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
9366
9367 if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
9368 {
9369 dt->udtio = exp;
9370 sym = exp->symtree->n.sym->ns->proc_name;
9371 /* Check to see if this is a nested DTIO call, with the
9372 dummy as the io-list object. */
9373 if (sym && sym == dtio_sub && sym->formal
9374 && sym->formal->sym == exp->symtree->n.sym
9375 && exp->ref == NULL)
9376 {
9377 if (!sym->attr.recursive)
9378 {
9379 gfc_error ("DTIO %s procedure at %L must be recursive",
9380 sym->name, &sym->declared_at);
9381 return;
9382 }
9383 }
9384 }
9385 }
9386
9387 if (ts->type == BT_CLASS && dtio_sub == NULL)
9388 {
9389 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9390 "it is processed by a defined input/output procedure",
9391 &code->loc);
9392 return;
9393 }
9394
9395 if (ts->type == BT_DERIVED)
9396 {
9397 /* Check that transferred derived type doesn't contain POINTER
9398 components unless it is processed by a defined input/output
9399 procedure". */
9400 if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
9401 {
9402 gfc_error ("Data transfer element at %L cannot have POINTER "
9403 "components unless it is processed by a defined "
9404 "input/output procedure", &code->loc);
9405 return;
9406 }
9407
9408 /* F08:C935. */
9409 if (ts->u.derived->attr.proc_pointer_comp)
9410 {
9411 gfc_error ("Data transfer element at %L cannot have "
9412 "procedure pointer components", &code->loc);
9413 return;
9414 }
9415
9416 if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
9417 {
9418 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9419 "components unless it is processed by a defined "
9420 "input/output procedure", &code->loc);
9421 return;
9422 }
9423
9424 /* C_PTR and C_FUNPTR have private components which means they can not
9425 be printed. However, if -std=gnu and not -pedantic, allow
9426 the component to be printed to help debugging. */
9427 if (ts->u.derived->ts.f90_type == BT_VOID)
9428 {
9429 if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
9430 "cannot have PRIVATE components", &code->loc))
9431 return;
9432 }
9433 else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
9434 {
9435 gfc_error ("Data transfer element at %L cannot have "
9436 "PRIVATE components unless it is processed by "
9437 "a defined input/output procedure", &code->loc);
9438 return;
9439 }
9440 }
9441
9442 if (exp->expr_type == EXPR_STRUCTURE)
9443 return;
9444
9445 sym = exp->symtree->n.sym;
9446
9447 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
9448 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
9449 {
9450 gfc_error ("Data transfer element at %L cannot be a full reference to "
9451 "an assumed-size array", &code->loc);
9452 return;
9453 }
9454
9455 if (async_io_dt && exp->expr_type == EXPR_VARIABLE)
9456 exp->symtree->n.sym->attr.asynchronous = 1;
9457 }
9458
9459
9460 /*********** Toplevel code resolution subroutines ***********/
9461
9462 /* Find the set of labels that are reachable from this block. We also
9463 record the last statement in each block. */
9464
9465 static void
find_reachable_labels(gfc_code * block)9466 find_reachable_labels (gfc_code *block)
9467 {
9468 gfc_code *c;
9469
9470 if (!block)
9471 return;
9472
9473 cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
9474
9475 /* Collect labels in this block. We don't keep those corresponding
9476 to END {IF|SELECT}, these are checked in resolve_branch by going
9477 up through the code_stack. */
9478 for (c = block; c; c = c->next)
9479 {
9480 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
9481 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
9482 }
9483
9484 /* Merge with labels from parent block. */
9485 if (cs_base->prev)
9486 {
9487 gcc_assert (cs_base->prev->reachable_labels);
9488 bitmap_ior_into (cs_base->reachable_labels,
9489 cs_base->prev->reachable_labels);
9490 }
9491 }
9492
9493
9494 static void
resolve_lock_unlock_event(gfc_code * code)9495 resolve_lock_unlock_event (gfc_code *code)
9496 {
9497 if (code->expr1->expr_type == EXPR_FUNCTION
9498 && code->expr1->value.function.isym
9499 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
9500 remove_caf_get_intrinsic (code->expr1);
9501
9502 if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
9503 && (code->expr1->ts.type != BT_DERIVED
9504 || code->expr1->expr_type != EXPR_VARIABLE
9505 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
9506 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
9507 || code->expr1->rank != 0
9508 || (!gfc_is_coarray (code->expr1) &&
9509 !gfc_is_coindexed (code->expr1))))
9510 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9511 &code->expr1->where);
9512 else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
9513 && (code->expr1->ts.type != BT_DERIVED
9514 || code->expr1->expr_type != EXPR_VARIABLE
9515 || code->expr1->ts.u.derived->from_intmod
9516 != INTMOD_ISO_FORTRAN_ENV
9517 || code->expr1->ts.u.derived->intmod_sym_id
9518 != ISOFORTRAN_EVENT_TYPE
9519 || code->expr1->rank != 0))
9520 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9521 &code->expr1->where);
9522 else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
9523 && !gfc_is_coindexed (code->expr1))
9524 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9525 &code->expr1->where);
9526 else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
9527 gfc_error ("Event variable argument at %L must be a coarray but not "
9528 "coindexed", &code->expr1->where);
9529
9530 /* Check STAT. */
9531 if (code->expr2
9532 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
9533 || code->expr2->expr_type != EXPR_VARIABLE))
9534 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9535 &code->expr2->where);
9536
9537 if (code->expr2
9538 && !gfc_check_vardef_context (code->expr2, false, false, false,
9539 _("STAT variable")))
9540 return;
9541
9542 /* Check ERRMSG. */
9543 if (code->expr3
9544 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
9545 || code->expr3->expr_type != EXPR_VARIABLE))
9546 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9547 &code->expr3->where);
9548
9549 if (code->expr3
9550 && !gfc_check_vardef_context (code->expr3, false, false, false,
9551 _("ERRMSG variable")))
9552 return;
9553
9554 /* Check for LOCK the ACQUIRED_LOCK. */
9555 if (code->op != EXEC_EVENT_WAIT && code->expr4
9556 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
9557 || code->expr4->expr_type != EXPR_VARIABLE))
9558 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9559 "variable", &code->expr4->where);
9560
9561 if (code->op != EXEC_EVENT_WAIT && code->expr4
9562 && !gfc_check_vardef_context (code->expr4, false, false, false,
9563 _("ACQUIRED_LOCK variable")))
9564 return;
9565
9566 /* Check for EVENT WAIT the UNTIL_COUNT. */
9567 if (code->op == EXEC_EVENT_WAIT && code->expr4)
9568 {
9569 if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
9570 || code->expr4->rank != 0)
9571 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9572 "expression", &code->expr4->where);
9573 }
9574 }
9575
9576
9577 static void
resolve_critical(gfc_code * code)9578 resolve_critical (gfc_code *code)
9579 {
9580 gfc_symtree *symtree;
9581 gfc_symbol *lock_type;
9582 char name[GFC_MAX_SYMBOL_LEN];
9583 static int serial = 0;
9584
9585 if (flag_coarray != GFC_FCOARRAY_LIB)
9586 return;
9587
9588 symtree = gfc_find_symtree (gfc_current_ns->sym_root,
9589 GFC_PREFIX ("lock_type"));
9590 if (symtree)
9591 lock_type = symtree->n.sym;
9592 else
9593 {
9594 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
9595 false) != 0)
9596 gcc_unreachable ();
9597 lock_type = symtree->n.sym;
9598 lock_type->attr.flavor = FL_DERIVED;
9599 lock_type->attr.zero_comp = 1;
9600 lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
9601 lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
9602 }
9603
9604 sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
9605 if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
9606 gcc_unreachable ();
9607
9608 code->resolved_sym = symtree->n.sym;
9609 symtree->n.sym->attr.flavor = FL_VARIABLE;
9610 symtree->n.sym->attr.referenced = 1;
9611 symtree->n.sym->attr.artificial = 1;
9612 symtree->n.sym->attr.codimension = 1;
9613 symtree->n.sym->ts.type = BT_DERIVED;
9614 symtree->n.sym->ts.u.derived = lock_type;
9615 symtree->n.sym->as = gfc_get_array_spec ();
9616 symtree->n.sym->as->corank = 1;
9617 symtree->n.sym->as->type = AS_EXPLICIT;
9618 symtree->n.sym->as->cotype = AS_EXPLICIT;
9619 symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
9620 NULL, 1);
9621 gfc_commit_symbols();
9622 }
9623
9624
9625 static void
resolve_sync(gfc_code * code)9626 resolve_sync (gfc_code *code)
9627 {
9628 /* Check imageset. The * case matches expr1 == NULL. */
9629 if (code->expr1)
9630 {
9631 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
9632 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9633 "INTEGER expression", &code->expr1->where);
9634 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
9635 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
9636 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9637 &code->expr1->where);
9638 else if (code->expr1->expr_type == EXPR_ARRAY
9639 && gfc_simplify_expr (code->expr1, 0))
9640 {
9641 gfc_constructor *cons;
9642 cons = gfc_constructor_first (code->expr1->value.constructor);
9643 for (; cons; cons = gfc_constructor_next (cons))
9644 if (cons->expr->expr_type == EXPR_CONSTANT
9645 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
9646 gfc_error ("Imageset argument at %L must between 1 and "
9647 "num_images()", &cons->expr->where);
9648 }
9649 }
9650
9651 /* Check STAT. */
9652 gfc_resolve_expr (code->expr2);
9653 if (code->expr2
9654 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
9655 || code->expr2->expr_type != EXPR_VARIABLE))
9656 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9657 &code->expr2->where);
9658
9659 /* Check ERRMSG. */
9660 gfc_resolve_expr (code->expr3);
9661 if (code->expr3
9662 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
9663 || code->expr3->expr_type != EXPR_VARIABLE))
9664 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9665 &code->expr3->where);
9666 }
9667
9668
9669 /* Given a branch to a label, see if the branch is conforming.
9670 The code node describes where the branch is located. */
9671
9672 static void
resolve_branch(gfc_st_label * label,gfc_code * code)9673 resolve_branch (gfc_st_label *label, gfc_code *code)
9674 {
9675 code_stack *stack;
9676
9677 if (label == NULL)
9678 return;
9679
9680 /* Step one: is this a valid branching target? */
9681
9682 if (label->defined == ST_LABEL_UNKNOWN)
9683 {
9684 gfc_error ("Label %d referenced at %L is never defined", label->value,
9685 &code->loc);
9686 return;
9687 }
9688
9689 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
9690 {
9691 gfc_error ("Statement at %L is not a valid branch target statement "
9692 "for the branch statement at %L", &label->where, &code->loc);
9693 return;
9694 }
9695
9696 /* Step two: make sure this branch is not a branch to itself ;-) */
9697
9698 if (code->here == label)
9699 {
9700 gfc_warning (0,
9701 "Branch at %L may result in an infinite loop", &code->loc);
9702 return;
9703 }
9704
9705 /* Step three: See if the label is in the same block as the
9706 branching statement. The hard work has been done by setting up
9707 the bitmap reachable_labels. */
9708
9709 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
9710 {
9711 /* Check now whether there is a CRITICAL construct; if so, check
9712 whether the label is still visible outside of the CRITICAL block,
9713 which is invalid. */
9714 for (stack = cs_base; stack; stack = stack->prev)
9715 {
9716 if (stack->current->op == EXEC_CRITICAL
9717 && bitmap_bit_p (stack->reachable_labels, label->value))
9718 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9719 "label at %L", &code->loc, &label->where);
9720 else if (stack->current->op == EXEC_DO_CONCURRENT
9721 && bitmap_bit_p (stack->reachable_labels, label->value))
9722 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9723 "for label at %L", &code->loc, &label->where);
9724 }
9725
9726 return;
9727 }
9728
9729 /* Step four: If we haven't found the label in the bitmap, it may
9730 still be the label of the END of the enclosing block, in which
9731 case we find it by going up the code_stack. */
9732
9733 for (stack = cs_base; stack; stack = stack->prev)
9734 {
9735 if (stack->current->next && stack->current->next->here == label)
9736 break;
9737 if (stack->current->op == EXEC_CRITICAL)
9738 {
9739 /* Note: A label at END CRITICAL does not leave the CRITICAL
9740 construct as END CRITICAL is still part of it. */
9741 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9742 " at %L", &code->loc, &label->where);
9743 return;
9744 }
9745 else if (stack->current->op == EXEC_DO_CONCURRENT)
9746 {
9747 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9748 "label at %L", &code->loc, &label->where);
9749 return;
9750 }
9751 }
9752
9753 if (stack)
9754 {
9755 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
9756 return;
9757 }
9758
9759 /* The label is not in an enclosing block, so illegal. This was
9760 allowed in Fortran 66, so we allow it as extension. No
9761 further checks are necessary in this case. */
9762 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
9763 "as the GOTO statement at %L", &label->where,
9764 &code->loc);
9765 return;
9766 }
9767
9768
9769 /* Check whether EXPR1 has the same shape as EXPR2. */
9770
9771 static bool
resolve_where_shape(gfc_expr * expr1,gfc_expr * expr2)9772 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
9773 {
9774 mpz_t shape[GFC_MAX_DIMENSIONS];
9775 mpz_t shape2[GFC_MAX_DIMENSIONS];
9776 bool result = false;
9777 int i;
9778
9779 /* Compare the rank. */
9780 if (expr1->rank != expr2->rank)
9781 return result;
9782
9783 /* Compare the size of each dimension. */
9784 for (i=0; i<expr1->rank; i++)
9785 {
9786 if (!gfc_array_dimen_size (expr1, i, &shape[i]))
9787 goto ignore;
9788
9789 if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
9790 goto ignore;
9791
9792 if (mpz_cmp (shape[i], shape2[i]))
9793 goto over;
9794 }
9795
9796 /* When either of the two expression is an assumed size array, we
9797 ignore the comparison of dimension sizes. */
9798 ignore:
9799 result = true;
9800
9801 over:
9802 gfc_clear_shape (shape, i);
9803 gfc_clear_shape (shape2, i);
9804 return result;
9805 }
9806
9807
9808 /* Check whether a WHERE assignment target or a WHERE mask expression
9809 has the same shape as the outmost WHERE mask expression. */
9810
9811 static void
resolve_where(gfc_code * code,gfc_expr * mask)9812 resolve_where (gfc_code *code, gfc_expr *mask)
9813 {
9814 gfc_code *cblock;
9815 gfc_code *cnext;
9816 gfc_expr *e = NULL;
9817
9818 cblock = code->block;
9819
9820 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9821 In case of nested WHERE, only the outmost one is stored. */
9822 if (mask == NULL) /* outmost WHERE */
9823 e = cblock->expr1;
9824 else /* inner WHERE */
9825 e = mask;
9826
9827 while (cblock)
9828 {
9829 if (cblock->expr1)
9830 {
9831 /* Check if the mask-expr has a consistent shape with the
9832 outmost WHERE mask-expr. */
9833 if (!resolve_where_shape (cblock->expr1, e))
9834 gfc_error ("WHERE mask at %L has inconsistent shape",
9835 &cblock->expr1->where);
9836 }
9837
9838 /* the assignment statement of a WHERE statement, or the first
9839 statement in where-body-construct of a WHERE construct */
9840 cnext = cblock->next;
9841 while (cnext)
9842 {
9843 switch (cnext->op)
9844 {
9845 /* WHERE assignment statement */
9846 case EXEC_ASSIGN:
9847
9848 /* Check shape consistent for WHERE assignment target. */
9849 if (e && !resolve_where_shape (cnext->expr1, e))
9850 gfc_error ("WHERE assignment target at %L has "
9851 "inconsistent shape", &cnext->expr1->where);
9852 break;
9853
9854
9855 case EXEC_ASSIGN_CALL:
9856 resolve_call (cnext);
9857 if (!cnext->resolved_sym->attr.elemental)
9858 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9859 &cnext->ext.actual->expr->where);
9860 break;
9861
9862 /* WHERE or WHERE construct is part of a where-body-construct */
9863 case EXEC_WHERE:
9864 resolve_where (cnext, e);
9865 break;
9866
9867 default:
9868 gfc_error ("Unsupported statement inside WHERE at %L",
9869 &cnext->loc);
9870 }
9871 /* the next statement within the same where-body-construct */
9872 cnext = cnext->next;
9873 }
9874 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9875 cblock = cblock->block;
9876 }
9877 }
9878
9879
9880 /* Resolve assignment in FORALL construct.
9881 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9882 FORALL index variables. */
9883
9884 static void
gfc_resolve_assign_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9885 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
9886 {
9887 int n;
9888
9889 for (n = 0; n < nvar; n++)
9890 {
9891 gfc_symbol *forall_index;
9892
9893 forall_index = var_expr[n]->symtree->n.sym;
9894
9895 /* Check whether the assignment target is one of the FORALL index
9896 variable. */
9897 if ((code->expr1->expr_type == EXPR_VARIABLE)
9898 && (code->expr1->symtree->n.sym == forall_index))
9899 gfc_error ("Assignment to a FORALL index variable at %L",
9900 &code->expr1->where);
9901 else
9902 {
9903 /* If one of the FORALL index variables doesn't appear in the
9904 assignment variable, then there could be a many-to-one
9905 assignment. Emit a warning rather than an error because the
9906 mask could be resolving this problem. */
9907 if (!find_forall_index (code->expr1, forall_index, 0))
9908 gfc_warning (0, "The FORALL with index %qs is not used on the "
9909 "left side of the assignment at %L and so might "
9910 "cause multiple assignment to this object",
9911 var_expr[n]->symtree->name, &code->expr1->where);
9912 }
9913 }
9914 }
9915
9916
9917 /* Resolve WHERE statement in FORALL construct. */
9918
9919 static void
gfc_resolve_where_code_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9920 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
9921 gfc_expr **var_expr)
9922 {
9923 gfc_code *cblock;
9924 gfc_code *cnext;
9925
9926 cblock = code->block;
9927 while (cblock)
9928 {
9929 /* the assignment statement of a WHERE statement, or the first
9930 statement in where-body-construct of a WHERE construct */
9931 cnext = cblock->next;
9932 while (cnext)
9933 {
9934 switch (cnext->op)
9935 {
9936 /* WHERE assignment statement */
9937 case EXEC_ASSIGN:
9938 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
9939 break;
9940
9941 /* WHERE operator assignment statement */
9942 case EXEC_ASSIGN_CALL:
9943 resolve_call (cnext);
9944 if (!cnext->resolved_sym->attr.elemental)
9945 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9946 &cnext->ext.actual->expr->where);
9947 break;
9948
9949 /* WHERE or WHERE construct is part of a where-body-construct */
9950 case EXEC_WHERE:
9951 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
9952 break;
9953
9954 default:
9955 gfc_error ("Unsupported statement inside WHERE at %L",
9956 &cnext->loc);
9957 }
9958 /* the next statement within the same where-body-construct */
9959 cnext = cnext->next;
9960 }
9961 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9962 cblock = cblock->block;
9963 }
9964 }
9965
9966
9967 /* Traverse the FORALL body to check whether the following errors exist:
9968 1. For assignment, check if a many-to-one assignment happens.
9969 2. For WHERE statement, check the WHERE body to see if there is any
9970 many-to-one assignment. */
9971
9972 static void
gfc_resolve_forall_body(gfc_code * code,int nvar,gfc_expr ** var_expr)9973 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
9974 {
9975 gfc_code *c;
9976
9977 c = code->block->next;
9978 while (c)
9979 {
9980 switch (c->op)
9981 {
9982 case EXEC_ASSIGN:
9983 case EXEC_POINTER_ASSIGN:
9984 gfc_resolve_assign_in_forall (c, nvar, var_expr);
9985 break;
9986
9987 case EXEC_ASSIGN_CALL:
9988 resolve_call (c);
9989 break;
9990
9991 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9992 there is no need to handle it here. */
9993 case EXEC_FORALL:
9994 break;
9995 case EXEC_WHERE:
9996 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
9997 break;
9998 default:
9999 break;
10000 }
10001 /* The next statement in the FORALL body. */
10002 c = c->next;
10003 }
10004 }
10005
10006
10007 /* Counts the number of iterators needed inside a forall construct, including
10008 nested forall constructs. This is used to allocate the needed memory
10009 in gfc_resolve_forall. */
10010
10011 static int
gfc_count_forall_iterators(gfc_code * code)10012 gfc_count_forall_iterators (gfc_code *code)
10013 {
10014 int max_iters, sub_iters, current_iters;
10015 gfc_forall_iterator *fa;
10016
10017 gcc_assert(code->op == EXEC_FORALL);
10018 max_iters = 0;
10019 current_iters = 0;
10020
10021 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10022 current_iters ++;
10023
10024 code = code->block->next;
10025
10026 while (code)
10027 {
10028 if (code->op == EXEC_FORALL)
10029 {
10030 sub_iters = gfc_count_forall_iterators (code);
10031 if (sub_iters > max_iters)
10032 max_iters = sub_iters;
10033 }
10034 code = code->next;
10035 }
10036
10037 return current_iters + max_iters;
10038 }
10039
10040
10041 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10042 gfc_resolve_forall_body to resolve the FORALL body. */
10043
10044 static void
gfc_resolve_forall(gfc_code * code,gfc_namespace * ns,int forall_save)10045 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
10046 {
10047 static gfc_expr **var_expr;
10048 static int total_var = 0;
10049 static int nvar = 0;
10050 int i, old_nvar, tmp;
10051 gfc_forall_iterator *fa;
10052
10053 old_nvar = nvar;
10054
10055 /* Start to resolve a FORALL construct */
10056 if (forall_save == 0)
10057 {
10058 /* Count the total number of FORALL indices in the nested FORALL
10059 construct in order to allocate the VAR_EXPR with proper size. */
10060 total_var = gfc_count_forall_iterators (code);
10061
10062 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10063 var_expr = XCNEWVEC (gfc_expr *, total_var);
10064 }
10065
10066 /* The information about FORALL iterator, including FORALL indices start, end
10067 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10068 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10069 {
10070 /* Fortran 20008: C738 (R753). */
10071 if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
10072 {
10073 gfc_error ("FORALL index-name at %L must be a scalar variable "
10074 "of type integer", &fa->var->where);
10075 continue;
10076 }
10077
10078 /* Check if any outer FORALL index name is the same as the current
10079 one. */
10080 for (i = 0; i < nvar; i++)
10081 {
10082 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
10083 gfc_error ("An outer FORALL construct already has an index "
10084 "with this name %L", &fa->var->where);
10085 }
10086
10087 /* Record the current FORALL index. */
10088 var_expr[nvar] = gfc_copy_expr (fa->var);
10089
10090 nvar++;
10091
10092 /* No memory leak. */
10093 gcc_assert (nvar <= total_var);
10094 }
10095
10096 /* Resolve the FORALL body. */
10097 gfc_resolve_forall_body (code, nvar, var_expr);
10098
10099 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10100 gfc_resolve_blocks (code->block, ns);
10101
10102 tmp = nvar;
10103 nvar = old_nvar;
10104 /* Free only the VAR_EXPRs allocated in this frame. */
10105 for (i = nvar; i < tmp; i++)
10106 gfc_free_expr (var_expr[i]);
10107
10108 if (nvar == 0)
10109 {
10110 /* We are in the outermost FORALL construct. */
10111 gcc_assert (forall_save == 0);
10112
10113 /* VAR_EXPR is not needed any more. */
10114 free (var_expr);
10115 total_var = 0;
10116 }
10117 }
10118
10119
10120 /* Resolve a BLOCK construct statement. */
10121
10122 static void
resolve_block_construct(gfc_code * code)10123 resolve_block_construct (gfc_code* code)
10124 {
10125 /* Resolve the BLOCK's namespace. */
10126 gfc_resolve (code->ext.block.ns);
10127
10128 /* For an ASSOCIATE block, the associations (and their targets) are already
10129 resolved during resolve_symbol. */
10130 }
10131
10132
10133 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10134 DO code nodes. */
10135
10136 void
gfc_resolve_blocks(gfc_code * b,gfc_namespace * ns)10137 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
10138 {
10139 bool t;
10140
10141 for (; b; b = b->block)
10142 {
10143 t = gfc_resolve_expr (b->expr1);
10144 if (!gfc_resolve_expr (b->expr2))
10145 t = false;
10146
10147 switch (b->op)
10148 {
10149 case EXEC_IF:
10150 if (t && b->expr1 != NULL
10151 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
10152 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10153 &b->expr1->where);
10154 break;
10155
10156 case EXEC_WHERE:
10157 if (t
10158 && b->expr1 != NULL
10159 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
10160 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10161 &b->expr1->where);
10162 break;
10163
10164 case EXEC_GOTO:
10165 resolve_branch (b->label1, b);
10166 break;
10167
10168 case EXEC_BLOCK:
10169 resolve_block_construct (b);
10170 break;
10171
10172 case EXEC_SELECT:
10173 case EXEC_SELECT_TYPE:
10174 case EXEC_FORALL:
10175 case EXEC_DO:
10176 case EXEC_DO_WHILE:
10177 case EXEC_DO_CONCURRENT:
10178 case EXEC_CRITICAL:
10179 case EXEC_READ:
10180 case EXEC_WRITE:
10181 case EXEC_IOLENGTH:
10182 case EXEC_WAIT:
10183 break;
10184
10185 case EXEC_OMP_ATOMIC:
10186 case EXEC_OACC_ATOMIC:
10187 {
10188 gfc_omp_atomic_op aop
10189 = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
10190
10191 /* Verify this before calling gfc_resolve_code, which might
10192 change it. */
10193 gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
10194 gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE)
10195 && b->next->next == NULL)
10196 || ((aop == GFC_OMP_ATOMIC_CAPTURE)
10197 && b->next->next != NULL
10198 && b->next->next->op == EXEC_ASSIGN
10199 && b->next->next->next == NULL));
10200 }
10201 break;
10202
10203 case EXEC_OACC_PARALLEL_LOOP:
10204 case EXEC_OACC_PARALLEL:
10205 case EXEC_OACC_KERNELS_LOOP:
10206 case EXEC_OACC_KERNELS:
10207 case EXEC_OACC_DATA:
10208 case EXEC_OACC_HOST_DATA:
10209 case EXEC_OACC_LOOP:
10210 case EXEC_OACC_UPDATE:
10211 case EXEC_OACC_WAIT:
10212 case EXEC_OACC_CACHE:
10213 case EXEC_OACC_ENTER_DATA:
10214 case EXEC_OACC_EXIT_DATA:
10215 case EXEC_OACC_ROUTINE:
10216 case EXEC_OMP_CRITICAL:
10217 case EXEC_OMP_DISTRIBUTE:
10218 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10219 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10220 case EXEC_OMP_DISTRIBUTE_SIMD:
10221 case EXEC_OMP_DO:
10222 case EXEC_OMP_DO_SIMD:
10223 case EXEC_OMP_MASTER:
10224 case EXEC_OMP_ORDERED:
10225 case EXEC_OMP_PARALLEL:
10226 case EXEC_OMP_PARALLEL_DO:
10227 case EXEC_OMP_PARALLEL_DO_SIMD:
10228 case EXEC_OMP_PARALLEL_SECTIONS:
10229 case EXEC_OMP_PARALLEL_WORKSHARE:
10230 case EXEC_OMP_SECTIONS:
10231 case EXEC_OMP_SIMD:
10232 case EXEC_OMP_SINGLE:
10233 case EXEC_OMP_TARGET:
10234 case EXEC_OMP_TARGET_DATA:
10235 case EXEC_OMP_TARGET_ENTER_DATA:
10236 case EXEC_OMP_TARGET_EXIT_DATA:
10237 case EXEC_OMP_TARGET_PARALLEL:
10238 case EXEC_OMP_TARGET_PARALLEL_DO:
10239 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10240 case EXEC_OMP_TARGET_SIMD:
10241 case EXEC_OMP_TARGET_TEAMS:
10242 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10243 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10244 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10245 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10246 case EXEC_OMP_TARGET_UPDATE:
10247 case EXEC_OMP_TASK:
10248 case EXEC_OMP_TASKGROUP:
10249 case EXEC_OMP_TASKLOOP:
10250 case EXEC_OMP_TASKLOOP_SIMD:
10251 case EXEC_OMP_TASKWAIT:
10252 case EXEC_OMP_TASKYIELD:
10253 case EXEC_OMP_TEAMS:
10254 case EXEC_OMP_TEAMS_DISTRIBUTE:
10255 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10256 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10257 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10258 case EXEC_OMP_WORKSHARE:
10259 break;
10260
10261 default:
10262 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10263 }
10264
10265 gfc_resolve_code (b->next, ns);
10266 }
10267 }
10268
10269
10270 /* Does everything to resolve an ordinary assignment. Returns true
10271 if this is an interface assignment. */
10272 static bool
resolve_ordinary_assign(gfc_code * code,gfc_namespace * ns)10273 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
10274 {
10275 bool rval = false;
10276 gfc_expr *lhs;
10277 gfc_expr *rhs;
10278 int n;
10279 gfc_ref *ref;
10280 symbol_attribute attr;
10281
10282 if (gfc_extend_assign (code, ns))
10283 {
10284 gfc_expr** rhsptr;
10285
10286 if (code->op == EXEC_ASSIGN_CALL)
10287 {
10288 lhs = code->ext.actual->expr;
10289 rhsptr = &code->ext.actual->next->expr;
10290 }
10291 else
10292 {
10293 gfc_actual_arglist* args;
10294 gfc_typebound_proc* tbp;
10295
10296 gcc_assert (code->op == EXEC_COMPCALL);
10297
10298 args = code->expr1->value.compcall.actual;
10299 lhs = args->expr;
10300 rhsptr = &args->next->expr;
10301
10302 tbp = code->expr1->value.compcall.tbp;
10303 gcc_assert (!tbp->is_generic);
10304 }
10305
10306 /* Make a temporary rhs when there is a default initializer
10307 and rhs is the same symbol as the lhs. */
10308 if ((*rhsptr)->expr_type == EXPR_VARIABLE
10309 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
10310 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
10311 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
10312 *rhsptr = gfc_get_parentheses (*rhsptr);
10313
10314 return true;
10315 }
10316
10317 lhs = code->expr1;
10318 rhs = code->expr2;
10319
10320 if (rhs->is_boz
10321 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
10322 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10323 &code->loc))
10324 return false;
10325
10326 /* Handle the case of a BOZ literal on the RHS. */
10327 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
10328 {
10329 int rc;
10330 if (warn_surprising)
10331 gfc_warning (OPT_Wsurprising,
10332 "BOZ literal at %L is bitwise transferred "
10333 "non-integer symbol %qs", &code->loc,
10334 lhs->symtree->n.sym->name);
10335
10336 if (!gfc_convert_boz (rhs, &lhs->ts))
10337 return false;
10338 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
10339 {
10340 if (rc == ARITH_UNDERFLOW)
10341 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10342 ". This check can be disabled with the option "
10343 "%<-fno-range-check%>", &rhs->where);
10344 else if (rc == ARITH_OVERFLOW)
10345 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10346 ". This check can be disabled with the option "
10347 "%<-fno-range-check%>", &rhs->where);
10348 else if (rc == ARITH_NAN)
10349 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10350 ". This check can be disabled with the option "
10351 "%<-fno-range-check%>", &rhs->where);
10352 return false;
10353 }
10354 }
10355
10356 if (lhs->ts.type == BT_CHARACTER
10357 && warn_character_truncation)
10358 {
10359 HOST_WIDE_INT llen = 0, rlen = 0;
10360 if (lhs->ts.u.cl != NULL
10361 && lhs->ts.u.cl->length != NULL
10362 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10363 llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
10364
10365 if (rhs->expr_type == EXPR_CONSTANT)
10366 rlen = rhs->value.character.length;
10367
10368 else if (rhs->ts.u.cl != NULL
10369 && rhs->ts.u.cl->length != NULL
10370 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10371 rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
10372
10373 if (rlen && llen && rlen > llen)
10374 gfc_warning_now (OPT_Wcharacter_truncation,
10375 "CHARACTER expression will be truncated "
10376 "in assignment (%ld/%ld) at %L",
10377 (long) llen, (long) rlen, &code->loc);
10378 }
10379
10380 /* Ensure that a vector index expression for the lvalue is evaluated
10381 to a temporary if the lvalue symbol is referenced in it. */
10382 if (lhs->rank)
10383 {
10384 for (ref = lhs->ref; ref; ref= ref->next)
10385 if (ref->type == REF_ARRAY)
10386 {
10387 for (n = 0; n < ref->u.ar.dimen; n++)
10388 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
10389 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
10390 ref->u.ar.start[n]))
10391 ref->u.ar.start[n]
10392 = gfc_get_parentheses (ref->u.ar.start[n]);
10393 }
10394 }
10395
10396 if (gfc_pure (NULL))
10397 {
10398 if (lhs->ts.type == BT_DERIVED
10399 && lhs->expr_type == EXPR_VARIABLE
10400 && lhs->ts.u.derived->attr.pointer_comp
10401 && rhs->expr_type == EXPR_VARIABLE
10402 && (gfc_impure_variable (rhs->symtree->n.sym)
10403 || gfc_is_coindexed (rhs)))
10404 {
10405 /* F2008, C1283. */
10406 if (gfc_is_coindexed (rhs))
10407 gfc_error ("Coindexed expression at %L is assigned to "
10408 "a derived type variable with a POINTER "
10409 "component in a PURE procedure",
10410 &rhs->where);
10411 else
10412 gfc_error ("The impure variable at %L is assigned to "
10413 "a derived type variable with a POINTER "
10414 "component in a PURE procedure (12.6)",
10415 &rhs->where);
10416 return rval;
10417 }
10418
10419 /* Fortran 2008, C1283. */
10420 if (gfc_is_coindexed (lhs))
10421 {
10422 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10423 "procedure", &rhs->where);
10424 return rval;
10425 }
10426 }
10427
10428 if (gfc_implicit_pure (NULL))
10429 {
10430 if (lhs->expr_type == EXPR_VARIABLE
10431 && lhs->symtree->n.sym != gfc_current_ns->proc_name
10432 && lhs->symtree->n.sym->ns != gfc_current_ns)
10433 gfc_unset_implicit_pure (NULL);
10434
10435 if (lhs->ts.type == BT_DERIVED
10436 && lhs->expr_type == EXPR_VARIABLE
10437 && lhs->ts.u.derived->attr.pointer_comp
10438 && rhs->expr_type == EXPR_VARIABLE
10439 && (gfc_impure_variable (rhs->symtree->n.sym)
10440 || gfc_is_coindexed (rhs)))
10441 gfc_unset_implicit_pure (NULL);
10442
10443 /* Fortran 2008, C1283. */
10444 if (gfc_is_coindexed (lhs))
10445 gfc_unset_implicit_pure (NULL);
10446 }
10447
10448 /* F2008, 7.2.1.2. */
10449 attr = gfc_expr_attr (lhs);
10450 if (lhs->ts.type == BT_CLASS && attr.allocatable)
10451 {
10452 if (attr.codimension)
10453 {
10454 gfc_error ("Assignment to polymorphic coarray at %L is not "
10455 "permitted", &lhs->where);
10456 return false;
10457 }
10458 if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
10459 "polymorphic variable at %L", &lhs->where))
10460 return false;
10461 if (!flag_realloc_lhs)
10462 {
10463 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10464 "requires %<-frealloc-lhs%>", &lhs->where);
10465 return false;
10466 }
10467 }
10468 else if (lhs->ts.type == BT_CLASS)
10469 {
10470 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10471 "assignment at %L - check that there is a matching specific "
10472 "subroutine for '=' operator", &lhs->where);
10473 return false;
10474 }
10475
10476 bool lhs_coindexed = gfc_is_coindexed (lhs);
10477
10478 /* F2008, Section 7.2.1.2. */
10479 if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
10480 {
10481 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10482 "component in assignment at %L", &lhs->where);
10483 return false;
10484 }
10485
10486 /* Assign the 'data' of a class object to a derived type. */
10487 if (lhs->ts.type == BT_DERIVED
10488 && rhs->ts.type == BT_CLASS
10489 && rhs->expr_type != EXPR_ARRAY)
10490 gfc_add_data_component (rhs);
10491
10492 /* Make sure there is a vtable and, in particular, a _copy for the
10493 rhs type. */
10494 if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
10495 gfc_find_vtab (&rhs->ts);
10496
10497 bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
10498 && (lhs_coindexed
10499 || (code->expr2->expr_type == EXPR_FUNCTION
10500 && code->expr2->value.function.isym
10501 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
10502 && (code->expr1->rank == 0 || code->expr2->rank != 0)
10503 && !gfc_expr_attr (rhs).allocatable
10504 && !gfc_has_vector_subscript (rhs)));
10505
10506 gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
10507
10508 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10509 Additionally, insert this code when the RHS is a CAF as we then use the
10510 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10511 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10512 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10513 path. */
10514 if (caf_convert_to_send)
10515 {
10516 if (code->expr2->expr_type == EXPR_FUNCTION
10517 && code->expr2->value.function.isym
10518 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
10519 remove_caf_get_intrinsic (code->expr2);
10520 code->op = EXEC_CALL;
10521 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
10522 code->resolved_sym = code->symtree->n.sym;
10523 code->resolved_sym->attr.flavor = FL_PROCEDURE;
10524 code->resolved_sym->attr.intrinsic = 1;
10525 code->resolved_sym->attr.subroutine = 1;
10526 code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10527 gfc_commit_symbol (code->resolved_sym);
10528 code->ext.actual = gfc_get_actual_arglist ();
10529 code->ext.actual->expr = lhs;
10530 code->ext.actual->next = gfc_get_actual_arglist ();
10531 code->ext.actual->next->expr = rhs;
10532 code->expr1 = NULL;
10533 code->expr2 = NULL;
10534 }
10535
10536 return false;
10537 }
10538
10539
10540 /* Add a component reference onto an expression. */
10541
10542 static void
add_comp_ref(gfc_expr * e,gfc_component * c)10543 add_comp_ref (gfc_expr *e, gfc_component *c)
10544 {
10545 gfc_ref **ref;
10546 ref = &(e->ref);
10547 while (*ref)
10548 ref = &((*ref)->next);
10549 *ref = gfc_get_ref ();
10550 (*ref)->type = REF_COMPONENT;
10551 (*ref)->u.c.sym = e->ts.u.derived;
10552 (*ref)->u.c.component = c;
10553 e->ts = c->ts;
10554
10555 /* Add a full array ref, as necessary. */
10556 if (c->as)
10557 {
10558 gfc_add_full_array_ref (e, c->as);
10559 e->rank = c->as->rank;
10560 }
10561 }
10562
10563
10564 /* Build an assignment. Keep the argument 'op' for future use, so that
10565 pointer assignments can be made. */
10566
10567 static gfc_code *
build_assignment(gfc_exec_op op,gfc_expr * expr1,gfc_expr * expr2,gfc_component * comp1,gfc_component * comp2,locus loc)10568 build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
10569 gfc_component *comp1, gfc_component *comp2, locus loc)
10570 {
10571 gfc_code *this_code;
10572
10573 this_code = gfc_get_code (op);
10574 this_code->next = NULL;
10575 this_code->expr1 = gfc_copy_expr (expr1);
10576 this_code->expr2 = gfc_copy_expr (expr2);
10577 this_code->loc = loc;
10578 if (comp1 && comp2)
10579 {
10580 add_comp_ref (this_code->expr1, comp1);
10581 add_comp_ref (this_code->expr2, comp2);
10582 }
10583
10584 return this_code;
10585 }
10586
10587
10588 /* Makes a temporary variable expression based on the characteristics of
10589 a given variable expression. */
10590
10591 static gfc_expr*
get_temp_from_expr(gfc_expr * e,gfc_namespace * ns)10592 get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
10593 {
10594 static int serial = 0;
10595 char name[GFC_MAX_SYMBOL_LEN];
10596 gfc_symtree *tmp;
10597 gfc_array_spec *as;
10598 gfc_array_ref *aref;
10599 gfc_ref *ref;
10600
10601 sprintf (name, GFC_PREFIX("DA%d"), serial++);
10602 gfc_get_sym_tree (name, ns, &tmp, false);
10603 gfc_add_type (tmp->n.sym, &e->ts, NULL);
10604
10605 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
10606 tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
10607 NULL,
10608 e->value.character.length);
10609
10610 as = NULL;
10611 ref = NULL;
10612 aref = NULL;
10613
10614 /* Obtain the arrayspec for the temporary. */
10615 if (e->rank && e->expr_type != EXPR_ARRAY
10616 && e->expr_type != EXPR_FUNCTION
10617 && e->expr_type != EXPR_OP)
10618 {
10619 aref = gfc_find_array_ref (e);
10620 if (e->expr_type == EXPR_VARIABLE
10621 && e->symtree->n.sym->as == aref->as)
10622 as = aref->as;
10623 else
10624 {
10625 for (ref = e->ref; ref; ref = ref->next)
10626 if (ref->type == REF_COMPONENT
10627 && ref->u.c.component->as == aref->as)
10628 {
10629 as = aref->as;
10630 break;
10631 }
10632 }
10633 }
10634
10635 /* Add the attributes and the arrayspec to the temporary. */
10636 tmp->n.sym->attr = gfc_expr_attr (e);
10637 tmp->n.sym->attr.function = 0;
10638 tmp->n.sym->attr.result = 0;
10639 tmp->n.sym->attr.flavor = FL_VARIABLE;
10640 tmp->n.sym->attr.dummy = 0;
10641 tmp->n.sym->attr.intent = INTENT_UNKNOWN;
10642
10643 if (as)
10644 {
10645 tmp->n.sym->as = gfc_copy_array_spec (as);
10646 if (!ref)
10647 ref = e->ref;
10648 if (as->type == AS_DEFERRED)
10649 tmp->n.sym->attr.allocatable = 1;
10650 }
10651 else if (e->rank && (e->expr_type == EXPR_ARRAY
10652 || e->expr_type == EXPR_FUNCTION
10653 || e->expr_type == EXPR_OP))
10654 {
10655 tmp->n.sym->as = gfc_get_array_spec ();
10656 tmp->n.sym->as->type = AS_DEFERRED;
10657 tmp->n.sym->as->rank = e->rank;
10658 tmp->n.sym->attr.allocatable = 1;
10659 tmp->n.sym->attr.dimension = 1;
10660 }
10661 else
10662 tmp->n.sym->attr.dimension = 0;
10663
10664 gfc_set_sym_referenced (tmp->n.sym);
10665 gfc_commit_symbol (tmp->n.sym);
10666 e = gfc_lval_expr_from_sym (tmp->n.sym);
10667
10668 /* Should the lhs be a section, use its array ref for the
10669 temporary expression. */
10670 if (aref && aref->type != AR_FULL)
10671 {
10672 gfc_free_ref_list (e->ref);
10673 e->ref = gfc_copy_ref (ref);
10674 }
10675 return e;
10676 }
10677
10678
10679 /* Add one line of code to the code chain, making sure that 'head' and
10680 'tail' are appropriately updated. */
10681
10682 static void
add_code_to_chain(gfc_code ** this_code,gfc_code ** head,gfc_code ** tail)10683 add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
10684 {
10685 gcc_assert (this_code);
10686 if (*head == NULL)
10687 *head = *tail = *this_code;
10688 else
10689 *tail = gfc_append_code (*tail, *this_code);
10690 *this_code = NULL;
10691 }
10692
10693
10694 /* Counts the potential number of part array references that would
10695 result from resolution of typebound defined assignments. */
10696
10697 static int
nonscalar_typebound_assign(gfc_symbol * derived,int depth)10698 nonscalar_typebound_assign (gfc_symbol *derived, int depth)
10699 {
10700 gfc_component *c;
10701 int c_depth = 0, t_depth;
10702
10703 for (c= derived->components; c; c = c->next)
10704 {
10705 if ((!gfc_bt_struct (c->ts.type)
10706 || c->attr.pointer
10707 || c->attr.allocatable
10708 || c->attr.proc_pointer_comp
10709 || c->attr.class_pointer
10710 || c->attr.proc_pointer)
10711 && !c->attr.defined_assign_comp)
10712 continue;
10713
10714 if (c->as && c_depth == 0)
10715 c_depth = 1;
10716
10717 if (c->ts.u.derived->attr.defined_assign_comp)
10718 t_depth = nonscalar_typebound_assign (c->ts.u.derived,
10719 c->as ? 1 : 0);
10720 else
10721 t_depth = 0;
10722
10723 c_depth = t_depth > c_depth ? t_depth : c_depth;
10724 }
10725 return depth + c_depth;
10726 }
10727
10728
10729 /* Implement 7.2.1.3 of the F08 standard:
10730 "An intrinsic assignment where the variable is of derived type is
10731 performed as if each component of the variable were assigned from the
10732 corresponding component of expr using pointer assignment (7.2.2) for
10733 each pointer component, defined assignment for each nonpointer
10734 nonallocatable component of a type that has a type-bound defined
10735 assignment consistent with the component, intrinsic assignment for
10736 each other nonpointer nonallocatable component, ..."
10737
10738 The pointer assignments are taken care of by the intrinsic
10739 assignment of the structure itself. This function recursively adds
10740 defined assignments where required. The recursion is accomplished
10741 by calling gfc_resolve_code.
10742
10743 When the lhs in a defined assignment has intent INOUT, we need a
10744 temporary for the lhs. In pseudo-code:
10745
10746 ! Only call function lhs once.
10747 if (lhs is not a constant or an variable)
10748 temp_x = expr2
10749 expr2 => temp_x
10750 ! Do the intrinsic assignment
10751 expr1 = expr2
10752 ! Now do the defined assignments
10753 do over components with typebound defined assignment [%cmp]
10754 #if one component's assignment procedure is INOUT
10755 t1 = expr1
10756 #if expr2 non-variable
10757 temp_x = expr2
10758 expr2 => temp_x
10759 # endif
10760 expr1 = expr2
10761 # for each cmp
10762 t1%cmp {defined=} expr2%cmp
10763 expr1%cmp = t1%cmp
10764 #else
10765 expr1 = expr2
10766
10767 # for each cmp
10768 expr1%cmp {defined=} expr2%cmp
10769 #endif
10770 */
10771
10772 /* The temporary assignments have to be put on top of the additional
10773 code to avoid the result being changed by the intrinsic assignment.
10774 */
10775 static int component_assignment_level = 0;
10776 static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
10777
10778 static void
generate_component_assignments(gfc_code ** code,gfc_namespace * ns)10779 generate_component_assignments (gfc_code **code, gfc_namespace *ns)
10780 {
10781 gfc_component *comp1, *comp2;
10782 gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
10783 gfc_expr *t1;
10784 int error_count, depth;
10785
10786 gfc_get_errors (NULL, &error_count);
10787
10788 /* Filter out continuing processing after an error. */
10789 if (error_count
10790 || (*code)->expr1->ts.type != BT_DERIVED
10791 || (*code)->expr2->ts.type != BT_DERIVED)
10792 return;
10793
10794 /* TODO: Handle more than one part array reference in assignments. */
10795 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
10796 (*code)->expr1->rank ? 1 : 0);
10797 if (depth > 1)
10798 {
10799 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10800 "done because multiple part array references would "
10801 "occur in intermediate expressions.", &(*code)->loc);
10802 return;
10803 }
10804
10805 component_assignment_level++;
10806
10807 /* Create a temporary so that functions get called only once. */
10808 if ((*code)->expr2->expr_type != EXPR_VARIABLE
10809 && (*code)->expr2->expr_type != EXPR_CONSTANT)
10810 {
10811 gfc_expr *tmp_expr;
10812
10813 /* Assign the rhs to the temporary. */
10814 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
10815 this_code = build_assignment (EXEC_ASSIGN,
10816 tmp_expr, (*code)->expr2,
10817 NULL, NULL, (*code)->loc);
10818 /* Add the code and substitute the rhs expression. */
10819 add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
10820 gfc_free_expr ((*code)->expr2);
10821 (*code)->expr2 = tmp_expr;
10822 }
10823
10824 /* Do the intrinsic assignment. This is not needed if the lhs is one
10825 of the temporaries generated here, since the intrinsic assignment
10826 to the final result already does this. */
10827 if ((*code)->expr1->symtree->n.sym->name[2] != '@')
10828 {
10829 this_code = build_assignment (EXEC_ASSIGN,
10830 (*code)->expr1, (*code)->expr2,
10831 NULL, NULL, (*code)->loc);
10832 add_code_to_chain (&this_code, &head, &tail);
10833 }
10834
10835 comp1 = (*code)->expr1->ts.u.derived->components;
10836 comp2 = (*code)->expr2->ts.u.derived->components;
10837
10838 t1 = NULL;
10839 for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
10840 {
10841 bool inout = false;
10842
10843 /* The intrinsic assignment does the right thing for pointers
10844 of all kinds and allocatable components. */
10845 if (!gfc_bt_struct (comp1->ts.type)
10846 || comp1->attr.pointer
10847 || comp1->attr.allocatable
10848 || comp1->attr.proc_pointer_comp
10849 || comp1->attr.class_pointer
10850 || comp1->attr.proc_pointer)
10851 continue;
10852
10853 /* Make an assigment for this component. */
10854 this_code = build_assignment (EXEC_ASSIGN,
10855 (*code)->expr1, (*code)->expr2,
10856 comp1, comp2, (*code)->loc);
10857
10858 /* Convert the assignment if there is a defined assignment for
10859 this type. Otherwise, using the call from gfc_resolve_code,
10860 recurse into its components. */
10861 gfc_resolve_code (this_code, ns);
10862
10863 if (this_code->op == EXEC_ASSIGN_CALL)
10864 {
10865 gfc_formal_arglist *dummy_args;
10866 gfc_symbol *rsym;
10867 /* Check that there is a typebound defined assignment. If not,
10868 then this must be a module defined assignment. We cannot
10869 use the defined_assign_comp attribute here because it must
10870 be this derived type that has the defined assignment and not
10871 a parent type. */
10872 if (!(comp1->ts.u.derived->f2k_derived
10873 && comp1->ts.u.derived->f2k_derived
10874 ->tb_op[INTRINSIC_ASSIGN]))
10875 {
10876 gfc_free_statements (this_code);
10877 this_code = NULL;
10878 continue;
10879 }
10880
10881 /* If the first argument of the subroutine has intent INOUT
10882 a temporary must be generated and used instead. */
10883 rsym = this_code->resolved_sym;
10884 dummy_args = gfc_sym_get_dummy_args (rsym);
10885 if (dummy_args
10886 && dummy_args->sym->attr.intent == INTENT_INOUT)
10887 {
10888 gfc_code *temp_code;
10889 inout = true;
10890
10891 /* Build the temporary required for the assignment and put
10892 it at the head of the generated code. */
10893 if (!t1)
10894 {
10895 t1 = get_temp_from_expr ((*code)->expr1, ns);
10896 temp_code = build_assignment (EXEC_ASSIGN,
10897 t1, (*code)->expr1,
10898 NULL, NULL, (*code)->loc);
10899
10900 /* For allocatable LHS, check whether it is allocated. Note
10901 that allocatable components with defined assignment are
10902 not yet support. See PR 57696. */
10903 if ((*code)->expr1->symtree->n.sym->attr.allocatable)
10904 {
10905 gfc_code *block;
10906 gfc_expr *e =
10907 gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10908 block = gfc_get_code (EXEC_IF);
10909 block->block = gfc_get_code (EXEC_IF);
10910 block->block->expr1
10911 = gfc_build_intrinsic_call (ns,
10912 GFC_ISYM_ALLOCATED, "allocated",
10913 (*code)->loc, 1, e);
10914 block->block->next = temp_code;
10915 temp_code = block;
10916 }
10917 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
10918 }
10919
10920 /* Replace the first actual arg with the component of the
10921 temporary. */
10922 gfc_free_expr (this_code->ext.actual->expr);
10923 this_code->ext.actual->expr = gfc_copy_expr (t1);
10924 add_comp_ref (this_code->ext.actual->expr, comp1);
10925
10926 /* If the LHS variable is allocatable and wasn't allocated and
10927 the temporary is allocatable, pointer assign the address of
10928 the freshly allocated LHS to the temporary. */
10929 if ((*code)->expr1->symtree->n.sym->attr.allocatable
10930 && gfc_expr_attr ((*code)->expr1).allocatable)
10931 {
10932 gfc_code *block;
10933 gfc_expr *cond;
10934
10935 cond = gfc_get_expr ();
10936 cond->ts.type = BT_LOGICAL;
10937 cond->ts.kind = gfc_default_logical_kind;
10938 cond->expr_type = EXPR_OP;
10939 cond->where = (*code)->loc;
10940 cond->value.op.op = INTRINSIC_NOT;
10941 cond->value.op.op1 = gfc_build_intrinsic_call (ns,
10942 GFC_ISYM_ALLOCATED, "allocated",
10943 (*code)->loc, 1, gfc_copy_expr (t1));
10944 block = gfc_get_code (EXEC_IF);
10945 block->block = gfc_get_code (EXEC_IF);
10946 block->block->expr1 = cond;
10947 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10948 t1, (*code)->expr1,
10949 NULL, NULL, (*code)->loc);
10950 add_code_to_chain (&block, &head, &tail);
10951 }
10952 }
10953 }
10954 else if (this_code->op == EXEC_ASSIGN && !this_code->next)
10955 {
10956 /* Don't add intrinsic assignments since they are already
10957 effected by the intrinsic assignment of the structure. */
10958 gfc_free_statements (this_code);
10959 this_code = NULL;
10960 continue;
10961 }
10962
10963 add_code_to_chain (&this_code, &head, &tail);
10964
10965 if (t1 && inout)
10966 {
10967 /* Transfer the value to the final result. */
10968 this_code = build_assignment (EXEC_ASSIGN,
10969 (*code)->expr1, t1,
10970 comp1, comp2, (*code)->loc);
10971 add_code_to_chain (&this_code, &head, &tail);
10972 }
10973 }
10974
10975 /* Put the temporary assignments at the top of the generated code. */
10976 if (tmp_head && component_assignment_level == 1)
10977 {
10978 gfc_append_code (tmp_head, head);
10979 head = tmp_head;
10980 tmp_head = tmp_tail = NULL;
10981 }
10982
10983 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10984 // not accidentally deallocated. Hence, nullify t1.
10985 if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
10986 && gfc_expr_attr ((*code)->expr1).allocatable)
10987 {
10988 gfc_code *block;
10989 gfc_expr *cond;
10990 gfc_expr *e;
10991
10992 e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10993 cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
10994 (*code)->loc, 2, gfc_copy_expr (t1), e);
10995 block = gfc_get_code (EXEC_IF);
10996 block->block = gfc_get_code (EXEC_IF);
10997 block->block->expr1 = cond;
10998 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10999 t1, gfc_get_null_expr (&(*code)->loc),
11000 NULL, NULL, (*code)->loc);
11001 gfc_append_code (tail, block);
11002 tail = block;
11003 }
11004
11005 /* Now attach the remaining code chain to the input code. Step on
11006 to the end of the new code since resolution is complete. */
11007 gcc_assert ((*code)->op == EXEC_ASSIGN);
11008 tail->next = (*code)->next;
11009 /* Overwrite 'code' because this would place the intrinsic assignment
11010 before the temporary for the lhs is created. */
11011 gfc_free_expr ((*code)->expr1);
11012 gfc_free_expr ((*code)->expr2);
11013 **code = *head;
11014 if (head != tail)
11015 free (head);
11016 *code = tail;
11017
11018 component_assignment_level--;
11019 }
11020
11021
11022 /* F2008: Pointer function assignments are of the form:
11023 ptr_fcn (args) = expr
11024 This function breaks these assignments into two statements:
11025 temporary_pointer => ptr_fcn(args)
11026 temporary_pointer = expr */
11027
11028 static bool
resolve_ptr_fcn_assign(gfc_code ** code,gfc_namespace * ns)11029 resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
11030 {
11031 gfc_expr *tmp_ptr_expr;
11032 gfc_code *this_code;
11033 gfc_component *comp;
11034 gfc_symbol *s;
11035
11036 if ((*code)->expr1->expr_type != EXPR_FUNCTION)
11037 return false;
11038
11039 /* Even if standard does not support this feature, continue to build
11040 the two statements to avoid upsetting frontend_passes.c. */
11041 gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
11042 "%L", &(*code)->loc);
11043
11044 comp = gfc_get_proc_ptr_comp ((*code)->expr1);
11045
11046 if (comp)
11047 s = comp->ts.interface;
11048 else
11049 s = (*code)->expr1->symtree->n.sym;
11050
11051 if (s == NULL || !s->result->attr.pointer)
11052 {
11053 gfc_error ("The function result on the lhs of the assignment at "
11054 "%L must have the pointer attribute.",
11055 &(*code)->expr1->where);
11056 (*code)->op = EXEC_NOP;
11057 return false;
11058 }
11059
11060 tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns);
11061
11062 /* get_temp_from_expression is set up for ordinary assignments. To that
11063 end, where array bounds are not known, arrays are made allocatable.
11064 Change the temporary to a pointer here. */
11065 tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
11066 tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
11067 tmp_ptr_expr->where = (*code)->loc;
11068
11069 this_code = build_assignment (EXEC_ASSIGN,
11070 tmp_ptr_expr, (*code)->expr2,
11071 NULL, NULL, (*code)->loc);
11072 this_code->next = (*code)->next;
11073 (*code)->next = this_code;
11074 (*code)->op = EXEC_POINTER_ASSIGN;
11075 (*code)->expr2 = (*code)->expr1;
11076 (*code)->expr1 = tmp_ptr_expr;
11077
11078 return true;
11079 }
11080
11081
11082 /* Deferred character length assignments from an operator expression
11083 require a temporary because the character length of the lhs can
11084 change in the course of the assignment. */
11085
11086 static bool
deferred_op_assign(gfc_code ** code,gfc_namespace * ns)11087 deferred_op_assign (gfc_code **code, gfc_namespace *ns)
11088 {
11089 gfc_expr *tmp_expr;
11090 gfc_code *this_code;
11091
11092 if (!((*code)->expr1->ts.type == BT_CHARACTER
11093 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
11094 && (*code)->expr2->expr_type == EXPR_OP))
11095 return false;
11096
11097 if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
11098 return false;
11099
11100 if (gfc_expr_attr ((*code)->expr1).pointer)
11101 return false;
11102
11103 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
11104 tmp_expr->where = (*code)->loc;
11105
11106 /* A new charlen is required to ensure that the variable string
11107 length is different to that of the original lhs. */
11108 tmp_expr->ts.u.cl = gfc_get_charlen();
11109 tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
11110 tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
11111 (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
11112
11113 tmp_expr->symtree->n.sym->ts.deferred = 1;
11114
11115 this_code = build_assignment (EXEC_ASSIGN,
11116 (*code)->expr1,
11117 gfc_copy_expr (tmp_expr),
11118 NULL, NULL, (*code)->loc);
11119
11120 (*code)->expr1 = tmp_expr;
11121
11122 this_code->next = (*code)->next;
11123 (*code)->next = this_code;
11124
11125 return true;
11126 }
11127
11128
11129 /* Given a block of code, recursively resolve everything pointed to by this
11130 code block. */
11131
11132 void
gfc_resolve_code(gfc_code * code,gfc_namespace * ns)11133 gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
11134 {
11135 int omp_workshare_save;
11136 int forall_save, do_concurrent_save;
11137 code_stack frame;
11138 bool t;
11139
11140 frame.prev = cs_base;
11141 frame.head = code;
11142 cs_base = &frame;
11143
11144 find_reachable_labels (code);
11145
11146 for (; code; code = code->next)
11147 {
11148 frame.current = code;
11149 forall_save = forall_flag;
11150 do_concurrent_save = gfc_do_concurrent_flag;
11151
11152 if (code->op == EXEC_FORALL)
11153 {
11154 forall_flag = 1;
11155 gfc_resolve_forall (code, ns, forall_save);
11156 forall_flag = 2;
11157 }
11158 else if (code->block)
11159 {
11160 omp_workshare_save = -1;
11161 switch (code->op)
11162 {
11163 case EXEC_OACC_PARALLEL_LOOP:
11164 case EXEC_OACC_PARALLEL:
11165 case EXEC_OACC_KERNELS_LOOP:
11166 case EXEC_OACC_KERNELS:
11167 case EXEC_OACC_DATA:
11168 case EXEC_OACC_HOST_DATA:
11169 case EXEC_OACC_LOOP:
11170 gfc_resolve_oacc_blocks (code, ns);
11171 break;
11172 case EXEC_OMP_PARALLEL_WORKSHARE:
11173 omp_workshare_save = omp_workshare_flag;
11174 omp_workshare_flag = 1;
11175 gfc_resolve_omp_parallel_blocks (code, ns);
11176 break;
11177 case EXEC_OMP_PARALLEL:
11178 case EXEC_OMP_PARALLEL_DO:
11179 case EXEC_OMP_PARALLEL_DO_SIMD:
11180 case EXEC_OMP_PARALLEL_SECTIONS:
11181 case EXEC_OMP_TARGET_PARALLEL:
11182 case EXEC_OMP_TARGET_PARALLEL_DO:
11183 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11184 case EXEC_OMP_TARGET_TEAMS:
11185 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11186 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11187 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11188 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11189 case EXEC_OMP_TASK:
11190 case EXEC_OMP_TASKLOOP:
11191 case EXEC_OMP_TASKLOOP_SIMD:
11192 case EXEC_OMP_TEAMS:
11193 case EXEC_OMP_TEAMS_DISTRIBUTE:
11194 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11195 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11196 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11197 omp_workshare_save = omp_workshare_flag;
11198 omp_workshare_flag = 0;
11199 gfc_resolve_omp_parallel_blocks (code, ns);
11200 break;
11201 case EXEC_OMP_DISTRIBUTE:
11202 case EXEC_OMP_DISTRIBUTE_SIMD:
11203 case EXEC_OMP_DO:
11204 case EXEC_OMP_DO_SIMD:
11205 case EXEC_OMP_SIMD:
11206 case EXEC_OMP_TARGET_SIMD:
11207 gfc_resolve_omp_do_blocks (code, ns);
11208 break;
11209 case EXEC_SELECT_TYPE:
11210 /* Blocks are handled in resolve_select_type because we have
11211 to transform the SELECT TYPE into ASSOCIATE first. */
11212 break;
11213 case EXEC_DO_CONCURRENT:
11214 gfc_do_concurrent_flag = 1;
11215 gfc_resolve_blocks (code->block, ns);
11216 gfc_do_concurrent_flag = 2;
11217 break;
11218 case EXEC_OMP_WORKSHARE:
11219 omp_workshare_save = omp_workshare_flag;
11220 omp_workshare_flag = 1;
11221 /* FALL THROUGH */
11222 default:
11223 gfc_resolve_blocks (code->block, ns);
11224 break;
11225 }
11226
11227 if (omp_workshare_save != -1)
11228 omp_workshare_flag = omp_workshare_save;
11229 }
11230 start:
11231 t = true;
11232 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
11233 t = gfc_resolve_expr (code->expr1);
11234 forall_flag = forall_save;
11235 gfc_do_concurrent_flag = do_concurrent_save;
11236
11237 if (!gfc_resolve_expr (code->expr2))
11238 t = false;
11239
11240 if (code->op == EXEC_ALLOCATE
11241 && !gfc_resolve_expr (code->expr3))
11242 t = false;
11243
11244 switch (code->op)
11245 {
11246 case EXEC_NOP:
11247 case EXEC_END_BLOCK:
11248 case EXEC_END_NESTED_BLOCK:
11249 case EXEC_CYCLE:
11250 case EXEC_PAUSE:
11251 case EXEC_STOP:
11252 case EXEC_ERROR_STOP:
11253 case EXEC_EXIT:
11254 case EXEC_CONTINUE:
11255 case EXEC_DT_END:
11256 case EXEC_ASSIGN_CALL:
11257 break;
11258
11259 case EXEC_CRITICAL:
11260 resolve_critical (code);
11261 break;
11262
11263 case EXEC_SYNC_ALL:
11264 case EXEC_SYNC_IMAGES:
11265 case EXEC_SYNC_MEMORY:
11266 resolve_sync (code);
11267 break;
11268
11269 case EXEC_LOCK:
11270 case EXEC_UNLOCK:
11271 case EXEC_EVENT_POST:
11272 case EXEC_EVENT_WAIT:
11273 resolve_lock_unlock_event (code);
11274 break;
11275
11276 case EXEC_FAIL_IMAGE:
11277 case EXEC_FORM_TEAM:
11278 case EXEC_CHANGE_TEAM:
11279 case EXEC_END_TEAM:
11280 case EXEC_SYNC_TEAM:
11281 break;
11282
11283 case EXEC_ENTRY:
11284 /* Keep track of which entry we are up to. */
11285 current_entry_id = code->ext.entry->id;
11286 break;
11287
11288 case EXEC_WHERE:
11289 resolve_where (code, NULL);
11290 break;
11291
11292 case EXEC_GOTO:
11293 if (code->expr1 != NULL)
11294 {
11295 if (code->expr1->ts.type != BT_INTEGER)
11296 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11297 "INTEGER variable", &code->expr1->where);
11298 else if (code->expr1->symtree->n.sym->attr.assign != 1)
11299 gfc_error ("Variable %qs has not been assigned a target "
11300 "label at %L", code->expr1->symtree->n.sym->name,
11301 &code->expr1->where);
11302 }
11303 else
11304 resolve_branch (code->label1, code);
11305 break;
11306
11307 case EXEC_RETURN:
11308 if (code->expr1 != NULL
11309 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
11310 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11311 "INTEGER return specifier", &code->expr1->where);
11312 break;
11313
11314 case EXEC_INIT_ASSIGN:
11315 case EXEC_END_PROCEDURE:
11316 break;
11317
11318 case EXEC_ASSIGN:
11319 if (!t)
11320 break;
11321
11322 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11323 the LHS. */
11324 if (code->expr1->expr_type == EXPR_FUNCTION
11325 && code->expr1->value.function.isym
11326 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
11327 remove_caf_get_intrinsic (code->expr1);
11328
11329 /* If this is a pointer function in an lvalue variable context,
11330 the new code will have to be resolved afresh. This is also the
11331 case with an error, where the code is transformed into NOP to
11332 prevent ICEs downstream. */
11333 if (resolve_ptr_fcn_assign (&code, ns)
11334 || code->op == EXEC_NOP)
11335 goto start;
11336
11337 if (!gfc_check_vardef_context (code->expr1, false, false, false,
11338 _("assignment")))
11339 break;
11340
11341 if (resolve_ordinary_assign (code, ns))
11342 {
11343 if (code->op == EXEC_COMPCALL)
11344 goto compcall;
11345 else
11346 goto call;
11347 }
11348
11349 /* Check for dependencies in deferred character length array
11350 assignments and generate a temporary, if necessary. */
11351 if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
11352 break;
11353
11354 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11355 if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
11356 && code->expr1->ts.u.derived
11357 && code->expr1->ts.u.derived->attr.defined_assign_comp)
11358 generate_component_assignments (&code, ns);
11359
11360 break;
11361
11362 case EXEC_LABEL_ASSIGN:
11363 if (code->label1->defined == ST_LABEL_UNKNOWN)
11364 gfc_error ("Label %d referenced at %L is never defined",
11365 code->label1->value, &code->label1->where);
11366 if (t
11367 && (code->expr1->expr_type != EXPR_VARIABLE
11368 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
11369 || code->expr1->symtree->n.sym->ts.kind
11370 != gfc_default_integer_kind
11371 || code->expr1->symtree->n.sym->as != NULL))
11372 gfc_error ("ASSIGN statement at %L requires a scalar "
11373 "default INTEGER variable", &code->expr1->where);
11374 break;
11375
11376 case EXEC_POINTER_ASSIGN:
11377 {
11378 gfc_expr* e;
11379
11380 if (!t)
11381 break;
11382
11383 /* This is both a variable definition and pointer assignment
11384 context, so check both of them. For rank remapping, a final
11385 array ref may be present on the LHS and fool gfc_expr_attr
11386 used in gfc_check_vardef_context. Remove it. */
11387 e = remove_last_array_ref (code->expr1);
11388 t = gfc_check_vardef_context (e, true, false, false,
11389 _("pointer assignment"));
11390 if (t)
11391 t = gfc_check_vardef_context (e, false, false, false,
11392 _("pointer assignment"));
11393 gfc_free_expr (e);
11394 if (!t)
11395 break;
11396
11397 gfc_check_pointer_assign (code->expr1, code->expr2);
11398
11399 /* Assigning a class object always is a regular assign. */
11400 if (code->expr2->ts.type == BT_CLASS
11401 && code->expr1->ts.type == BT_CLASS
11402 && !CLASS_DATA (code->expr2)->attr.dimension
11403 && !(gfc_expr_attr (code->expr1).proc_pointer
11404 && code->expr2->expr_type == EXPR_VARIABLE
11405 && code->expr2->symtree->n.sym->attr.flavor
11406 == FL_PROCEDURE))
11407 code->op = EXEC_ASSIGN;
11408 break;
11409 }
11410
11411 case EXEC_ARITHMETIC_IF:
11412 {
11413 gfc_expr *e = code->expr1;
11414
11415 gfc_resolve_expr (e);
11416 if (e->expr_type == EXPR_NULL)
11417 gfc_error ("Invalid NULL at %L", &e->where);
11418
11419 if (t && (e->rank > 0
11420 || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
11421 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11422 "REAL or INTEGER expression", &e->where);
11423
11424 resolve_branch (code->label1, code);
11425 resolve_branch (code->label2, code);
11426 resolve_branch (code->label3, code);
11427 }
11428 break;
11429
11430 case EXEC_IF:
11431 if (t && code->expr1 != NULL
11432 && (code->expr1->ts.type != BT_LOGICAL
11433 || code->expr1->rank != 0))
11434 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11435 &code->expr1->where);
11436 break;
11437
11438 case EXEC_CALL:
11439 call:
11440 resolve_call (code);
11441 break;
11442
11443 case EXEC_COMPCALL:
11444 compcall:
11445 resolve_typebound_subroutine (code);
11446 break;
11447
11448 case EXEC_CALL_PPC:
11449 resolve_ppc_call (code);
11450 break;
11451
11452 case EXEC_SELECT:
11453 /* Select is complicated. Also, a SELECT construct could be
11454 a transformed computed GOTO. */
11455 resolve_select (code, false);
11456 break;
11457
11458 case EXEC_SELECT_TYPE:
11459 resolve_select_type (code, ns);
11460 break;
11461
11462 case EXEC_BLOCK:
11463 resolve_block_construct (code);
11464 break;
11465
11466 case EXEC_DO:
11467 if (code->ext.iterator != NULL)
11468 {
11469 gfc_iterator *iter = code->ext.iterator;
11470 if (gfc_resolve_iterator (iter, true, false))
11471 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
11472 true);
11473 }
11474 break;
11475
11476 case EXEC_DO_WHILE:
11477 if (code->expr1 == NULL)
11478 gfc_internal_error ("gfc_resolve_code(): No expression on "
11479 "DO WHILE");
11480 if (t
11481 && (code->expr1->rank != 0
11482 || code->expr1->ts.type != BT_LOGICAL))
11483 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11484 "a scalar LOGICAL expression", &code->expr1->where);
11485 break;
11486
11487 case EXEC_ALLOCATE:
11488 if (t)
11489 resolve_allocate_deallocate (code, "ALLOCATE");
11490
11491 break;
11492
11493 case EXEC_DEALLOCATE:
11494 if (t)
11495 resolve_allocate_deallocate (code, "DEALLOCATE");
11496
11497 break;
11498
11499 case EXEC_OPEN:
11500 if (!gfc_resolve_open (code->ext.open))
11501 break;
11502
11503 resolve_branch (code->ext.open->err, code);
11504 break;
11505
11506 case EXEC_CLOSE:
11507 if (!gfc_resolve_close (code->ext.close))
11508 break;
11509
11510 resolve_branch (code->ext.close->err, code);
11511 break;
11512
11513 case EXEC_BACKSPACE:
11514 case EXEC_ENDFILE:
11515 case EXEC_REWIND:
11516 case EXEC_FLUSH:
11517 if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
11518 break;
11519
11520 resolve_branch (code->ext.filepos->err, code);
11521 break;
11522
11523 case EXEC_INQUIRE:
11524 if (!gfc_resolve_inquire (code->ext.inquire))
11525 break;
11526
11527 resolve_branch (code->ext.inquire->err, code);
11528 break;
11529
11530 case EXEC_IOLENGTH:
11531 gcc_assert (code->ext.inquire != NULL);
11532 if (!gfc_resolve_inquire (code->ext.inquire))
11533 break;
11534
11535 resolve_branch (code->ext.inquire->err, code);
11536 break;
11537
11538 case EXEC_WAIT:
11539 if (!gfc_resolve_wait (code->ext.wait))
11540 break;
11541
11542 resolve_branch (code->ext.wait->err, code);
11543 resolve_branch (code->ext.wait->end, code);
11544 resolve_branch (code->ext.wait->eor, code);
11545 break;
11546
11547 case EXEC_READ:
11548 case EXEC_WRITE:
11549 if (!gfc_resolve_dt (code->ext.dt, &code->loc))
11550 break;
11551
11552 resolve_branch (code->ext.dt->err, code);
11553 resolve_branch (code->ext.dt->end, code);
11554 resolve_branch (code->ext.dt->eor, code);
11555 break;
11556
11557 case EXEC_TRANSFER:
11558 resolve_transfer (code);
11559 break;
11560
11561 case EXEC_DO_CONCURRENT:
11562 case EXEC_FORALL:
11563 resolve_forall_iterators (code->ext.forall_iterator);
11564
11565 if (code->expr1 != NULL
11566 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
11567 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11568 "expression", &code->expr1->where);
11569 break;
11570
11571 case EXEC_OACC_PARALLEL_LOOP:
11572 case EXEC_OACC_PARALLEL:
11573 case EXEC_OACC_KERNELS_LOOP:
11574 case EXEC_OACC_KERNELS:
11575 case EXEC_OACC_DATA:
11576 case EXEC_OACC_HOST_DATA:
11577 case EXEC_OACC_LOOP:
11578 case EXEC_OACC_UPDATE:
11579 case EXEC_OACC_WAIT:
11580 case EXEC_OACC_CACHE:
11581 case EXEC_OACC_ENTER_DATA:
11582 case EXEC_OACC_EXIT_DATA:
11583 case EXEC_OACC_ATOMIC:
11584 case EXEC_OACC_DECLARE:
11585 gfc_resolve_oacc_directive (code, ns);
11586 break;
11587
11588 case EXEC_OMP_ATOMIC:
11589 case EXEC_OMP_BARRIER:
11590 case EXEC_OMP_CANCEL:
11591 case EXEC_OMP_CANCELLATION_POINT:
11592 case EXEC_OMP_CRITICAL:
11593 case EXEC_OMP_FLUSH:
11594 case EXEC_OMP_DISTRIBUTE:
11595 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11596 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11597 case EXEC_OMP_DISTRIBUTE_SIMD:
11598 case EXEC_OMP_DO:
11599 case EXEC_OMP_DO_SIMD:
11600 case EXEC_OMP_MASTER:
11601 case EXEC_OMP_ORDERED:
11602 case EXEC_OMP_SECTIONS:
11603 case EXEC_OMP_SIMD:
11604 case EXEC_OMP_SINGLE:
11605 case EXEC_OMP_TARGET:
11606 case EXEC_OMP_TARGET_DATA:
11607 case EXEC_OMP_TARGET_ENTER_DATA:
11608 case EXEC_OMP_TARGET_EXIT_DATA:
11609 case EXEC_OMP_TARGET_PARALLEL:
11610 case EXEC_OMP_TARGET_PARALLEL_DO:
11611 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11612 case EXEC_OMP_TARGET_SIMD:
11613 case EXEC_OMP_TARGET_TEAMS:
11614 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11615 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11616 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11617 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11618 case EXEC_OMP_TARGET_UPDATE:
11619 case EXEC_OMP_TASK:
11620 case EXEC_OMP_TASKGROUP:
11621 case EXEC_OMP_TASKLOOP:
11622 case EXEC_OMP_TASKLOOP_SIMD:
11623 case EXEC_OMP_TASKWAIT:
11624 case EXEC_OMP_TASKYIELD:
11625 case EXEC_OMP_TEAMS:
11626 case EXEC_OMP_TEAMS_DISTRIBUTE:
11627 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11628 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11629 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11630 case EXEC_OMP_WORKSHARE:
11631 gfc_resolve_omp_directive (code, ns);
11632 break;
11633
11634 case EXEC_OMP_PARALLEL:
11635 case EXEC_OMP_PARALLEL_DO:
11636 case EXEC_OMP_PARALLEL_DO_SIMD:
11637 case EXEC_OMP_PARALLEL_SECTIONS:
11638 case EXEC_OMP_PARALLEL_WORKSHARE:
11639 omp_workshare_save = omp_workshare_flag;
11640 omp_workshare_flag = 0;
11641 gfc_resolve_omp_directive (code, ns);
11642 omp_workshare_flag = omp_workshare_save;
11643 break;
11644
11645 default:
11646 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11647 }
11648 }
11649
11650 cs_base = frame.prev;
11651 }
11652
11653
11654 /* Resolve initial values and make sure they are compatible with
11655 the variable. */
11656
11657 static void
resolve_values(gfc_symbol * sym)11658 resolve_values (gfc_symbol *sym)
11659 {
11660 bool t;
11661
11662 if (sym->value == NULL)
11663 return;
11664
11665 if (sym->value->expr_type == EXPR_STRUCTURE)
11666 t= resolve_structure_cons (sym->value, 1);
11667 else
11668 t = gfc_resolve_expr (sym->value);
11669
11670 if (!t)
11671 return;
11672
11673 gfc_check_assign_symbol (sym, NULL, sym->value);
11674 }
11675
11676
11677 /* Verify any BIND(C) derived types in the namespace so we can report errors
11678 for them once, rather than for each variable declared of that type. */
11679
11680 static void
resolve_bind_c_derived_types(gfc_symbol * derived_sym)11681 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
11682 {
11683 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
11684 && derived_sym->attr.is_bind_c == 1)
11685 verify_bind_c_derived_type (derived_sym);
11686
11687 return;
11688 }
11689
11690
11691 /* Check the interfaces of DTIO procedures associated with derived
11692 type 'sym'. These procedures can either have typebound bindings or
11693 can appear in DTIO generic interfaces. */
11694
11695 static void
gfc_verify_DTIO_procedures(gfc_symbol * sym)11696 gfc_verify_DTIO_procedures (gfc_symbol *sym)
11697 {
11698 if (!sym || sym->attr.flavor != FL_DERIVED)
11699 return;
11700
11701 gfc_check_dtio_interfaces (sym);
11702
11703 return;
11704 }
11705
11706 /* Verify that any binding labels used in a given namespace do not collide
11707 with the names or binding labels of any global symbols. Multiple INTERFACE
11708 for the same procedure are permitted. */
11709
11710 static void
gfc_verify_binding_labels(gfc_symbol * sym)11711 gfc_verify_binding_labels (gfc_symbol *sym)
11712 {
11713 gfc_gsymbol *gsym;
11714 const char *module;
11715
11716 if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
11717 || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
11718 return;
11719
11720 gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
11721
11722 if (sym->module)
11723 module = sym->module;
11724 else if (sym->ns && sym->ns->proc_name
11725 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11726 module = sym->ns->proc_name->name;
11727 else if (sym->ns && sym->ns->parent
11728 && sym->ns && sym->ns->parent->proc_name
11729 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
11730 module = sym->ns->parent->proc_name->name;
11731 else
11732 module = NULL;
11733
11734 if (!gsym
11735 || (!gsym->defined
11736 && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
11737 {
11738 if (!gsym)
11739 gsym = gfc_get_gsymbol (sym->binding_label, true);
11740 gsym->where = sym->declared_at;
11741 gsym->sym_name = sym->name;
11742 gsym->binding_label = sym->binding_label;
11743 gsym->ns = sym->ns;
11744 gsym->mod_name = module;
11745 if (sym->attr.function)
11746 gsym->type = GSYM_FUNCTION;
11747 else if (sym->attr.subroutine)
11748 gsym->type = GSYM_SUBROUTINE;
11749 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11750 gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
11751 return;
11752 }
11753
11754 if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
11755 {
11756 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11757 "identifier as entity at %L", sym->name,
11758 sym->binding_label, &sym->declared_at, &gsym->where);
11759 /* Clear the binding label to prevent checking multiple times. */
11760 sym->binding_label = NULL;
11761
11762 }
11763 else if (sym->attr.flavor == FL_VARIABLE && module
11764 && (strcmp (module, gsym->mod_name) != 0
11765 || strcmp (sym->name, gsym->sym_name) != 0))
11766 {
11767 /* This can only happen if the variable is defined in a module - if it
11768 isn't the same module, reject it. */
11769 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11770 "uses the same global identifier as entity at %L from module %qs",
11771 sym->name, module, sym->binding_label,
11772 &sym->declared_at, &gsym->where, gsym->mod_name);
11773 sym->binding_label = NULL;
11774 }
11775 else if ((sym->attr.function || sym->attr.subroutine)
11776 && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
11777 || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
11778 && sym != gsym->ns->proc_name
11779 && (module != gsym->mod_name
11780 || strcmp (gsym->sym_name, sym->name) != 0
11781 || (module && strcmp (module, gsym->mod_name) != 0)))
11782 {
11783 /* Print an error if the procedure is defined multiple times; we have to
11784 exclude references to the same procedure via module association or
11785 multiple checks for the same procedure. */
11786 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11787 "global identifier as entity at %L", sym->name,
11788 sym->binding_label, &sym->declared_at, &gsym->where);
11789 sym->binding_label = NULL;
11790 }
11791 }
11792
11793
11794 /* Resolve an index expression. */
11795
11796 static bool
resolve_index_expr(gfc_expr * e)11797 resolve_index_expr (gfc_expr *e)
11798 {
11799 if (!gfc_resolve_expr (e))
11800 return false;
11801
11802 if (!gfc_simplify_expr (e, 0))
11803 return false;
11804
11805 if (!gfc_specification_expr (e))
11806 return false;
11807
11808 return true;
11809 }
11810
11811
11812 /* Resolve a charlen structure. */
11813
11814 static bool
resolve_charlen(gfc_charlen * cl)11815 resolve_charlen (gfc_charlen *cl)
11816 {
11817 int k;
11818 bool saved_specification_expr;
11819
11820 if (cl->resolved)
11821 return true;
11822
11823 cl->resolved = 1;
11824 saved_specification_expr = specification_expr;
11825 specification_expr = true;
11826
11827 if (cl->length_from_typespec)
11828 {
11829 if (!gfc_resolve_expr (cl->length))
11830 {
11831 specification_expr = saved_specification_expr;
11832 return false;
11833 }
11834
11835 if (!gfc_simplify_expr (cl->length, 0))
11836 {
11837 specification_expr = saved_specification_expr;
11838 return false;
11839 }
11840
11841 /* cl->length has been resolved. It should have an integer type. */
11842 if (cl->length->ts.type != BT_INTEGER)
11843 {
11844 gfc_error ("Scalar INTEGER expression expected at %L",
11845 &cl->length->where);
11846 return false;
11847 }
11848 }
11849 else
11850 {
11851 if (!resolve_index_expr (cl->length))
11852 {
11853 specification_expr = saved_specification_expr;
11854 return false;
11855 }
11856 }
11857
11858 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11859 a negative value, the length of character entities declared is zero. */
11860 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
11861 && mpz_sgn (cl->length->value.integer) < 0)
11862 gfc_replace_expr (cl->length,
11863 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
11864
11865 /* Check that the character length is not too large. */
11866 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
11867 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
11868 && cl->length->ts.type == BT_INTEGER
11869 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
11870 {
11871 gfc_error ("String length at %L is too large", &cl->length->where);
11872 specification_expr = saved_specification_expr;
11873 return false;
11874 }
11875
11876 specification_expr = saved_specification_expr;
11877 return true;
11878 }
11879
11880
11881 /* Test for non-constant shape arrays. */
11882
11883 static bool
is_non_constant_shape_array(gfc_symbol * sym)11884 is_non_constant_shape_array (gfc_symbol *sym)
11885 {
11886 gfc_expr *e;
11887 int i;
11888 bool not_constant;
11889
11890 not_constant = false;
11891 if (sym->as != NULL)
11892 {
11893 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11894 has not been simplified; parameter array references. Do the
11895 simplification now. */
11896 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
11897 {
11898 e = sym->as->lower[i];
11899 if (e && (!resolve_index_expr(e)
11900 || !gfc_is_constant_expr (e)))
11901 not_constant = true;
11902 e = sym->as->upper[i];
11903 if (e && (!resolve_index_expr(e)
11904 || !gfc_is_constant_expr (e)))
11905 not_constant = true;
11906 }
11907 }
11908 return not_constant;
11909 }
11910
11911 /* Given a symbol and an initialization expression, add code to initialize
11912 the symbol to the function entry. */
11913 static void
build_init_assign(gfc_symbol * sym,gfc_expr * init)11914 build_init_assign (gfc_symbol *sym, gfc_expr *init)
11915 {
11916 gfc_expr *lval;
11917 gfc_code *init_st;
11918 gfc_namespace *ns = sym->ns;
11919
11920 /* Search for the function namespace if this is a contained
11921 function without an explicit result. */
11922 if (sym->attr.function && sym == sym->result
11923 && sym->name != sym->ns->proc_name->name)
11924 {
11925 ns = ns->contained;
11926 for (;ns; ns = ns->sibling)
11927 if (strcmp (ns->proc_name->name, sym->name) == 0)
11928 break;
11929 }
11930
11931 if (ns == NULL)
11932 {
11933 gfc_free_expr (init);
11934 return;
11935 }
11936
11937 /* Build an l-value expression for the result. */
11938 lval = gfc_lval_expr_from_sym (sym);
11939
11940 /* Add the code at scope entry. */
11941 init_st = gfc_get_code (EXEC_INIT_ASSIGN);
11942 init_st->next = ns->code;
11943 ns->code = init_st;
11944
11945 /* Assign the default initializer to the l-value. */
11946 init_st->loc = sym->declared_at;
11947 init_st->expr1 = lval;
11948 init_st->expr2 = init;
11949 }
11950
11951
11952 /* Whether or not we can generate a default initializer for a symbol. */
11953
11954 static bool
can_generate_init(gfc_symbol * sym)11955 can_generate_init (gfc_symbol *sym)
11956 {
11957 symbol_attribute *a;
11958 if (!sym)
11959 return false;
11960 a = &sym->attr;
11961
11962 /* These symbols should never have a default initialization. */
11963 return !(
11964 a->allocatable
11965 || a->external
11966 || a->pointer
11967 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
11968 && (CLASS_DATA (sym)->attr.class_pointer
11969 || CLASS_DATA (sym)->attr.proc_pointer))
11970 || a->in_equivalence
11971 || a->in_common
11972 || a->data
11973 || sym->module
11974 || a->cray_pointee
11975 || a->cray_pointer
11976 || sym->assoc
11977 || (!a->referenced && !a->result)
11978 || (a->dummy && a->intent != INTENT_OUT)
11979 || (a->function && sym != sym->result)
11980 );
11981 }
11982
11983
11984 /* Assign the default initializer to a derived type variable or result. */
11985
11986 static void
apply_default_init(gfc_symbol * sym)11987 apply_default_init (gfc_symbol *sym)
11988 {
11989 gfc_expr *init = NULL;
11990
11991 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
11992 return;
11993
11994 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
11995 init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
11996
11997 if (init == NULL && sym->ts.type != BT_CLASS)
11998 return;
11999
12000 build_init_assign (sym, init);
12001 sym->attr.referenced = 1;
12002 }
12003
12004
12005 /* Build an initializer for a local. Returns null if the symbol should not have
12006 a default initialization. */
12007
12008 static gfc_expr *
build_default_init_expr(gfc_symbol * sym)12009 build_default_init_expr (gfc_symbol *sym)
12010 {
12011 /* These symbols should never have a default initialization. */
12012 if (sym->attr.allocatable
12013 || sym->attr.external
12014 || sym->attr.dummy
12015 || sym->attr.pointer
12016 || sym->attr.in_equivalence
12017 || sym->attr.in_common
12018 || sym->attr.data
12019 || sym->module
12020 || sym->attr.cray_pointee
12021 || sym->attr.cray_pointer
12022 || sym->assoc)
12023 return NULL;
12024
12025 /* Get the appropriate init expression. */
12026 return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
12027 }
12028
12029 /* Add an initialization expression to a local variable. */
12030 static void
apply_default_init_local(gfc_symbol * sym)12031 apply_default_init_local (gfc_symbol *sym)
12032 {
12033 gfc_expr *init = NULL;
12034
12035 /* The symbol should be a variable or a function return value. */
12036 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
12037 || (sym->attr.function && sym->result != sym))
12038 return;
12039
12040 /* Try to build the initializer expression. If we can't initialize
12041 this symbol, then init will be NULL. */
12042 init = build_default_init_expr (sym);
12043 if (init == NULL)
12044 return;
12045
12046 /* For saved variables, we don't want to add an initializer at function
12047 entry, so we just add a static initializer. Note that automatic variables
12048 are stack allocated even with -fno-automatic; we have also to exclude
12049 result variable, which are also nonstatic. */
12050 if (!sym->attr.automatic
12051 && (sym->attr.save || sym->ns->save_all
12052 || (flag_max_stack_var_size == 0 && !sym->attr.result
12053 && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
12054 && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
12055 {
12056 /* Don't clobber an existing initializer! */
12057 gcc_assert (sym->value == NULL);
12058 sym->value = init;
12059 return;
12060 }
12061
12062 build_init_assign (sym, init);
12063 }
12064
12065
12066 /* Resolution of common features of flavors variable and procedure. */
12067
12068 static bool
resolve_fl_var_and_proc(gfc_symbol * sym,int mp_flag)12069 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
12070 {
12071 gfc_array_spec *as;
12072
12073 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12074 as = CLASS_DATA (sym)->as;
12075 else
12076 as = sym->as;
12077
12078 /* Constraints on deferred shape variable. */
12079 if (as == NULL || as->type != AS_DEFERRED)
12080 {
12081 bool pointer, allocatable, dimension;
12082
12083 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12084 {
12085 pointer = CLASS_DATA (sym)->attr.class_pointer;
12086 allocatable = CLASS_DATA (sym)->attr.allocatable;
12087 dimension = CLASS_DATA (sym)->attr.dimension;
12088 }
12089 else
12090 {
12091 pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
12092 allocatable = sym->attr.allocatable;
12093 dimension = sym->attr.dimension;
12094 }
12095
12096 if (allocatable)
12097 {
12098 if (dimension && as->type != AS_ASSUMED_RANK)
12099 {
12100 gfc_error ("Allocatable array %qs at %L must have a deferred "
12101 "shape or assumed rank", sym->name, &sym->declared_at);
12102 return false;
12103 }
12104 else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
12105 "%qs at %L may not be ALLOCATABLE",
12106 sym->name, &sym->declared_at))
12107 return false;
12108 }
12109
12110 if (pointer && dimension && as->type != AS_ASSUMED_RANK)
12111 {
12112 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12113 "assumed rank", sym->name, &sym->declared_at);
12114 return false;
12115 }
12116 }
12117 else
12118 {
12119 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
12120 && sym->ts.type != BT_CLASS && !sym->assoc)
12121 {
12122 gfc_error ("Array %qs at %L cannot have a deferred shape",
12123 sym->name, &sym->declared_at);
12124 return false;
12125 }
12126 }
12127
12128 /* Constraints on polymorphic variables. */
12129 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
12130 {
12131 /* F03:C502. */
12132 if (sym->attr.class_ok
12133 && !sym->attr.select_type_temporary
12134 && !UNLIMITED_POLY (sym)
12135 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
12136 {
12137 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12138 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
12139 &sym->declared_at);
12140 return false;
12141 }
12142
12143 /* F03:C509. */
12144 /* Assume that use associated symbols were checked in the module ns.
12145 Class-variables that are associate-names are also something special
12146 and excepted from the test. */
12147 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
12148 {
12149 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12150 "or pointer", sym->name, &sym->declared_at);
12151 return false;
12152 }
12153 }
12154
12155 return true;
12156 }
12157
12158
12159 /* Additional checks for symbols with flavor variable and derived
12160 type. To be called from resolve_fl_variable. */
12161
12162 static bool
resolve_fl_variable_derived(gfc_symbol * sym,int no_init_flag)12163 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
12164 {
12165 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
12166
12167 /* Check to see if a derived type is blocked from being host
12168 associated by the presence of another class I symbol in the same
12169 namespace. 14.6.1.3 of the standard and the discussion on
12170 comp.lang.fortran. */
12171 if (sym->ns != sym->ts.u.derived->ns
12172 && !sym->ts.u.derived->attr.use_assoc
12173 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
12174 {
12175 gfc_symbol *s;
12176 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
12177 if (s && s->attr.generic)
12178 s = gfc_find_dt_in_generic (s);
12179 if (s && !gfc_fl_struct (s->attr.flavor))
12180 {
12181 gfc_error ("The type %qs cannot be host associated at %L "
12182 "because it is blocked by an incompatible object "
12183 "of the same name declared at %L",
12184 sym->ts.u.derived->name, &sym->declared_at,
12185 &s->declared_at);
12186 return false;
12187 }
12188 }
12189
12190 /* 4th constraint in section 11.3: "If an object of a type for which
12191 component-initialization is specified (R429) appears in the
12192 specification-part of a module and does not have the ALLOCATABLE
12193 or POINTER attribute, the object shall have the SAVE attribute."
12194
12195 The check for initializers is performed with
12196 gfc_has_default_initializer because gfc_default_initializer generates
12197 a hidden default for allocatable components. */
12198 if (!(sym->value || no_init_flag) && sym->ns->proc_name
12199 && sym->ns->proc_name->attr.flavor == FL_MODULE
12200 && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
12201 && !sym->attr.pointer && !sym->attr.allocatable
12202 && gfc_has_default_initializer (sym->ts.u.derived)
12203 && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
12204 "%qs at %L, needed due to the default "
12205 "initialization", sym->name, &sym->declared_at))
12206 return false;
12207
12208 /* Assign default initializer. */
12209 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
12210 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
12211 sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
12212
12213 return true;
12214 }
12215
12216
12217 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12218 except in the declaration of an entity or component that has the POINTER
12219 or ALLOCATABLE attribute. */
12220
12221 static bool
deferred_requirements(gfc_symbol * sym)12222 deferred_requirements (gfc_symbol *sym)
12223 {
12224 if (sym->ts.deferred
12225 && !(sym->attr.pointer
12226 || sym->attr.allocatable
12227 || sym->attr.associate_var
12228 || sym->attr.omp_udr_artificial_var))
12229 {
12230 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12231 "requires either the POINTER or ALLOCATABLE attribute",
12232 sym->name, &sym->declared_at);
12233 return false;
12234 }
12235 return true;
12236 }
12237
12238
12239 /* Resolve symbols with flavor variable. */
12240
12241 static bool
resolve_fl_variable(gfc_symbol * sym,int mp_flag)12242 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
12243 {
12244 int no_init_flag, automatic_flag;
12245 gfc_expr *e;
12246 const char *auto_save_msg;
12247 bool saved_specification_expr;
12248
12249 auto_save_msg = "Automatic object %qs at %L cannot have the "
12250 "SAVE attribute";
12251
12252 if (!resolve_fl_var_and_proc (sym, mp_flag))
12253 return false;
12254
12255 /* Set this flag to check that variables are parameters of all entries.
12256 This check is effected by the call to gfc_resolve_expr through
12257 is_non_constant_shape_array. */
12258 saved_specification_expr = specification_expr;
12259 specification_expr = true;
12260
12261 if (sym->ns->proc_name
12262 && (sym->ns->proc_name->attr.flavor == FL_MODULE
12263 || sym->ns->proc_name->attr.is_main_program)
12264 && !sym->attr.use_assoc
12265 && !sym->attr.allocatable
12266 && !sym->attr.pointer
12267 && is_non_constant_shape_array (sym))
12268 {
12269 /* F08:C541. The shape of an array defined in a main program or module
12270 * needs to be constant. */
12271 gfc_error ("The module or main program array %qs at %L must "
12272 "have constant shape", sym->name, &sym->declared_at);
12273 specification_expr = saved_specification_expr;
12274 return false;
12275 }
12276
12277 /* Constraints on deferred type parameter. */
12278 if (!deferred_requirements (sym))
12279 return false;
12280
12281 if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
12282 {
12283 /* Make sure that character string variables with assumed length are
12284 dummy arguments. */
12285 e = sym->ts.u.cl->length;
12286 if (e == NULL && !sym->attr.dummy && !sym->attr.result
12287 && !sym->ts.deferred && !sym->attr.select_type_temporary
12288 && !sym->attr.omp_udr_artificial_var)
12289 {
12290 gfc_error ("Entity with assumed character length at %L must be a "
12291 "dummy argument or a PARAMETER", &sym->declared_at);
12292 specification_expr = saved_specification_expr;
12293 return false;
12294 }
12295
12296 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
12297 {
12298 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
12299 specification_expr = saved_specification_expr;
12300 return false;
12301 }
12302
12303 if (!gfc_is_constant_expr (e)
12304 && !(e->expr_type == EXPR_VARIABLE
12305 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
12306 {
12307 if (!sym->attr.use_assoc && sym->ns->proc_name
12308 && (sym->ns->proc_name->attr.flavor == FL_MODULE
12309 || sym->ns->proc_name->attr.is_main_program))
12310 {
12311 gfc_error ("%qs at %L must have constant character length "
12312 "in this context", sym->name, &sym->declared_at);
12313 specification_expr = saved_specification_expr;
12314 return false;
12315 }
12316 if (sym->attr.in_common)
12317 {
12318 gfc_error ("COMMON variable %qs at %L must have constant "
12319 "character length", sym->name, &sym->declared_at);
12320 specification_expr = saved_specification_expr;
12321 return false;
12322 }
12323 }
12324 }
12325
12326 if (sym->value == NULL && sym->attr.referenced)
12327 apply_default_init_local (sym); /* Try to apply a default initialization. */
12328
12329 /* Determine if the symbol may not have an initializer. */
12330 no_init_flag = automatic_flag = 0;
12331 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
12332 || sym->attr.intrinsic || sym->attr.result)
12333 no_init_flag = 1;
12334 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
12335 && is_non_constant_shape_array (sym))
12336 {
12337 no_init_flag = automatic_flag = 1;
12338
12339 /* Also, they must not have the SAVE attribute.
12340 SAVE_IMPLICIT is checked below. */
12341 if (sym->as && sym->attr.codimension)
12342 {
12343 int corank = sym->as->corank;
12344 sym->as->corank = 0;
12345 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
12346 sym->as->corank = corank;
12347 }
12348 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
12349 {
12350 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
12351 specification_expr = saved_specification_expr;
12352 return false;
12353 }
12354 }
12355
12356 /* Ensure that any initializer is simplified. */
12357 if (sym->value)
12358 gfc_simplify_expr (sym->value, 1);
12359
12360 /* Reject illegal initializers. */
12361 if (!sym->mark && sym->value)
12362 {
12363 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
12364 && CLASS_DATA (sym)->attr.allocatable))
12365 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12366 sym->name, &sym->declared_at);
12367 else if (sym->attr.external)
12368 gfc_error ("External %qs at %L cannot have an initializer",
12369 sym->name, &sym->declared_at);
12370 else if (sym->attr.dummy
12371 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
12372 gfc_error ("Dummy %qs at %L cannot have an initializer",
12373 sym->name, &sym->declared_at);
12374 else if (sym->attr.intrinsic)
12375 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12376 sym->name, &sym->declared_at);
12377 else if (sym->attr.result)
12378 gfc_error ("Function result %qs at %L cannot have an initializer",
12379 sym->name, &sym->declared_at);
12380 else if (automatic_flag)
12381 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12382 sym->name, &sym->declared_at);
12383 else
12384 goto no_init_error;
12385 specification_expr = saved_specification_expr;
12386 return false;
12387 }
12388
12389 no_init_error:
12390 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
12391 {
12392 bool res = resolve_fl_variable_derived (sym, no_init_flag);
12393 specification_expr = saved_specification_expr;
12394 return res;
12395 }
12396
12397 specification_expr = saved_specification_expr;
12398 return true;
12399 }
12400
12401
12402 /* Compare the dummy characteristics of a module procedure interface
12403 declaration with the corresponding declaration in a submodule. */
12404 static gfc_formal_arglist *new_formal;
12405 static char errmsg[200];
12406
12407 static void
compare_fsyms(gfc_symbol * sym)12408 compare_fsyms (gfc_symbol *sym)
12409 {
12410 gfc_symbol *fsym;
12411
12412 if (sym == NULL || new_formal == NULL)
12413 return;
12414
12415 fsym = new_formal->sym;
12416
12417 if (sym == fsym)
12418 return;
12419
12420 if (strcmp (sym->name, fsym->name) == 0)
12421 {
12422 if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
12423 gfc_error ("%s at %L", errmsg, &fsym->declared_at);
12424 }
12425 }
12426
12427
12428 /* Resolve a procedure. */
12429
12430 static bool
resolve_fl_procedure(gfc_symbol * sym,int mp_flag)12431 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
12432 {
12433 gfc_formal_arglist *arg;
12434
12435 if (sym->attr.function
12436 && !resolve_fl_var_and_proc (sym, mp_flag))
12437 return false;
12438
12439 if (sym->ts.type == BT_CHARACTER)
12440 {
12441 gfc_charlen *cl = sym->ts.u.cl;
12442
12443 if (cl && cl->length && gfc_is_constant_expr (cl->length)
12444 && !resolve_charlen (cl))
12445 return false;
12446
12447 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12448 && sym->attr.proc == PROC_ST_FUNCTION)
12449 {
12450 gfc_error ("Character-valued statement function %qs at %L must "
12451 "have constant length", sym->name, &sym->declared_at);
12452 return false;
12453 }
12454 }
12455
12456 /* Ensure that derived type for are not of a private type. Internal
12457 module procedures are excluded by 2.2.3.3 - i.e., they are not
12458 externally accessible and can access all the objects accessible in
12459 the host. */
12460 if (!(sym->ns->parent
12461 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
12462 && gfc_check_symbol_access (sym))
12463 {
12464 gfc_interface *iface;
12465
12466 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
12467 {
12468 if (arg->sym
12469 && arg->sym->ts.type == BT_DERIVED
12470 && !arg->sym->ts.u.derived->attr.use_assoc
12471 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
12472 && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
12473 "and cannot be a dummy argument"
12474 " of %qs, which is PUBLIC at %L",
12475 arg->sym->name, sym->name,
12476 &sym->declared_at))
12477 {
12478 /* Stop this message from recurring. */
12479 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
12480 return false;
12481 }
12482 }
12483
12484 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12485 PRIVATE to the containing module. */
12486 for (iface = sym->generic; iface; iface = iface->next)
12487 {
12488 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
12489 {
12490 if (arg->sym
12491 && arg->sym->ts.type == BT_DERIVED
12492 && !arg->sym->ts.u.derived->attr.use_assoc
12493 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
12494 && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
12495 "PUBLIC interface %qs at %L "
12496 "takes dummy arguments of %qs which "
12497 "is PRIVATE", iface->sym->name,
12498 sym->name, &iface->sym->declared_at,
12499 gfc_typename(&arg->sym->ts)))
12500 {
12501 /* Stop this message from recurring. */
12502 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
12503 return false;
12504 }
12505 }
12506 }
12507 }
12508
12509 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
12510 && !sym->attr.proc_pointer)
12511 {
12512 gfc_error ("Function %qs at %L cannot have an initializer",
12513 sym->name, &sym->declared_at);
12514 return false;
12515 }
12516
12517 /* An external symbol may not have an initializer because it is taken to be
12518 a procedure. Exception: Procedure Pointers. */
12519 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
12520 {
12521 gfc_error ("External object %qs at %L may not have an initializer",
12522 sym->name, &sym->declared_at);
12523 return false;
12524 }
12525
12526 /* An elemental function is required to return a scalar 12.7.1 */
12527 if (sym->attr.elemental && sym->attr.function
12528 && (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)))
12529 {
12530 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12531 "result", sym->name, &sym->declared_at);
12532 /* Reset so that the error only occurs once. */
12533 sym->attr.elemental = 0;
12534 return false;
12535 }
12536
12537 if (sym->attr.proc == PROC_ST_FUNCTION
12538 && (sym->attr.allocatable || sym->attr.pointer))
12539 {
12540 gfc_error ("Statement function %qs at %L may not have pointer or "
12541 "allocatable attribute", sym->name, &sym->declared_at);
12542 return false;
12543 }
12544
12545 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12546 char-len-param shall not be array-valued, pointer-valued, recursive
12547 or pure. ....snip... A character value of * may only be used in the
12548 following ways: (i) Dummy arg of procedure - dummy associates with
12549 actual length; (ii) To declare a named constant; or (iii) External
12550 function - but length must be declared in calling scoping unit. */
12551 if (sym->attr.function
12552 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
12553 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
12554 {
12555 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
12556 || (sym->attr.recursive) || (sym->attr.pure))
12557 {
12558 if (sym->as && sym->as->rank)
12559 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12560 "array-valued", sym->name, &sym->declared_at);
12561
12562 if (sym->attr.pointer)
12563 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12564 "pointer-valued", sym->name, &sym->declared_at);
12565
12566 if (sym->attr.pure)
12567 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12568 "pure", sym->name, &sym->declared_at);
12569
12570 if (sym->attr.recursive)
12571 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12572 "recursive", sym->name, &sym->declared_at);
12573
12574 return false;
12575 }
12576
12577 /* Appendix B.2 of the standard. Contained functions give an
12578 error anyway. Deferred character length is an F2003 feature.
12579 Don't warn on intrinsic conversion functions, which start
12580 with two underscores. */
12581 if (!sym->attr.contained && !sym->ts.deferred
12582 && (sym->name[0] != '_' || sym->name[1] != '_'))
12583 gfc_notify_std (GFC_STD_F95_OBS,
12584 "CHARACTER(*) function %qs at %L",
12585 sym->name, &sym->declared_at);
12586 }
12587
12588 /* F2008, C1218. */
12589 if (sym->attr.elemental)
12590 {
12591 if (sym->attr.proc_pointer)
12592 {
12593 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12594 sym->name, &sym->declared_at);
12595 return false;
12596 }
12597 if (sym->attr.dummy)
12598 {
12599 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12600 sym->name, &sym->declared_at);
12601 return false;
12602 }
12603 }
12604
12605 /* F2018, C15100: "The result of an elemental function shall be scalar,
12606 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12607 pointer is tested and caught elsewhere. */
12608 if (sym->attr.elemental && sym->result
12609 && (sym->result->attr.allocatable || sym->result->attr.pointer))
12610 {
12611 gfc_error ("Function result variable %qs at %L of elemental "
12612 "function %qs shall not have an ALLOCATABLE or POINTER "
12613 "attribute", sym->result->name,
12614 &sym->result->declared_at, sym->name);
12615 return false;
12616 }
12617
12618 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
12619 {
12620 gfc_formal_arglist *curr_arg;
12621 int has_non_interop_arg = 0;
12622
12623 if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12624 sym->common_block))
12625 {
12626 /* Clear these to prevent looking at them again if there was an
12627 error. */
12628 sym->attr.is_bind_c = 0;
12629 sym->attr.is_c_interop = 0;
12630 sym->ts.is_c_interop = 0;
12631 }
12632 else
12633 {
12634 /* So far, no errors have been found. */
12635 sym->attr.is_c_interop = 1;
12636 sym->ts.is_c_interop = 1;
12637 }
12638
12639 curr_arg = gfc_sym_get_dummy_args (sym);
12640 while (curr_arg != NULL)
12641 {
12642 /* Skip implicitly typed dummy args here. */
12643 if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
12644 if (!gfc_verify_c_interop_param (curr_arg->sym))
12645 /* If something is found to fail, record the fact so we
12646 can mark the symbol for the procedure as not being
12647 BIND(C) to try and prevent multiple errors being
12648 reported. */
12649 has_non_interop_arg = 1;
12650
12651 curr_arg = curr_arg->next;
12652 }
12653
12654 /* See if any of the arguments were not interoperable and if so, clear
12655 the procedure symbol to prevent duplicate error messages. */
12656 if (has_non_interop_arg != 0)
12657 {
12658 sym->attr.is_c_interop = 0;
12659 sym->ts.is_c_interop = 0;
12660 sym->attr.is_bind_c = 0;
12661 }
12662 }
12663
12664 if (!sym->attr.proc_pointer)
12665 {
12666 if (sym->attr.save == SAVE_EXPLICIT)
12667 {
12668 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12669 "in %qs at %L", sym->name, &sym->declared_at);
12670 return false;
12671 }
12672 if (sym->attr.intent)
12673 {
12674 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12675 "in %qs at %L", sym->name, &sym->declared_at);
12676 return false;
12677 }
12678 if (sym->attr.subroutine && sym->attr.result)
12679 {
12680 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12681 "in %qs at %L", sym->name, &sym->declared_at);
12682 return false;
12683 }
12684 if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
12685 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
12686 || sym->attr.contained))
12687 {
12688 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12689 "in %qs at %L", sym->name, &sym->declared_at);
12690 return false;
12691 }
12692 if (strcmp ("ppr@", sym->name) == 0)
12693 {
12694 gfc_error ("Procedure pointer result %qs at %L "
12695 "is missing the pointer attribute",
12696 sym->ns->proc_name->name, &sym->declared_at);
12697 return false;
12698 }
12699 }
12700
12701 /* Assume that a procedure whose body is not known has references
12702 to external arrays. */
12703 if (sym->attr.if_source != IFSRC_DECL)
12704 sym->attr.array_outer_dependency = 1;
12705
12706 /* Compare the characteristics of a module procedure with the
12707 interface declaration. Ideally this would be done with
12708 gfc_compare_interfaces but, at present, the formal interface
12709 cannot be copied to the ts.interface. */
12710 if (sym->attr.module_procedure
12711 && sym->attr.if_source == IFSRC_DECL)
12712 {
12713 gfc_symbol *iface;
12714 char name[2*GFC_MAX_SYMBOL_LEN + 1];
12715 char *module_name;
12716 char *submodule_name;
12717 strcpy (name, sym->ns->proc_name->name);
12718 module_name = strtok (name, ".");
12719 submodule_name = strtok (NULL, ".");
12720
12721 iface = sym->tlink;
12722 sym->tlink = NULL;
12723
12724 /* Make sure that the result uses the correct charlen for deferred
12725 length results. */
12726 if (iface && sym->result
12727 && iface->ts.type == BT_CHARACTER
12728 && iface->ts.deferred)
12729 sym->result->ts.u.cl = iface->ts.u.cl;
12730
12731 if (iface == NULL)
12732 goto check_formal;
12733
12734 /* Check the procedure characteristics. */
12735 if (sym->attr.elemental != iface->attr.elemental)
12736 {
12737 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12738 "PROCEDURE at %L and its interface in %s",
12739 &sym->declared_at, module_name);
12740 return false;
12741 }
12742
12743 if (sym->attr.pure != iface->attr.pure)
12744 {
12745 gfc_error ("Mismatch in PURE attribute between MODULE "
12746 "PROCEDURE at %L and its interface in %s",
12747 &sym->declared_at, module_name);
12748 return false;
12749 }
12750
12751 if (sym->attr.recursive != iface->attr.recursive)
12752 {
12753 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12754 "PROCEDURE at %L and its interface in %s",
12755 &sym->declared_at, module_name);
12756 return false;
12757 }
12758
12759 /* Check the result characteristics. */
12760 if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
12761 {
12762 gfc_error ("%s between the MODULE PROCEDURE declaration "
12763 "in MODULE %qs and the declaration at %L in "
12764 "(SUB)MODULE %qs",
12765 errmsg, module_name, &sym->declared_at,
12766 submodule_name ? submodule_name : module_name);
12767 return false;
12768 }
12769
12770 check_formal:
12771 /* Check the characteristics of the formal arguments. */
12772 if (sym->formal && sym->formal_ns)
12773 {
12774 for (arg = sym->formal; arg && arg->sym; arg = arg->next)
12775 {
12776 new_formal = arg;
12777 gfc_traverse_ns (sym->formal_ns, compare_fsyms);
12778 }
12779 }
12780 }
12781 return true;
12782 }
12783
12784
12785 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12786 been defined and we now know their defined arguments, check that they fulfill
12787 the requirements of the standard for procedures used as finalizers. */
12788
12789 static bool
gfc_resolve_finalizers(gfc_symbol * derived,bool * finalizable)12790 gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
12791 {
12792 gfc_finalizer* list;
12793 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
12794 bool result = true;
12795 bool seen_scalar = false;
12796 gfc_symbol *vtab;
12797 gfc_component *c;
12798 gfc_symbol *parent = gfc_get_derived_super_type (derived);
12799
12800 if (parent)
12801 gfc_resolve_finalizers (parent, finalizable);
12802
12803 /* Ensure that derived-type components have a their finalizers resolved. */
12804 bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
12805 for (c = derived->components; c; c = c->next)
12806 if (c->ts.type == BT_DERIVED
12807 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
12808 {
12809 bool has_final2 = false;
12810 if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
12811 return false; /* Error. */
12812 has_final = has_final || has_final2;
12813 }
12814 /* Return early if not finalizable. */
12815 if (!has_final)
12816 {
12817 if (finalizable)
12818 *finalizable = false;
12819 return true;
12820 }
12821
12822 /* Walk over the list of finalizer-procedures, check them, and if any one
12823 does not fit in with the standard's definition, print an error and remove
12824 it from the list. */
12825 prev_link = &derived->f2k_derived->finalizers;
12826 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
12827 {
12828 gfc_formal_arglist *dummy_args;
12829 gfc_symbol* arg;
12830 gfc_finalizer* i;
12831 int my_rank;
12832
12833 /* Skip this finalizer if we already resolved it. */
12834 if (list->proc_tree)
12835 {
12836 if (list->proc_tree->n.sym->formal->sym->as == NULL
12837 || list->proc_tree->n.sym->formal->sym->as->rank == 0)
12838 seen_scalar = true;
12839 prev_link = &(list->next);
12840 continue;
12841 }
12842
12843 /* Check this exists and is a SUBROUTINE. */
12844 if (!list->proc_sym->attr.subroutine)
12845 {
12846 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12847 list->proc_sym->name, &list->where);
12848 goto error;
12849 }
12850
12851 /* We should have exactly one argument. */
12852 dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
12853 if (!dummy_args || dummy_args->next)
12854 {
12855 gfc_error ("FINAL procedure at %L must have exactly one argument",
12856 &list->where);
12857 goto error;
12858 }
12859 arg = dummy_args->sym;
12860
12861 /* This argument must be of our type. */
12862 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
12863 {
12864 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12865 &arg->declared_at, derived->name);
12866 goto error;
12867 }
12868
12869 /* It must neither be a pointer nor allocatable nor optional. */
12870 if (arg->attr.pointer)
12871 {
12872 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12873 &arg->declared_at);
12874 goto error;
12875 }
12876 if (arg->attr.allocatable)
12877 {
12878 gfc_error ("Argument of FINAL procedure at %L must not be"
12879 " ALLOCATABLE", &arg->declared_at);
12880 goto error;
12881 }
12882 if (arg->attr.optional)
12883 {
12884 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12885 &arg->declared_at);
12886 goto error;
12887 }
12888
12889 /* It must not be INTENT(OUT). */
12890 if (arg->attr.intent == INTENT_OUT)
12891 {
12892 gfc_error ("Argument of FINAL procedure at %L must not be"
12893 " INTENT(OUT)", &arg->declared_at);
12894 goto error;
12895 }
12896
12897 /* Warn if the procedure is non-scalar and not assumed shape. */
12898 if (warn_surprising && arg->as && arg->as->rank != 0
12899 && arg->as->type != AS_ASSUMED_SHAPE)
12900 gfc_warning (OPT_Wsurprising,
12901 "Non-scalar FINAL procedure at %L should have assumed"
12902 " shape argument", &arg->declared_at);
12903
12904 /* Check that it does not match in kind and rank with a FINAL procedure
12905 defined earlier. To really loop over the *earlier* declarations,
12906 we need to walk the tail of the list as new ones were pushed at the
12907 front. */
12908 /* TODO: Handle kind parameters once they are implemented. */
12909 my_rank = (arg->as ? arg->as->rank : 0);
12910 for (i = list->next; i; i = i->next)
12911 {
12912 gfc_formal_arglist *dummy_args;
12913
12914 /* Argument list might be empty; that is an error signalled earlier,
12915 but we nevertheless continued resolving. */
12916 dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
12917 if (dummy_args)
12918 {
12919 gfc_symbol* i_arg = dummy_args->sym;
12920 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
12921 if (i_rank == my_rank)
12922 {
12923 gfc_error ("FINAL procedure %qs declared at %L has the same"
12924 " rank (%d) as %qs",
12925 list->proc_sym->name, &list->where, my_rank,
12926 i->proc_sym->name);
12927 goto error;
12928 }
12929 }
12930 }
12931
12932 /* Is this the/a scalar finalizer procedure? */
12933 if (my_rank == 0)
12934 seen_scalar = true;
12935
12936 /* Find the symtree for this procedure. */
12937 gcc_assert (!list->proc_tree);
12938 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
12939
12940 prev_link = &list->next;
12941 continue;
12942
12943 /* Remove wrong nodes immediately from the list so we don't risk any
12944 troubles in the future when they might fail later expectations. */
12945 error:
12946 i = list;
12947 *prev_link = list->next;
12948 gfc_free_finalizer (i);
12949 result = false;
12950 }
12951
12952 if (result == false)
12953 return false;
12954
12955 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12956 were nodes in the list, must have been for arrays. It is surely a good
12957 idea to have a scalar version there if there's something to finalize. */
12958 if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
12959 gfc_warning (OPT_Wsurprising,
12960 "Only array FINAL procedures declared for derived type %qs"
12961 " defined at %L, suggest also scalar one",
12962 derived->name, &derived->declared_at);
12963
12964 vtab = gfc_find_derived_vtab (derived);
12965 c = vtab->ts.u.derived->components->next->next->next->next->next;
12966 gfc_set_sym_referenced (c->initializer->symtree->n.sym);
12967
12968 if (finalizable)
12969 *finalizable = true;
12970
12971 return true;
12972 }
12973
12974
12975 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12976
12977 static bool
check_generic_tbp_ambiguity(gfc_tbp_generic * t1,gfc_tbp_generic * t2,const char * generic_name,locus where)12978 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
12979 const char* generic_name, locus where)
12980 {
12981 gfc_symbol *sym1, *sym2;
12982 const char *pass1, *pass2;
12983 gfc_formal_arglist *dummy_args;
12984
12985 gcc_assert (t1->specific && t2->specific);
12986 gcc_assert (!t1->specific->is_generic);
12987 gcc_assert (!t2->specific->is_generic);
12988 gcc_assert (t1->is_operator == t2->is_operator);
12989
12990 sym1 = t1->specific->u.specific->n.sym;
12991 sym2 = t2->specific->u.specific->n.sym;
12992
12993 if (sym1 == sym2)
12994 return true;
12995
12996 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12997 if (sym1->attr.subroutine != sym2->attr.subroutine
12998 || sym1->attr.function != sym2->attr.function)
12999 {
13000 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
13001 " GENERIC %qs at %L",
13002 sym1->name, sym2->name, generic_name, &where);
13003 return false;
13004 }
13005
13006 /* Determine PASS arguments. */
13007 if (t1->specific->nopass)
13008 pass1 = NULL;
13009 else if (t1->specific->pass_arg)
13010 pass1 = t1->specific->pass_arg;
13011 else
13012 {
13013 dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
13014 if (dummy_args)
13015 pass1 = dummy_args->sym->name;
13016 else
13017 pass1 = NULL;
13018 }
13019 if (t2->specific->nopass)
13020 pass2 = NULL;
13021 else if (t2->specific->pass_arg)
13022 pass2 = t2->specific->pass_arg;
13023 else
13024 {
13025 dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
13026 if (dummy_args)
13027 pass2 = dummy_args->sym->name;
13028 else
13029 pass2 = NULL;
13030 }
13031
13032 /* Compare the interfaces. */
13033 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
13034 NULL, 0, pass1, pass2))
13035 {
13036 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13037 sym1->name, sym2->name, generic_name, &where);
13038 return false;
13039 }
13040
13041 return true;
13042 }
13043
13044
13045 /* Worker function for resolving a generic procedure binding; this is used to
13046 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13047
13048 The difference between those cases is finding possible inherited bindings
13049 that are overridden, as one has to look for them in tb_sym_root,
13050 tb_uop_root or tb_op, respectively. Thus the caller must already find
13051 the super-type and set p->overridden correctly. */
13052
13053 static bool
resolve_tb_generic_targets(gfc_symbol * super_type,gfc_typebound_proc * p,const char * name)13054 resolve_tb_generic_targets (gfc_symbol* super_type,
13055 gfc_typebound_proc* p, const char* name)
13056 {
13057 gfc_tbp_generic* target;
13058 gfc_symtree* first_target;
13059 gfc_symtree* inherited;
13060
13061 gcc_assert (p && p->is_generic);
13062
13063 /* Try to find the specific bindings for the symtrees in our target-list. */
13064 gcc_assert (p->u.generic);
13065 for (target = p->u.generic; target; target = target->next)
13066 if (!target->specific)
13067 {
13068 gfc_typebound_proc* overridden_tbp;
13069 gfc_tbp_generic* g;
13070 const char* target_name;
13071
13072 target_name = target->specific_st->name;
13073
13074 /* Defined for this type directly. */
13075 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
13076 {
13077 target->specific = target->specific_st->n.tb;
13078 goto specific_found;
13079 }
13080
13081 /* Look for an inherited specific binding. */
13082 if (super_type)
13083 {
13084 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
13085 true, NULL);
13086
13087 if (inherited)
13088 {
13089 gcc_assert (inherited->n.tb);
13090 target->specific = inherited->n.tb;
13091 goto specific_found;
13092 }
13093 }
13094
13095 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13096 " at %L", target_name, name, &p->where);
13097 return false;
13098
13099 /* Once we've found the specific binding, check it is not ambiguous with
13100 other specifics already found or inherited for the same GENERIC. */
13101 specific_found:
13102 gcc_assert (target->specific);
13103
13104 /* This must really be a specific binding! */
13105 if (target->specific->is_generic)
13106 {
13107 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13108 " %qs is GENERIC, too", name, &p->where, target_name);
13109 return false;
13110 }
13111
13112 /* Check those already resolved on this type directly. */
13113 for (g = p->u.generic; g; g = g->next)
13114 if (g != target && g->specific
13115 && !check_generic_tbp_ambiguity (target, g, name, p->where))
13116 return false;
13117
13118 /* Check for ambiguity with inherited specific targets. */
13119 for (overridden_tbp = p->overridden; overridden_tbp;
13120 overridden_tbp = overridden_tbp->overridden)
13121 if (overridden_tbp->is_generic)
13122 {
13123 for (g = overridden_tbp->u.generic; g; g = g->next)
13124 {
13125 gcc_assert (g->specific);
13126 if (!check_generic_tbp_ambiguity (target, g, name, p->where))
13127 return false;
13128 }
13129 }
13130 }
13131
13132 /* If we attempt to "overwrite" a specific binding, this is an error. */
13133 if (p->overridden && !p->overridden->is_generic)
13134 {
13135 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
13136 " the same name", name, &p->where);
13137 return false;
13138 }
13139
13140 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13141 all must have the same attributes here. */
13142 first_target = p->u.generic->specific->u.specific;
13143 gcc_assert (first_target);
13144 p->subroutine = first_target->n.sym->attr.subroutine;
13145 p->function = first_target->n.sym->attr.function;
13146
13147 return true;
13148 }
13149
13150
13151 /* Resolve a GENERIC procedure binding for a derived type. */
13152
13153 static bool
resolve_typebound_generic(gfc_symbol * derived,gfc_symtree * st)13154 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
13155 {
13156 gfc_symbol* super_type;
13157
13158 /* Find the overridden binding if any. */
13159 st->n.tb->overridden = NULL;
13160 super_type = gfc_get_derived_super_type (derived);
13161 if (super_type)
13162 {
13163 gfc_symtree* overridden;
13164 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
13165 true, NULL);
13166
13167 if (overridden && overridden->n.tb)
13168 st->n.tb->overridden = overridden->n.tb;
13169 }
13170
13171 /* Resolve using worker function. */
13172 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
13173 }
13174
13175
13176 /* Retrieve the target-procedure of an operator binding and do some checks in
13177 common for intrinsic and user-defined type-bound operators. */
13178
13179 static gfc_symbol*
get_checked_tb_operator_target(gfc_tbp_generic * target,locus where)13180 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
13181 {
13182 gfc_symbol* target_proc;
13183
13184 gcc_assert (target->specific && !target->specific->is_generic);
13185 target_proc = target->specific->u.specific->n.sym;
13186 gcc_assert (target_proc);
13187
13188 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13189 if (target->specific->nopass)
13190 {
13191 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
13192 return NULL;
13193 }
13194
13195 return target_proc;
13196 }
13197
13198
13199 /* Resolve a type-bound intrinsic operator. */
13200
13201 static bool
resolve_typebound_intrinsic_op(gfc_symbol * derived,gfc_intrinsic_op op,gfc_typebound_proc * p)13202 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
13203 gfc_typebound_proc* p)
13204 {
13205 gfc_symbol* super_type;
13206 gfc_tbp_generic* target;
13207
13208 /* If there's already an error here, do nothing (but don't fail again). */
13209 if (p->error)
13210 return true;
13211
13212 /* Operators should always be GENERIC bindings. */
13213 gcc_assert (p->is_generic);
13214
13215 /* Look for an overridden binding. */
13216 super_type = gfc_get_derived_super_type (derived);
13217 if (super_type && super_type->f2k_derived)
13218 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
13219 op, true, NULL);
13220 else
13221 p->overridden = NULL;
13222
13223 /* Resolve general GENERIC properties using worker function. */
13224 if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
13225 goto error;
13226
13227 /* Check the targets to be procedures of correct interface. */
13228 for (target = p->u.generic; target; target = target->next)
13229 {
13230 gfc_symbol* target_proc;
13231
13232 target_proc = get_checked_tb_operator_target (target, p->where);
13233 if (!target_proc)
13234 goto error;
13235
13236 if (!gfc_check_operator_interface (target_proc, op, p->where))
13237 goto error;
13238
13239 /* Add target to non-typebound operator list. */
13240 if (!target->specific->deferred && !derived->attr.use_assoc
13241 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
13242 {
13243 gfc_interface *head, *intr;
13244
13245 /* Preempt 'gfc_check_new_interface' for submodules, where the
13246 mechanism for handling module procedures winds up resolving
13247 operator interfaces twice and would otherwise cause an error. */
13248 for (intr = derived->ns->op[op]; intr; intr = intr->next)
13249 if (intr->sym == target_proc
13250 && target_proc->attr.used_in_submodule)
13251 return true;
13252
13253 if (!gfc_check_new_interface (derived->ns->op[op],
13254 target_proc, p->where))
13255 return false;
13256 head = derived->ns->op[op];
13257 intr = gfc_get_interface ();
13258 intr->sym = target_proc;
13259 intr->where = p->where;
13260 intr->next = head;
13261 derived->ns->op[op] = intr;
13262 }
13263 }
13264
13265 return true;
13266
13267 error:
13268 p->error = 1;
13269 return false;
13270 }
13271
13272
13273 /* Resolve a type-bound user operator (tree-walker callback). */
13274
13275 static gfc_symbol* resolve_bindings_derived;
13276 static bool resolve_bindings_result;
13277
13278 static bool check_uop_procedure (gfc_symbol* sym, locus where);
13279
13280 static void
resolve_typebound_user_op(gfc_symtree * stree)13281 resolve_typebound_user_op (gfc_symtree* stree)
13282 {
13283 gfc_symbol* super_type;
13284 gfc_tbp_generic* target;
13285
13286 gcc_assert (stree && stree->n.tb);
13287
13288 if (stree->n.tb->error)
13289 return;
13290
13291 /* Operators should always be GENERIC bindings. */
13292 gcc_assert (stree->n.tb->is_generic);
13293
13294 /* Find overridden procedure, if any. */
13295 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
13296 if (super_type && super_type->f2k_derived)
13297 {
13298 gfc_symtree* overridden;
13299 overridden = gfc_find_typebound_user_op (super_type, NULL,
13300 stree->name, true, NULL);
13301
13302 if (overridden && overridden->n.tb)
13303 stree->n.tb->overridden = overridden->n.tb;
13304 }
13305 else
13306 stree->n.tb->overridden = NULL;
13307
13308 /* Resolve basically using worker function. */
13309 if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
13310 goto error;
13311
13312 /* Check the targets to be functions of correct interface. */
13313 for (target = stree->n.tb->u.generic; target; target = target->next)
13314 {
13315 gfc_symbol* target_proc;
13316
13317 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
13318 if (!target_proc)
13319 goto error;
13320
13321 if (!check_uop_procedure (target_proc, stree->n.tb->where))
13322 goto error;
13323 }
13324
13325 return;
13326
13327 error:
13328 resolve_bindings_result = false;
13329 stree->n.tb->error = 1;
13330 }
13331
13332
13333 /* Resolve the type-bound procedures for a derived type. */
13334
13335 static void
resolve_typebound_procedure(gfc_symtree * stree)13336 resolve_typebound_procedure (gfc_symtree* stree)
13337 {
13338 gfc_symbol* proc;
13339 locus where;
13340 gfc_symbol* me_arg;
13341 gfc_symbol* super_type;
13342 gfc_component* comp;
13343
13344 gcc_assert (stree);
13345
13346 /* Undefined specific symbol from GENERIC target definition. */
13347 if (!stree->n.tb)
13348 return;
13349
13350 if (stree->n.tb->error)
13351 return;
13352
13353 /* If this is a GENERIC binding, use that routine. */
13354 if (stree->n.tb->is_generic)
13355 {
13356 if (!resolve_typebound_generic (resolve_bindings_derived, stree))
13357 goto error;
13358 return;
13359 }
13360
13361 /* Get the target-procedure to check it. */
13362 gcc_assert (!stree->n.tb->is_generic);
13363 gcc_assert (stree->n.tb->u.specific);
13364 proc = stree->n.tb->u.specific->n.sym;
13365 where = stree->n.tb->where;
13366
13367 /* Default access should already be resolved from the parser. */
13368 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
13369
13370 if (stree->n.tb->deferred)
13371 {
13372 if (!check_proc_interface (proc, &where))
13373 goto error;
13374 }
13375 else
13376 {
13377 /* Check for F08:C465. */
13378 if ((!proc->attr.subroutine && !proc->attr.function)
13379 || (proc->attr.proc != PROC_MODULE
13380 && proc->attr.if_source != IFSRC_IFBODY)
13381 || proc->attr.abstract)
13382 {
13383 gfc_error ("%qs must be a module procedure or an external procedure with"
13384 " an explicit interface at %L", proc->name, &where);
13385 goto error;
13386 }
13387 }
13388
13389 stree->n.tb->subroutine = proc->attr.subroutine;
13390 stree->n.tb->function = proc->attr.function;
13391
13392 /* Find the super-type of the current derived type. We could do this once and
13393 store in a global if speed is needed, but as long as not I believe this is
13394 more readable and clearer. */
13395 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
13396
13397 /* If PASS, resolve and check arguments if not already resolved / loaded
13398 from a .mod file. */
13399 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
13400 {
13401 gfc_formal_arglist *dummy_args;
13402
13403 dummy_args = gfc_sym_get_dummy_args (proc);
13404 if (stree->n.tb->pass_arg)
13405 {
13406 gfc_formal_arglist *i;
13407
13408 /* If an explicit passing argument name is given, walk the arg-list
13409 and look for it. */
13410
13411 me_arg = NULL;
13412 stree->n.tb->pass_arg_num = 1;
13413 for (i = dummy_args; i; i = i->next)
13414 {
13415 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
13416 {
13417 me_arg = i->sym;
13418 break;
13419 }
13420 ++stree->n.tb->pass_arg_num;
13421 }
13422
13423 if (!me_arg)
13424 {
13425 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13426 " argument %qs",
13427 proc->name, stree->n.tb->pass_arg, &where,
13428 stree->n.tb->pass_arg);
13429 goto error;
13430 }
13431 }
13432 else
13433 {
13434 /* Otherwise, take the first one; there should in fact be at least
13435 one. */
13436 stree->n.tb->pass_arg_num = 1;
13437 if (!dummy_args)
13438 {
13439 gfc_error ("Procedure %qs with PASS at %L must have at"
13440 " least one argument", proc->name, &where);
13441 goto error;
13442 }
13443 me_arg = dummy_args->sym;
13444 }
13445
13446 /* Now check that the argument-type matches and the passed-object
13447 dummy argument is generally fine. */
13448
13449 gcc_assert (me_arg);
13450
13451 if (me_arg->ts.type != BT_CLASS)
13452 {
13453 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13454 " at %L", proc->name, &where);
13455 goto error;
13456 }
13457
13458 if (CLASS_DATA (me_arg)->ts.u.derived
13459 != resolve_bindings_derived)
13460 {
13461 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13462 " the derived-type %qs", me_arg->name, proc->name,
13463 me_arg->name, &where, resolve_bindings_derived->name);
13464 goto error;
13465 }
13466
13467 gcc_assert (me_arg->ts.type == BT_CLASS);
13468 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
13469 {
13470 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13471 " scalar", proc->name, &where);
13472 goto error;
13473 }
13474 if (CLASS_DATA (me_arg)->attr.allocatable)
13475 {
13476 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13477 " be ALLOCATABLE", proc->name, &where);
13478 goto error;
13479 }
13480 if (CLASS_DATA (me_arg)->attr.class_pointer)
13481 {
13482 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13483 " be POINTER", proc->name, &where);
13484 goto error;
13485 }
13486 }
13487
13488 /* If we are extending some type, check that we don't override a procedure
13489 flagged NON_OVERRIDABLE. */
13490 stree->n.tb->overridden = NULL;
13491 if (super_type)
13492 {
13493 gfc_symtree* overridden;
13494 overridden = gfc_find_typebound_proc (super_type, NULL,
13495 stree->name, true, NULL);
13496
13497 if (overridden)
13498 {
13499 if (overridden->n.tb)
13500 stree->n.tb->overridden = overridden->n.tb;
13501
13502 if (!gfc_check_typebound_override (stree, overridden))
13503 goto error;
13504 }
13505 }
13506
13507 /* See if there's a name collision with a component directly in this type. */
13508 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
13509 if (!strcmp (comp->name, stree->name))
13510 {
13511 gfc_error ("Procedure %qs at %L has the same name as a component of"
13512 " %qs",
13513 stree->name, &where, resolve_bindings_derived->name);
13514 goto error;
13515 }
13516
13517 /* Try to find a name collision with an inherited component. */
13518 if (super_type && gfc_find_component (super_type, stree->name, true, true,
13519 NULL))
13520 {
13521 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13522 " component of %qs",
13523 stree->name, &where, resolve_bindings_derived->name);
13524 goto error;
13525 }
13526
13527 stree->n.tb->error = 0;
13528 return;
13529
13530 error:
13531 resolve_bindings_result = false;
13532 stree->n.tb->error = 1;
13533 }
13534
13535
13536 static bool
resolve_typebound_procedures(gfc_symbol * derived)13537 resolve_typebound_procedures (gfc_symbol* derived)
13538 {
13539 int op;
13540 gfc_symbol* super_type;
13541
13542 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
13543 return true;
13544
13545 super_type = gfc_get_derived_super_type (derived);
13546 if (super_type)
13547 resolve_symbol (super_type);
13548
13549 resolve_bindings_derived = derived;
13550 resolve_bindings_result = true;
13551
13552 if (derived->f2k_derived->tb_sym_root)
13553 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
13554 &resolve_typebound_procedure);
13555
13556 if (derived->f2k_derived->tb_uop_root)
13557 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
13558 &resolve_typebound_user_op);
13559
13560 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
13561 {
13562 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
13563 if (p && !resolve_typebound_intrinsic_op (derived,
13564 (gfc_intrinsic_op)op, p))
13565 resolve_bindings_result = false;
13566 }
13567
13568 return resolve_bindings_result;
13569 }
13570
13571
13572 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13573 to give all identical derived types the same backend_decl. */
13574 static void
add_dt_to_dt_list(gfc_symbol * derived)13575 add_dt_to_dt_list (gfc_symbol *derived)
13576 {
13577 gfc_dt_list *dt_list;
13578
13579 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
13580 if (derived == dt_list->derived)
13581 return;
13582
13583 dt_list = gfc_get_dt_list ();
13584 dt_list->next = gfc_derived_types;
13585 dt_list->derived = derived;
13586 gfc_derived_types = dt_list;
13587 }
13588
13589
13590 /* Ensure that a derived-type is really not abstract, meaning that every
13591 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13592
13593 static bool
ensure_not_abstract_walker(gfc_symbol * sub,gfc_symtree * st)13594 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
13595 {
13596 if (!st)
13597 return true;
13598
13599 if (!ensure_not_abstract_walker (sub, st->left))
13600 return false;
13601 if (!ensure_not_abstract_walker (sub, st->right))
13602 return false;
13603
13604 if (st->n.tb && st->n.tb->deferred)
13605 {
13606 gfc_symtree* overriding;
13607 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
13608 if (!overriding)
13609 return false;
13610 gcc_assert (overriding->n.tb);
13611 if (overriding->n.tb->deferred)
13612 {
13613 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13614 " %qs is DEFERRED and not overridden",
13615 sub->name, &sub->declared_at, st->name);
13616 return false;
13617 }
13618 }
13619
13620 return true;
13621 }
13622
13623 static bool
ensure_not_abstract(gfc_symbol * sub,gfc_symbol * ancestor)13624 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
13625 {
13626 /* The algorithm used here is to recursively travel up the ancestry of sub
13627 and for each ancestor-type, check all bindings. If any of them is
13628 DEFERRED, look it up starting from sub and see if the found (overriding)
13629 binding is not DEFERRED.
13630 This is not the most efficient way to do this, but it should be ok and is
13631 clearer than something sophisticated. */
13632
13633 gcc_assert (ancestor && !sub->attr.abstract);
13634
13635 if (!ancestor->attr.abstract)
13636 return true;
13637
13638 /* Walk bindings of this ancestor. */
13639 if (ancestor->f2k_derived)
13640 {
13641 bool t;
13642 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
13643 if (!t)
13644 return false;
13645 }
13646
13647 /* Find next ancestor type and recurse on it. */
13648 ancestor = gfc_get_derived_super_type (ancestor);
13649 if (ancestor)
13650 return ensure_not_abstract (sub, ancestor);
13651
13652 return true;
13653 }
13654
13655
13656 /* This check for typebound defined assignments is done recursively
13657 since the order in which derived types are resolved is not always in
13658 order of the declarations. */
13659
13660 static void
check_defined_assignments(gfc_symbol * derived)13661 check_defined_assignments (gfc_symbol *derived)
13662 {
13663 gfc_component *c;
13664
13665 for (c = derived->components; c; c = c->next)
13666 {
13667 if (!gfc_bt_struct (c->ts.type)
13668 || c->attr.pointer
13669 || c->attr.allocatable
13670 || c->attr.proc_pointer_comp
13671 || c->attr.class_pointer
13672 || c->attr.proc_pointer)
13673 continue;
13674
13675 if (c->ts.u.derived->attr.defined_assign_comp
13676 || (c->ts.u.derived->f2k_derived
13677 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
13678 {
13679 derived->attr.defined_assign_comp = 1;
13680 return;
13681 }
13682
13683 check_defined_assignments (c->ts.u.derived);
13684 if (c->ts.u.derived->attr.defined_assign_comp)
13685 {
13686 derived->attr.defined_assign_comp = 1;
13687 return;
13688 }
13689 }
13690 }
13691
13692
13693 /* Resolve a single component of a derived type or structure. */
13694
13695 static bool
resolve_component(gfc_component * c,gfc_symbol * sym)13696 resolve_component (gfc_component *c, gfc_symbol *sym)
13697 {
13698 gfc_symbol *super_type;
13699
13700 if (c->attr.artificial)
13701 return true;
13702
13703 /* Do not allow vtype components to be resolved in nameless namespaces
13704 such as block data because the procedure pointers will cause ICEs
13705 and vtables are not needed in these contexts. */
13706 if (sym->attr.vtype && sym->attr.use_assoc
13707 && sym->ns->proc_name == NULL)
13708 return true;
13709
13710 /* F2008, C442. */
13711 if ((!sym->attr.is_class || c != sym->components)
13712 && c->attr.codimension
13713 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
13714 {
13715 gfc_error ("Coarray component %qs at %L must be allocatable with "
13716 "deferred shape", c->name, &c->loc);
13717 return false;
13718 }
13719
13720 /* F2008, C443. */
13721 if (c->attr.codimension && c->ts.type == BT_DERIVED
13722 && c->ts.u.derived->ts.is_iso_c)
13723 {
13724 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13725 "shall not be a coarray", c->name, &c->loc);
13726 return false;
13727 }
13728
13729 /* F2008, C444. */
13730 if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
13731 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
13732 || c->attr.allocatable))
13733 {
13734 gfc_error ("Component %qs at %L with coarray component "
13735 "shall be a nonpointer, nonallocatable scalar",
13736 c->name, &c->loc);
13737 return false;
13738 }
13739
13740 /* F2008, C448. */
13741 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
13742 {
13743 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13744 "is not an array pointer", c->name, &c->loc);
13745 return false;
13746 }
13747
13748 /* F2003, 15.2.1 - length has to be one. */
13749 if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
13750 && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
13751 || !gfc_is_constant_expr (c->ts.u.cl->length)
13752 || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
13753 {
13754 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13755 c->name, &c->loc);
13756 return false;
13757 }
13758
13759 if (c->attr.proc_pointer && c->ts.interface)
13760 {
13761 gfc_symbol *ifc = c->ts.interface;
13762
13763 if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
13764 {
13765 c->tb->error = 1;
13766 return false;
13767 }
13768
13769 if (ifc->attr.if_source || ifc->attr.intrinsic)
13770 {
13771 /* Resolve interface and copy attributes. */
13772 if (ifc->formal && !ifc->formal_ns)
13773 resolve_symbol (ifc);
13774 if (ifc->attr.intrinsic)
13775 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
13776
13777 if (ifc->result)
13778 {
13779 c->ts = ifc->result->ts;
13780 c->attr.allocatable = ifc->result->attr.allocatable;
13781 c->attr.pointer = ifc->result->attr.pointer;
13782 c->attr.dimension = ifc->result->attr.dimension;
13783 c->as = gfc_copy_array_spec (ifc->result->as);
13784 c->attr.class_ok = ifc->result->attr.class_ok;
13785 }
13786 else
13787 {
13788 c->ts = ifc->ts;
13789 c->attr.allocatable = ifc->attr.allocatable;
13790 c->attr.pointer = ifc->attr.pointer;
13791 c->attr.dimension = ifc->attr.dimension;
13792 c->as = gfc_copy_array_spec (ifc->as);
13793 c->attr.class_ok = ifc->attr.class_ok;
13794 }
13795 c->ts.interface = ifc;
13796 c->attr.function = ifc->attr.function;
13797 c->attr.subroutine = ifc->attr.subroutine;
13798
13799 c->attr.pure = ifc->attr.pure;
13800 c->attr.elemental = ifc->attr.elemental;
13801 c->attr.recursive = ifc->attr.recursive;
13802 c->attr.always_explicit = ifc->attr.always_explicit;
13803 c->attr.ext_attr |= ifc->attr.ext_attr;
13804 /* Copy char length. */
13805 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
13806 {
13807 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
13808 if (cl->length && !cl->resolved
13809 && !gfc_resolve_expr (cl->length))
13810 {
13811 c->tb->error = 1;
13812 return false;
13813 }
13814 c->ts.u.cl = cl;
13815 }
13816 }
13817 }
13818 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
13819 {
13820 /* Since PPCs are not implicitly typed, a PPC without an explicit
13821 interface must be a subroutine. */
13822 gfc_add_subroutine (&c->attr, c->name, &c->loc);
13823 }
13824
13825 /* Procedure pointer components: Check PASS arg. */
13826 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
13827 && !sym->attr.vtype)
13828 {
13829 gfc_symbol* me_arg;
13830
13831 if (c->tb->pass_arg)
13832 {
13833 gfc_formal_arglist* i;
13834
13835 /* If an explicit passing argument name is given, walk the arg-list
13836 and look for it. */
13837
13838 me_arg = NULL;
13839 c->tb->pass_arg_num = 1;
13840 for (i = c->ts.interface->formal; i; i = i->next)
13841 {
13842 if (!strcmp (i->sym->name, c->tb->pass_arg))
13843 {
13844 me_arg = i->sym;
13845 break;
13846 }
13847 c->tb->pass_arg_num++;
13848 }
13849
13850 if (!me_arg)
13851 {
13852 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13853 "at %L has no argument %qs", c->name,
13854 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
13855 c->tb->error = 1;
13856 return false;
13857 }
13858 }
13859 else
13860 {
13861 /* Otherwise, take the first one; there should in fact be at least
13862 one. */
13863 c->tb->pass_arg_num = 1;
13864 if (!c->ts.interface->formal)
13865 {
13866 gfc_error ("Procedure pointer component %qs with PASS at %L "
13867 "must have at least one argument",
13868 c->name, &c->loc);
13869 c->tb->error = 1;
13870 return false;
13871 }
13872 me_arg = c->ts.interface->formal->sym;
13873 }
13874
13875 /* Now check that the argument-type matches. */
13876 gcc_assert (me_arg);
13877 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
13878 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
13879 || (me_arg->ts.type == BT_CLASS
13880 && CLASS_DATA (me_arg)->ts.u.derived != sym))
13881 {
13882 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13883 " the derived type %qs", me_arg->name, c->name,
13884 me_arg->name, &c->loc, sym->name);
13885 c->tb->error = 1;
13886 return false;
13887 }
13888
13889 /* Check for F03:C453. */
13890 if (CLASS_DATA (me_arg)->attr.dimension)
13891 {
13892 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13893 "must be scalar", me_arg->name, c->name, me_arg->name,
13894 &c->loc);
13895 c->tb->error = 1;
13896 return false;
13897 }
13898
13899 if (CLASS_DATA (me_arg)->attr.class_pointer)
13900 {
13901 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13902 "may not have the POINTER attribute", me_arg->name,
13903 c->name, me_arg->name, &c->loc);
13904 c->tb->error = 1;
13905 return false;
13906 }
13907
13908 if (CLASS_DATA (me_arg)->attr.allocatable)
13909 {
13910 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13911 "may not be ALLOCATABLE", me_arg->name, c->name,
13912 me_arg->name, &c->loc);
13913 c->tb->error = 1;
13914 return false;
13915 }
13916
13917 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
13918 {
13919 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13920 " at %L", c->name, &c->loc);
13921 return false;
13922 }
13923
13924 }
13925
13926 /* Check type-spec if this is not the parent-type component. */
13927 if (((sym->attr.is_class
13928 && (!sym->components->ts.u.derived->attr.extension
13929 || c != sym->components->ts.u.derived->components))
13930 || (!sym->attr.is_class
13931 && (!sym->attr.extension || c != sym->components)))
13932 && !sym->attr.vtype
13933 && !resolve_typespec_used (&c->ts, &c->loc, c->name))
13934 return false;
13935
13936 super_type = gfc_get_derived_super_type (sym);
13937
13938 /* If this type is an extension, set the accessibility of the parent
13939 component. */
13940 if (super_type
13941 && ((sym->attr.is_class
13942 && c == sym->components->ts.u.derived->components)
13943 || (!sym->attr.is_class && c == sym->components))
13944 && strcmp (super_type->name, c->name) == 0)
13945 c->attr.access = super_type->attr.access;
13946
13947 /* If this type is an extension, see if this component has the same name
13948 as an inherited type-bound procedure. */
13949 if (super_type && !sym->attr.is_class
13950 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
13951 {
13952 gfc_error ("Component %qs of %qs at %L has the same name as an"
13953 " inherited type-bound procedure",
13954 c->name, sym->name, &c->loc);
13955 return false;
13956 }
13957
13958 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
13959 && !c->ts.deferred)
13960 {
13961 if (c->ts.u.cl->length == NULL
13962 || (!resolve_charlen(c->ts.u.cl))
13963 || !gfc_is_constant_expr (c->ts.u.cl->length))
13964 {
13965 gfc_error ("Character length of component %qs needs to "
13966 "be a constant specification expression at %L",
13967 c->name,
13968 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
13969 return false;
13970 }
13971 }
13972
13973 if (c->ts.type == BT_CHARACTER && c->ts.deferred
13974 && !c->attr.pointer && !c->attr.allocatable)
13975 {
13976 gfc_error ("Character component %qs of %qs at %L with deferred "
13977 "length must be a POINTER or ALLOCATABLE",
13978 c->name, sym->name, &c->loc);
13979 return false;
13980 }
13981
13982 /* Add the hidden deferred length field. */
13983 if (c->ts.type == BT_CHARACTER
13984 && (c->ts.deferred || c->attr.pdt_string)
13985 && !c->attr.function
13986 && !sym->attr.is_class)
13987 {
13988 char name[GFC_MAX_SYMBOL_LEN+9];
13989 gfc_component *strlen;
13990 sprintf (name, "_%s_length", c->name);
13991 strlen = gfc_find_component (sym, name, true, true, NULL);
13992 if (strlen == NULL)
13993 {
13994 if (!gfc_add_component (sym, name, &strlen))
13995 return false;
13996 strlen->ts.type = BT_INTEGER;
13997 strlen->ts.kind = gfc_charlen_int_kind;
13998 strlen->attr.access = ACCESS_PRIVATE;
13999 strlen->attr.artificial = 1;
14000 }
14001 }
14002
14003 if (c->ts.type == BT_DERIVED
14004 && sym->component_access != ACCESS_PRIVATE
14005 && gfc_check_symbol_access (sym)
14006 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
14007 && !c->ts.u.derived->attr.use_assoc
14008 && !gfc_check_symbol_access (c->ts.u.derived)
14009 && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
14010 "PRIVATE type and cannot be a component of "
14011 "%qs, which is PUBLIC at %L", c->name,
14012 sym->name, &sym->declared_at))
14013 return false;
14014
14015 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
14016 {
14017 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14018 "type %s", c->name, &c->loc, sym->name);
14019 return false;
14020 }
14021
14022 if (sym->attr.sequence)
14023 {
14024 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
14025 {
14026 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14027 "not have the SEQUENCE attribute",
14028 c->ts.u.derived->name, &sym->declared_at);
14029 return false;
14030 }
14031 }
14032
14033 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
14034 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
14035 else if (c->ts.type == BT_CLASS && c->attr.class_ok
14036 && CLASS_DATA (c)->ts.u.derived->attr.generic)
14037 CLASS_DATA (c)->ts.u.derived
14038 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
14039
14040 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
14041 && c->attr.pointer && c->ts.u.derived->components == NULL
14042 && !c->ts.u.derived->attr.zero_comp)
14043 {
14044 gfc_error ("The pointer component %qs of %qs at %L is a type "
14045 "that has not been declared", c->name, sym->name,
14046 &c->loc);
14047 return false;
14048 }
14049
14050 if (c->ts.type == BT_CLASS && c->attr.class_ok
14051 && CLASS_DATA (c)->attr.class_pointer
14052 && CLASS_DATA (c)->ts.u.derived->components == NULL
14053 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
14054 && !UNLIMITED_POLY (c))
14055 {
14056 gfc_error ("The pointer component %qs of %qs at %L is a type "
14057 "that has not been declared", c->name, sym->name,
14058 &c->loc);
14059 return false;
14060 }
14061
14062 /* If an allocatable component derived type is of the same type as
14063 the enclosing derived type, we need a vtable generating so that
14064 the __deallocate procedure is created. */
14065 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
14066 && c->ts.u.derived == sym && c->attr.allocatable == 1)
14067 gfc_find_vtab (&c->ts);
14068
14069 /* Ensure that all the derived type components are put on the
14070 derived type list; even in formal namespaces, where derived type
14071 pointer components might not have been declared. */
14072 if (c->ts.type == BT_DERIVED
14073 && c->ts.u.derived
14074 && c->ts.u.derived->components
14075 && c->attr.pointer
14076 && sym != c->ts.u.derived)
14077 add_dt_to_dt_list (c->ts.u.derived);
14078
14079 if (!gfc_resolve_array_spec (c->as,
14080 !(c->attr.pointer || c->attr.proc_pointer
14081 || c->attr.allocatable)))
14082 return false;
14083
14084 if (c->initializer && !sym->attr.vtype
14085 && !c->attr.pdt_kind && !c->attr.pdt_len
14086 && !gfc_check_assign_symbol (sym, c, c->initializer))
14087 return false;
14088
14089 return true;
14090 }
14091
14092
14093 /* Be nice about the locus for a structure expression - show the locus of the
14094 first non-null sub-expression if we can. */
14095
14096 static locus *
cons_where(gfc_expr * struct_expr)14097 cons_where (gfc_expr *struct_expr)
14098 {
14099 gfc_constructor *cons;
14100
14101 gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
14102
14103 cons = gfc_constructor_first (struct_expr->value.constructor);
14104 for (; cons; cons = gfc_constructor_next (cons))
14105 {
14106 if (cons->expr && cons->expr->expr_type != EXPR_NULL)
14107 return &cons->expr->where;
14108 }
14109
14110 return &struct_expr->where;
14111 }
14112
14113 /* Resolve the components of a structure type. Much less work than derived
14114 types. */
14115
14116 static bool
resolve_fl_struct(gfc_symbol * sym)14117 resolve_fl_struct (gfc_symbol *sym)
14118 {
14119 gfc_component *c;
14120 gfc_expr *init = NULL;
14121 bool success;
14122
14123 /* Make sure UNIONs do not have overlapping initializers. */
14124 if (sym->attr.flavor == FL_UNION)
14125 {
14126 for (c = sym->components; c; c = c->next)
14127 {
14128 if (init && c->initializer)
14129 {
14130 gfc_error ("Conflicting initializers in union at %L and %L",
14131 cons_where (init), cons_where (c->initializer));
14132 gfc_free_expr (c->initializer);
14133 c->initializer = NULL;
14134 }
14135 if (init == NULL)
14136 init = c->initializer;
14137 }
14138 }
14139
14140 success = true;
14141 for (c = sym->components; c; c = c->next)
14142 if (!resolve_component (c, sym))
14143 success = false;
14144
14145 if (!success)
14146 return false;
14147
14148 if (sym->components)
14149 add_dt_to_dt_list (sym);
14150
14151 return true;
14152 }
14153
14154
14155 /* Resolve the components of a derived type. This does not have to wait until
14156 resolution stage, but can be done as soon as the dt declaration has been
14157 parsed. */
14158
14159 static bool
resolve_fl_derived0(gfc_symbol * sym)14160 resolve_fl_derived0 (gfc_symbol *sym)
14161 {
14162 gfc_symbol* super_type;
14163 gfc_component *c;
14164 gfc_formal_arglist *f;
14165 bool success;
14166
14167 if (sym->attr.unlimited_polymorphic)
14168 return true;
14169
14170 super_type = gfc_get_derived_super_type (sym);
14171
14172 /* F2008, C432. */
14173 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
14174 {
14175 gfc_error ("As extending type %qs at %L has a coarray component, "
14176 "parent type %qs shall also have one", sym->name,
14177 &sym->declared_at, super_type->name);
14178 return false;
14179 }
14180
14181 /* Ensure the extended type gets resolved before we do. */
14182 if (super_type && !resolve_fl_derived0 (super_type))
14183 return false;
14184
14185 /* An ABSTRACT type must be extensible. */
14186 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
14187 {
14188 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14189 sym->name, &sym->declared_at);
14190 return false;
14191 }
14192
14193 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
14194 : sym->components;
14195
14196 success = true;
14197 for ( ; c != NULL; c = c->next)
14198 if (!resolve_component (c, sym))
14199 success = false;
14200
14201 if (!success)
14202 return false;
14203
14204 /* Now add the caf token field, where needed. */
14205 if (flag_coarray != GFC_FCOARRAY_NONE
14206 && !sym->attr.is_class && !sym->attr.vtype)
14207 {
14208 for (c = sym->components; c; c = c->next)
14209 if (!c->attr.dimension && !c->attr.codimension
14210 && (c->attr.allocatable || c->attr.pointer))
14211 {
14212 char name[GFC_MAX_SYMBOL_LEN+9];
14213 gfc_component *token;
14214 sprintf (name, "_caf_%s", c->name);
14215 token = gfc_find_component (sym, name, true, true, NULL);
14216 if (token == NULL)
14217 {
14218 if (!gfc_add_component (sym, name, &token))
14219 return false;
14220 token->ts.type = BT_VOID;
14221 token->ts.kind = gfc_default_integer_kind;
14222 token->attr.access = ACCESS_PRIVATE;
14223 token->attr.artificial = 1;
14224 token->attr.caf_token = 1;
14225 }
14226 }
14227 }
14228
14229 check_defined_assignments (sym);
14230
14231 if (!sym->attr.defined_assign_comp && super_type)
14232 sym->attr.defined_assign_comp
14233 = super_type->attr.defined_assign_comp;
14234
14235 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14236 all DEFERRED bindings are overridden. */
14237 if (super_type && super_type->attr.abstract && !sym->attr.abstract
14238 && !sym->attr.is_class
14239 && !ensure_not_abstract (sym, super_type))
14240 return false;
14241
14242 /* Check that there is a component for every PDT parameter. */
14243 if (sym->attr.pdt_template)
14244 {
14245 for (f = sym->formal; f; f = f->next)
14246 {
14247 if (!f->sym)
14248 continue;
14249 c = gfc_find_component (sym, f->sym->name, true, true, NULL);
14250 if (c == NULL)
14251 {
14252 gfc_error ("Parameterized type %qs does not have a component "
14253 "corresponding to parameter %qs at %L", sym->name,
14254 f->sym->name, &sym->declared_at);
14255 break;
14256 }
14257 }
14258 }
14259
14260 /* Add derived type to the derived type list. */
14261 add_dt_to_dt_list (sym);
14262
14263 return true;
14264 }
14265
14266
14267 /* The following procedure does the full resolution of a derived type,
14268 including resolution of all type-bound procedures (if present). In contrast
14269 to 'resolve_fl_derived0' this can only be done after the module has been
14270 parsed completely. */
14271
14272 static bool
resolve_fl_derived(gfc_symbol * sym)14273 resolve_fl_derived (gfc_symbol *sym)
14274 {
14275 gfc_symbol *gen_dt = NULL;
14276
14277 if (sym->attr.unlimited_polymorphic)
14278 return true;
14279
14280 if (!sym->attr.is_class)
14281 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
14282 if (gen_dt && gen_dt->generic && gen_dt->generic->next
14283 && (!gen_dt->generic->sym->attr.use_assoc
14284 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
14285 && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
14286 "%qs at %L being the same name as derived "
14287 "type at %L", sym->name,
14288 gen_dt->generic->sym == sym
14289 ? gen_dt->generic->next->sym->name
14290 : gen_dt->generic->sym->name,
14291 gen_dt->generic->sym == sym
14292 ? &gen_dt->generic->next->sym->declared_at
14293 : &gen_dt->generic->sym->declared_at,
14294 &sym->declared_at))
14295 return false;
14296
14297 /* Resolve the finalizer procedures. */
14298 if (!gfc_resolve_finalizers (sym, NULL))
14299 return false;
14300
14301 if (sym->attr.is_class && sym->ts.u.derived == NULL)
14302 {
14303 /* Fix up incomplete CLASS symbols. */
14304 gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
14305 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
14306
14307 /* Nothing more to do for unlimited polymorphic entities. */
14308 if (data->ts.u.derived->attr.unlimited_polymorphic)
14309 return true;
14310 else if (vptr->ts.u.derived == NULL)
14311 {
14312 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
14313 gcc_assert (vtab);
14314 vptr->ts.u.derived = vtab->ts.u.derived;
14315 if (!resolve_fl_derived0 (vptr->ts.u.derived))
14316 return false;
14317 }
14318 }
14319
14320 if (!resolve_fl_derived0 (sym))
14321 return false;
14322
14323 /* Resolve the type-bound procedures. */
14324 if (!resolve_typebound_procedures (sym))
14325 return false;
14326
14327 /* Generate module vtables subject to their accessibility and their not
14328 being vtables or pdt templates. If this is not done class declarations
14329 in external procedures wind up with their own version and so SELECT TYPE
14330 fails because the vptrs do not have the same address. */
14331 if (gfc_option.allow_std & GFC_STD_F2003
14332 && sym->ns->proc_name
14333 && sym->ns->proc_name->attr.flavor == FL_MODULE
14334 && sym->attr.access != ACCESS_PRIVATE
14335 && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template))
14336 {
14337 gfc_symbol *vtab = gfc_find_derived_vtab (sym);
14338 gfc_set_sym_referenced (vtab);
14339 }
14340
14341 return true;
14342 }
14343
14344
14345 static bool
resolve_fl_namelist(gfc_symbol * sym)14346 resolve_fl_namelist (gfc_symbol *sym)
14347 {
14348 gfc_namelist *nl;
14349 gfc_symbol *nlsym;
14350
14351 for (nl = sym->namelist; nl; nl = nl->next)
14352 {
14353 /* Check again, the check in match only works if NAMELIST comes
14354 after the decl. */
14355 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
14356 {
14357 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14358 "allowed", nl->sym->name, sym->name, &sym->declared_at);
14359 return false;
14360 }
14361
14362 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
14363 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
14364 "with assumed shape in namelist %qs at %L",
14365 nl->sym->name, sym->name, &sym->declared_at))
14366 return false;
14367
14368 if (is_non_constant_shape_array (nl->sym)
14369 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
14370 "with nonconstant shape in namelist %qs at %L",
14371 nl->sym->name, sym->name, &sym->declared_at))
14372 return false;
14373
14374 if (nl->sym->ts.type == BT_CHARACTER
14375 && (nl->sym->ts.u.cl->length == NULL
14376 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
14377 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
14378 "nonconstant character length in "
14379 "namelist %qs at %L", nl->sym->name,
14380 sym->name, &sym->declared_at))
14381 return false;
14382
14383 }
14384
14385 /* Reject PRIVATE objects in a PUBLIC namelist. */
14386 if (gfc_check_symbol_access (sym))
14387 {
14388 for (nl = sym->namelist; nl; nl = nl->next)
14389 {
14390 if (!nl->sym->attr.use_assoc
14391 && !is_sym_host_assoc (nl->sym, sym->ns)
14392 && !gfc_check_symbol_access (nl->sym))
14393 {
14394 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14395 "cannot be member of PUBLIC namelist %qs at %L",
14396 nl->sym->name, sym->name, &sym->declared_at);
14397 return false;
14398 }
14399
14400 if (nl->sym->ts.type == BT_DERIVED
14401 && (nl->sym->ts.u.derived->attr.alloc_comp
14402 || nl->sym->ts.u.derived->attr.pointer_comp))
14403 {
14404 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
14405 "namelist %qs at %L with ALLOCATABLE "
14406 "or POINTER components", nl->sym->name,
14407 sym->name, &sym->declared_at))
14408 return false;
14409 return true;
14410 }
14411
14412 /* Types with private components that came here by USE-association. */
14413 if (nl->sym->ts.type == BT_DERIVED
14414 && derived_inaccessible (nl->sym->ts.u.derived))
14415 {
14416 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14417 "components and cannot be member of namelist %qs at %L",
14418 nl->sym->name, sym->name, &sym->declared_at);
14419 return false;
14420 }
14421
14422 /* Types with private components that are defined in the same module. */
14423 if (nl->sym->ts.type == BT_DERIVED
14424 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
14425 && nl->sym->ts.u.derived->attr.private_comp)
14426 {
14427 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14428 "cannot be a member of PUBLIC namelist %qs at %L",
14429 nl->sym->name, sym->name, &sym->declared_at);
14430 return false;
14431 }
14432 }
14433 }
14434
14435
14436 /* 14.1.2 A module or internal procedure represent local entities
14437 of the same type as a namelist member and so are not allowed. */
14438 for (nl = sym->namelist; nl; nl = nl->next)
14439 {
14440 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
14441 continue;
14442
14443 if (nl->sym->attr.function && nl->sym == nl->sym->result)
14444 if ((nl->sym == sym->ns->proc_name)
14445 ||
14446 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
14447 continue;
14448
14449 nlsym = NULL;
14450 if (nl->sym->name)
14451 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
14452 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
14453 {
14454 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14455 "attribute in %qs at %L", nlsym->name,
14456 &sym->declared_at);
14457 return false;
14458 }
14459 }
14460
14461 if (async_io_dt)
14462 {
14463 for (nl = sym->namelist; nl; nl = nl->next)
14464 nl->sym->attr.asynchronous = 1;
14465 }
14466 return true;
14467 }
14468
14469
14470 static bool
resolve_fl_parameter(gfc_symbol * sym)14471 resolve_fl_parameter (gfc_symbol *sym)
14472 {
14473 /* A parameter array's shape needs to be constant. */
14474 if (sym->as != NULL
14475 && (sym->as->type == AS_DEFERRED
14476 || is_non_constant_shape_array (sym)))
14477 {
14478 gfc_error ("Parameter array %qs at %L cannot be automatic "
14479 "or of deferred shape", sym->name, &sym->declared_at);
14480 return false;
14481 }
14482
14483 /* Constraints on deferred type parameter. */
14484 if (!deferred_requirements (sym))
14485 return false;
14486
14487 /* Make sure a parameter that has been implicitly typed still
14488 matches the implicit type, since PARAMETER statements can precede
14489 IMPLICIT statements. */
14490 if (sym->attr.implicit_type
14491 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
14492 sym->ns)))
14493 {
14494 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14495 "later IMPLICIT type", sym->name, &sym->declared_at);
14496 return false;
14497 }
14498
14499 /* Make sure the types of derived parameters are consistent. This
14500 type checking is deferred until resolution because the type may
14501 refer to a derived type from the host. */
14502 if (sym->ts.type == BT_DERIVED
14503 && !gfc_compare_types (&sym->ts, &sym->value->ts))
14504 {
14505 gfc_error ("Incompatible derived type in PARAMETER at %L",
14506 &sym->value->where);
14507 return false;
14508 }
14509
14510 /* F03:C509,C514. */
14511 if (sym->ts.type == BT_CLASS)
14512 {
14513 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14514 sym->name, &sym->declared_at);
14515 return false;
14516 }
14517
14518 return true;
14519 }
14520
14521
14522 /* Called by resolve_symbol to check PDTs. */
14523
14524 static void
resolve_pdt(gfc_symbol * sym)14525 resolve_pdt (gfc_symbol* sym)
14526 {
14527 gfc_symbol *derived = NULL;
14528 gfc_actual_arglist *param;
14529 gfc_component *c;
14530 bool const_len_exprs = true;
14531 bool assumed_len_exprs = false;
14532 symbol_attribute *attr;
14533
14534 if (sym->ts.type == BT_DERIVED)
14535 {
14536 derived = sym->ts.u.derived;
14537 attr = &(sym->attr);
14538 }
14539 else if (sym->ts.type == BT_CLASS)
14540 {
14541 derived = CLASS_DATA (sym)->ts.u.derived;
14542 attr = &(CLASS_DATA (sym)->attr);
14543 }
14544 else
14545 gcc_unreachable ();
14546
14547 gcc_assert (derived->attr.pdt_type);
14548
14549 for (param = sym->param_list; param; param = param->next)
14550 {
14551 c = gfc_find_component (derived, param->name, false, true, NULL);
14552 gcc_assert (c);
14553 if (c->attr.pdt_kind)
14554 continue;
14555
14556 if (param->expr && !gfc_is_constant_expr (param->expr)
14557 && c->attr.pdt_len)
14558 const_len_exprs = false;
14559 else if (param->spec_type == SPEC_ASSUMED)
14560 assumed_len_exprs = true;
14561
14562 if (param->spec_type == SPEC_DEFERRED
14563 && !attr->allocatable && !attr->pointer)
14564 gfc_error ("The object %qs at %L has a deferred LEN "
14565 "parameter %qs and is neither allocatable "
14566 "nor a pointer", sym->name, &sym->declared_at,
14567 param->name);
14568
14569 }
14570
14571 if (!const_len_exprs
14572 && (sym->ns->proc_name->attr.is_main_program
14573 || sym->ns->proc_name->attr.flavor == FL_MODULE
14574 || sym->attr.save != SAVE_NONE))
14575 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14576 "SAVE attribute or be a variable declared in the "
14577 "main program, a module or a submodule(F08/C513)",
14578 sym->name, &sym->declared_at);
14579
14580 if (assumed_len_exprs && !(sym->attr.dummy
14581 || sym->attr.select_type_temporary || sym->attr.associate_var))
14582 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14583 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14584 sym->name, &sym->declared_at);
14585 }
14586
14587
14588 /* Do anything necessary to resolve a symbol. Right now, we just
14589 assume that an otherwise unknown symbol is a variable. This sort
14590 of thing commonly happens for symbols in module. */
14591
14592 static void
resolve_symbol(gfc_symbol * sym)14593 resolve_symbol (gfc_symbol *sym)
14594 {
14595 int check_constant, mp_flag;
14596 gfc_symtree *symtree;
14597 gfc_symtree *this_symtree;
14598 gfc_namespace *ns;
14599 gfc_component *c;
14600 symbol_attribute class_attr;
14601 gfc_array_spec *as;
14602 bool saved_specification_expr;
14603
14604 if (sym->resolved)
14605 return;
14606 sym->resolved = 1;
14607
14608 /* No symbol will ever have union type; only components can be unions.
14609 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14610 (just like derived type declaration symbols have flavor FL_DERIVED). */
14611 gcc_assert (sym->ts.type != BT_UNION);
14612
14613 /* Coarrayed polymorphic objects with allocatable or pointer components are
14614 yet unsupported for -fcoarray=lib. */
14615 if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
14616 && sym->ts.u.derived && CLASS_DATA (sym)
14617 && CLASS_DATA (sym)->attr.codimension
14618 && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
14619 || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
14620 {
14621 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14622 "type coarrays at %L are unsupported", &sym->declared_at);
14623 return;
14624 }
14625
14626 if (sym->attr.artificial)
14627 return;
14628
14629 if (sym->attr.unlimited_polymorphic)
14630 return;
14631
14632 if (sym->attr.flavor == FL_UNKNOWN
14633 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
14634 && !sym->attr.generic && !sym->attr.external
14635 && sym->attr.if_source == IFSRC_UNKNOWN
14636 && sym->ts.type == BT_UNKNOWN))
14637 {
14638
14639 /* If we find that a flavorless symbol is an interface in one of the
14640 parent namespaces, find its symtree in this namespace, free the
14641 symbol and set the symtree to point to the interface symbol. */
14642 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
14643 {
14644 symtree = gfc_find_symtree (ns->sym_root, sym->name);
14645 if (symtree && (symtree->n.sym->generic ||
14646 (symtree->n.sym->attr.flavor == FL_PROCEDURE
14647 && sym->ns->construct_entities)))
14648 {
14649 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
14650 sym->name);
14651 if (this_symtree->n.sym == sym)
14652 {
14653 symtree->n.sym->refs++;
14654 gfc_release_symbol (sym);
14655 this_symtree->n.sym = symtree->n.sym;
14656 return;
14657 }
14658 }
14659 }
14660
14661 /* Otherwise give it a flavor according to such attributes as
14662 it has. */
14663 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
14664 && sym->attr.intrinsic == 0)
14665 sym->attr.flavor = FL_VARIABLE;
14666 else if (sym->attr.flavor == FL_UNKNOWN)
14667 {
14668 sym->attr.flavor = FL_PROCEDURE;
14669 if (sym->attr.dimension)
14670 sym->attr.function = 1;
14671 }
14672 }
14673
14674 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
14675 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
14676
14677 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
14678 && !resolve_procedure_interface (sym))
14679 return;
14680
14681 if (sym->attr.is_protected && !sym->attr.proc_pointer
14682 && (sym->attr.procedure || sym->attr.external))
14683 {
14684 if (sym->attr.external)
14685 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14686 "at %L", &sym->declared_at);
14687 else
14688 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14689 "at %L", &sym->declared_at);
14690
14691 return;
14692 }
14693
14694 if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
14695 return;
14696
14697 else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
14698 && !resolve_fl_struct (sym))
14699 return;
14700
14701 /* Symbols that are module procedures with results (functions) have
14702 the types and array specification copied for type checking in
14703 procedures that call them, as well as for saving to a module
14704 file. These symbols can't stand the scrutiny that their results
14705 can. */
14706 mp_flag = (sym->result != NULL && sym->result != sym);
14707
14708 /* Make sure that the intrinsic is consistent with its internal
14709 representation. This needs to be done before assigning a default
14710 type to avoid spurious warnings. */
14711 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
14712 && !gfc_resolve_intrinsic (sym, &sym->declared_at))
14713 return;
14714
14715 /* Resolve associate names. */
14716 if (sym->assoc)
14717 resolve_assoc_var (sym, true);
14718
14719 /* Assign default type to symbols that need one and don't have one. */
14720 if (sym->ts.type == BT_UNKNOWN)
14721 {
14722 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
14723 {
14724 gfc_set_default_type (sym, 1, NULL);
14725 }
14726
14727 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
14728 && !sym->attr.function && !sym->attr.subroutine
14729 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
14730 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
14731
14732 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
14733 {
14734 /* The specific case of an external procedure should emit an error
14735 in the case that there is no implicit type. */
14736 if (!mp_flag)
14737 {
14738 if (!sym->attr.mixed_entry_master)
14739 gfc_set_default_type (sym, sym->attr.external, NULL);
14740 }
14741 else
14742 {
14743 /* Result may be in another namespace. */
14744 resolve_symbol (sym->result);
14745
14746 if (!sym->result->attr.proc_pointer)
14747 {
14748 sym->ts = sym->result->ts;
14749 sym->as = gfc_copy_array_spec (sym->result->as);
14750 sym->attr.dimension = sym->result->attr.dimension;
14751 sym->attr.pointer = sym->result->attr.pointer;
14752 sym->attr.allocatable = sym->result->attr.allocatable;
14753 sym->attr.contiguous = sym->result->attr.contiguous;
14754 }
14755 }
14756 }
14757 }
14758 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
14759 {
14760 bool saved_specification_expr = specification_expr;
14761 specification_expr = true;
14762 gfc_resolve_array_spec (sym->result->as, false);
14763 specification_expr = saved_specification_expr;
14764 }
14765
14766 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
14767 {
14768 as = CLASS_DATA (sym)->as;
14769 class_attr = CLASS_DATA (sym)->attr;
14770 class_attr.pointer = class_attr.class_pointer;
14771 }
14772 else
14773 {
14774 class_attr = sym->attr;
14775 as = sym->as;
14776 }
14777
14778 /* F2008, C530. */
14779 if (sym->attr.contiguous
14780 && (!class_attr.dimension
14781 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
14782 && !class_attr.pointer)))
14783 {
14784 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14785 "array pointer or an assumed-shape or assumed-rank array",
14786 sym->name, &sym->declared_at);
14787 return;
14788 }
14789
14790 /* Assumed size arrays and assumed shape arrays must be dummy
14791 arguments. Array-spec's of implied-shape should have been resolved to
14792 AS_EXPLICIT already. */
14793
14794 if (as)
14795 {
14796 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14797 specification expression. */
14798 if (as->type == AS_IMPLIED_SHAPE)
14799 {
14800 int i;
14801 for (i=0; i<as->rank; i++)
14802 {
14803 if (as->lower[i] != NULL && as->upper[i] == NULL)
14804 {
14805 gfc_error ("Bad specification for assumed size array at %L",
14806 &as->lower[i]->where);
14807 return;
14808 }
14809 }
14810 gcc_unreachable();
14811 }
14812
14813 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
14814 || as->type == AS_ASSUMED_SHAPE)
14815 && !sym->attr.dummy && !sym->attr.select_type_temporary)
14816 {
14817 if (as->type == AS_ASSUMED_SIZE)
14818 gfc_error ("Assumed size array at %L must be a dummy argument",
14819 &sym->declared_at);
14820 else
14821 gfc_error ("Assumed shape array at %L must be a dummy argument",
14822 &sym->declared_at);
14823 return;
14824 }
14825 /* TS 29113, C535a. */
14826 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
14827 && !sym->attr.select_type_temporary)
14828 {
14829 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14830 &sym->declared_at);
14831 return;
14832 }
14833 if (as->type == AS_ASSUMED_RANK
14834 && (sym->attr.codimension || sym->attr.value))
14835 {
14836 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14837 "CODIMENSION attribute", &sym->declared_at);
14838 return;
14839 }
14840 }
14841
14842 /* Make sure symbols with known intent or optional are really dummy
14843 variable. Because of ENTRY statement, this has to be deferred
14844 until resolution time. */
14845
14846 if (!sym->attr.dummy
14847 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
14848 {
14849 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
14850 return;
14851 }
14852
14853 if (sym->attr.value && !sym->attr.dummy)
14854 {
14855 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14856 "it is not a dummy argument", sym->name, &sym->declared_at);
14857 return;
14858 }
14859
14860 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
14861 {
14862 gfc_charlen *cl = sym->ts.u.cl;
14863 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
14864 {
14865 gfc_error ("Character dummy variable %qs at %L with VALUE "
14866 "attribute must have constant length",
14867 sym->name, &sym->declared_at);
14868 return;
14869 }
14870
14871 if (sym->ts.is_c_interop
14872 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
14873 {
14874 gfc_error ("C interoperable character dummy variable %qs at %L "
14875 "with VALUE attribute must have length one",
14876 sym->name, &sym->declared_at);
14877 return;
14878 }
14879 }
14880
14881 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
14882 && sym->ts.u.derived->attr.generic)
14883 {
14884 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
14885 if (!sym->ts.u.derived)
14886 {
14887 gfc_error ("The derived type %qs at %L is of type %qs, "
14888 "which has not been defined", sym->name,
14889 &sym->declared_at, sym->ts.u.derived->name);
14890 sym->ts.type = BT_UNKNOWN;
14891 return;
14892 }
14893 }
14894
14895 /* Use the same constraints as TYPE(*), except for the type check
14896 and that only scalars and assumed-size arrays are permitted. */
14897 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
14898 {
14899 if (!sym->attr.dummy)
14900 {
14901 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14902 "a dummy argument", sym->name, &sym->declared_at);
14903 return;
14904 }
14905
14906 if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
14907 && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
14908 && sym->ts.type != BT_COMPLEX)
14909 {
14910 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14911 "of type TYPE(*) or of an numeric intrinsic type",
14912 sym->name, &sym->declared_at);
14913 return;
14914 }
14915
14916 if (sym->attr.allocatable || sym->attr.codimension
14917 || sym->attr.pointer || sym->attr.value)
14918 {
14919 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14920 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14921 "attribute", sym->name, &sym->declared_at);
14922 return;
14923 }
14924
14925 if (sym->attr.intent == INTENT_OUT)
14926 {
14927 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14928 "have the INTENT(OUT) attribute",
14929 sym->name, &sym->declared_at);
14930 return;
14931 }
14932 if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
14933 {
14934 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14935 "either be a scalar or an assumed-size array",
14936 sym->name, &sym->declared_at);
14937 return;
14938 }
14939
14940 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14941 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14942 packing. */
14943 sym->ts.type = BT_ASSUMED;
14944 sym->as = gfc_get_array_spec ();
14945 sym->as->type = AS_ASSUMED_SIZE;
14946 sym->as->rank = 1;
14947 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
14948 }
14949 else if (sym->ts.type == BT_ASSUMED)
14950 {
14951 /* TS 29113, C407a. */
14952 if (!sym->attr.dummy)
14953 {
14954 gfc_error ("Assumed type of variable %s at %L is only permitted "
14955 "for dummy variables", sym->name, &sym->declared_at);
14956 return;
14957 }
14958 if (sym->attr.allocatable || sym->attr.codimension
14959 || sym->attr.pointer || sym->attr.value)
14960 {
14961 gfc_error ("Assumed-type variable %s at %L may not have the "
14962 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14963 sym->name, &sym->declared_at);
14964 return;
14965 }
14966 if (sym->attr.intent == INTENT_OUT)
14967 {
14968 gfc_error ("Assumed-type variable %s at %L may not have the "
14969 "INTENT(OUT) attribute",
14970 sym->name, &sym->declared_at);
14971 return;
14972 }
14973 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
14974 {
14975 gfc_error ("Assumed-type variable %s at %L shall not be an "
14976 "explicit-shape array", sym->name, &sym->declared_at);
14977 return;
14978 }
14979 }
14980
14981 /* If the symbol is marked as bind(c), that it is declared at module level
14982 scope and verify its type and kind. Do not do the latter for symbols
14983 that are implicitly typed because that is handled in
14984 gfc_set_default_type. Handle dummy arguments and procedure definitions
14985 separately. Also, anything that is use associated is not handled here
14986 but instead is handled in the module it is declared in. Finally, derived
14987 type definitions are allowed to be BIND(C) since that only implies that
14988 they're interoperable, and they are checked fully for interoperability
14989 when a variable is declared of that type. */
14990 if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
14991 && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
14992 && sym->attr.flavor != FL_DERIVED)
14993 {
14994 bool t = true;
14995
14996 /* First, make sure the variable is declared at the
14997 module-level scope (J3/04-007, Section 15.3). */
14998 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
14999 sym->attr.in_common == 0)
15000 {
15001 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15002 "is neither a COMMON block nor declared at the "
15003 "module level scope", sym->name, &(sym->declared_at));
15004 t = false;
15005 }
15006 else if (sym->ts.type == BT_CHARACTER
15007 && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
15008 || !gfc_is_constant_expr (sym->ts.u.cl->length)
15009 || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
15010 {
15011 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15012 sym->name, &sym->declared_at);
15013 t = false;
15014 }
15015 else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
15016 {
15017 t = verify_com_block_vars_c_interop (sym->common_head);
15018 }
15019 else if (sym->attr.implicit_type == 0)
15020 {
15021 /* If type() declaration, we need to verify that the components
15022 of the given type are all C interoperable, etc. */
15023 if (sym->ts.type == BT_DERIVED &&
15024 sym->ts.u.derived->attr.is_c_interop != 1)
15025 {
15026 /* Make sure the user marked the derived type as BIND(C). If
15027 not, call the verify routine. This could print an error
15028 for the derived type more than once if multiple variables
15029 of that type are declared. */
15030 if (sym->ts.u.derived->attr.is_bind_c != 1)
15031 verify_bind_c_derived_type (sym->ts.u.derived);
15032 t = false;
15033 }
15034
15035 /* Verify the variable itself as C interoperable if it
15036 is BIND(C). It is not possible for this to succeed if
15037 the verify_bind_c_derived_type failed, so don't have to handle
15038 any error returned by verify_bind_c_derived_type. */
15039 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15040 sym->common_block);
15041 }
15042
15043 if (!t)
15044 {
15045 /* clear the is_bind_c flag to prevent reporting errors more than
15046 once if something failed. */
15047 sym->attr.is_bind_c = 0;
15048 return;
15049 }
15050 }
15051
15052 /* If a derived type symbol has reached this point, without its
15053 type being declared, we have an error. Notice that most
15054 conditions that produce undefined derived types have already
15055 been dealt with. However, the likes of:
15056 implicit type(t) (t) ..... call foo (t) will get us here if
15057 the type is not declared in the scope of the implicit
15058 statement. Change the type to BT_UNKNOWN, both because it is so
15059 and to prevent an ICE. */
15060 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
15061 && sym->ts.u.derived->components == NULL
15062 && !sym->ts.u.derived->attr.zero_comp)
15063 {
15064 gfc_error ("The derived type %qs at %L is of type %qs, "
15065 "which has not been defined", sym->name,
15066 &sym->declared_at, sym->ts.u.derived->name);
15067 sym->ts.type = BT_UNKNOWN;
15068 return;
15069 }
15070
15071 /* Make sure that the derived type has been resolved and that the
15072 derived type is visible in the symbol's namespace, if it is a
15073 module function and is not PRIVATE. */
15074 if (sym->ts.type == BT_DERIVED
15075 && sym->ts.u.derived->attr.use_assoc
15076 && sym->ns->proc_name
15077 && sym->ns->proc_name->attr.flavor == FL_MODULE
15078 && !resolve_fl_derived (sym->ts.u.derived))
15079 return;
15080
15081 /* Unless the derived-type declaration is use associated, Fortran 95
15082 does not allow public entries of private derived types.
15083 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15084 161 in 95-006r3. */
15085 if (sym->ts.type == BT_DERIVED
15086 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
15087 && !sym->ts.u.derived->attr.use_assoc
15088 && gfc_check_symbol_access (sym)
15089 && !gfc_check_symbol_access (sym->ts.u.derived)
15090 && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
15091 "derived type %qs",
15092 (sym->attr.flavor == FL_PARAMETER)
15093 ? "parameter" : "variable",
15094 sym->name, &sym->declared_at,
15095 sym->ts.u.derived->name))
15096 return;
15097
15098 /* F2008, C1302. */
15099 if (sym->ts.type == BT_DERIVED
15100 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
15101 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
15102 || sym->ts.u.derived->attr.lock_comp)
15103 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
15104 {
15105 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15106 "type LOCK_TYPE must be a coarray", sym->name,
15107 &sym->declared_at);
15108 return;
15109 }
15110
15111 /* TS18508, C702/C703. */
15112 if (sym->ts.type == BT_DERIVED
15113 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
15114 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
15115 || sym->ts.u.derived->attr.event_comp)
15116 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
15117 {
15118 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15119 "type EVENT_TYPE must be a coarray", sym->name,
15120 &sym->declared_at);
15121 return;
15122 }
15123
15124 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15125 default initialization is defined (5.1.2.4.4). */
15126 if (sym->ts.type == BT_DERIVED
15127 && sym->attr.dummy
15128 && sym->attr.intent == INTENT_OUT
15129 && sym->as
15130 && sym->as->type == AS_ASSUMED_SIZE)
15131 {
15132 for (c = sym->ts.u.derived->components; c; c = c->next)
15133 {
15134 if (c->initializer)
15135 {
15136 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15137 "ASSUMED SIZE and so cannot have a default initializer",
15138 sym->name, &sym->declared_at);
15139 return;
15140 }
15141 }
15142 }
15143
15144 /* F2008, C542. */
15145 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
15146 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
15147 {
15148 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15149 "INTENT(OUT)", sym->name, &sym->declared_at);
15150 return;
15151 }
15152
15153 /* TS18508. */
15154 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
15155 && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
15156 {
15157 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15158 "INTENT(OUT)", sym->name, &sym->declared_at);
15159 return;
15160 }
15161
15162 /* F2008, C525. */
15163 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
15164 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15165 && CLASS_DATA (sym)->attr.coarray_comp))
15166 || class_attr.codimension)
15167 && (sym->attr.result || sym->result == sym))
15168 {
15169 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15170 "a coarray component", sym->name, &sym->declared_at);
15171 return;
15172 }
15173
15174 /* F2008, C524. */
15175 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
15176 && sym->ts.u.derived->ts.is_iso_c)
15177 {
15178 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15179 "shall not be a coarray", sym->name, &sym->declared_at);
15180 return;
15181 }
15182
15183 /* F2008, C525. */
15184 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
15185 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15186 && CLASS_DATA (sym)->attr.coarray_comp))
15187 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
15188 || class_attr.allocatable))
15189 {
15190 gfc_error ("Variable %qs at %L with coarray component shall be a "
15191 "nonpointer, nonallocatable scalar, which is not a coarray",
15192 sym->name, &sym->declared_at);
15193 return;
15194 }
15195
15196 /* F2008, C526. The function-result case was handled above. */
15197 if (class_attr.codimension
15198 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
15199 || sym->attr.select_type_temporary
15200 || sym->attr.associate_var
15201 || (sym->ns->save_all && !sym->attr.automatic)
15202 || sym->ns->proc_name->attr.flavor == FL_MODULE
15203 || sym->ns->proc_name->attr.is_main_program
15204 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
15205 {
15206 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15207 "nor a dummy argument", sym->name, &sym->declared_at);
15208 return;
15209 }
15210 /* F2008, C528. */
15211 else if (class_attr.codimension && !sym->attr.select_type_temporary
15212 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
15213 {
15214 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15215 "deferred shape", sym->name, &sym->declared_at);
15216 return;
15217 }
15218 else if (class_attr.codimension && class_attr.allocatable && as
15219 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
15220 {
15221 gfc_error ("Allocatable coarray variable %qs at %L must have "
15222 "deferred shape", sym->name, &sym->declared_at);
15223 return;
15224 }
15225
15226 /* F2008, C541. */
15227 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
15228 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15229 && CLASS_DATA (sym)->attr.coarray_comp))
15230 || (class_attr.codimension && class_attr.allocatable))
15231 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
15232 {
15233 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15234 "allocatable coarray or have coarray components",
15235 sym->name, &sym->declared_at);
15236 return;
15237 }
15238
15239 if (class_attr.codimension && sym->attr.dummy
15240 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
15241 {
15242 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15243 "procedure %qs", sym->name, &sym->declared_at,
15244 sym->ns->proc_name->name);
15245 return;
15246 }
15247
15248 if (sym->ts.type == BT_LOGICAL
15249 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
15250 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
15251 && sym->ns->proc_name->attr.is_bind_c)))
15252 {
15253 int i;
15254 for (i = 0; gfc_logical_kinds[i].kind; i++)
15255 if (gfc_logical_kinds[i].kind == sym->ts.kind)
15256 break;
15257 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
15258 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
15259 "%L with non-C_Bool kind in BIND(C) procedure "
15260 "%qs", sym->name, &sym->declared_at,
15261 sym->ns->proc_name->name))
15262 return;
15263 else if (!gfc_logical_kinds[i].c_bool
15264 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
15265 "%qs at %L with non-C_Bool kind in "
15266 "BIND(C) procedure %qs", sym->name,
15267 &sym->declared_at,
15268 sym->attr.function ? sym->name
15269 : sym->ns->proc_name->name))
15270 return;
15271 }
15272
15273 switch (sym->attr.flavor)
15274 {
15275 case FL_VARIABLE:
15276 if (!resolve_fl_variable (sym, mp_flag))
15277 return;
15278 break;
15279
15280 case FL_PROCEDURE:
15281 if (sym->formal && !sym->formal_ns)
15282 {
15283 /* Check that none of the arguments are a namelist. */
15284 gfc_formal_arglist *formal = sym->formal;
15285
15286 for (; formal; formal = formal->next)
15287 if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
15288 {
15289 gfc_error ("Namelist %qs can not be an argument to "
15290 "subroutine or function at %L",
15291 formal->sym->name, &sym->declared_at);
15292 return;
15293 }
15294 }
15295
15296 if (!resolve_fl_procedure (sym, mp_flag))
15297 return;
15298 break;
15299
15300 case FL_NAMELIST:
15301 if (!resolve_fl_namelist (sym))
15302 return;
15303 break;
15304
15305 case FL_PARAMETER:
15306 if (!resolve_fl_parameter (sym))
15307 return;
15308 break;
15309
15310 default:
15311 break;
15312 }
15313
15314 /* Resolve array specifier. Check as well some constraints
15315 on COMMON blocks. */
15316
15317 check_constant = sym->attr.in_common && !sym->attr.pointer;
15318
15319 /* Set the formal_arg_flag so that check_conflict will not throw
15320 an error for host associated variables in the specification
15321 expression for an array_valued function. */
15322 if ((sym->attr.function || sym->attr.result) && sym->as)
15323 formal_arg_flag = true;
15324
15325 saved_specification_expr = specification_expr;
15326 specification_expr = true;
15327 gfc_resolve_array_spec (sym->as, check_constant);
15328 specification_expr = saved_specification_expr;
15329
15330 formal_arg_flag = false;
15331
15332 /* Resolve formal namespaces. */
15333 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
15334 && !sym->attr.contained && !sym->attr.intrinsic)
15335 gfc_resolve (sym->formal_ns);
15336
15337 /* Make sure the formal namespace is present. */
15338 if (sym->formal && !sym->formal_ns)
15339 {
15340 gfc_formal_arglist *formal = sym->formal;
15341 while (formal && !formal->sym)
15342 formal = formal->next;
15343
15344 if (formal)
15345 {
15346 sym->formal_ns = formal->sym->ns;
15347 if (sym->ns != formal->sym->ns)
15348 sym->formal_ns->refs++;
15349 }
15350 }
15351
15352 /* Check threadprivate restrictions. */
15353 if (sym->attr.threadprivate && !sym->attr.save
15354 && !(sym->ns->save_all && !sym->attr.automatic)
15355 && (!sym->attr.in_common
15356 && sym->module == NULL
15357 && (sym->ns->proc_name == NULL
15358 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
15359 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
15360
15361 /* Check omp declare target restrictions. */
15362 if (sym->attr.omp_declare_target
15363 && sym->attr.flavor == FL_VARIABLE
15364 && !sym->attr.save
15365 && !(sym->ns->save_all && !sym->attr.automatic)
15366 && (!sym->attr.in_common
15367 && sym->module == NULL
15368 && (sym->ns->proc_name == NULL
15369 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
15370 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15371 sym->name, &sym->declared_at);
15372
15373 /* If we have come this far we can apply default-initializers, as
15374 described in 14.7.5, to those variables that have not already
15375 been assigned one. */
15376 if (sym->ts.type == BT_DERIVED
15377 && !sym->value
15378 && !sym->attr.allocatable
15379 && !sym->attr.alloc_comp)
15380 {
15381 symbol_attribute *a = &sym->attr;
15382
15383 if ((!a->save && !a->dummy && !a->pointer
15384 && !a->in_common && !a->use_assoc
15385 && a->referenced
15386 && !((a->function || a->result)
15387 && (!a->dimension
15388 || sym->ts.u.derived->attr.alloc_comp
15389 || sym->ts.u.derived->attr.pointer_comp))
15390 && !(a->function && sym != sym->result))
15391 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
15392 apply_default_init (sym);
15393 else if (a->function && sym->result && a->access != ACCESS_PRIVATE
15394 && (sym->ts.u.derived->attr.alloc_comp
15395 || sym->ts.u.derived->attr.pointer_comp))
15396 /* Mark the result symbol to be referenced, when it has allocatable
15397 components. */
15398 sym->result->attr.referenced = 1;
15399 }
15400
15401 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
15402 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
15403 && !CLASS_DATA (sym)->attr.class_pointer
15404 && !CLASS_DATA (sym)->attr.allocatable)
15405 apply_default_init (sym);
15406
15407 /* If this symbol has a type-spec, check it. */
15408 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
15409 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
15410 if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
15411 return;
15412
15413 if (sym->param_list)
15414 resolve_pdt (sym);
15415 }
15416
15417
15418 /************* Resolve DATA statements *************/
15419
15420 static struct
15421 {
15422 gfc_data_value *vnode;
15423 mpz_t left;
15424 }
15425 values;
15426
15427
15428 /* Advance the values structure to point to the next value in the data list. */
15429
15430 static bool
next_data_value(void)15431 next_data_value (void)
15432 {
15433 while (mpz_cmp_ui (values.left, 0) == 0)
15434 {
15435
15436 if (values.vnode->next == NULL)
15437 return false;
15438
15439 values.vnode = values.vnode->next;
15440 mpz_set (values.left, values.vnode->repeat);
15441 }
15442
15443 return true;
15444 }
15445
15446
15447 static bool
check_data_variable(gfc_data_variable * var,locus * where)15448 check_data_variable (gfc_data_variable *var, locus *where)
15449 {
15450 gfc_expr *e;
15451 mpz_t size;
15452 mpz_t offset;
15453 bool t;
15454 ar_type mark = AR_UNKNOWN;
15455 int i;
15456 mpz_t section_index[GFC_MAX_DIMENSIONS];
15457 gfc_ref *ref;
15458 gfc_array_ref *ar;
15459 gfc_symbol *sym;
15460 int has_pointer;
15461
15462 if (!gfc_resolve_expr (var->expr))
15463 return false;
15464
15465 ar = NULL;
15466 mpz_init_set_si (offset, 0);
15467 e = var->expr;
15468
15469 if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
15470 && e->value.function.isym->id == GFC_ISYM_CAF_GET)
15471 e = e->value.function.actual->expr;
15472
15473 if (e->expr_type != EXPR_VARIABLE)
15474 {
15475 gfc_error ("Expecting definable entity near %L", where);
15476 return false;
15477 }
15478
15479 sym = e->symtree->n.sym;
15480
15481 if (sym->ns->is_block_data && !sym->attr.in_common)
15482 {
15483 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15484 sym->name, &sym->declared_at);
15485 return false;
15486 }
15487
15488 if (e->ref == NULL && sym->as)
15489 {
15490 gfc_error ("DATA array %qs at %L must be specified in a previous"
15491 " declaration", sym->name, where);
15492 return false;
15493 }
15494
15495 has_pointer = sym->attr.pointer;
15496
15497 if (gfc_is_coindexed (e))
15498 {
15499 gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
15500 where);
15501 return false;
15502 }
15503
15504 for (ref = e->ref; ref; ref = ref->next)
15505 {
15506 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
15507 has_pointer = 1;
15508
15509 if (has_pointer
15510 && ref->type == REF_ARRAY
15511 && ref->u.ar.type != AR_FULL)
15512 {
15513 gfc_error ("DATA element %qs at %L is a pointer and so must "
15514 "be a full array", sym->name, where);
15515 return false;
15516 }
15517 }
15518
15519 if (e->rank == 0 || has_pointer)
15520 {
15521 mpz_init_set_ui (size, 1);
15522 ref = NULL;
15523 }
15524 else
15525 {
15526 ref = e->ref;
15527
15528 /* Find the array section reference. */
15529 for (ref = e->ref; ref; ref = ref->next)
15530 {
15531 if (ref->type != REF_ARRAY)
15532 continue;
15533 if (ref->u.ar.type == AR_ELEMENT)
15534 continue;
15535 break;
15536 }
15537 gcc_assert (ref);
15538
15539 /* Set marks according to the reference pattern. */
15540 switch (ref->u.ar.type)
15541 {
15542 case AR_FULL:
15543 mark = AR_FULL;
15544 break;
15545
15546 case AR_SECTION:
15547 ar = &ref->u.ar;
15548 /* Get the start position of array section. */
15549 gfc_get_section_index (ar, section_index, &offset);
15550 mark = AR_SECTION;
15551 break;
15552
15553 default:
15554 gcc_unreachable ();
15555 }
15556
15557 if (!gfc_array_size (e, &size))
15558 {
15559 gfc_error ("Nonconstant array section at %L in DATA statement",
15560 where);
15561 mpz_clear (offset);
15562 return false;
15563 }
15564 }
15565
15566 t = true;
15567
15568 while (mpz_cmp_ui (size, 0) > 0)
15569 {
15570 if (!next_data_value ())
15571 {
15572 gfc_error ("DATA statement at %L has more variables than values",
15573 where);
15574 t = false;
15575 break;
15576 }
15577
15578 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
15579 if (!t)
15580 break;
15581
15582 /* If we have more than one element left in the repeat count,
15583 and we have more than one element left in the target variable,
15584 then create a range assignment. */
15585 /* FIXME: Only done for full arrays for now, since array sections
15586 seem tricky. */
15587 if (mark == AR_FULL && ref && ref->next == NULL
15588 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
15589 {
15590 mpz_t range;
15591
15592 if (mpz_cmp (size, values.left) >= 0)
15593 {
15594 mpz_init_set (range, values.left);
15595 mpz_sub (size, size, values.left);
15596 mpz_set_ui (values.left, 0);
15597 }
15598 else
15599 {
15600 mpz_init_set (range, size);
15601 mpz_sub (values.left, values.left, size);
15602 mpz_set_ui (size, 0);
15603 }
15604
15605 t = gfc_assign_data_value (var->expr, values.vnode->expr,
15606 offset, &range);
15607
15608 mpz_add (offset, offset, range);
15609 mpz_clear (range);
15610
15611 if (!t)
15612 break;
15613 }
15614
15615 /* Assign initial value to symbol. */
15616 else
15617 {
15618 mpz_sub_ui (values.left, values.left, 1);
15619 mpz_sub_ui (size, size, 1);
15620
15621 t = gfc_assign_data_value (var->expr, values.vnode->expr,
15622 offset, NULL);
15623 if (!t)
15624 break;
15625
15626 if (mark == AR_FULL)
15627 mpz_add_ui (offset, offset, 1);
15628
15629 /* Modify the array section indexes and recalculate the offset
15630 for next element. */
15631 else if (mark == AR_SECTION)
15632 gfc_advance_section (section_index, ar, &offset);
15633 }
15634 }
15635
15636 if (mark == AR_SECTION)
15637 {
15638 for (i = 0; i < ar->dimen; i++)
15639 mpz_clear (section_index[i]);
15640 }
15641
15642 mpz_clear (size);
15643 mpz_clear (offset);
15644
15645 return t;
15646 }
15647
15648
15649 static bool traverse_data_var (gfc_data_variable *, locus *);
15650
15651 /* Iterate over a list of elements in a DATA statement. */
15652
15653 static bool
traverse_data_list(gfc_data_variable * var,locus * where)15654 traverse_data_list (gfc_data_variable *var, locus *where)
15655 {
15656 mpz_t trip;
15657 iterator_stack frame;
15658 gfc_expr *e, *start, *end, *step;
15659 bool retval = true;
15660
15661 mpz_init (frame.value);
15662 mpz_init (trip);
15663
15664 start = gfc_copy_expr (var->iter.start);
15665 end = gfc_copy_expr (var->iter.end);
15666 step = gfc_copy_expr (var->iter.step);
15667
15668 if (!gfc_simplify_expr (start, 1)
15669 || start->expr_type != EXPR_CONSTANT)
15670 {
15671 gfc_error ("start of implied-do loop at %L could not be "
15672 "simplified to a constant value", &start->where);
15673 retval = false;
15674 goto cleanup;
15675 }
15676 if (!gfc_simplify_expr (end, 1)
15677 || end->expr_type != EXPR_CONSTANT)
15678 {
15679 gfc_error ("end of implied-do loop at %L could not be "
15680 "simplified to a constant value", &start->where);
15681 retval = false;
15682 goto cleanup;
15683 }
15684 if (!gfc_simplify_expr (step, 1)
15685 || step->expr_type != EXPR_CONSTANT)
15686 {
15687 gfc_error ("step of implied-do loop at %L could not be "
15688 "simplified to a constant value", &start->where);
15689 retval = false;
15690 goto cleanup;
15691 }
15692
15693 mpz_set (trip, end->value.integer);
15694 mpz_sub (trip, trip, start->value.integer);
15695 mpz_add (trip, trip, step->value.integer);
15696
15697 mpz_div (trip, trip, step->value.integer);
15698
15699 mpz_set (frame.value, start->value.integer);
15700
15701 frame.prev = iter_stack;
15702 frame.variable = var->iter.var->symtree;
15703 iter_stack = &frame;
15704
15705 while (mpz_cmp_ui (trip, 0) > 0)
15706 {
15707 if (!traverse_data_var (var->list, where))
15708 {
15709 retval = false;
15710 goto cleanup;
15711 }
15712
15713 e = gfc_copy_expr (var->expr);
15714 if (!gfc_simplify_expr (e, 1))
15715 {
15716 gfc_free_expr (e);
15717 retval = false;
15718 goto cleanup;
15719 }
15720
15721 mpz_add (frame.value, frame.value, step->value.integer);
15722
15723 mpz_sub_ui (trip, trip, 1);
15724 }
15725
15726 cleanup:
15727 mpz_clear (frame.value);
15728 mpz_clear (trip);
15729
15730 gfc_free_expr (start);
15731 gfc_free_expr (end);
15732 gfc_free_expr (step);
15733
15734 iter_stack = frame.prev;
15735 return retval;
15736 }
15737
15738
15739 /* Type resolve variables in the variable list of a DATA statement. */
15740
15741 static bool
traverse_data_var(gfc_data_variable * var,locus * where)15742 traverse_data_var (gfc_data_variable *var, locus *where)
15743 {
15744 bool t;
15745
15746 for (; var; var = var->next)
15747 {
15748 if (var->expr == NULL)
15749 t = traverse_data_list (var, where);
15750 else
15751 t = check_data_variable (var, where);
15752
15753 if (!t)
15754 return false;
15755 }
15756
15757 return true;
15758 }
15759
15760
15761 /* Resolve the expressions and iterators associated with a data statement.
15762 This is separate from the assignment checking because data lists should
15763 only be resolved once. */
15764
15765 static bool
resolve_data_variables(gfc_data_variable * d)15766 resolve_data_variables (gfc_data_variable *d)
15767 {
15768 for (; d; d = d->next)
15769 {
15770 if (d->list == NULL)
15771 {
15772 if (!gfc_resolve_expr (d->expr))
15773 return false;
15774 }
15775 else
15776 {
15777 if (!gfc_resolve_iterator (&d->iter, false, true))
15778 return false;
15779
15780 if (!resolve_data_variables (d->list))
15781 return false;
15782 }
15783 }
15784
15785 return true;
15786 }
15787
15788
15789 /* Resolve a single DATA statement. We implement this by storing a pointer to
15790 the value list into static variables, and then recursively traversing the
15791 variables list, expanding iterators and such. */
15792
15793 static void
resolve_data(gfc_data * d)15794 resolve_data (gfc_data *d)
15795 {
15796
15797 if (!resolve_data_variables (d->var))
15798 return;
15799
15800 values.vnode = d->value;
15801 if (d->value == NULL)
15802 mpz_set_ui (values.left, 0);
15803 else
15804 mpz_set (values.left, d->value->repeat);
15805
15806 if (!traverse_data_var (d->var, &d->where))
15807 return;
15808
15809 /* At this point, we better not have any values left. */
15810
15811 if (next_data_value ())
15812 gfc_error ("DATA statement at %L has more values than variables",
15813 &d->where);
15814 }
15815
15816
15817 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15818 accessed by host or use association, is a dummy argument to a pure function,
15819 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15820 is storage associated with any such variable, shall not be used in the
15821 following contexts: (clients of this function). */
15822
15823 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15824 procedure. Returns zero if assignment is OK, nonzero if there is a
15825 problem. */
15826 int
gfc_impure_variable(gfc_symbol * sym)15827 gfc_impure_variable (gfc_symbol *sym)
15828 {
15829 gfc_symbol *proc;
15830 gfc_namespace *ns;
15831
15832 if (sym->attr.use_assoc || sym->attr.in_common)
15833 return 1;
15834
15835 /* Check if the symbol's ns is inside the pure procedure. */
15836 for (ns = gfc_current_ns; ns; ns = ns->parent)
15837 {
15838 if (ns == sym->ns)
15839 break;
15840 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
15841 return 1;
15842 }
15843
15844 proc = sym->ns->proc_name;
15845 if (sym->attr.dummy
15846 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
15847 || proc->attr.function))
15848 return 1;
15849
15850 /* TODO: Sort out what can be storage associated, if anything, and include
15851 it here. In principle equivalences should be scanned but it does not
15852 seem to be possible to storage associate an impure variable this way. */
15853 return 0;
15854 }
15855
15856
15857 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15858 current namespace is inside a pure procedure. */
15859
15860 int
gfc_pure(gfc_symbol * sym)15861 gfc_pure (gfc_symbol *sym)
15862 {
15863 symbol_attribute attr;
15864 gfc_namespace *ns;
15865
15866 if (sym == NULL)
15867 {
15868 /* Check if the current namespace or one of its parents
15869 belongs to a pure procedure. */
15870 for (ns = gfc_current_ns; ns; ns = ns->parent)
15871 {
15872 sym = ns->proc_name;
15873 if (sym == NULL)
15874 return 0;
15875 attr = sym->attr;
15876 if (attr.flavor == FL_PROCEDURE && attr.pure)
15877 return 1;
15878 }
15879 return 0;
15880 }
15881
15882 attr = sym->attr;
15883
15884 return attr.flavor == FL_PROCEDURE && attr.pure;
15885 }
15886
15887
15888 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15889 checks if the current namespace is implicitly pure. Note that this
15890 function returns false for a PURE procedure. */
15891
15892 int
gfc_implicit_pure(gfc_symbol * sym)15893 gfc_implicit_pure (gfc_symbol *sym)
15894 {
15895 gfc_namespace *ns;
15896
15897 if (sym == NULL)
15898 {
15899 /* Check if the current procedure is implicit_pure. Walk up
15900 the procedure list until we find a procedure. */
15901 for (ns = gfc_current_ns; ns; ns = ns->parent)
15902 {
15903 sym = ns->proc_name;
15904 if (sym == NULL)
15905 return 0;
15906
15907 if (sym->attr.flavor == FL_PROCEDURE)
15908 break;
15909 }
15910 }
15911
15912 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
15913 && !sym->attr.pure;
15914 }
15915
15916
15917 void
gfc_unset_implicit_pure(gfc_symbol * sym)15918 gfc_unset_implicit_pure (gfc_symbol *sym)
15919 {
15920 gfc_namespace *ns;
15921
15922 if (sym == NULL)
15923 {
15924 /* Check if the current procedure is implicit_pure. Walk up
15925 the procedure list until we find a procedure. */
15926 for (ns = gfc_current_ns; ns; ns = ns->parent)
15927 {
15928 sym = ns->proc_name;
15929 if (sym == NULL)
15930 return;
15931
15932 if (sym->attr.flavor == FL_PROCEDURE)
15933 break;
15934 }
15935 }
15936
15937 if (sym->attr.flavor == FL_PROCEDURE)
15938 sym->attr.implicit_pure = 0;
15939 else
15940 sym->attr.pure = 0;
15941 }
15942
15943
15944 /* Test whether the current procedure is elemental or not. */
15945
15946 int
gfc_elemental(gfc_symbol * sym)15947 gfc_elemental (gfc_symbol *sym)
15948 {
15949 symbol_attribute attr;
15950
15951 if (sym == NULL)
15952 sym = gfc_current_ns->proc_name;
15953 if (sym == NULL)
15954 return 0;
15955 attr = sym->attr;
15956
15957 return attr.flavor == FL_PROCEDURE && attr.elemental;
15958 }
15959
15960
15961 /* Warn about unused labels. */
15962
15963 static void
warn_unused_fortran_label(gfc_st_label * label)15964 warn_unused_fortran_label (gfc_st_label *label)
15965 {
15966 if (label == NULL)
15967 return;
15968
15969 warn_unused_fortran_label (label->left);
15970
15971 if (label->defined == ST_LABEL_UNKNOWN)
15972 return;
15973
15974 switch (label->referenced)
15975 {
15976 case ST_LABEL_UNKNOWN:
15977 gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
15978 label->value, &label->where);
15979 break;
15980
15981 case ST_LABEL_BAD_TARGET:
15982 gfc_warning (OPT_Wunused_label,
15983 "Label %d at %L defined but cannot be used",
15984 label->value, &label->where);
15985 break;
15986
15987 default:
15988 break;
15989 }
15990
15991 warn_unused_fortran_label (label->right);
15992 }
15993
15994
15995 /* Returns the sequence type of a symbol or sequence. */
15996
15997 static seq_type
sequence_type(gfc_typespec ts)15998 sequence_type (gfc_typespec ts)
15999 {
16000 seq_type result;
16001 gfc_component *c;
16002
16003 switch (ts.type)
16004 {
16005 case BT_DERIVED:
16006
16007 if (ts.u.derived->components == NULL)
16008 return SEQ_NONDEFAULT;
16009
16010 result = sequence_type (ts.u.derived->components->ts);
16011 for (c = ts.u.derived->components->next; c; c = c->next)
16012 if (sequence_type (c->ts) != result)
16013 return SEQ_MIXED;
16014
16015 return result;
16016
16017 case BT_CHARACTER:
16018 if (ts.kind != gfc_default_character_kind)
16019 return SEQ_NONDEFAULT;
16020
16021 return SEQ_CHARACTER;
16022
16023 case BT_INTEGER:
16024 if (ts.kind != gfc_default_integer_kind)
16025 return SEQ_NONDEFAULT;
16026
16027 return SEQ_NUMERIC;
16028
16029 case BT_REAL:
16030 if (!(ts.kind == gfc_default_real_kind
16031 || ts.kind == gfc_default_double_kind))
16032 return SEQ_NONDEFAULT;
16033
16034 return SEQ_NUMERIC;
16035
16036 case BT_COMPLEX:
16037 if (ts.kind != gfc_default_complex_kind)
16038 return SEQ_NONDEFAULT;
16039
16040 return SEQ_NUMERIC;
16041
16042 case BT_LOGICAL:
16043 if (ts.kind != gfc_default_logical_kind)
16044 return SEQ_NONDEFAULT;
16045
16046 return SEQ_NUMERIC;
16047
16048 default:
16049 return SEQ_NONDEFAULT;
16050 }
16051 }
16052
16053
16054 /* Resolve derived type EQUIVALENCE object. */
16055
16056 static bool
resolve_equivalence_derived(gfc_symbol * derived,gfc_symbol * sym,gfc_expr * e)16057 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
16058 {
16059 gfc_component *c = derived->components;
16060
16061 if (!derived)
16062 return true;
16063
16064 /* Shall not be an object of nonsequence derived type. */
16065 if (!derived->attr.sequence)
16066 {
16067 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16068 "attribute to be an EQUIVALENCE object", sym->name,
16069 &e->where);
16070 return false;
16071 }
16072
16073 /* Shall not have allocatable components. */
16074 if (derived->attr.alloc_comp)
16075 {
16076 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16077 "components to be an EQUIVALENCE object",sym->name,
16078 &e->where);
16079 return false;
16080 }
16081
16082 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
16083 {
16084 gfc_error ("Derived type variable %qs at %L with default "
16085 "initialization cannot be in EQUIVALENCE with a variable "
16086 "in COMMON", sym->name, &e->where);
16087 return false;
16088 }
16089
16090 for (; c ; c = c->next)
16091 {
16092 if (gfc_bt_struct (c->ts.type)
16093 && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
16094 return false;
16095
16096 /* Shall not be an object of sequence derived type containing a pointer
16097 in the structure. */
16098 if (c->attr.pointer)
16099 {
16100 gfc_error ("Derived type variable %qs at %L with pointer "
16101 "component(s) cannot be an EQUIVALENCE object",
16102 sym->name, &e->where);
16103 return false;
16104 }
16105 }
16106 return true;
16107 }
16108
16109
16110 /* Resolve equivalence object.
16111 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16112 an allocatable array, an object of nonsequence derived type, an object of
16113 sequence derived type containing a pointer at any level of component
16114 selection, an automatic object, a function name, an entry name, a result
16115 name, a named constant, a structure component, or a subobject of any of
16116 the preceding objects. A substring shall not have length zero. A
16117 derived type shall not have components with default initialization nor
16118 shall two objects of an equivalence group be initialized.
16119 Either all or none of the objects shall have an protected attribute.
16120 The simple constraints are done in symbol.c(check_conflict) and the rest
16121 are implemented here. */
16122
16123 static void
resolve_equivalence(gfc_equiv * eq)16124 resolve_equivalence (gfc_equiv *eq)
16125 {
16126 gfc_symbol *sym;
16127 gfc_symbol *first_sym;
16128 gfc_expr *e;
16129 gfc_ref *r;
16130 locus *last_where = NULL;
16131 seq_type eq_type, last_eq_type;
16132 gfc_typespec *last_ts;
16133 int object, cnt_protected;
16134 const char *msg;
16135
16136 last_ts = &eq->expr->symtree->n.sym->ts;
16137
16138 first_sym = eq->expr->symtree->n.sym;
16139
16140 cnt_protected = 0;
16141
16142 for (object = 1; eq; eq = eq->eq, object++)
16143 {
16144 e = eq->expr;
16145
16146 e->ts = e->symtree->n.sym->ts;
16147 /* match_varspec might not know yet if it is seeing
16148 array reference or substring reference, as it doesn't
16149 know the types. */
16150 if (e->ref && e->ref->type == REF_ARRAY)
16151 {
16152 gfc_ref *ref = e->ref;
16153 sym = e->symtree->n.sym;
16154
16155 if (sym->attr.dimension)
16156 {
16157 ref->u.ar.as = sym->as;
16158 ref = ref->next;
16159 }
16160
16161 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16162 if (e->ts.type == BT_CHARACTER
16163 && ref
16164 && ref->type == REF_ARRAY
16165 && ref->u.ar.dimen == 1
16166 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
16167 && ref->u.ar.stride[0] == NULL)
16168 {
16169 gfc_expr *start = ref->u.ar.start[0];
16170 gfc_expr *end = ref->u.ar.end[0];
16171 void *mem = NULL;
16172
16173 /* Optimize away the (:) reference. */
16174 if (start == NULL && end == NULL)
16175 {
16176 if (e->ref == ref)
16177 e->ref = ref->next;
16178 else
16179 e->ref->next = ref->next;
16180 mem = ref;
16181 }
16182 else
16183 {
16184 ref->type = REF_SUBSTRING;
16185 if (start == NULL)
16186 start = gfc_get_int_expr (gfc_charlen_int_kind,
16187 NULL, 1);
16188 ref->u.ss.start = start;
16189 if (end == NULL && e->ts.u.cl)
16190 end = gfc_copy_expr (e->ts.u.cl->length);
16191 ref->u.ss.end = end;
16192 ref->u.ss.length = e->ts.u.cl;
16193 e->ts.u.cl = NULL;
16194 }
16195 ref = ref->next;
16196 free (mem);
16197 }
16198
16199 /* Any further ref is an error. */
16200 if (ref)
16201 {
16202 gcc_assert (ref->type == REF_ARRAY);
16203 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16204 &ref->u.ar.where);
16205 continue;
16206 }
16207 }
16208
16209 if (!gfc_resolve_expr (e))
16210 continue;
16211
16212 sym = e->symtree->n.sym;
16213
16214 if (sym->attr.is_protected)
16215 cnt_protected++;
16216 if (cnt_protected > 0 && cnt_protected != object)
16217 {
16218 gfc_error ("Either all or none of the objects in the "
16219 "EQUIVALENCE set at %L shall have the "
16220 "PROTECTED attribute",
16221 &e->where);
16222 break;
16223 }
16224
16225 /* Shall not equivalence common block variables in a PURE procedure. */
16226 if (sym->ns->proc_name
16227 && sym->ns->proc_name->attr.pure
16228 && sym->attr.in_common)
16229 {
16230 /* Need to check for symbols that may have entered the pure
16231 procedure via a USE statement. */
16232 bool saw_sym = false;
16233 if (sym->ns->use_stmts)
16234 {
16235 gfc_use_rename *r;
16236 for (r = sym->ns->use_stmts->rename; r; r = r->next)
16237 if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
16238 }
16239 else
16240 saw_sym = true;
16241
16242 if (saw_sym)
16243 gfc_error ("COMMON block member %qs at %L cannot be an "
16244 "EQUIVALENCE object in the pure procedure %qs",
16245 sym->name, &e->where, sym->ns->proc_name->name);
16246 break;
16247 }
16248
16249 /* Shall not be a named constant. */
16250 if (e->expr_type == EXPR_CONSTANT)
16251 {
16252 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16253 "object", sym->name, &e->where);
16254 continue;
16255 }
16256
16257 if (e->ts.type == BT_DERIVED
16258 && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
16259 continue;
16260
16261 /* Check that the types correspond correctly:
16262 Note 5.28:
16263 A numeric sequence structure may be equivalenced to another sequence
16264 structure, an object of default integer type, default real type, double
16265 precision real type, default logical type such that components of the
16266 structure ultimately only become associated to objects of the same
16267 kind. A character sequence structure may be equivalenced to an object
16268 of default character kind or another character sequence structure.
16269 Other objects may be equivalenced only to objects of the same type and
16270 kind parameters. */
16271
16272 /* Identical types are unconditionally OK. */
16273 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
16274 goto identical_types;
16275
16276 last_eq_type = sequence_type (*last_ts);
16277 eq_type = sequence_type (sym->ts);
16278
16279 /* Since the pair of objects is not of the same type, mixed or
16280 non-default sequences can be rejected. */
16281
16282 msg = "Sequence %s with mixed components in EQUIVALENCE "
16283 "statement at %L with different type objects";
16284 if ((object ==2
16285 && last_eq_type == SEQ_MIXED
16286 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
16287 || (eq_type == SEQ_MIXED
16288 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
16289 continue;
16290
16291 msg = "Non-default type object or sequence %s in EQUIVALENCE "
16292 "statement at %L with objects of different type";
16293 if ((object ==2
16294 && last_eq_type == SEQ_NONDEFAULT
16295 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
16296 || (eq_type == SEQ_NONDEFAULT
16297 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
16298 continue;
16299
16300 msg ="Non-CHARACTER object %qs in default CHARACTER "
16301 "EQUIVALENCE statement at %L";
16302 if (last_eq_type == SEQ_CHARACTER
16303 && eq_type != SEQ_CHARACTER
16304 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
16305 continue;
16306
16307 msg ="Non-NUMERIC object %qs in default NUMERIC "
16308 "EQUIVALENCE statement at %L";
16309 if (last_eq_type == SEQ_NUMERIC
16310 && eq_type != SEQ_NUMERIC
16311 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
16312 continue;
16313
16314 identical_types:
16315 last_ts =&sym->ts;
16316 last_where = &e->where;
16317
16318 if (!e->ref)
16319 continue;
16320
16321 /* Shall not be an automatic array. */
16322 if (e->ref->type == REF_ARRAY
16323 && !gfc_resolve_array_spec (e->ref->u.ar.as, 1))
16324 {
16325 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16326 "an EQUIVALENCE object", sym->name, &e->where);
16327 continue;
16328 }
16329
16330 r = e->ref;
16331 while (r)
16332 {
16333 /* Shall not be a structure component. */
16334 if (r->type == REF_COMPONENT)
16335 {
16336 gfc_error ("Structure component %qs at %L cannot be an "
16337 "EQUIVALENCE object",
16338 r->u.c.component->name, &e->where);
16339 break;
16340 }
16341
16342 /* A substring shall not have length zero. */
16343 if (r->type == REF_SUBSTRING)
16344 {
16345 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
16346 {
16347 gfc_error ("Substring at %L has length zero",
16348 &r->u.ss.start->where);
16349 break;
16350 }
16351 }
16352 r = r->next;
16353 }
16354 }
16355 }
16356
16357
16358 /* Function called by resolve_fntype to flag other symbols used in the
16359 length type parameter specification of function results. */
16360
16361 static bool
flag_fn_result_spec(gfc_expr * expr,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)16362 flag_fn_result_spec (gfc_expr *expr,
16363 gfc_symbol *sym,
16364 int *f ATTRIBUTE_UNUSED)
16365 {
16366 gfc_namespace *ns;
16367 gfc_symbol *s;
16368
16369 if (expr->expr_type == EXPR_VARIABLE)
16370 {
16371 s = expr->symtree->n.sym;
16372 for (ns = s->ns; ns; ns = ns->parent)
16373 if (!ns->parent)
16374 break;
16375
16376 if (sym == s)
16377 {
16378 gfc_error ("Self reference in character length expression "
16379 "for %qs at %L", sym->name, &expr->where);
16380 return true;
16381 }
16382
16383 if (!s->fn_result_spec
16384 && s->attr.flavor == FL_PARAMETER)
16385 {
16386 /* Function contained in a module.... */
16387 if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
16388 {
16389 gfc_symtree *st;
16390 s->fn_result_spec = 1;
16391 /* Make sure that this symbol is translated as a module
16392 variable. */
16393 st = gfc_get_unique_symtree (ns);
16394 st->n.sym = s;
16395 s->refs++;
16396 }
16397 /* ... which is use associated and called. */
16398 else if (s->attr.use_assoc || s->attr.used_in_submodule
16399 ||
16400 /* External function matched with an interface. */
16401 (s->ns->proc_name
16402 && ((s->ns == ns
16403 && s->ns->proc_name->attr.if_source == IFSRC_DECL)
16404 || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
16405 && s->ns->proc_name->attr.function))
16406 s->fn_result_spec = 1;
16407 }
16408 }
16409 return false;
16410 }
16411
16412
16413 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16414
16415 static void
resolve_fntype(gfc_namespace * ns)16416 resolve_fntype (gfc_namespace *ns)
16417 {
16418 gfc_entry_list *el;
16419 gfc_symbol *sym;
16420
16421 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
16422 return;
16423
16424 /* If there are any entries, ns->proc_name is the entry master
16425 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16426 if (ns->entries)
16427 sym = ns->entries->sym;
16428 else
16429 sym = ns->proc_name;
16430 if (sym->result == sym
16431 && sym->ts.type == BT_UNKNOWN
16432 && !gfc_set_default_type (sym, 0, NULL)
16433 && !sym->attr.untyped)
16434 {
16435 gfc_error ("Function %qs at %L has no IMPLICIT type",
16436 sym->name, &sym->declared_at);
16437 sym->attr.untyped = 1;
16438 }
16439
16440 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
16441 && !sym->attr.contained
16442 && !gfc_check_symbol_access (sym->ts.u.derived)
16443 && gfc_check_symbol_access (sym))
16444 {
16445 gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
16446 "%L of PRIVATE type %qs", sym->name,
16447 &sym->declared_at, sym->ts.u.derived->name);
16448 }
16449
16450 if (ns->entries)
16451 for (el = ns->entries->next; el; el = el->next)
16452 {
16453 if (el->sym->result == el->sym
16454 && el->sym->ts.type == BT_UNKNOWN
16455 && !gfc_set_default_type (el->sym, 0, NULL)
16456 && !el->sym->attr.untyped)
16457 {
16458 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16459 el->sym->name, &el->sym->declared_at);
16460 el->sym->attr.untyped = 1;
16461 }
16462 }
16463
16464 if (sym->ts.type == BT_CHARACTER)
16465 gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
16466 }
16467
16468
16469 /* 12.3.2.1.1 Defined operators. */
16470
16471 static bool
check_uop_procedure(gfc_symbol * sym,locus where)16472 check_uop_procedure (gfc_symbol *sym, locus where)
16473 {
16474 gfc_formal_arglist *formal;
16475
16476 if (!sym->attr.function)
16477 {
16478 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16479 sym->name, &where);
16480 return false;
16481 }
16482
16483 if (sym->ts.type == BT_CHARACTER
16484 && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
16485 && !(sym->result && ((sym->result->ts.u.cl
16486 && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
16487 {
16488 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16489 "character length", sym->name, &where);
16490 return false;
16491 }
16492
16493 formal = gfc_sym_get_dummy_args (sym);
16494 if (!formal || !formal->sym)
16495 {
16496 gfc_error ("User operator procedure %qs at %L must have at least "
16497 "one argument", sym->name, &where);
16498 return false;
16499 }
16500
16501 if (formal->sym->attr.intent != INTENT_IN)
16502 {
16503 gfc_error ("First argument of operator interface at %L must be "
16504 "INTENT(IN)", &where);
16505 return false;
16506 }
16507
16508 if (formal->sym->attr.optional)
16509 {
16510 gfc_error ("First argument of operator interface at %L cannot be "
16511 "optional", &where);
16512 return false;
16513 }
16514
16515 formal = formal->next;
16516 if (!formal || !formal->sym)
16517 return true;
16518
16519 if (formal->sym->attr.intent != INTENT_IN)
16520 {
16521 gfc_error ("Second argument of operator interface at %L must be "
16522 "INTENT(IN)", &where);
16523 return false;
16524 }
16525
16526 if (formal->sym->attr.optional)
16527 {
16528 gfc_error ("Second argument of operator interface at %L cannot be "
16529 "optional", &where);
16530 return false;
16531 }
16532
16533 if (formal->next)
16534 {
16535 gfc_error ("Operator interface at %L must have, at most, two "
16536 "arguments", &where);
16537 return false;
16538 }
16539
16540 return true;
16541 }
16542
16543 static void
gfc_resolve_uops(gfc_symtree * symtree)16544 gfc_resolve_uops (gfc_symtree *symtree)
16545 {
16546 gfc_interface *itr;
16547
16548 if (symtree == NULL)
16549 return;
16550
16551 gfc_resolve_uops (symtree->left);
16552 gfc_resolve_uops (symtree->right);
16553
16554 for (itr = symtree->n.uop->op; itr; itr = itr->next)
16555 check_uop_procedure (itr->sym, itr->sym->declared_at);
16556 }
16557
16558
16559 /* Examine all of the expressions associated with a program unit,
16560 assign types to all intermediate expressions, make sure that all
16561 assignments are to compatible types and figure out which names
16562 refer to which functions or subroutines. It doesn't check code
16563 block, which is handled by gfc_resolve_code. */
16564
16565 static void
resolve_types(gfc_namespace * ns)16566 resolve_types (gfc_namespace *ns)
16567 {
16568 gfc_namespace *n;
16569 gfc_charlen *cl;
16570 gfc_data *d;
16571 gfc_equiv *eq;
16572 gfc_namespace* old_ns = gfc_current_ns;
16573
16574 if (ns->types_resolved)
16575 return;
16576
16577 /* Check that all IMPLICIT types are ok. */
16578 if (!ns->seen_implicit_none)
16579 {
16580 unsigned letter;
16581 for (letter = 0; letter != GFC_LETTERS; ++letter)
16582 if (ns->set_flag[letter]
16583 && !resolve_typespec_used (&ns->default_type[letter],
16584 &ns->implicit_loc[letter], NULL))
16585 return;
16586 }
16587
16588 gfc_current_ns = ns;
16589
16590 resolve_entries (ns);
16591
16592 resolve_common_vars (&ns->blank_common, false);
16593 resolve_common_blocks (ns->common_root);
16594
16595 resolve_contained_functions (ns);
16596
16597 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
16598 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
16599 resolve_formal_arglist (ns->proc_name);
16600
16601 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
16602
16603 for (cl = ns->cl_list; cl; cl = cl->next)
16604 resolve_charlen (cl);
16605
16606 gfc_traverse_ns (ns, resolve_symbol);
16607
16608 resolve_fntype (ns);
16609
16610 for (n = ns->contained; n; n = n->sibling)
16611 {
16612 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
16613 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16614 "also be PURE", n->proc_name->name,
16615 &n->proc_name->declared_at);
16616
16617 resolve_types (n);
16618 }
16619
16620 forall_flag = 0;
16621 gfc_do_concurrent_flag = 0;
16622 gfc_check_interfaces (ns);
16623
16624 gfc_traverse_ns (ns, resolve_values);
16625
16626 if (ns->save_all)
16627 gfc_save_all (ns);
16628
16629 iter_stack = NULL;
16630 for (d = ns->data; d; d = d->next)
16631 resolve_data (d);
16632
16633 iter_stack = NULL;
16634 gfc_traverse_ns (ns, gfc_formalize_init_value);
16635
16636 gfc_traverse_ns (ns, gfc_verify_binding_labels);
16637
16638 for (eq = ns->equiv; eq; eq = eq->next)
16639 resolve_equivalence (eq);
16640
16641 /* Warn about unused labels. */
16642 if (warn_unused_label)
16643 warn_unused_fortran_label (ns->st_labels);
16644
16645 gfc_resolve_uops (ns->uop_root);
16646
16647 gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
16648
16649 gfc_resolve_omp_declare_simd (ns);
16650
16651 gfc_resolve_omp_udrs (ns->omp_udr_root);
16652
16653 ns->types_resolved = 1;
16654
16655 gfc_current_ns = old_ns;
16656 }
16657
16658
16659 /* Call gfc_resolve_code recursively. */
16660
16661 static void
resolve_codes(gfc_namespace * ns)16662 resolve_codes (gfc_namespace *ns)
16663 {
16664 gfc_namespace *n;
16665 bitmap_obstack old_obstack;
16666
16667 if (ns->resolved == 1)
16668 return;
16669
16670 for (n = ns->contained; n; n = n->sibling)
16671 resolve_codes (n);
16672
16673 gfc_current_ns = ns;
16674
16675 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16676 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
16677 cs_base = NULL;
16678
16679 /* Set to an out of range value. */
16680 current_entry_id = -1;
16681
16682 old_obstack = labels_obstack;
16683 bitmap_obstack_initialize (&labels_obstack);
16684
16685 gfc_resolve_oacc_declare (ns);
16686 gfc_resolve_omp_local_vars (ns);
16687 gfc_resolve_code (ns->code, ns);
16688
16689 bitmap_obstack_release (&labels_obstack);
16690 labels_obstack = old_obstack;
16691 }
16692
16693
16694 /* This function is called after a complete program unit has been compiled.
16695 Its purpose is to examine all of the expressions associated with a program
16696 unit, assign types to all intermediate expressions, make sure that all
16697 assignments are to compatible types and figure out which names refer to
16698 which functions or subroutines. */
16699
16700 void
gfc_resolve(gfc_namespace * ns)16701 gfc_resolve (gfc_namespace *ns)
16702 {
16703 gfc_namespace *old_ns;
16704 code_stack *old_cs_base;
16705 struct gfc_omp_saved_state old_omp_state;
16706
16707 if (ns->resolved)
16708 return;
16709
16710 ns->resolved = -1;
16711 old_ns = gfc_current_ns;
16712 old_cs_base = cs_base;
16713
16714 /* As gfc_resolve can be called during resolution of an OpenMP construct
16715 body, we should clear any state associated to it, so that say NS's
16716 DO loops are not interpreted as OpenMP loops. */
16717 if (!ns->construct_entities)
16718 gfc_omp_save_and_clear_state (&old_omp_state);
16719
16720 resolve_types (ns);
16721 component_assignment_level = 0;
16722 resolve_codes (ns);
16723
16724 gfc_current_ns = old_ns;
16725 cs_base = old_cs_base;
16726 ns->resolved = 1;
16727
16728 gfc_run_passes (ns);
16729
16730 if (!ns->construct_entities)
16731 gfc_omp_restore_state (&old_omp_state);
16732 }
16733