Line data Source code
1 : /* Perform type resolution on the various structures.
2 : Copyright (C) 2001-2026 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 : struct check_default_none_data
58 : {
59 : gfc_code *code;
60 : hash_set<gfc_symbol *> *sym_hash;
61 : gfc_namespace *ns;
62 : bool default_none;
63 : };
64 :
65 : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
66 :
67 : static int forall_flag;
68 : int gfc_do_concurrent_flag;
69 :
70 : /* True when we are resolving an expression that is an actual argument to
71 : a procedure. */
72 : static bool actual_arg = false;
73 : /* True when we are resolving an expression that is the first actual argument
74 : to a procedure. */
75 : static bool first_actual_arg = false;
76 :
77 :
78 : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
79 :
80 : static int omp_workshare_flag;
81 :
82 :
83 : /* True if we are resolving a specification expression. */
84 : static bool specification_expr = false;
85 : /* The dummy whose character length or array bounds are currently being
86 : resolved as a specification expression. */
87 : static gfc_symbol *specification_expr_symbol = NULL;
88 :
89 : /* The id of the last entry seen. */
90 : static int current_entry_id;
91 :
92 : /* We use bitmaps to determine if a branch target is valid. */
93 : static bitmap_obstack labels_obstack;
94 :
95 : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
96 : static bool inquiry_argument = false;
97 :
98 : static bool
99 464 : entry_dummy_seen_p (gfc_symbol *sym)
100 : {
101 464 : gfc_entry_list *entry;
102 464 : gfc_formal_arglist *formal;
103 :
104 464 : gcc_checking_assert (sym->attr.dummy && sym->ns == gfc_current_ns);
105 :
106 464 : for (entry = gfc_current_ns->entries;
107 471 : entry && entry->id <= current_entry_id;
108 7 : entry = entry->next)
109 765 : for (formal = entry->sym->formal; formal; formal = formal->next)
110 758 : if (formal->sym && sym->name == formal->sym->name)
111 : return true;
112 :
113 : return false;
114 : }
115 :
116 :
117 : /* Is the symbol host associated? */
118 : static bool
119 55146 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
120 : {
121 60405 : for (ns = ns->parent; ns; ns = ns->parent)
122 : {
123 5517 : if (sym->ns == ns)
124 : return true;
125 : }
126 :
127 : return false;
128 : }
129 :
130 : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
131 : an ABSTRACT derived-type. If where is not NULL, an error message with that
132 : locus is printed, optionally using name. */
133 :
134 : static bool
135 1599679 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
136 : {
137 1599679 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
138 : {
139 5 : if (where)
140 : {
141 5 : if (name)
142 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
143 : name, where, ts->u.derived->name);
144 : else
145 1 : gfc_error ("ABSTRACT type %qs used at %L",
146 : ts->u.derived->name, where);
147 : }
148 :
149 : return false;
150 : }
151 :
152 : return true;
153 : }
154 :
155 :
156 : static bool
157 5693 : check_proc_interface (gfc_symbol *ifc, locus *where)
158 : {
159 : /* Several checks for F08:C1216. */
160 5693 : if (ifc->attr.procedure)
161 : {
162 2 : gfc_error ("Interface %qs at %L is declared "
163 : "in a later PROCEDURE statement", ifc->name, where);
164 2 : return false;
165 : }
166 5691 : if (ifc->generic)
167 : {
168 : /* For generic interfaces, check if there is
169 : a specific procedure with the same name. */
170 : gfc_interface *gen = ifc->generic;
171 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
172 5 : gen = gen->next;
173 7 : if (!gen)
174 : {
175 4 : gfc_error ("Interface %qs at %L may not be generic",
176 : ifc->name, where);
177 4 : return false;
178 : }
179 : }
180 5687 : if (ifc->attr.proc == PROC_ST_FUNCTION)
181 : {
182 4 : gfc_error ("Interface %qs at %L may not be a statement function",
183 : ifc->name, where);
184 4 : return false;
185 : }
186 5683 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
187 5683 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
188 17 : ifc->attr.intrinsic = 1;
189 5683 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
190 : {
191 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
192 : "PROCEDURE statement at %L", ifc->name, where);
193 3 : return false;
194 : }
195 5680 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
196 : {
197 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
198 7 : return false;
199 : }
200 : return true;
201 : }
202 :
203 :
204 : static void resolve_symbol (gfc_symbol *sym);
205 :
206 :
207 : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
208 :
209 : static bool
210 2141 : resolve_procedure_interface (gfc_symbol *sym)
211 : {
212 2141 : gfc_symbol *ifc = sym->ts.interface;
213 :
214 2141 : if (!ifc)
215 : return true;
216 :
217 1981 : if (ifc == sym)
218 : {
219 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
220 : sym->name, &sym->declared_at);
221 2 : return false;
222 : }
223 1979 : if (!check_proc_interface (ifc, &sym->declared_at))
224 : return false;
225 :
226 1970 : if (ifc->attr.if_source || ifc->attr.intrinsic)
227 : {
228 : /* Resolve interface and copy attributes. */
229 1691 : resolve_symbol (ifc);
230 1691 : if (ifc->attr.intrinsic)
231 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
232 :
233 1691 : if (ifc->result)
234 : {
235 780 : sym->ts = ifc->result->ts;
236 780 : sym->attr.allocatable = ifc->result->attr.allocatable;
237 780 : sym->attr.pointer = ifc->result->attr.pointer;
238 780 : sym->attr.dimension = ifc->result->attr.dimension;
239 780 : sym->attr.class_ok = ifc->result->attr.class_ok;
240 780 : sym->as = gfc_copy_array_spec (ifc->result->as);
241 780 : sym->result = sym;
242 : }
243 : else
244 : {
245 911 : sym->ts = ifc->ts;
246 911 : sym->attr.allocatable = ifc->attr.allocatable;
247 911 : sym->attr.pointer = ifc->attr.pointer;
248 911 : sym->attr.dimension = ifc->attr.dimension;
249 911 : sym->attr.class_ok = ifc->attr.class_ok;
250 911 : sym->as = gfc_copy_array_spec (ifc->as);
251 : }
252 1691 : sym->ts.interface = ifc;
253 1691 : sym->attr.function = ifc->attr.function;
254 1691 : sym->attr.subroutine = ifc->attr.subroutine;
255 :
256 1691 : sym->attr.pure = ifc->attr.pure;
257 1691 : sym->attr.elemental = ifc->attr.elemental;
258 1691 : sym->attr.contiguous = ifc->attr.contiguous;
259 1691 : sym->attr.recursive = ifc->attr.recursive;
260 1691 : sym->attr.always_explicit = ifc->attr.always_explicit;
261 1691 : sym->attr.ext_attr |= ifc->attr.ext_attr;
262 1691 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
263 : /* Copy char length. */
264 1691 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
265 : {
266 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
267 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
268 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
269 : return false;
270 : }
271 : }
272 :
273 : return true;
274 : }
275 :
276 :
277 : /* Resolve types of formal argument lists. These have to be done early so that
278 : the formal argument lists of module procedures can be copied to the
279 : containing module before the individual procedures are resolved
280 : individually. We also resolve argument lists of procedures in interface
281 : blocks because they are self-contained scoping units.
282 :
283 : Since a dummy argument cannot be a non-dummy procedure, the only
284 : resort left for untyped names are the IMPLICIT types. */
285 :
286 : void
287 553480 : gfc_resolve_formal_arglist (gfc_symbol *proc)
288 : {
289 553480 : gfc_formal_arglist *f;
290 553480 : gfc_symbol *sym;
291 553480 : bool saved_specification_expr;
292 553480 : int i;
293 :
294 553480 : if (proc->result != NULL)
295 344771 : sym = proc->result;
296 : else
297 : sym = proc;
298 :
299 553480 : if (gfc_elemental (proc)
300 390675 : || sym->attr.pointer || sym->attr.allocatable
301 931803 : || (sym->as && sym->as->rank != 0))
302 : {
303 177487 : proc->attr.always_explicit = 1;
304 177487 : sym->attr.always_explicit = 1;
305 : }
306 :
307 553480 : gfc_namespace *orig_current_ns = gfc_current_ns;
308 553480 : gfc_current_ns = gfc_get_procedure_ns (proc);
309 :
310 1432856 : for (f = proc->formal; f; f = f->next)
311 : {
312 879378 : gfc_array_spec *as;
313 879378 : gfc_symbol *saved_specification_expr_symbol;
314 :
315 879378 : sym = f->sym;
316 :
317 879378 : if (sym == NULL)
318 : {
319 : /* Alternate return placeholder. */
320 171 : if (gfc_elemental (proc))
321 1 : gfc_error ("Alternate return specifier in elemental subroutine "
322 : "%qs at %L is not allowed", proc->name,
323 : &proc->declared_at);
324 171 : if (proc->attr.function)
325 1 : gfc_error ("Alternate return specifier in function "
326 : "%qs at %L is not allowed", proc->name,
327 : &proc->declared_at);
328 171 : continue;
329 : }
330 :
331 611 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
332 879818 : && !resolve_procedure_interface (sym))
333 : break;
334 :
335 879207 : if (strcmp (proc->name, sym->name) == 0)
336 : {
337 2 : gfc_error ("Self-referential argument "
338 : "%qs at %L is not allowed", sym->name,
339 : &proc->declared_at);
340 2 : break;
341 : }
342 :
343 879205 : if (sym->attr.if_source != IFSRC_UNKNOWN)
344 903 : gfc_resolve_formal_arglist (sym);
345 :
346 879205 : if (sym->attr.subroutine || sym->attr.external)
347 : {
348 913 : if (sym->attr.flavor == FL_UNKNOWN)
349 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
350 : }
351 : else
352 : {
353 878292 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
354 3688 : && (!sym->attr.function || sym->result == sym))
355 3650 : gfc_set_default_type (sym, 1, sym->ns);
356 : }
357 :
358 879205 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
359 893557 : ? CLASS_DATA (sym)->as : sym->as;
360 :
361 879205 : saved_specification_expr = specification_expr;
362 879205 : saved_specification_expr_symbol = specification_expr_symbol;
363 879205 : specification_expr = true;
364 879205 : specification_expr_symbol = sym;
365 879205 : gfc_resolve_array_spec (as, 0);
366 879205 : specification_expr = saved_specification_expr;
367 879205 : specification_expr_symbol = saved_specification_expr_symbol;
368 :
369 : /* We can't tell if an array with dimension (:) is assumed or deferred
370 : shape until we know if it has the pointer or allocatable attributes.
371 : */
372 879205 : if (as && as->rank > 0 && as->type == AS_DEFERRED
373 12761 : && ((sym->ts.type != BT_CLASS
374 11580 : && !(sym->attr.pointer || sym->attr.allocatable))
375 5450 : || (sym->ts.type == BT_CLASS
376 1181 : && !(CLASS_DATA (sym)->attr.class_pointer
377 981 : || CLASS_DATA (sym)->attr.allocatable)))
378 7853 : && sym->attr.flavor != FL_PROCEDURE)
379 : {
380 7852 : as->type = AS_ASSUMED_SHAPE;
381 18211 : for (i = 0; i < as->rank; i++)
382 10359 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
383 : }
384 :
385 138985 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
386 124574 : || (as && as->type == AS_ASSUMED_RANK)
387 824973 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
388 814737 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
389 11968 : && (CLASS_DATA (sym)->attr.class_pointer
390 11485 : || CLASS_DATA (sym)->attr.allocatable
391 10545 : || CLASS_DATA (sym)->attr.target))
392 813314 : || sym->attr.optional)
393 : {
394 81497 : proc->attr.always_explicit = 1;
395 81497 : if (proc->result)
396 36995 : proc->result->attr.always_explicit = 1;
397 : }
398 :
399 : /* If the flavor is unknown at this point, it has to be a variable.
400 : A procedure specification would have already set the type. */
401 :
402 879205 : if (sym->attr.flavor == FL_UNKNOWN)
403 52291 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
404 :
405 879205 : if (gfc_pure (proc))
406 : {
407 328683 : if (sym->attr.flavor == FL_PROCEDURE)
408 : {
409 : /* F08:C1279. */
410 29 : if (!gfc_pure (sym))
411 : {
412 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
413 : "also be PURE", sym->name, &sym->declared_at);
414 1 : continue;
415 : }
416 : }
417 328654 : else if (!sym->attr.pointer)
418 : {
419 328640 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
420 : {
421 111 : if (sym->attr.value)
422 110 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
423 : " of pure function %qs at %L with VALUE "
424 : "attribute but without INTENT(IN)",
425 : sym->name, proc->name, &sym->declared_at);
426 : else
427 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
428 : "be INTENT(IN) or VALUE", sym->name, proc->name,
429 : &sym->declared_at);
430 : }
431 :
432 328640 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
433 : {
434 159 : if (sym->attr.value)
435 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
436 : " of pure subroutine %qs at %L with VALUE "
437 : "attribute but without INTENT", sym->name,
438 : proc->name, &sym->declared_at);
439 : else
440 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
441 : "must have its INTENT specified or have the "
442 : "VALUE attribute", sym->name, proc->name,
443 : &sym->declared_at);
444 : }
445 : }
446 :
447 : /* F08:C1278a. */
448 328682 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
449 : {
450 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
451 : " may not be polymorphic", sym->name, proc->name,
452 : &sym->declared_at);
453 1 : continue;
454 : }
455 : }
456 :
457 879203 : if (proc->attr.implicit_pure)
458 : {
459 25901 : if (sym->attr.flavor == FL_PROCEDURE)
460 : {
461 337 : if (!gfc_pure (sym))
462 305 : proc->attr.implicit_pure = 0;
463 : }
464 25564 : else if (!sym->attr.pointer)
465 : {
466 24774 : if (proc->attr.function && sym->attr.intent != INTENT_IN
467 2748 : && !sym->value)
468 2748 : proc->attr.implicit_pure = 0;
469 :
470 24774 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
471 4303 : && !sym->value)
472 4303 : proc->attr.implicit_pure = 0;
473 : }
474 : }
475 :
476 879203 : if (gfc_elemental (proc))
477 : {
478 : /* F08:C1289. */
479 302806 : if (sym->attr.codimension
480 302805 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
481 965 : && CLASS_DATA (sym)->attr.codimension))
482 : {
483 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
484 : "procedure", sym->name, &sym->declared_at);
485 3 : continue;
486 : }
487 :
488 302803 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
489 963 : && CLASS_DATA (sym)->as))
490 : {
491 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
492 : "be scalar", sym->name, &sym->declared_at);
493 2 : continue;
494 : }
495 :
496 302801 : if (sym->attr.allocatable
497 302800 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
498 962 : && CLASS_DATA (sym)->attr.allocatable))
499 : {
500 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
501 : "have the ALLOCATABLE attribute", sym->name,
502 : &sym->declared_at);
503 2 : continue;
504 : }
505 :
506 302799 : if (sym->attr.pointer
507 302798 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
508 961 : && CLASS_DATA (sym)->attr.class_pointer))
509 : {
510 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
511 : "have the POINTER attribute", sym->name,
512 : &sym->declared_at);
513 2 : continue;
514 : }
515 :
516 302797 : if (sym->attr.flavor == FL_PROCEDURE)
517 : {
518 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
519 : "procedure %qs at %L", sym->name, proc->name,
520 : &sym->declared_at);
521 2 : continue;
522 : }
523 :
524 : /* Fortran 2008 Corrigendum 1, C1290a. */
525 302795 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
526 : {
527 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
528 : "have its INTENT specified or have the VALUE "
529 : "attribute", sym->name, proc->name,
530 : &sym->declared_at);
531 2 : continue;
532 : }
533 : }
534 :
535 : /* Each dummy shall be specified to be scalar. */
536 879190 : if (proc->attr.proc == PROC_ST_FUNCTION)
537 : {
538 307 : if (sym->as != NULL)
539 : {
540 : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
541 : shall be specified, explicitly or implicitly, to be scalar. */
542 1 : gfc_error ("Argument %qs of statement function %qs at %L "
543 : "must be scalar", sym->name, proc->name,
544 : &proc->declared_at);
545 1 : continue;
546 : }
547 :
548 306 : if (sym->ts.type == BT_CHARACTER)
549 : {
550 48 : gfc_charlen *cl = sym->ts.u.cl;
551 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
552 : {
553 0 : gfc_error ("Character-valued argument %qs of statement "
554 : "function at %L must have constant length",
555 : sym->name, &sym->declared_at);
556 0 : continue;
557 : }
558 : }
559 : }
560 : }
561 553480 : if (sym)
562 553388 : sym->formal_resolved = 1;
563 553480 : gfc_current_ns = orig_current_ns;
564 553480 : }
565 :
566 :
567 : /* Work function called when searching for symbols that have argument lists
568 : associated with them. */
569 :
570 : static void
571 1922582 : find_arglists (gfc_symbol *sym)
572 : {
573 1922582 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
574 348726 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
575 : return;
576 :
577 346173 : gfc_resolve_formal_arglist (sym);
578 : }
579 :
580 :
581 : /* Given a namespace, resolve all formal argument lists within the namespace.
582 : */
583 :
584 : static void
585 362782 : resolve_formal_arglists (gfc_namespace *ns)
586 : {
587 0 : if (ns == NULL)
588 : return;
589 :
590 362782 : gfc_traverse_ns (ns, find_arglists);
591 : }
592 :
593 :
594 : static void
595 38307 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
596 : {
597 38307 : bool t;
598 :
599 38307 : if (sym && sym->attr.flavor == FL_PROCEDURE
600 38307 : && sym->ns->parent
601 1458 : && sym->ns->parent->proc_name
602 1458 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
603 0 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
604 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
605 : "encompassing procedure", sym->name, &sym->declared_at);
606 :
607 : /* If this namespace is not a function or an entry master function,
608 : ignore it. */
609 38307 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
610 11134 : || sym->attr.entry_master)
611 : return;
612 :
613 10945 : if (!sym->result)
614 : return;
615 :
616 : /* Try to find out of what the return type is. */
617 10945 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
618 : {
619 58 : t = gfc_set_default_type (sym->result, 0, ns);
620 :
621 58 : if (!t && !sym->result->attr.untyped)
622 : {
623 19 : if (sym->result == sym)
624 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
625 : sym->name, &sym->declared_at);
626 18 : else if (!sym->result->attr.proc_pointer)
627 0 : gfc_error ("Result %qs of contained function %qs at %L has "
628 : "no IMPLICIT type", sym->result->name, sym->name,
629 : &sym->result->declared_at);
630 19 : sym->result->attr.untyped = 1;
631 : }
632 : }
633 :
634 : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
635 : type, lists the only ways a character length value of * can be used:
636 : dummy arguments of procedures, named constants, function results and
637 : in allocate statements if the allocate_object is an assumed length dummy
638 : in external functions. Internal function results and results of module
639 : procedures are not on this list, ergo, not permitted. */
640 :
641 10945 : if (sym->result->ts.type == BT_CHARACTER)
642 : {
643 1211 : gfc_charlen *cl = sym->result->ts.u.cl;
644 1211 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
645 : {
646 : /* See if this is a module-procedure and adapt error message
647 : accordingly. */
648 4 : bool module_proc;
649 4 : gcc_assert (ns->parent && ns->parent->proc_name);
650 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
651 :
652 7 : gfc_error (module_proc
653 : ? G_("Character-valued module procedure %qs at %L"
654 : " must not be assumed length")
655 : : G_("Character-valued internal function %qs at %L"
656 : " must not be assumed length"),
657 : sym->name, &sym->declared_at);
658 : }
659 : }
660 : }
661 :
662 :
663 : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
664 : introduce duplicates. */
665 :
666 : static void
667 1491 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
668 : {
669 1491 : gfc_formal_arglist *f, *new_arglist;
670 1491 : gfc_symbol *new_sym;
671 :
672 2644 : for (; new_args != NULL; new_args = new_args->next)
673 : {
674 1153 : new_sym = new_args->sym;
675 : /* See if this arg is already in the formal argument list. */
676 2186 : for (f = proc->formal; f; f = f->next)
677 : {
678 1481 : if (new_sym == f->sym)
679 : break;
680 : }
681 :
682 1153 : if (f)
683 448 : continue;
684 :
685 : /* Add a new argument. Argument order is not important. */
686 705 : new_arglist = gfc_get_formal_arglist ();
687 705 : new_arglist->sym = new_sym;
688 705 : new_arglist->next = proc->formal;
689 705 : proc->formal = new_arglist;
690 : }
691 1491 : }
692 :
693 :
694 : /* Flag the arguments that are not present in all entries. */
695 :
696 : static void
697 1491 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
698 : {
699 1491 : gfc_formal_arglist *f, *head;
700 1491 : head = new_args;
701 :
702 3086 : for (f = proc->formal; f; f = f->next)
703 : {
704 1595 : if (f->sym == NULL)
705 36 : continue;
706 :
707 2738 : for (new_args = head; new_args; new_args = new_args->next)
708 : {
709 2287 : if (new_args->sym == f->sym)
710 : break;
711 : }
712 :
713 1559 : if (new_args)
714 1108 : continue;
715 :
716 451 : f->sym->attr.not_always_present = 1;
717 : }
718 1491 : }
719 :
720 :
721 : /* Resolve alternate entry points. If a symbol has multiple entry points we
722 : create a new master symbol for the main routine, and turn the existing
723 : symbol into an entry point. */
724 :
725 : static void
726 400582 : resolve_entries (gfc_namespace *ns)
727 : {
728 400582 : gfc_namespace *old_ns;
729 400582 : gfc_code *c;
730 400582 : gfc_symbol *proc;
731 400582 : gfc_entry_list *el;
732 : /* Provide sufficient space to hold "master.%d.%s". */
733 400582 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
734 400582 : static int master_count = 0;
735 :
736 400582 : if (ns->proc_name == NULL)
737 399879 : return;
738 :
739 : /* No need to do anything if this procedure doesn't have alternate entry
740 : points. */
741 400533 : if (!ns->entries)
742 : return;
743 :
744 : /* We may already have resolved alternate entry points. */
745 954 : if (ns->proc_name->attr.entry_master)
746 : return;
747 :
748 : /* If this isn't a procedure something has gone horribly wrong. */
749 703 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
750 :
751 : /* Remember the current namespace. */
752 703 : old_ns = gfc_current_ns;
753 :
754 703 : gfc_current_ns = ns;
755 :
756 : /* Add the main entry point to the list of entry points. */
757 703 : el = gfc_get_entry_list ();
758 703 : el->sym = ns->proc_name;
759 703 : el->id = 0;
760 703 : el->next = ns->entries;
761 703 : ns->entries = el;
762 703 : ns->proc_name->attr.entry = 1;
763 :
764 : /* If it is a module function, it needs to be in the right namespace
765 : so that gfc_get_fake_result_decl can gather up the results. The
766 : need for this arose in get_proc_name, where these beasts were
767 : left in their own namespace, to keep prior references linked to
768 : the entry declaration.*/
769 703 : if (ns->proc_name->attr.function
770 596 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
771 189 : el->sym->ns = ns;
772 :
773 : /* Do the same for entries where the master is not a module
774 : procedure. These are retained in the module namespace because
775 : of the module procedure declaration. */
776 1491 : for (el = el->next; el; el = el->next)
777 788 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
778 0 : && el->sym->attr.mod_proc)
779 0 : el->sym->ns = ns;
780 703 : el = ns->entries;
781 :
782 : /* Add an entry statement for it. */
783 703 : c = gfc_get_code (EXEC_ENTRY);
784 703 : c->ext.entry = el;
785 703 : c->next = ns->code;
786 703 : ns->code = c;
787 :
788 : /* Create a new symbol for the master function. */
789 : /* Give the internal function a unique name (within this file).
790 : Also include the function name so the user has some hope of figuring
791 : out what is going on. */
792 703 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
793 703 : master_count++, ns->proc_name->name);
794 703 : gfc_get_ha_symbol (name, &proc);
795 703 : gcc_assert (proc != NULL);
796 :
797 703 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
798 703 : if (ns->proc_name->attr.subroutine)
799 107 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
800 : else
801 : {
802 596 : gfc_symbol *sym;
803 596 : gfc_typespec *ts, *fts;
804 596 : gfc_array_spec *as, *fas;
805 596 : gfc_add_function (&proc->attr, proc->name, NULL);
806 596 : proc->result = proc;
807 596 : fas = ns->entries->sym->as;
808 596 : fas = fas ? fas : ns->entries->sym->result->as;
809 596 : fts = &ns->entries->sym->result->ts;
810 596 : if (fts->type == BT_UNKNOWN)
811 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
812 1120 : for (el = ns->entries->next; el; el = el->next)
813 : {
814 635 : ts = &el->sym->result->ts;
815 635 : as = el->sym->as;
816 635 : as = as ? as : el->sym->result->as;
817 635 : if (ts->type == BT_UNKNOWN)
818 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
819 :
820 635 : if (! gfc_compare_types (ts, fts)
821 527 : || (el->sym->result->attr.dimension
822 527 : != ns->entries->sym->result->attr.dimension)
823 635 : || (el->sym->result->attr.pointer
824 527 : != ns->entries->sym->result->attr.pointer))
825 : break;
826 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
827 589 : && gfc_compare_array_spec (as, fas) == 0)
828 5 : gfc_error ("Function %s at %L has entries with mismatched "
829 : "array specifications", ns->entries->sym->name,
830 5 : &ns->entries->sym->declared_at);
831 : /* The characteristics need to match and thus both need to have
832 : the same string length, i.e. both len=*, or both len=4.
833 : Having both len=<variable> is also possible, but difficult to
834 : check at compile time. */
835 522 : else if (ts->type == BT_CHARACTER
836 113 : && (el->sym->result->attr.allocatable
837 113 : != ns->entries->sym->result->attr.allocatable))
838 : {
839 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
840 : "characteristics", ns->entries->sym->name,
841 : &ns->entries->sym->declared_at, el->sym->name);
842 3 : goto cleanup;
843 : }
844 519 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
845 110 : && (((ts->u.cl->length && !fts->u.cl->length)
846 109 : ||(!ts->u.cl->length && fts->u.cl->length))
847 90 : || (ts->u.cl->length
848 53 : && ts->u.cl->length->expr_type
849 53 : != fts->u.cl->length->expr_type)
850 90 : || (ts->u.cl->length
851 53 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
852 52 : && mpz_cmp (ts->u.cl->length->value.integer,
853 52 : fts->u.cl->length->value.integer) != 0)))
854 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
855 : "entries returning variables of different "
856 : "string lengths", ns->entries->sym->name,
857 21 : &ns->entries->sym->declared_at);
858 498 : else if (el->sym->result->attr.allocatable
859 498 : != ns->entries->sym->result->attr.allocatable)
860 : break;
861 : }
862 :
863 593 : if (el == NULL)
864 : {
865 485 : sym = ns->entries->sym->result;
866 : /* All result types the same. */
867 485 : proc->ts = *fts;
868 485 : if (sym->attr.dimension)
869 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
870 485 : if (sym->attr.pointer)
871 78 : gfc_add_pointer (&proc->attr, NULL);
872 485 : if (sym->attr.allocatable)
873 24 : gfc_add_allocatable (&proc->attr, NULL);
874 : }
875 : else
876 : {
877 : /* Otherwise the result will be passed through a union by
878 : reference. */
879 108 : proc->attr.mixed_entry_master = 1;
880 346 : for (el = ns->entries; el; el = el->next)
881 : {
882 238 : sym = el->sym->result;
883 238 : if (sym->attr.dimension)
884 : {
885 1 : if (el == ns->entries)
886 0 : gfc_error ("FUNCTION result %s cannot be an array in "
887 : "FUNCTION %s at %L", sym->name,
888 0 : ns->entries->sym->name, &sym->declared_at);
889 : else
890 1 : gfc_error ("ENTRY result %s cannot be an array in "
891 : "FUNCTION %s at %L", sym->name,
892 1 : ns->entries->sym->name, &sym->declared_at);
893 : }
894 237 : else if (sym->attr.pointer)
895 : {
896 1 : if (el == ns->entries)
897 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
898 : "FUNCTION %s at %L", sym->name,
899 1 : ns->entries->sym->name, &sym->declared_at);
900 : else
901 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
902 : "FUNCTION %s at %L", sym->name,
903 0 : ns->entries->sym->name, &sym->declared_at);
904 : }
905 236 : else if (sym->attr.allocatable)
906 : {
907 0 : if (el == ns->entries)
908 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
909 : "FUNCTION %s at %L", sym->name,
910 0 : ns->entries->sym->name, &sym->declared_at);
911 : else
912 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
913 : "FUNCTION %s at %L", sym->name,
914 0 : ns->entries->sym->name, &sym->declared_at);
915 : }
916 : else
917 : {
918 236 : ts = &sym->ts;
919 236 : if (ts->type == BT_UNKNOWN)
920 9 : ts = gfc_get_default_type (sym->name, NULL);
921 236 : switch (ts->type)
922 : {
923 85 : case BT_INTEGER:
924 85 : if (ts->kind == gfc_default_integer_kind)
925 : sym = NULL;
926 : break;
927 100 : case BT_REAL:
928 100 : if (ts->kind == gfc_default_real_kind
929 18 : || ts->kind == gfc_default_double_kind)
930 : sym = NULL;
931 : break;
932 20 : case BT_COMPLEX:
933 20 : if (ts->kind == gfc_default_complex_kind)
934 : sym = NULL;
935 : break;
936 28 : case BT_LOGICAL:
937 28 : if (ts->kind == gfc_default_logical_kind)
938 : sym = NULL;
939 : break;
940 : case BT_UNKNOWN:
941 : /* We will issue error elsewhere. */
942 : sym = NULL;
943 : break;
944 : default:
945 : break;
946 : }
947 3 : if (sym)
948 : {
949 3 : if (el == ns->entries)
950 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
951 : "in FUNCTION %s at %L", sym->name,
952 1 : gfc_typename (ts), ns->entries->sym->name,
953 : &sym->declared_at);
954 : else
955 2 : gfc_error ("ENTRY result %s cannot be of type %s "
956 : "in FUNCTION %s at %L", sym->name,
957 2 : gfc_typename (ts), ns->entries->sym->name,
958 : &sym->declared_at);
959 : }
960 : }
961 : }
962 : }
963 : }
964 :
965 108 : cleanup:
966 703 : proc->attr.access = ACCESS_PRIVATE;
967 703 : proc->attr.entry_master = 1;
968 :
969 : /* Merge all the entry point arguments. */
970 2194 : for (el = ns->entries; el; el = el->next)
971 1491 : merge_argument_lists (proc, el->sym->formal);
972 :
973 : /* Check the master formal arguments for any that are not
974 : present in all entry points. */
975 2194 : for (el = ns->entries; el; el = el->next)
976 1491 : check_argument_lists (proc, el->sym->formal);
977 :
978 : /* Use the master function for the function body. */
979 703 : ns->proc_name = proc;
980 :
981 : /* Finalize the new symbols. */
982 703 : gfc_commit_symbols ();
983 :
984 : /* Restore the original namespace. */
985 703 : gfc_current_ns = old_ns;
986 : }
987 :
988 :
989 : /* Forward declaration. */
990 : static bool is_non_constant_shape_array (gfc_symbol *sym);
991 :
992 :
993 : /* Resolve common variables. */
994 : static void
995 364760 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
996 : {
997 364760 : gfc_symbol *csym = common_block->head;
998 364760 : gfc_gsymbol *gsym;
999 :
1000 370813 : for (; csym; csym = csym->common_next)
1001 : {
1002 6053 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
1003 6053 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
1004 : {
1005 3 : if (csym->common_block)
1006 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1007 : "COMMON block at %L", gsym->name,
1008 : &gsym->where, &csym->common_block->where);
1009 : else
1010 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1011 : "COMMON block", gsym->name, &gsym->where);
1012 : }
1013 :
1014 : /* gfc_add_in_common may have been called before, but the reported errors
1015 : have been ignored to continue parsing.
1016 : We do the checks again here, unless the symbol is USE associated. */
1017 6053 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
1018 : {
1019 5780 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
1020 5780 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
1021 : &common_block->where);
1022 : }
1023 :
1024 6053 : if (csym->value || csym->attr.data)
1025 : {
1026 149 : if (!csym->ns->is_block_data)
1027 33 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1028 : "but only in BLOCK DATA initialization is "
1029 : "allowed", csym->name, &csym->declared_at);
1030 116 : else if (!named_common)
1031 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1032 : "in a blank COMMON but initialization is only "
1033 : "allowed in named common blocks", csym->name,
1034 : &csym->declared_at);
1035 : }
1036 :
1037 6053 : if (UNLIMITED_POLY (csym))
1038 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1039 : "[F2008:C5100]", csym->name, &csym->declared_at);
1040 :
1041 6053 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1042 : {
1043 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1044 : "COMMON at %L", csym->name, &csym->declared_at,
1045 : &common_block->where);
1046 : /* Avoid confusing follow-on error. */
1047 1 : csym->error = 1;
1048 : }
1049 :
1050 6053 : if (csym->ts.type != BT_DERIVED)
1051 6006 : continue;
1052 :
1053 47 : if (!(csym->ts.u.derived->attr.sequence
1054 3 : || csym->ts.u.derived->attr.is_bind_c))
1055 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1056 : "has neither the SEQUENCE nor the BIND(C) "
1057 : "attribute", csym->name, &csym->declared_at);
1058 47 : if (csym->ts.u.derived->attr.alloc_comp)
1059 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1060 : "has an ultimate component that is "
1061 : "allocatable", csym->name, &csym->declared_at);
1062 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1063 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1064 : "may not have default initializer", csym->name,
1065 : &csym->declared_at);
1066 :
1067 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1068 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1069 : }
1070 364760 : }
1071 :
1072 : /* Resolve common blocks. */
1073 : static void
1074 363313 : resolve_common_blocks (gfc_symtree *common_root)
1075 : {
1076 363313 : gfc_symbol *sym = NULL;
1077 363313 : gfc_gsymbol * gsym;
1078 :
1079 363313 : if (common_root == NULL)
1080 363191 : return;
1081 :
1082 1978 : if (common_root->left)
1083 257 : resolve_common_blocks (common_root->left);
1084 1978 : if (common_root->right)
1085 274 : resolve_common_blocks (common_root->right);
1086 :
1087 1978 : resolve_common_vars (common_root->n.common, true);
1088 :
1089 : /* The common name is a global name - in Fortran 2003 also if it has a
1090 : C binding name, since Fortran 2008 only the C binding name is a global
1091 : identifier. */
1092 1978 : if (!common_root->n.common->binding_label
1093 1978 : || gfc_notification_std (GFC_STD_F2008))
1094 : {
1095 3812 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1096 1906 : common_root->n.common->name);
1097 :
1098 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1099 14 : && gsym->type == GSYM_COMMON
1100 1919 : && ((common_root->n.common->binding_label
1101 6 : && (!gsym->binding_label
1102 0 : || strcmp (common_root->n.common->binding_label,
1103 : gsym->binding_label) != 0))
1104 7 : || (!common_root->n.common->binding_label
1105 7 : && gsym->binding_label)))
1106 : {
1107 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1108 : "identifier and must thus have the same binding name "
1109 : "as the same-named COMMON block at %L: %s vs %s",
1110 6 : common_root->n.common->name, &common_root->n.common->where,
1111 : &gsym->where,
1112 : common_root->n.common->binding_label
1113 : ? common_root->n.common->binding_label : "(blank)",
1114 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1115 6 : return;
1116 : }
1117 :
1118 1900 : if (gsym && gsym->type != GSYM_COMMON
1119 1 : && !common_root->n.common->binding_label)
1120 : {
1121 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1122 : "as entity at %L",
1123 0 : common_root->n.common->name, &common_root->n.common->where,
1124 : &gsym->where);
1125 0 : return;
1126 : }
1127 814 : if (gsym && gsym->type != GSYM_COMMON)
1128 : {
1129 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1130 : "%L sharing the identifier with global non-COMMON-block "
1131 1 : "entity at %L", common_root->n.common->name,
1132 1 : &common_root->n.common->where, &gsym->where);
1133 1 : return;
1134 : }
1135 1086 : if (!gsym)
1136 : {
1137 1086 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1138 1086 : gsym->type = GSYM_COMMON;
1139 1086 : gsym->where = common_root->n.common->where;
1140 1086 : gsym->defined = 1;
1141 : }
1142 1899 : gsym->used = 1;
1143 : }
1144 :
1145 1971 : if (common_root->n.common->binding_label)
1146 : {
1147 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1148 : common_root->n.common->binding_label);
1149 76 : if (gsym && gsym->type != GSYM_COMMON)
1150 : {
1151 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1152 : "global identifier as entity at %L",
1153 : &common_root->n.common->where,
1154 1 : common_root->n.common->binding_label, &gsym->where);
1155 1 : return;
1156 : }
1157 57 : if (!gsym)
1158 : {
1159 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1160 57 : gsym->type = GSYM_COMMON;
1161 57 : gsym->where = common_root->n.common->where;
1162 57 : gsym->defined = 1;
1163 : }
1164 75 : gsym->used = 1;
1165 : }
1166 :
1167 1970 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1168 1970 : if (sym == NULL)
1169 : return;
1170 :
1171 122 : if (sym->attr.flavor == FL_PARAMETER)
1172 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1173 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1174 :
1175 122 : if (sym->attr.external)
1176 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1177 1 : sym->name, &common_root->n.common->where);
1178 :
1179 122 : if (sym->attr.intrinsic)
1180 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1181 2 : sym->name, &common_root->n.common->where);
1182 120 : else if (sym->attr.result
1183 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1184 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1185 : "that is also a function result", sym->name,
1186 1 : &common_root->n.common->where);
1187 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1188 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1189 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1190 : "that is also a global procedure", sym->name,
1191 3 : &common_root->n.common->where);
1192 : }
1193 :
1194 :
1195 : /* Resolve contained function types. Because contained functions can call one
1196 : another, they have to be worked out before any of the contained procedures
1197 : can be resolved.
1198 :
1199 : The good news is that if a function doesn't already have a type, the only
1200 : way it can get one is through an IMPLICIT type or a RESULT variable, because
1201 : by definition contained functions are contained namespace they're contained
1202 : in, not in a sibling or parent namespace. */
1203 :
1204 : static void
1205 362782 : resolve_contained_functions (gfc_namespace *ns)
1206 : {
1207 362782 : gfc_namespace *child;
1208 362782 : gfc_entry_list *el;
1209 :
1210 362782 : resolve_formal_arglists (ns);
1211 :
1212 400582 : for (child = ns->contained; child; child = child->sibling)
1213 : {
1214 : /* Resolve alternate entry points first. */
1215 37800 : resolve_entries (child);
1216 :
1217 : /* Then check function return types. */
1218 37800 : resolve_contained_fntype (child->proc_name, child);
1219 38307 : for (el = child->entries; el; el = el->next)
1220 507 : resolve_contained_fntype (el->sym, child);
1221 : }
1222 362782 : }
1223 :
1224 :
1225 :
1226 : /* A Parameterized Derived Type constructor must contain values for
1227 : the PDT KIND parameters or they must have a default initializer.
1228 : Go through the constructor picking out the KIND expressions,
1229 : storing them in 'param_list' and then call gfc_get_pdt_instance
1230 : to obtain the PDT instance. */
1231 :
1232 : static gfc_actual_arglist *param_list, *param_tail, *param;
1233 :
1234 : static bool
1235 356 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1236 : {
1237 356 : param = gfc_get_actual_arglist ();
1238 356 : if (!param_list)
1239 288 : param_list = param_tail = param;
1240 : else
1241 : {
1242 68 : param_tail->next = param;
1243 68 : param_tail = param_tail->next;
1244 : }
1245 :
1246 356 : param_tail->name = c->name;
1247 356 : if (expr)
1248 356 : param_tail->expr = gfc_copy_expr (expr);
1249 0 : else if (c->initializer)
1250 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1251 : else
1252 : {
1253 0 : param_tail->spec_type = SPEC_ASSUMED;
1254 0 : if (c->attr.pdt_kind)
1255 : {
1256 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1257 : "at %C has no value", param->name);
1258 0 : return false;
1259 : }
1260 : }
1261 :
1262 : return true;
1263 : }
1264 :
1265 : static bool
1266 336 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1267 : gfc_symbol *derived)
1268 : {
1269 336 : gfc_constructor *cons = NULL;
1270 336 : gfc_component *comp;
1271 336 : bool t = true;
1272 :
1273 336 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1274 300 : cons = gfc_constructor_first (expr->value.constructor);
1275 36 : else if (constr)
1276 36 : cons = *constr;
1277 336 : gcc_assert (cons);
1278 :
1279 336 : comp = derived->components;
1280 :
1281 1036 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1282 : {
1283 700 : if (cons->expr
1284 700 : && cons->expr->expr_type == EXPR_STRUCTURE
1285 12 : && comp->ts.type == BT_DERIVED)
1286 : {
1287 12 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1288 12 : if (!t)
1289 : return t;
1290 : }
1291 688 : else if (comp->ts.type == BT_DERIVED)
1292 : {
1293 36 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1294 36 : if (!t)
1295 : return t;
1296 : }
1297 652 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1298 356 : && derived->attr.pdt_template)
1299 : {
1300 356 : t = get_pdt_spec_expr (comp, cons->expr);
1301 356 : if (!t)
1302 : return t;
1303 : }
1304 : }
1305 : return t;
1306 : }
1307 :
1308 :
1309 : static bool resolve_fl_derived0 (gfc_symbol *sym);
1310 : static bool resolve_fl_struct (gfc_symbol *sym);
1311 :
1312 :
1313 : /* Resolve all of the elements of a structure constructor and make sure that
1314 : the types are correct. The 'init' flag indicates that the given
1315 : constructor is an initializer. */
1316 :
1317 : static bool
1318 64662 : resolve_structure_cons (gfc_expr *expr, int init)
1319 : {
1320 64662 : gfc_constructor *cons;
1321 64662 : gfc_component *comp;
1322 64662 : bool t;
1323 64662 : symbol_attribute a;
1324 :
1325 64662 : t = true;
1326 :
1327 64662 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1328 : {
1329 61628 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1330 61478 : resolve_fl_derived0 (expr->ts.u.derived);
1331 : else
1332 150 : resolve_fl_struct (expr->ts.u.derived);
1333 :
1334 : /* If this is a Parameterized Derived Type template, find the
1335 : instance corresponding to the PDT kind parameters. */
1336 61628 : if (expr->ts.u.derived->attr.pdt_template)
1337 : {
1338 288 : param_list = NULL;
1339 288 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1340 288 : if (!t)
1341 : return t;
1342 288 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1343 :
1344 288 : expr->param_list = gfc_copy_actual_arglist (param_list);
1345 :
1346 288 : if (param_list)
1347 288 : gfc_free_actual_arglist (param_list);
1348 :
1349 288 : if (!expr->ts.u.derived->attr.pdt_type)
1350 : return false;
1351 : }
1352 : }
1353 :
1354 : /* A constructor may have references if it is the result of substituting a
1355 : parameter variable. In this case we just pull out the component we
1356 : want. */
1357 64662 : if (expr->ref)
1358 160 : comp = expr->ref->u.c.sym->components;
1359 64502 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1360 : || expr->ts.type == BT_UNION)
1361 64500 : && expr->ts.u.derived)
1362 64500 : comp = expr->ts.u.derived->components;
1363 : else
1364 : return false;
1365 :
1366 64660 : cons = gfc_constructor_first (expr->value.constructor);
1367 :
1368 281478 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1369 : {
1370 152160 : int rank;
1371 :
1372 152160 : if (!cons->expr)
1373 10334 : continue;
1374 :
1375 : /* Unions use an EXPR_NULL contrived expression to tell the translation
1376 : phase to generate an initializer of the appropriate length.
1377 : Ignore it here. */
1378 141826 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1379 15 : continue;
1380 :
1381 141811 : if (!gfc_resolve_expr (cons->expr))
1382 : {
1383 0 : t = false;
1384 0 : continue;
1385 : }
1386 :
1387 141811 : rank = comp->as ? comp->as->rank : 0;
1388 141811 : if (comp->ts.type == BT_CLASS
1389 1861 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1390 1860 : && CLASS_DATA (comp)->as)
1391 561 : rank = CLASS_DATA (comp)->as->rank;
1392 :
1393 141811 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1394 234 : gfc_find_vtab (&cons->expr->ts);
1395 :
1396 141811 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1397 527 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1398 : {
1399 4 : gfc_error ("The rank of the element in the structure "
1400 : "constructor at %L does not match that of the "
1401 : "component (%d/%d)", &cons->expr->where,
1402 : cons->expr->rank, rank);
1403 4 : t = false;
1404 : }
1405 :
1406 : /* If we don't have the right type, try to convert it. */
1407 :
1408 247669 : if (!comp->attr.proc_pointer &&
1409 105858 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1410 : {
1411 12990 : if (strcmp (comp->name, "_extends") == 0)
1412 : {
1413 : /* Can afford to be brutal with the _extends initializer.
1414 : The derived type can get lost because it is PRIVATE
1415 : but it is not usage constrained by the standard. */
1416 9541 : cons->expr->ts = comp->ts;
1417 : }
1418 3449 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1419 : {
1420 2 : gfc_error ("The element in the structure constructor at %L, "
1421 : "for pointer component %qs, is %s but should be %s",
1422 2 : &cons->expr->where, comp->name,
1423 2 : gfc_basic_typename (cons->expr->ts.type),
1424 : gfc_basic_typename (comp->ts.type));
1425 2 : t = false;
1426 : }
1427 3447 : else if (!UNLIMITED_POLY (comp))
1428 : {
1429 3384 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1430 3384 : if (t)
1431 141811 : t = t2;
1432 : }
1433 : }
1434 :
1435 : /* For strings, the length of the constructor should be the same as
1436 : the one of the structure, ensure this if the lengths are known at
1437 : compile time and when we are dealing with PARAMETER or structure
1438 : constructors. Skip for PDT types which have type parameters. */
1439 141811 : if (!IS_PDT (expr) && cons->expr->ts.type == BT_CHARACTER
1440 3925 : && comp->ts.type == BT_CHARACTER
1441 3899 : && comp->ts.u.cl && comp->ts.u.cl->length
1442 2510 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1443 2493 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1444 938 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1445 938 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1446 938 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1447 938 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1448 938 : comp->ts.u.cl->length->value.integer) != 0)
1449 : {
1450 11 : if (comp->attr.pointer)
1451 : {
1452 3 : HOST_WIDE_INT la, lb;
1453 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1454 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1455 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1456 : "component %qs in constructor at %L",
1457 3 : la, lb, comp->name, &cons->expr->where);
1458 3 : t = false;
1459 : }
1460 :
1461 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1462 4 : && cons->expr->rank != 0
1463 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1464 : {
1465 : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1466 : to make use of the gfc_resolve_character_array_constructor
1467 : machinery. The expression is later simplified away to
1468 : an array of string literals. */
1469 1 : gfc_expr *para = cons->expr;
1470 1 : cons->expr = gfc_get_expr ();
1471 1 : cons->expr->ts = para->ts;
1472 1 : cons->expr->where = para->where;
1473 1 : cons->expr->expr_type = EXPR_ARRAY;
1474 1 : cons->expr->rank = para->rank;
1475 1 : cons->expr->corank = para->corank;
1476 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1477 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1478 1 : para, &cons->expr->where);
1479 : }
1480 :
1481 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1482 : {
1483 : /* Rely on the cleanup of the namespace to deal correctly with
1484 : the old charlen. (There was a block here that attempted to
1485 : remove the charlen but broke the chain in so doing.) */
1486 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1487 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1488 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1489 5 : gfc_resolve_character_array_constructor (cons->expr);
1490 : }
1491 : }
1492 :
1493 141811 : if (cons->expr->expr_type == EXPR_NULL
1494 42832 : && !(comp->attr.pointer || comp->attr.allocatable
1495 21344 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1496 1196 : || (comp->ts.type == BT_CLASS
1497 1194 : && (CLASS_DATA (comp)->attr.class_pointer
1498 977 : || CLASS_DATA (comp)->attr.allocatable))))
1499 : {
1500 2 : t = false;
1501 2 : gfc_error ("The NULL in the structure constructor at %L is "
1502 : "being applied to component %qs, which is neither "
1503 : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1504 : comp->name);
1505 : }
1506 :
1507 141811 : if (comp->attr.proc_pointer && comp->ts.interface)
1508 : {
1509 : /* Check procedure pointer interface. */
1510 16144 : gfc_symbol *s2 = NULL;
1511 16144 : gfc_component *c2;
1512 16144 : const char *name;
1513 16144 : char err[200];
1514 :
1515 16144 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1516 16144 : if (c2)
1517 : {
1518 12 : s2 = c2->ts.interface;
1519 12 : name = c2->name;
1520 : }
1521 16132 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1522 : {
1523 0 : s2 = cons->expr->symtree->n.sym->result;
1524 0 : name = cons->expr->symtree->n.sym->result->name;
1525 : }
1526 16132 : else if (cons->expr->expr_type != EXPR_NULL)
1527 : {
1528 15700 : s2 = cons->expr->symtree->n.sym;
1529 15700 : name = cons->expr->symtree->n.sym->name;
1530 : }
1531 :
1532 15712 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1533 : err, sizeof (err), NULL, NULL))
1534 : {
1535 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1536 : "component %qs in structure constructor at %L:"
1537 2 : " %s", comp->name, &cons->expr->where, err);
1538 2 : return false;
1539 : }
1540 : }
1541 :
1542 : /* Validate shape, except for dynamic or PDT arrays. */
1543 141809 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1544 2270 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1545 1526 : && !comp->attr.pdt_array)
1546 : {
1547 1279 : mpz_t len;
1548 1279 : mpz_init (len);
1549 3930 : for (int n = 0; n < rank; n++)
1550 : {
1551 1377 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1552 1372 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1553 : {
1554 5 : gfc_error ("Bad array spec of component %qs referenced in "
1555 : "structure constructor at %L",
1556 5 : comp->name, &cons->expr->where);
1557 5 : t = false;
1558 5 : break;
1559 1372 : };
1560 1372 : if (cons->expr->shape == NULL)
1561 12 : continue;
1562 1360 : mpz_set_ui (len, 1);
1563 1360 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1564 1360 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1565 1360 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1566 : {
1567 9 : gfc_error ("The shape of component %qs in the structure "
1568 : "constructor at %L differs from the shape of the "
1569 : "declared component for dimension %d (%ld/%ld)",
1570 : comp->name, &cons->expr->where, n+1,
1571 : mpz_get_si (cons->expr->shape[n]),
1572 : mpz_get_si (len));
1573 9 : t = false;
1574 : }
1575 : }
1576 1279 : mpz_clear (len);
1577 : }
1578 :
1579 141809 : if (!comp->attr.pointer || comp->attr.proc_pointer
1580 22954 : || cons->expr->expr_type == EXPR_NULL)
1581 131214 : continue;
1582 :
1583 10595 : a = gfc_expr_attr (cons->expr);
1584 :
1585 10595 : if (!a.pointer && !a.target)
1586 : {
1587 1 : t = false;
1588 1 : gfc_error ("The element in the structure constructor at %L, "
1589 : "for pointer component %qs should be a POINTER or "
1590 1 : "a TARGET", &cons->expr->where, comp->name);
1591 : }
1592 :
1593 10595 : if (init)
1594 : {
1595 : /* F08:C461. Additional checks for pointer initialization. */
1596 10527 : if (a.allocatable)
1597 : {
1598 0 : t = false;
1599 0 : gfc_error ("Pointer initialization target at %L "
1600 0 : "must not be ALLOCATABLE", &cons->expr->where);
1601 : }
1602 10527 : if (!a.save)
1603 : {
1604 0 : t = false;
1605 0 : gfc_error ("Pointer initialization target at %L "
1606 0 : "must have the SAVE attribute", &cons->expr->where);
1607 : }
1608 : }
1609 :
1610 : /* F2023:C770: A designator that is an initial-data-target shall ...
1611 : not have a vector subscript. */
1612 10595 : if (comp->attr.pointer && (a.pointer || a.target)
1613 21189 : && gfc_has_vector_index (cons->expr))
1614 : {
1615 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1616 1 : &cons->expr->where);
1617 1 : t = false;
1618 : }
1619 :
1620 : /* F2003, C1272 (3). */
1621 10595 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1622 10595 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1623 10558 : || gfc_is_coindexed (cons->expr));
1624 34 : if (impure && gfc_pure (NULL))
1625 : {
1626 1 : t = false;
1627 1 : gfc_error ("Invalid expression in the structure constructor for "
1628 : "pointer component %qs at %L in PURE procedure",
1629 1 : comp->name, &cons->expr->where);
1630 : }
1631 :
1632 10595 : if (impure)
1633 34 : gfc_unset_implicit_pure (NULL);
1634 : }
1635 :
1636 : return t;
1637 : }
1638 :
1639 :
1640 : /****************** Expression name resolution ******************/
1641 :
1642 : /* Returns 0 if a symbol was not declared with a type or
1643 : attribute declaration statement, nonzero otherwise. */
1644 :
1645 : static bool
1646 755763 : was_declared (gfc_symbol *sym)
1647 : {
1648 755763 : symbol_attribute a;
1649 :
1650 755763 : a = sym->attr;
1651 :
1652 755763 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1653 : return 1;
1654 :
1655 640185 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1656 631323 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1657 631321 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1658 631267 : || a.asynchronous || a.codimension
1659 631267 : || (a.subroutine && a.proc != PROC_UNKNOWN) || a.result)
1660 67282 : return 1;
1661 :
1662 : return 0;
1663 : }
1664 :
1665 :
1666 : /* Determine if a symbol is generic or not. */
1667 :
1668 : static int
1669 419926 : generic_sym (gfc_symbol *sym)
1670 : {
1671 419926 : gfc_symbol *s;
1672 :
1673 419926 : if (sym->attr.generic ||
1674 389985 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1675 : return 1;
1676 :
1677 388871 : if (was_declared (sym) || sym->ns->parent == NULL)
1678 : return 0;
1679 :
1680 80024 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1681 :
1682 80024 : if (s != NULL)
1683 : {
1684 163 : if (s == sym)
1685 : return 0;
1686 : else
1687 162 : return generic_sym (s);
1688 : }
1689 :
1690 : return 0;
1691 : }
1692 :
1693 :
1694 : /* Determine if a symbol is specific or not. */
1695 :
1696 : static int
1697 388783 : specific_sym (gfc_symbol *sym)
1698 : {
1699 388783 : gfc_symbol *s;
1700 :
1701 388783 : if (sym->attr.if_source == IFSRC_IFBODY
1702 377346 : || sym->attr.proc == PROC_MODULE
1703 348416 : || sym->attr.proc == PROC_INTERNAL
1704 299710 : || sym->attr.proc == PROC_ST_FUNCTION
1705 299420 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1706 687472 : || sym->attr.external)
1707 : return 1;
1708 :
1709 296280 : if (was_declared (sym) || sym->ns->parent == NULL)
1710 : return 0;
1711 :
1712 79922 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1713 :
1714 79922 : return (s == NULL) ? 0 : specific_sym (s);
1715 : }
1716 :
1717 :
1718 : /* Figure out if the procedure is specific, generic or unknown. */
1719 :
1720 : enum proc_type
1721 : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1722 :
1723 : static proc_type
1724 419615 : procedure_kind (gfc_symbol *sym)
1725 : {
1726 419615 : if (generic_sym (sym))
1727 : return PTYPE_GENERIC;
1728 :
1729 388706 : if (specific_sym (sym))
1730 92503 : return PTYPE_SPECIFIC;
1731 :
1732 : return PTYPE_UNKNOWN;
1733 : }
1734 :
1735 : /* Check references to assumed size arrays. The flag need_full_assumed_size
1736 : is nonzero when matching actual arguments. */
1737 :
1738 : static int need_full_assumed_size = 0;
1739 :
1740 : static bool
1741 1446651 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1742 : {
1743 1446651 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1744 : return false;
1745 :
1746 : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1747 : What should it be? */
1748 3812 : if (e->ref
1749 3810 : && e->ref->u.ar.as
1750 3809 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1751 3302 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1752 3302 : && (e->ref->u.ar.type == AR_FULL))
1753 : {
1754 25 : gfc_error ("The upper bound in the last dimension must "
1755 : "appear in the reference to the assumed size "
1756 : "array %qs at %L", sym->name, &e->where);
1757 25 : return true;
1758 : }
1759 : return false;
1760 : }
1761 :
1762 :
1763 : /* Look for bad assumed size array references in argument expressions
1764 : of elemental and array valued intrinsic procedures. Since this is
1765 : called from procedure resolution functions, it only recurses at
1766 : operators. */
1767 :
1768 : static bool
1769 233228 : resolve_assumed_size_actual (gfc_expr *e)
1770 : {
1771 233228 : if (e == NULL)
1772 : return false;
1773 :
1774 232659 : switch (e->expr_type)
1775 : {
1776 112076 : case EXPR_VARIABLE:
1777 112076 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1778 : return true;
1779 : break;
1780 :
1781 49522 : case EXPR_OP:
1782 49522 : if (resolve_assumed_size_actual (e->value.op.op1)
1783 49522 : || resolve_assumed_size_actual (e->value.op.op2))
1784 0 : return true;
1785 : break;
1786 :
1787 : default:
1788 : break;
1789 : }
1790 : return false;
1791 : }
1792 :
1793 :
1794 : /* Check a generic procedure, passed as an actual argument, to see if
1795 : there is a matching specific name. If none, it is an error, and if
1796 : more than one, the reference is ambiguous. */
1797 : static int
1798 8 : count_specific_procs (gfc_expr *e)
1799 : {
1800 8 : int n;
1801 8 : gfc_interface *p;
1802 8 : gfc_symbol *sym;
1803 :
1804 8 : n = 0;
1805 8 : sym = e->symtree->n.sym;
1806 :
1807 22 : for (p = sym->generic; p; p = p->next)
1808 14 : if (strcmp (sym->name, p->sym->name) == 0)
1809 : {
1810 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1811 : sym->name);
1812 8 : n++;
1813 : }
1814 :
1815 8 : if (n > 1)
1816 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1817 : &e->where);
1818 :
1819 8 : if (n == 0)
1820 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1821 : "argument at %L", sym->name, &e->where);
1822 :
1823 8 : return n;
1824 : }
1825 :
1826 :
1827 : /* See if a call to sym could possibly be a not allowed RECURSION because of
1828 : a missing RECURSIVE declaration. This means that either sym is the current
1829 : context itself, or sym is the parent of a contained procedure calling its
1830 : non-RECURSIVE containing procedure.
1831 : This also works if sym is an ENTRY. */
1832 :
1833 : static bool
1834 154837 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1835 : {
1836 154837 : gfc_symbol* proc_sym;
1837 154837 : gfc_symbol* context_proc;
1838 154837 : gfc_namespace* real_context;
1839 :
1840 154837 : if (sym->attr.flavor == FL_PROGRAM
1841 : || gfc_fl_struct (sym->attr.flavor))
1842 : return false;
1843 :
1844 : /* If we've got an ENTRY, find real procedure. */
1845 154836 : if (sym->attr.entry && sym->ns->entries)
1846 45 : proc_sym = sym->ns->entries->sym;
1847 : else
1848 : proc_sym = sym;
1849 :
1850 : /* If sym is RECURSIVE, all is well of course. */
1851 154836 : if (proc_sym->attr.recursive || flag_recursive)
1852 : return false;
1853 :
1854 : /* Find the context procedure's "real" symbol if it has entries.
1855 : We look for a procedure symbol, so recurse on the parents if we don't
1856 : find one (like in case of a BLOCK construct). */
1857 1997 : for (real_context = context; ; real_context = real_context->parent)
1858 : {
1859 : /* We should find something, eventually! */
1860 131178 : gcc_assert (real_context);
1861 :
1862 131178 : context_proc = (real_context->entries ? real_context->entries->sym
1863 : : real_context->proc_name);
1864 :
1865 : /* In some special cases, there may not be a proc_name, like for this
1866 : invalid code:
1867 : real(bad_kind()) function foo () ...
1868 : when checking the call to bad_kind ().
1869 : In these cases, we simply return here and assume that the
1870 : call is ok. */
1871 131178 : if (!context_proc)
1872 : return false;
1873 :
1874 130914 : if (context_proc->attr.flavor != FL_LABEL)
1875 : break;
1876 : }
1877 :
1878 : /* A call from sym's body to itself is recursion, of course. */
1879 128917 : if (context_proc == proc_sym)
1880 : return true;
1881 :
1882 : /* The same is true if context is a contained procedure and sym the
1883 : containing one. */
1884 128902 : if (context_proc->attr.contained)
1885 : {
1886 21805 : gfc_symbol* parent_proc;
1887 :
1888 21805 : gcc_assert (context->parent);
1889 21805 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1890 : : context->parent->proc_name);
1891 :
1892 21805 : if (parent_proc == proc_sym)
1893 9 : return true;
1894 : }
1895 :
1896 : return false;
1897 : }
1898 :
1899 :
1900 : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1901 : its typespec and formal argument list. */
1902 :
1903 : bool
1904 47456 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1905 : {
1906 47456 : gfc_intrinsic_sym* isym = NULL;
1907 47456 : const char* symstd;
1908 :
1909 47456 : if (sym->resolve_symbol_called >= 2)
1910 : return true;
1911 :
1912 37406 : sym->resolve_symbol_called = 2;
1913 :
1914 : /* Already resolved. */
1915 37406 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1916 : return true;
1917 :
1918 : /* We already know this one is an intrinsic, so we don't call
1919 : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1920 : gfc_find_subroutine directly to check whether it is a function or
1921 : subroutine. */
1922 :
1923 29332 : if (sym->intmod_sym_id && sym->attr.subroutine)
1924 : {
1925 12769 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1926 12769 : isym = gfc_intrinsic_subroutine_by_id (id);
1927 12769 : }
1928 16563 : else if (sym->intmod_sym_id)
1929 : {
1930 12712 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1931 12712 : isym = gfc_intrinsic_function_by_id (id);
1932 : }
1933 3851 : else if (!sym->attr.subroutine)
1934 3764 : isym = gfc_find_function (sym->name);
1935 :
1936 29245 : if (isym && !sym->attr.subroutine)
1937 : {
1938 16431 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1939 24 : && !sym->attr.implicit_type)
1940 10 : gfc_warning (OPT_Wsurprising,
1941 : "Type specified for intrinsic function %qs at %L is"
1942 : " ignored", sym->name, &sym->declared_at);
1943 :
1944 20932 : if (!sym->attr.function &&
1945 4501 : !gfc_add_function(&sym->attr, sym->name, loc))
1946 : return false;
1947 :
1948 16431 : sym->ts = isym->ts;
1949 : }
1950 12901 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1951 : {
1952 12898 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1953 : {
1954 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1955 : " specifier", sym->name, &sym->declared_at);
1956 1 : return false;
1957 : }
1958 :
1959 12938 : if (!sym->attr.subroutine &&
1960 41 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1961 : return false;
1962 : }
1963 : else
1964 : {
1965 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1966 : &sym->declared_at);
1967 3 : return false;
1968 : }
1969 :
1970 29327 : gfc_copy_formal_args_intr (sym, isym, NULL);
1971 :
1972 29327 : sym->attr.pure = isym->pure;
1973 29327 : sym->attr.elemental = isym->elemental;
1974 :
1975 : /* Check it is actually available in the standard settings. */
1976 29327 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1977 : {
1978 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1979 : "available in the current standard settings but %s. Use "
1980 : "an appropriate %<-std=*%> option or enable "
1981 : "%<-fall-intrinsics%> in order to use it.",
1982 : sym->name, &sym->declared_at, symstd);
1983 31 : return false;
1984 : }
1985 :
1986 : return true;
1987 : }
1988 :
1989 :
1990 : /* Resolve a procedure expression, like passing it to a called procedure or as
1991 : RHS for a procedure pointer assignment. */
1992 :
1993 : static bool
1994 1348159 : resolve_procedure_expression (gfc_expr* expr)
1995 : {
1996 1348159 : gfc_symbol* sym;
1997 :
1998 1348159 : if (expr->expr_type != EXPR_VARIABLE)
1999 : return true;
2000 1348142 : gcc_assert (expr->symtree);
2001 :
2002 1348142 : sym = expr->symtree->n.sym;
2003 :
2004 1348142 : if (sym->attr.intrinsic)
2005 1360 : gfc_resolve_intrinsic (sym, &expr->where);
2006 :
2007 1348142 : if (sym->attr.flavor != FL_PROCEDURE
2008 32666 : || (sym->attr.function && sym->result == sym))
2009 : return true;
2010 :
2011 : /* A non-RECURSIVE procedure that is used as procedure expression within its
2012 : own body is in danger of being called recursively. */
2013 17889 : if (is_illegal_recursion (sym, gfc_current_ns))
2014 : {
2015 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
2016 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
2017 : " possibly calling itself recursively in procedure %qs. "
2018 : " Declare it RECURSIVE or use %<-frecursive%>",
2019 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
2020 : else
2021 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
2022 : " itself recursively. Declare it RECURSIVE or use"
2023 : " %<-frecursive%>", sym->name, &expr->where);
2024 : }
2025 :
2026 : return true;
2027 : }
2028 :
2029 :
2030 : /* Check that name is not a derived type. */
2031 :
2032 : static bool
2033 3434 : is_dt_name (const char *name)
2034 : {
2035 3434 : gfc_symbol *dt_list, *dt_first;
2036 :
2037 3434 : dt_list = dt_first = gfc_derived_types;
2038 5888 : for (; dt_list; dt_list = dt_list->dt_next)
2039 : {
2040 3577 : if (strcmp(dt_list->name, name) == 0)
2041 : return true;
2042 3574 : if (dt_first == dt_list->dt_next)
2043 : break;
2044 : }
2045 : return false;
2046 : }
2047 :
2048 :
2049 : /* Resolve an actual argument list. Most of the time, this is just
2050 : resolving the expressions in the list.
2051 : The exception is that we sometimes have to decide whether arguments
2052 : that look like procedure arguments are really simple variable
2053 : references. */
2054 :
2055 : static bool
2056 434006 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2057 : bool no_formal_args)
2058 : {
2059 434006 : gfc_symbol *sym = NULL;
2060 434006 : gfc_symtree *parent_st;
2061 434006 : gfc_expr *e;
2062 434006 : gfc_component *comp;
2063 434006 : int save_need_full_assumed_size;
2064 434006 : bool return_value = false;
2065 434006 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2066 :
2067 434006 : actual_arg = true;
2068 434006 : first_actual_arg = true;
2069 :
2070 1112087 : for (; arg; arg = arg->next)
2071 : {
2072 678182 : e = arg->expr;
2073 678182 : if (e == NULL)
2074 : {
2075 : /* Check the label is a valid branching target. */
2076 2503 : if (arg->label)
2077 : {
2078 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2079 : {
2080 0 : gfc_error ("Label %d referenced at %L is never defined",
2081 : arg->label->value, &arg->label->where);
2082 0 : goto cleanup;
2083 : }
2084 : }
2085 2503 : first_actual_arg = false;
2086 2503 : continue;
2087 : }
2088 :
2089 675679 : if (e->expr_type == EXPR_VARIABLE
2090 298673 : && e->symtree->n.sym->attr.generic
2091 8 : && no_formal_args
2092 675684 : && count_specific_procs (e) != 1)
2093 2 : goto cleanup;
2094 :
2095 675677 : if (e->ts.type != BT_PROCEDURE)
2096 : {
2097 601631 : save_need_full_assumed_size = need_full_assumed_size;
2098 601631 : if (e->expr_type != EXPR_VARIABLE)
2099 377006 : need_full_assumed_size = 0;
2100 601631 : if (!gfc_resolve_expr (e))
2101 60 : goto cleanup;
2102 601571 : need_full_assumed_size = save_need_full_assumed_size;
2103 601571 : goto argument_list;
2104 : }
2105 :
2106 : /* See if the expression node should really be a variable reference. */
2107 :
2108 74046 : sym = e->symtree->n.sym;
2109 :
2110 74046 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2111 : {
2112 3 : gfc_error ("Derived type %qs is used as an actual "
2113 : "argument at %L", sym->name, &e->where);
2114 3 : goto cleanup;
2115 : }
2116 :
2117 74043 : if (sym->attr.flavor == FL_PROCEDURE
2118 70612 : || sym->attr.intrinsic
2119 70612 : || sym->attr.external)
2120 : {
2121 3431 : int actual_ok;
2122 :
2123 : /* If a procedure is not already determined to be something else
2124 : check if it is intrinsic. */
2125 3431 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2126 1254 : sym->attr.intrinsic = 1;
2127 :
2128 3431 : if (sym->attr.proc == PROC_ST_FUNCTION)
2129 : {
2130 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2131 : "actual argument", sym->name, &e->where);
2132 : }
2133 :
2134 6862 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2135 3431 : sym->attr.subroutine);
2136 3431 : if (sym->attr.intrinsic && actual_ok == 0)
2137 : {
2138 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2139 : "actual argument", sym->name, &e->where);
2140 : }
2141 :
2142 3431 : if (sym->attr.contained && !sym->attr.use_assoc
2143 444 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2144 : {
2145 256 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2146 : " used as actual argument at %L",
2147 : sym->name, &e->where))
2148 3 : goto cleanup;
2149 : }
2150 :
2151 3428 : if (sym->attr.elemental && !sym->attr.intrinsic)
2152 : {
2153 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2154 : "allowed as an actual argument at %L", sym->name,
2155 : &e->where);
2156 : }
2157 :
2158 : /* Check if a generic interface has a specific procedure
2159 : with the same name before emitting an error. */
2160 3428 : if (sym->attr.generic && count_specific_procs (e) != 1)
2161 0 : goto cleanup;
2162 :
2163 : /* Just in case a specific was found for the expression. */
2164 3428 : sym = e->symtree->n.sym;
2165 :
2166 : /* If the symbol is the function that names the current (or
2167 : parent) scope, then we really have a variable reference. */
2168 :
2169 3428 : if (gfc_is_function_return_value (sym, sym->ns))
2170 0 : goto got_variable;
2171 :
2172 : /* If all else fails, see if we have a specific intrinsic. */
2173 3428 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2174 : {
2175 0 : gfc_intrinsic_sym *isym;
2176 :
2177 0 : isym = gfc_find_function (sym->name);
2178 0 : if (isym == NULL || !isym->specific)
2179 : {
2180 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2181 : "for the reference %qs at %L", sym->name,
2182 : &e->where);
2183 0 : goto cleanup;
2184 : }
2185 0 : sym->ts = isym->ts;
2186 0 : sym->attr.intrinsic = 1;
2187 0 : sym->attr.function = 1;
2188 : }
2189 :
2190 3428 : if (!gfc_resolve_expr (e))
2191 0 : goto cleanup;
2192 3428 : goto argument_list;
2193 : }
2194 :
2195 : /* See if the name is a module procedure in a parent unit. */
2196 :
2197 70612 : if (was_declared (sym) || sym->ns->parent == NULL)
2198 70518 : goto got_variable;
2199 :
2200 94 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2201 : {
2202 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2203 0 : goto cleanup;
2204 : }
2205 :
2206 94 : if (parent_st == NULL)
2207 94 : goto got_variable;
2208 :
2209 0 : sym = parent_st->n.sym;
2210 0 : e->symtree = parent_st; /* Point to the right thing. */
2211 :
2212 0 : if (sym->attr.flavor == FL_PROCEDURE
2213 0 : || sym->attr.intrinsic
2214 0 : || sym->attr.external)
2215 : {
2216 0 : if (!gfc_resolve_expr (e))
2217 0 : goto cleanup;
2218 0 : goto argument_list;
2219 : }
2220 :
2221 0 : got_variable:
2222 70612 : e->expr_type = EXPR_VARIABLE;
2223 70612 : e->ts = sym->ts;
2224 70612 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2225 36494 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2226 3942 : && CLASS_DATA (sym)->as))
2227 : {
2228 39802 : gfc_array_spec *as
2229 36960 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2230 36960 : e->rank = as->rank;
2231 36960 : e->corank = as->corank;
2232 36960 : e->ref = gfc_get_ref ();
2233 36960 : e->ref->type = REF_ARRAY;
2234 36960 : e->ref->u.ar.type = AR_FULL;
2235 36960 : e->ref->u.ar.as = as;
2236 : }
2237 :
2238 : /* These symbols are set untyped by calls to gfc_set_default_type
2239 : with 'error_flag' = false. Reset the untyped attribute so that
2240 : the error will be generated in gfc_resolve_expr. */
2241 70612 : if (e->expr_type == EXPR_VARIABLE
2242 70612 : && sym->ts.type == BT_UNKNOWN
2243 36 : && sym->attr.untyped)
2244 5 : sym->attr.untyped = 0;
2245 :
2246 : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2247 : primary.cc (match_actual_arg). If above code determines that it
2248 : is a variable instead, it needs to be resolved as it was not
2249 : done at the beginning of this function. */
2250 70612 : save_need_full_assumed_size = need_full_assumed_size;
2251 70612 : if (e->expr_type != EXPR_VARIABLE)
2252 0 : need_full_assumed_size = 0;
2253 70612 : if (!gfc_resolve_expr (e))
2254 22 : goto cleanup;
2255 70590 : need_full_assumed_size = save_need_full_assumed_size;
2256 :
2257 675589 : argument_list:
2258 : /* Check argument list functions %VAL, %LOC and %REF. There is
2259 : nothing to do for %REF. */
2260 675589 : if (arg->name && arg->name[0] == '%')
2261 : {
2262 42 : if (strcmp ("%VAL", arg->name) == 0)
2263 : {
2264 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2265 : {
2266 2 : gfc_error ("By-value argument at %L is not of numeric "
2267 : "type", &e->where);
2268 2 : goto cleanup;
2269 : }
2270 :
2271 26 : if (e->rank)
2272 : {
2273 1 : gfc_error ("By-value argument at %L cannot be an array or "
2274 : "an array section", &e->where);
2275 1 : goto cleanup;
2276 : }
2277 :
2278 : /* Intrinsics are still PROC_UNKNOWN here. However,
2279 : since same file external procedures are not resolvable
2280 : in gfortran, it is a good deal easier to leave them to
2281 : intrinsic.cc. */
2282 25 : if (ptype != PROC_UNKNOWN
2283 25 : && ptype != PROC_DUMMY
2284 9 : && ptype != PROC_EXTERNAL
2285 9 : && ptype != PROC_MODULE)
2286 : {
2287 3 : gfc_error ("By-value argument at %L is not allowed "
2288 : "in this context", &e->where);
2289 3 : goto cleanup;
2290 : }
2291 : }
2292 :
2293 : /* Statement functions have already been excluded above. */
2294 14 : else if (strcmp ("%LOC", arg->name) == 0
2295 8 : && e->ts.type == BT_PROCEDURE)
2296 : {
2297 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2298 : {
2299 0 : gfc_error ("Passing internal procedure at %L by location "
2300 : "not allowed", &e->where);
2301 0 : goto cleanup;
2302 : }
2303 : }
2304 : }
2305 :
2306 675583 : comp = gfc_get_proc_ptr_comp(e);
2307 675583 : if (e->expr_type == EXPR_VARIABLE
2308 297295 : && comp && comp->attr.elemental)
2309 : {
2310 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2311 : "allowed as an actual argument at %L", comp->name,
2312 : &e->where);
2313 : }
2314 :
2315 : /* Fortran 2008, C1237. */
2316 297295 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2317 676028 : && gfc_has_ultimate_pointer (e))
2318 : {
2319 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2320 : "component", &e->where);
2321 3 : goto cleanup;
2322 : }
2323 :
2324 675580 : if (e->expr_type == EXPR_VARIABLE
2325 297292 : && e->ts.type == BT_PROCEDURE
2326 3428 : && no_formal_args
2327 1505 : && sym->attr.flavor == FL_PROCEDURE
2328 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2329 142 : && !sym->attr.external
2330 2 : && !sym->attr.intrinsic
2331 2 : && !sym->attr.artificial
2332 2 : && !sym->ts.interface)
2333 : {
2334 : /* Emit a warning for -std=legacy and an error otherwise. */
2335 2 : if (gfc_option.warn_std == 0)
2336 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2337 : "does neither have an explicit interface nor the "
2338 : "EXTERNAL attribute", sym->name, &e->where);
2339 : else
2340 : {
2341 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2342 : "does neither have an explicit interface nor the "
2343 : "EXTERNAL attribute", sym->name, &e->where);
2344 2 : goto cleanup;
2345 : }
2346 : }
2347 :
2348 675578 : first_actual_arg = false;
2349 : }
2350 :
2351 : return_value = true;
2352 :
2353 434006 : cleanup:
2354 434006 : actual_arg = actual_arg_sav;
2355 434006 : first_actual_arg = first_actual_arg_sav;
2356 :
2357 434006 : return return_value;
2358 : }
2359 :
2360 :
2361 : /* Do the checks of the actual argument list that are specific to elemental
2362 : procedures. If called with c == NULL, we have a function, otherwise if
2363 : expr == NULL, we have a subroutine. */
2364 :
2365 : static bool
2366 330477 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2367 : {
2368 330477 : gfc_actual_arglist *arg0;
2369 330477 : gfc_actual_arglist *arg;
2370 330477 : gfc_symbol *esym = NULL;
2371 330477 : gfc_intrinsic_sym *isym = NULL;
2372 330477 : gfc_expr *e = NULL;
2373 330477 : gfc_intrinsic_arg *iformal = NULL;
2374 330477 : gfc_formal_arglist *eformal = NULL;
2375 330477 : bool formal_optional = false;
2376 330477 : bool set_by_optional = false;
2377 330477 : int i;
2378 330477 : int rank = 0;
2379 :
2380 : /* Is this an elemental procedure? */
2381 330477 : if (expr && expr->value.function.actual != NULL)
2382 : {
2383 239299 : if (expr->value.function.esym != NULL
2384 44522 : && expr->value.function.esym->attr.elemental)
2385 : {
2386 : arg0 = expr->value.function.actual;
2387 : esym = expr->value.function.esym;
2388 : }
2389 222985 : else if (expr->value.function.isym != NULL
2390 193710 : && expr->value.function.isym->elemental)
2391 : {
2392 : arg0 = expr->value.function.actual;
2393 : isym = expr->value.function.isym;
2394 : }
2395 : else
2396 : return true;
2397 : }
2398 91178 : else if (c && c->ext.actual != NULL)
2399 : {
2400 72082 : arg0 = c->ext.actual;
2401 :
2402 72082 : if (c->resolved_sym)
2403 : esym = c->resolved_sym;
2404 : else
2405 323 : esym = c->symtree->n.sym;
2406 72082 : gcc_assert (esym);
2407 :
2408 72082 : if (!esym->attr.elemental)
2409 : return true;
2410 : }
2411 : else
2412 : return true;
2413 :
2414 : /* The rank of an elemental is the rank of its array argument(s). */
2415 175091 : for (arg = arg0; arg; arg = arg->next)
2416 : {
2417 113443 : if (arg->expr != NULL && arg->expr->rank != 0)
2418 : {
2419 10764 : rank = arg->expr->rank;
2420 10764 : if (arg->expr->expr_type == EXPR_VARIABLE
2421 5502 : && arg->expr->symtree->n.sym->attr.optional)
2422 10764 : set_by_optional = true;
2423 :
2424 : /* Function specific; set the result rank and shape. */
2425 10764 : if (expr)
2426 : {
2427 8356 : expr->rank = rank;
2428 8356 : expr->corank = arg->expr->corank;
2429 8356 : if (!expr->shape && arg->expr->shape)
2430 : {
2431 3974 : expr->shape = gfc_get_shape (rank);
2432 8743 : for (i = 0; i < rank; i++)
2433 4769 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2434 : }
2435 : }
2436 : break;
2437 : }
2438 : }
2439 :
2440 : /* If it is an array, it shall not be supplied as an actual argument
2441 : to an elemental procedure unless an array of the same rank is supplied
2442 : as an actual argument corresponding to a nonoptional dummy argument of
2443 : that elemental procedure(12.4.1.5). */
2444 72412 : formal_optional = false;
2445 72412 : if (isym)
2446 49885 : iformal = isym->formal;
2447 : else
2448 22527 : eformal = esym->formal;
2449 :
2450 191377 : for (arg = arg0; arg; arg = arg->next)
2451 : {
2452 118965 : if (eformal)
2453 : {
2454 40423 : if (eformal->sym && eformal->sym->attr.optional)
2455 40423 : formal_optional = true;
2456 40423 : eformal = eformal->next;
2457 : }
2458 78542 : else if (isym && iformal)
2459 : {
2460 68217 : if (iformal->optional)
2461 13532 : formal_optional = true;
2462 68217 : iformal = iformal->next;
2463 : }
2464 10325 : else if (isym)
2465 10317 : formal_optional = true;
2466 :
2467 118965 : if (pedantic && arg->expr != NULL
2468 67837 : && arg->expr->expr_type == EXPR_VARIABLE
2469 32010 : && arg->expr->symtree->n.sym->attr.optional
2470 578 : && formal_optional
2471 485 : && arg->expr->rank
2472 159 : && (set_by_optional || arg->expr->rank != rank)
2473 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2474 : {
2475 114 : bool t = false;
2476 : gfc_actual_arglist *a;
2477 :
2478 : /* Scan the argument list for a non-optional argument with the
2479 : same rank as arg. */
2480 114 : for (a = arg0; a; a = a->next)
2481 87 : if (a != arg
2482 45 : && a->expr->rank == arg->expr->rank
2483 39 : && (a->expr->expr_type != EXPR_VARIABLE
2484 37 : || (a->expr->expr_type == EXPR_VARIABLE
2485 37 : && !a->expr->symtree->n.sym->attr.optional)))
2486 : {
2487 : t = true;
2488 : break;
2489 : }
2490 :
2491 42 : if (!t)
2492 27 : gfc_warning (OPT_Wpedantic,
2493 : "%qs at %L is an array and OPTIONAL; If it is not "
2494 : "present, then it cannot be the actual argument of "
2495 : "an ELEMENTAL procedure unless there is a non-optional"
2496 : " argument with the same rank "
2497 : "(Fortran 2018, 15.5.2.12)",
2498 : arg->expr->symtree->n.sym->name, &arg->expr->where);
2499 : }
2500 : }
2501 :
2502 191366 : for (arg = arg0; arg; arg = arg->next)
2503 : {
2504 118963 : if (arg->expr == NULL || arg->expr->rank == 0)
2505 105305 : continue;
2506 :
2507 : /* Being elemental, the last upper bound of an assumed size array
2508 : argument must be present. */
2509 13658 : if (resolve_assumed_size_actual (arg->expr))
2510 : return false;
2511 :
2512 : /* Elemental procedure's array actual arguments must conform. */
2513 13655 : if (e != NULL)
2514 : {
2515 2894 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2516 : return false;
2517 : }
2518 : else
2519 10761 : e = arg->expr;
2520 : }
2521 :
2522 : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2523 : is an array, the intent inout/out variable needs to be also an array. */
2524 72403 : if (rank > 0 && esym && expr == NULL)
2525 7333 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2526 4931 : arg = arg->next, eformal = eformal->next)
2527 4933 : if (eformal->sym
2528 4932 : && (eformal->sym->attr.intent == INTENT_OUT
2529 3850 : || eformal->sym->attr.intent == INTENT_INOUT)
2530 1716 : && arg->expr && arg->expr->rank == 0)
2531 : {
2532 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2533 : "ELEMENTAL subroutine %qs is a scalar, but another "
2534 : "actual argument is an array", &arg->expr->where,
2535 : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2536 : : "INOUT", eformal->sym->name, esym->name);
2537 2 : return false;
2538 : }
2539 : return true;
2540 : }
2541 :
2542 :
2543 : /* This function does the checking of references to global procedures
2544 : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2545 : 77 and 95 standards. It checks for a gsymbol for the name, making
2546 : one if it does not already exist. If it already exists, then the
2547 : reference being resolved must correspond to the type of gsymbol.
2548 : Otherwise, the new symbol is equipped with the attributes of the
2549 : reference. The corresponding code that is called in creating
2550 : global entities is parse.cc.
2551 :
2552 : In addition, for all but -std=legacy, the gsymbols are used to
2553 : check the interfaces of external procedures from the same file.
2554 : The namespace of the gsymbol is resolved and then, once this is
2555 : done the interface is checked. */
2556 :
2557 :
2558 : static bool
2559 15009 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2560 : {
2561 15009 : if (!gsym_ns->proc_name->attr.recursive)
2562 : return true;
2563 :
2564 151 : if (sym->ns == gsym_ns)
2565 : return false;
2566 :
2567 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2568 0 : return false;
2569 :
2570 : return true;
2571 : }
2572 :
2573 : static bool
2574 15009 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2575 : {
2576 15009 : if (gsym_ns->entries)
2577 : {
2578 : gfc_entry_list *entry = gsym_ns->entries;
2579 :
2580 3312 : for (; entry; entry = entry->next)
2581 : {
2582 2333 : if (strcmp (sym->name, entry->sym->name) == 0)
2583 : {
2584 971 : if (strcmp (gsym_ns->proc_name->name,
2585 971 : sym->ns->proc_name->name) == 0)
2586 : return false;
2587 :
2588 971 : if (sym->ns->parent
2589 0 : && strcmp (gsym_ns->proc_name->name,
2590 0 : sym->ns->parent->proc_name->name) == 0)
2591 : return false;
2592 : }
2593 : }
2594 : }
2595 : return true;
2596 : }
2597 :
2598 :
2599 : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2600 :
2601 : bool
2602 15849 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2603 : {
2604 15849 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2605 :
2606 59136 : for ( ; arg; arg = arg->next)
2607 : {
2608 27846 : if (!arg->sym)
2609 157 : continue;
2610 :
2611 27689 : if (arg->sym->attr.allocatable) /* (2a) */
2612 : {
2613 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2614 0 : return true;
2615 : }
2616 27689 : else if (arg->sym->attr.asynchronous)
2617 : {
2618 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2619 0 : return true;
2620 : }
2621 27689 : else if (arg->sym->attr.optional)
2622 : {
2623 75 : strncpy (errmsg, _("optional argument"), err_len);
2624 75 : return true;
2625 : }
2626 27614 : else if (arg->sym->attr.pointer)
2627 : {
2628 12 : strncpy (errmsg, _("pointer argument"), err_len);
2629 12 : return true;
2630 : }
2631 27602 : else if (arg->sym->attr.target)
2632 : {
2633 72 : strncpy (errmsg, _("target argument"), err_len);
2634 72 : return true;
2635 : }
2636 27530 : else if (arg->sym->attr.value)
2637 : {
2638 12 : strncpy (errmsg, _("value argument"), err_len);
2639 12 : return true;
2640 : }
2641 27518 : else if (arg->sym->attr.volatile_)
2642 : {
2643 1 : strncpy (errmsg, _("volatile argument"), err_len);
2644 1 : return true;
2645 : }
2646 27517 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2647 : {
2648 69 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2649 69 : return true;
2650 : }
2651 27448 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2652 : {
2653 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2654 1 : return true;
2655 : }
2656 27447 : else if (arg->sym->attr.codimension) /* (2c) */
2657 : {
2658 1 : strncpy (errmsg, _("coarray argument"), err_len);
2659 1 : return true;
2660 : }
2661 27446 : else if (false) /* (2d) TODO: parametrized derived type */
2662 : {
2663 : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2664 : return true;
2665 : }
2666 27446 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2667 : {
2668 164 : strncpy (errmsg, _("polymorphic argument"), err_len);
2669 164 : return true;
2670 : }
2671 27282 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2672 : {
2673 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2674 0 : return true;
2675 : }
2676 27282 : else if (arg->sym->ts.type == BT_ASSUMED)
2677 : {
2678 : /* As assumed-type is unlimited polymorphic (cf. above).
2679 : See also TS 29113, Note 6.1. */
2680 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2681 1 : return true;
2682 : }
2683 : }
2684 :
2685 15441 : if (sym->attr.function)
2686 : {
2687 3497 : gfc_symbol *res = sym->result ? sym->result : sym;
2688 :
2689 3497 : if (res->attr.dimension) /* (3a) */
2690 : {
2691 93 : strncpy (errmsg, _("array result"), err_len);
2692 93 : return true;
2693 : }
2694 3404 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2695 : {
2696 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2697 38 : return true;
2698 : }
2699 3366 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2700 347 : && res->ts.u.cl->length
2701 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2702 : {
2703 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2704 12 : return true;
2705 : }
2706 : }
2707 :
2708 15298 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2709 : {
2710 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2711 7 : return true;
2712 : }
2713 15291 : else if (sym->attr.is_bind_c) /* (5) */
2714 : {
2715 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2716 0 : return true;
2717 : }
2718 :
2719 : return false;
2720 : }
2721 :
2722 :
2723 : static void
2724 29736 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2725 : {
2726 29736 : gfc_gsymbol * gsym;
2727 29736 : gfc_namespace *ns;
2728 29736 : enum gfc_symbol_type type;
2729 29736 : char reason[200];
2730 :
2731 29736 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2732 :
2733 29736 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2734 29736 : sym->binding_label != NULL);
2735 :
2736 29736 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2737 9 : gfc_global_used (gsym, where);
2738 :
2739 29736 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2740 9491 : || sym->attr.if_source == IFSRC_IFBODY)
2741 25184 : && gsym->type != GSYM_UNKNOWN
2742 22990 : && !gsym->binding_label
2743 20673 : && gsym->ns
2744 15009 : && gsym->ns->proc_name
2745 15009 : && not_in_recursive (sym, gsym->ns)
2746 44745 : && not_entry_self_reference (sym, gsym->ns))
2747 : {
2748 15009 : gfc_symbol *def_sym;
2749 15009 : def_sym = gsym->ns->proc_name;
2750 :
2751 15009 : if (gsym->ns->resolved != -1)
2752 : {
2753 :
2754 : /* Resolve the gsymbol namespace if needed. */
2755 14987 : if (!gsym->ns->resolved)
2756 : {
2757 2793 : gfc_symbol *old_dt_list;
2758 :
2759 : /* Stash away derived types so that the backend_decls
2760 : do not get mixed up. */
2761 2793 : old_dt_list = gfc_derived_types;
2762 2793 : gfc_derived_types = NULL;
2763 :
2764 2793 : gfc_resolve (gsym->ns);
2765 :
2766 : /* Store the new derived types with the global namespace. */
2767 2793 : if (gfc_derived_types)
2768 306 : gsym->ns->derived_types = gfc_derived_types;
2769 :
2770 : /* Restore the derived types of this namespace. */
2771 2793 : gfc_derived_types = old_dt_list;
2772 : }
2773 :
2774 : /* Make sure that translation for the gsymbol occurs before
2775 : the procedure currently being resolved. */
2776 14987 : ns = gfc_global_ns_list;
2777 25460 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2778 : {
2779 17050 : if (ns->sibling == gsym->ns)
2780 : {
2781 6577 : ns->sibling = gsym->ns->sibling;
2782 6577 : gsym->ns->sibling = gfc_global_ns_list;
2783 6577 : gfc_global_ns_list = gsym->ns;
2784 6577 : break;
2785 : }
2786 : }
2787 :
2788 : /* This can happen if a binding name has been specified. */
2789 14987 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2790 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2791 : }
2792 :
2793 : /* Look up the specific entry symbol so that interface checks use
2794 : the entry's own formal argument list, not the entry master's.
2795 : This must run even when resolved == -1 (recursive resolution in
2796 : progress), because def_sym starts as the namespace proc_name
2797 : which is the entry master with the combined formals. */
2798 15009 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2799 : {
2800 979 : gfc_entry_list *entry;
2801 1699 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2802 1699 : if (strcmp (entry->sym->name, sym->name) == 0)
2803 : {
2804 979 : def_sym = entry->sym;
2805 979 : break;
2806 : }
2807 : }
2808 :
2809 15009 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2810 : {
2811 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2812 : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2813 6 : gfc_typename (&def_sym->ts));
2814 28 : goto done;
2815 : }
2816 :
2817 15003 : if (sym->attr.if_source == IFSRC_UNKNOWN
2818 15003 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2819 : {
2820 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2821 : sym->name, &sym->declared_at, reason);
2822 8 : goto done;
2823 : }
2824 :
2825 14995 : bool bad_result_characteristics;
2826 14995 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2827 : reason, sizeof(reason), NULL, NULL,
2828 : &bad_result_characteristics))
2829 : {
2830 : /* Turn errors into warnings with -std=gnu and -std=legacy,
2831 : unless a function returns a wrong type, which can lead
2832 : to all kinds of ICEs and wrong code. */
2833 :
2834 14 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2835 2 : && !bad_result_characteristics)
2836 2 : gfc_errors_to_warnings (true);
2837 :
2838 14 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2839 : sym->name, &sym->declared_at, reason);
2840 14 : sym->error = 1;
2841 14 : gfc_errors_to_warnings (false);
2842 14 : goto done;
2843 : }
2844 : }
2845 :
2846 29736 : done:
2847 :
2848 29736 : if (gsym->type == GSYM_UNKNOWN)
2849 : {
2850 4092 : gsym->type = type;
2851 4092 : gsym->where = *where;
2852 : }
2853 :
2854 29736 : gsym->used = 1;
2855 29736 : }
2856 :
2857 :
2858 : /************* Function resolution *************/
2859 :
2860 : /* Resolve a function call known to be generic.
2861 : Section 14.1.2.4.1. */
2862 :
2863 : static match
2864 28172 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2865 : {
2866 28172 : gfc_symbol *s;
2867 :
2868 28172 : if (sym->attr.generic)
2869 : {
2870 27016 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2871 27016 : if (s != NULL)
2872 : {
2873 20203 : expr->value.function.name = s->name;
2874 20203 : expr->value.function.esym = s;
2875 :
2876 20203 : if (s->ts.type != BT_UNKNOWN)
2877 20186 : expr->ts = s->ts;
2878 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2879 15 : expr->ts = s->result->ts;
2880 :
2881 20203 : if (s->as != NULL)
2882 : {
2883 55 : expr->rank = s->as->rank;
2884 55 : expr->corank = s->as->corank;
2885 : }
2886 20148 : else if (s->result != NULL && s->result->as != NULL)
2887 : {
2888 0 : expr->rank = s->result->as->rank;
2889 0 : expr->corank = s->result->as->corank;
2890 : }
2891 :
2892 20203 : gfc_set_sym_referenced (expr->value.function.esym);
2893 :
2894 20203 : return MATCH_YES;
2895 : }
2896 :
2897 : /* TODO: Need to search for elemental references in generic
2898 : interface. */
2899 : }
2900 :
2901 7969 : if (sym->attr.intrinsic)
2902 1113 : return gfc_intrinsic_func_interface (expr, 0);
2903 :
2904 : return MATCH_NO;
2905 : }
2906 :
2907 :
2908 : static bool
2909 28028 : resolve_generic_f (gfc_expr *expr)
2910 : {
2911 28028 : gfc_symbol *sym;
2912 28028 : match m;
2913 28028 : gfc_interface *intr = NULL;
2914 :
2915 28028 : sym = expr->symtree->n.sym;
2916 :
2917 28172 : for (;;)
2918 : {
2919 28172 : m = resolve_generic_f0 (expr, sym);
2920 28172 : if (m == MATCH_YES)
2921 : return true;
2922 6858 : else if (m == MATCH_ERROR)
2923 : return false;
2924 :
2925 6858 : generic:
2926 6861 : if (!intr)
2927 6829 : for (intr = sym->generic; intr; intr = intr->next)
2928 6745 : if (gfc_fl_struct (intr->sym->attr.flavor))
2929 : break;
2930 :
2931 6861 : if (sym->ns->parent == NULL)
2932 : break;
2933 316 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2934 :
2935 316 : if (sym == NULL)
2936 : break;
2937 147 : if (!generic_sym (sym))
2938 3 : goto generic;
2939 : }
2940 :
2941 : /* Last ditch attempt. See if the reference is to an intrinsic
2942 : that possesses a matching interface. 14.1.2.4 */
2943 6714 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2944 : {
2945 5 : if (gfc_init_expr_flag)
2946 1 : gfc_error ("Function %qs in initialization expression at %L "
2947 : "must be an intrinsic function",
2948 1 : expr->symtree->n.sym->name, &expr->where);
2949 : else
2950 4 : gfc_error ("There is no specific function for the generic %qs "
2951 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2952 : return false;
2953 : }
2954 :
2955 6709 : if (intr)
2956 : {
2957 6674 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2958 : NULL, false))
2959 : return false;
2960 6647 : if (!gfc_use_derived (expr->ts.u.derived))
2961 : return false;
2962 6647 : return resolve_structure_cons (expr, 0);
2963 : }
2964 :
2965 35 : m = gfc_intrinsic_func_interface (expr, 0);
2966 35 : if (m == MATCH_YES)
2967 : return true;
2968 :
2969 3 : if (m == MATCH_NO)
2970 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2971 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2972 : &expr->where);
2973 :
2974 : return false;
2975 : }
2976 :
2977 :
2978 : /* Resolve a function call known to be specific. */
2979 :
2980 : static match
2981 28506 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2982 : {
2983 28506 : match m;
2984 :
2985 28506 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2986 : {
2987 8209 : if (sym->attr.dummy)
2988 : {
2989 282 : sym->attr.proc = PROC_DUMMY;
2990 282 : goto found;
2991 : }
2992 :
2993 7927 : sym->attr.proc = PROC_EXTERNAL;
2994 7927 : goto found;
2995 : }
2996 :
2997 20297 : if (sym->attr.proc == PROC_MODULE
2998 11280 : || sym->attr.proc == PROC_ST_FUNCTION
2999 10990 : || sym->attr.proc == PROC_INTERNAL)
3000 19559 : goto found;
3001 :
3002 738 : if (sym->attr.intrinsic)
3003 : {
3004 731 : m = gfc_intrinsic_func_interface (expr, 1);
3005 731 : if (m == MATCH_YES)
3006 : return MATCH_YES;
3007 0 : if (m == MATCH_NO)
3008 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
3009 : "with an intrinsic", sym->name, &expr->where);
3010 :
3011 : return MATCH_ERROR;
3012 : }
3013 :
3014 : return MATCH_NO;
3015 :
3016 27768 : found:
3017 27768 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3018 :
3019 27768 : if (sym->result)
3020 27768 : expr->ts = sym->result->ts;
3021 : else
3022 0 : expr->ts = sym->ts;
3023 27768 : expr->value.function.name = sym->name;
3024 27768 : expr->value.function.esym = sym;
3025 : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
3026 : error(s). */
3027 27768 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
3028 : return MATCH_ERROR;
3029 27767 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
3030 : {
3031 322 : expr->rank = CLASS_DATA (sym)->as->rank;
3032 322 : expr->corank = CLASS_DATA (sym)->as->corank;
3033 : }
3034 27445 : else if (sym->as != NULL)
3035 : {
3036 2335 : expr->rank = sym->as->rank;
3037 2335 : expr->corank = sym->as->corank;
3038 : }
3039 :
3040 : return MATCH_YES;
3041 : }
3042 :
3043 :
3044 : static bool
3045 28499 : resolve_specific_f (gfc_expr *expr)
3046 : {
3047 28499 : gfc_symbol *sym;
3048 28499 : match m;
3049 :
3050 28499 : sym = expr->symtree->n.sym;
3051 :
3052 28506 : for (;;)
3053 : {
3054 28506 : m = resolve_specific_f0 (sym, expr);
3055 28506 : if (m == MATCH_YES)
3056 : return true;
3057 8 : if (m == MATCH_ERROR)
3058 : return false;
3059 :
3060 7 : if (sym->ns->parent == NULL)
3061 : break;
3062 :
3063 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3064 :
3065 7 : if (sym == NULL)
3066 : break;
3067 : }
3068 :
3069 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3070 0 : expr->symtree->n.sym->name, &expr->where);
3071 :
3072 0 : return true;
3073 : }
3074 :
3075 : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3076 : candidates in CANDIDATES_LEN. */
3077 :
3078 : static void
3079 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3080 : char **&candidates,
3081 : size_t &candidates_len)
3082 : {
3083 388 : gfc_symtree *p;
3084 :
3085 388 : if (sym == NULL)
3086 : return;
3087 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3088 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3089 51 : vec_push (candidates, candidates_len, sym->name);
3090 :
3091 388 : p = sym->left;
3092 388 : if (p)
3093 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3094 :
3095 388 : p = sym->right;
3096 388 : if (p)
3097 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3098 : }
3099 :
3100 :
3101 : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3102 :
3103 : const char*
3104 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3105 : {
3106 57 : char **candidates = NULL;
3107 57 : size_t candidates_len = 0;
3108 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3109 57 : return gfc_closest_fuzzy_match (fn, candidates);
3110 : }
3111 :
3112 :
3113 : /* Resolve a procedure call not known to be generic nor specific. */
3114 :
3115 : static bool
3116 280240 : resolve_unknown_f (gfc_expr *expr)
3117 : {
3118 280240 : gfc_symbol *sym;
3119 280240 : gfc_typespec *ts;
3120 :
3121 280240 : sym = expr->symtree->n.sym;
3122 :
3123 280240 : if (sym->attr.dummy)
3124 : {
3125 293 : sym->attr.proc = PROC_DUMMY;
3126 293 : expr->value.function.name = sym->name;
3127 293 : goto set_type;
3128 : }
3129 :
3130 : /* See if we have an intrinsic function reference. */
3131 :
3132 279947 : if (gfc_is_intrinsic (sym, 0, expr->where))
3133 : {
3134 277685 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3135 : return true;
3136 819 : return false;
3137 : }
3138 :
3139 : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3140 : /* Intrinsics were handled above, only non-intrinsics left here. */
3141 2262 : if (sym->attr.flavor == FL_PROCEDURE
3142 2259 : && sym->attr.implicit_type
3143 376 : && sym->ns
3144 376 : && sym->ns->has_implicit_none_export)
3145 : {
3146 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3147 : "for symbol %qs at %L", sym->name, &sym->declared_at);
3148 3 : sym->error = 1;
3149 3 : return false;
3150 : }
3151 :
3152 : /* The reference is to an external name. */
3153 :
3154 2259 : sym->attr.proc = PROC_EXTERNAL;
3155 2259 : expr->value.function.name = sym->name;
3156 2259 : expr->value.function.esym = expr->symtree->n.sym;
3157 :
3158 2259 : if (sym->as != NULL)
3159 : {
3160 1 : expr->rank = sym->as->rank;
3161 1 : expr->corank = sym->as->corank;
3162 : }
3163 :
3164 : /* Type of the expression is either the type of the symbol or the
3165 : default type of the symbol. */
3166 :
3167 2258 : set_type:
3168 2552 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3169 :
3170 2552 : if (sym->ts.type != BT_UNKNOWN)
3171 2501 : expr->ts = sym->ts;
3172 : else
3173 : {
3174 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3175 :
3176 51 : if (ts->type == BT_UNKNOWN)
3177 : {
3178 41 : const char *guessed
3179 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3180 41 : if (guessed)
3181 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3182 : "; did you mean %qs?",
3183 : sym->name, &expr->where, guessed);
3184 : else
3185 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3186 : sym->name, &expr->where);
3187 : return false;
3188 : }
3189 : else
3190 10 : expr->ts = *ts;
3191 : }
3192 :
3193 : return true;
3194 : }
3195 :
3196 :
3197 : /* Return true, if the symbol is an external procedure. */
3198 : static bool
3199 865345 : is_external_proc (gfc_symbol *sym)
3200 : {
3201 863622 : if (!sym->attr.dummy && !sym->attr.contained
3202 753626 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3203 164770 : && sym->attr.proc != PROC_ST_FUNCTION
3204 164175 : && !sym->attr.proc_pointer
3205 162969 : && !sym->attr.use_assoc
3206 924848 : && sym->name)
3207 59503 : return true;
3208 :
3209 : return false;
3210 : }
3211 :
3212 :
3213 : /* Figure out if a function reference is pure or not. Also set the name
3214 : of the function for a potential error message. Return nonzero if the
3215 : function is PURE, zero if not. */
3216 : static bool
3217 : pure_stmt_function (gfc_expr *, gfc_symbol *);
3218 :
3219 : bool
3220 260012 : gfc_pure_function (gfc_expr *e, const char **name)
3221 : {
3222 260012 : bool pure;
3223 260012 : gfc_component *comp;
3224 :
3225 260012 : *name = NULL;
3226 :
3227 260012 : if (e->symtree != NULL
3228 259656 : && e->symtree->n.sym != NULL
3229 259656 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3230 305 : return pure_stmt_function (e, e->symtree->n.sym);
3231 :
3232 259707 : comp = gfc_get_proc_ptr_comp (e);
3233 259707 : if (comp)
3234 : {
3235 485 : pure = gfc_pure (comp->ts.interface);
3236 485 : *name = comp->name;
3237 : }
3238 259222 : else if (e->value.function.esym)
3239 : {
3240 53570 : pure = gfc_pure (e->value.function.esym);
3241 53570 : *name = e->value.function.esym->name;
3242 : }
3243 205652 : else if (e->value.function.isym)
3244 : {
3245 409140 : pure = e->value.function.isym->pure
3246 204570 : || e->value.function.isym->elemental;
3247 204570 : *name = e->value.function.isym->name;
3248 : }
3249 1082 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3250 : {
3251 : /* The function has been resolved, but esym is not yet set.
3252 : This can happen with functions as dummy argument. */
3253 291 : pure = e->symtree->n.sym->attr.pure;
3254 291 : *name = e->symtree->n.sym->name;
3255 : }
3256 : else
3257 : {
3258 : /* Implicit functions are not pure. */
3259 791 : pure = 0;
3260 791 : *name = e->value.function.name;
3261 : }
3262 :
3263 : return pure;
3264 : }
3265 :
3266 :
3267 : /* Check if the expression is a reference to an implicitly pure function. */
3268 :
3269 : bool
3270 38866 : gfc_implicit_pure_function (gfc_expr *e)
3271 : {
3272 38866 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3273 38866 : if (comp)
3274 463 : return gfc_implicit_pure (comp->ts.interface);
3275 38403 : else if (e->value.function.esym)
3276 32993 : return gfc_implicit_pure (e->value.function.esym);
3277 : else
3278 : return 0;
3279 : }
3280 :
3281 :
3282 : static bool
3283 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3284 : int *f ATTRIBUTE_UNUSED)
3285 : {
3286 981 : const char *name;
3287 :
3288 : /* Don't bother recursing into other statement functions
3289 : since they will be checked individually for purity. */
3290 981 : if (e->expr_type != EXPR_FUNCTION
3291 343 : || !e->symtree
3292 343 : || e->symtree->n.sym == sym
3293 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3294 : return false;
3295 :
3296 19 : return !gfc_pure_function (e, &name);
3297 : }
3298 :
3299 :
3300 : static bool
3301 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3302 : {
3303 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3304 : }
3305 :
3306 :
3307 : /* Check if an impure function is allowed in the current context. */
3308 :
3309 247987 : static bool check_pure_function (gfc_expr *e)
3310 : {
3311 247987 : const char *name = NULL;
3312 247987 : code_stack *stack;
3313 247987 : bool saw_block = false;
3314 :
3315 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3316 : gfc_do_concurrent_flag = 0 when the check for an impure function
3317 : occurs. Check the stack to see if the source code has a nested
3318 : BLOCK construct. */
3319 :
3320 574070 : for (stack = cs_base; stack; stack = stack->prev)
3321 : {
3322 326085 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3323 : {
3324 7693 : saw_block = true;
3325 7693 : continue;
3326 : }
3327 :
3328 5439 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3329 : {
3330 16 : bool is_pure;
3331 326083 : is_pure = (e->value.function.isym
3332 15 : && (e->value.function.isym->pure
3333 1 : || e->value.function.isym->elemental))
3334 17 : || (e->value.function.esym
3335 1 : && (e->value.function.esym->attr.pure
3336 1 : || e->value.function.esym->attr.elemental));
3337 2 : if (!is_pure)
3338 : {
3339 2 : gfc_error ("Reference to impure function at %L inside a "
3340 : "DO CONCURRENT", &e->where);
3341 2 : return false;
3342 : }
3343 : }
3344 : }
3345 :
3346 247985 : if (!gfc_pure_function (e, &name) && name)
3347 : {
3348 37569 : if (forall_flag)
3349 : {
3350 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3351 : "FORALL %s", name, &e->where,
3352 : forall_flag == 2 ? "mask" : "block");
3353 4 : return false;
3354 : }
3355 37565 : else if (gfc_do_concurrent_flag)
3356 : {
3357 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3358 : "DO CONCURRENT %s", name, &e->where,
3359 : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3360 2 : return false;
3361 : }
3362 37563 : else if (gfc_pure (NULL))
3363 : {
3364 5 : gfc_error ("Reference to impure function %qs at %L "
3365 : "within a PURE procedure", name, &e->where);
3366 5 : return false;
3367 : }
3368 37558 : if (!gfc_implicit_pure_function (e))
3369 30887 : gfc_unset_implicit_pure (NULL);
3370 : }
3371 : return true;
3372 : }
3373 :
3374 :
3375 : /* Update current procedure's array_outer_dependency flag, considering
3376 : a call to procedure SYM. */
3377 :
3378 : static void
3379 134880 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3380 : {
3381 : /* Check to see if this is a sibling function that has not yet
3382 : been resolved. */
3383 134880 : gfc_namespace *sibling = gfc_current_ns->sibling;
3384 253283 : for (; sibling; sibling = sibling->sibling)
3385 : {
3386 125661 : if (sibling->proc_name == sym)
3387 : {
3388 7258 : gfc_resolve (sibling);
3389 7258 : break;
3390 : }
3391 : }
3392 :
3393 : /* If SYM has references to outer arrays, so has the procedure calling
3394 : SYM. If SYM is a procedure pointer, we can assume the worst. */
3395 134880 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3396 68910 : && gfc_current_ns->proc_name)
3397 68866 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3398 134880 : }
3399 :
3400 :
3401 : /* Resolve a function call, which means resolving the arguments, then figuring
3402 : out which entity the name refers to. */
3403 :
3404 : static bool
3405 350181 : resolve_function (gfc_expr *expr)
3406 : {
3407 350181 : gfc_actual_arglist *arg;
3408 350181 : gfc_symbol *sym;
3409 350181 : bool t;
3410 350181 : int temp;
3411 350181 : procedure_type p = PROC_INTRINSIC;
3412 350181 : bool no_formal_args;
3413 :
3414 350181 : sym = NULL;
3415 350181 : if (expr->symtree)
3416 349825 : sym = expr->symtree->n.sym;
3417 :
3418 : /* If this is a procedure pointer component, it has already been resolved. */
3419 350181 : if (gfc_is_proc_ptr_comp (expr))
3420 : return true;
3421 :
3422 : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3423 : another caf_get. */
3424 349765 : if (sym && sym->attr.intrinsic
3425 8763 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3426 8763 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3427 : return true;
3428 :
3429 349765 : if (expr->ref)
3430 : {
3431 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3432 : &expr->where);
3433 1 : return false;
3434 : }
3435 :
3436 349408 : if (sym && sym->attr.intrinsic
3437 358527 : && !gfc_resolve_intrinsic (sym, &expr->where))
3438 : return false;
3439 :
3440 349764 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3441 : {
3442 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3443 4 : return false;
3444 : }
3445 :
3446 : /* If this is a deferred TBP with an abstract interface (which may
3447 : of course be referenced), expr->value.function.esym will be set. */
3448 349404 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3449 : {
3450 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3451 : sym->name, &expr->where);
3452 1 : return false;
3453 : }
3454 :
3455 : /* If this is a deferred TBP with an abstract interface, its result
3456 : cannot be an assumed length character (F2003: C418). */
3457 349403 : if (sym && sym->attr.abstract && sym->attr.function
3458 192 : && sym->result->ts.u.cl
3459 158 : && sym->result->ts.u.cl->length == NULL
3460 2 : && !sym->result->ts.deferred)
3461 : {
3462 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3463 : "character length result (F2008: C418)", sym->name,
3464 : &sym->declared_at);
3465 1 : return false;
3466 : }
3467 :
3468 : /* Switch off assumed size checking and do this again for certain kinds
3469 : of procedure, once the procedure itself is resolved. */
3470 349758 : need_full_assumed_size++;
3471 :
3472 349758 : if (expr->symtree && expr->symtree->n.sym)
3473 349402 : p = expr->symtree->n.sym->attr.proc;
3474 :
3475 349758 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3476 1187 : inquiry_argument = true;
3477 349402 : no_formal_args = sym && is_external_proc (sym)
3478 363784 : && gfc_sym_get_dummy_args (sym) == NULL;
3479 :
3480 349758 : if (!resolve_actual_arglist (expr->value.function.actual,
3481 : p, no_formal_args))
3482 : {
3483 67 : inquiry_argument = false;
3484 67 : return false;
3485 : }
3486 :
3487 349691 : inquiry_argument = false;
3488 :
3489 : /* Resume assumed_size checking. */
3490 349691 : need_full_assumed_size--;
3491 :
3492 : /* If the procedure is external, check for usage. */
3493 349691 : if (sym && is_external_proc (sym))
3494 14006 : resolve_global_procedure (sym, &expr->where, 0);
3495 :
3496 349691 : if (sym && sym->ts.type == BT_CHARACTER
3497 3365 : && sym->ts.u.cl
3498 3271 : && sym->ts.u.cl->length == NULL
3499 683 : && !sym->attr.dummy
3500 676 : && !sym->ts.deferred
3501 2 : && expr->value.function.esym == NULL
3502 2 : && !sym->attr.contained)
3503 : {
3504 : /* Internal procedures are taken care of in resolve_contained_fntype. */
3505 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3506 : "be used at %L since it is not a dummy argument",
3507 : sym->name, &expr->where);
3508 1 : return false;
3509 : }
3510 :
3511 : /* Add and check formal interface when -fc-prototypes-external is in
3512 : force, see comment in resolve_call(). */
3513 :
3514 349690 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3515 18 : && sym->attr.external)
3516 : {
3517 18 : if (sym->formal)
3518 : {
3519 6 : bool conflict;
3520 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3521 : sym->formal, 0, 0, 0, NULL);
3522 6 : if (conflict)
3523 : {
3524 6 : sym->ext_dummy_arglist_mismatch = 1;
3525 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3526 : "Different argument lists in external dummy "
3527 : "function %s at %L and %L", sym->name,
3528 : &expr->where, &sym->other_loc);
3529 : }
3530 : }
3531 12 : else if (!sym->formal_resolved)
3532 : {
3533 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3534 6 : sym->other_loc = expr->where;
3535 : }
3536 : }
3537 : /* See if function is already resolved. */
3538 :
3539 349690 : if (expr->value.function.name != NULL
3540 337615 : || expr->value.function.isym != NULL)
3541 : {
3542 12923 : if (expr->ts.type == BT_UNKNOWN)
3543 3 : expr->ts = sym->ts;
3544 : t = true;
3545 : }
3546 : else
3547 : {
3548 : /* Apply the rules of section 14.1.2. */
3549 :
3550 336767 : switch (procedure_kind (sym))
3551 : {
3552 28028 : case PTYPE_GENERIC:
3553 28028 : t = resolve_generic_f (expr);
3554 28028 : break;
3555 :
3556 28499 : case PTYPE_SPECIFIC:
3557 28499 : t = resolve_specific_f (expr);
3558 28499 : break;
3559 :
3560 280240 : case PTYPE_UNKNOWN:
3561 280240 : t = resolve_unknown_f (expr);
3562 280240 : break;
3563 :
3564 : default:
3565 : gfc_internal_error ("resolve_function(): bad function type");
3566 : }
3567 : }
3568 :
3569 : /* If the expression is still a function (it might have simplified),
3570 : then we check to see if we are calling an elemental function. */
3571 :
3572 349690 : if (expr->expr_type != EXPR_FUNCTION)
3573 : return t;
3574 :
3575 : /* Walk the argument list looking for invalid BOZ. */
3576 750947 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3577 503422 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3578 : {
3579 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3580 : "actual argument in a function reference",
3581 : &arg->expr->where);
3582 5 : return false;
3583 : }
3584 :
3585 247525 : temp = need_full_assumed_size;
3586 247525 : need_full_assumed_size = 0;
3587 :
3588 247525 : if (!resolve_elemental_actual (expr, NULL))
3589 : return false;
3590 :
3591 247522 : if (omp_workshare_flag
3592 32 : && expr->value.function.esym
3593 247527 : && ! gfc_elemental (expr->value.function.esym))
3594 : {
3595 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3596 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3597 : &expr->where);
3598 4 : t = false;
3599 : }
3600 :
3601 : #define GENERIC_ID expr->value.function.isym->id
3602 247518 : else if (expr->value.function.actual != NULL
3603 239296 : && expr->value.function.isym != NULL
3604 193709 : && GENERIC_ID != GFC_ISYM_LBOUND
3605 : && GENERIC_ID != GFC_ISYM_LCOBOUND
3606 : && GENERIC_ID != GFC_ISYM_UCOBOUND
3607 : && GENERIC_ID != GFC_ISYM_LEN
3608 : && GENERIC_ID != GFC_ISYM_LOC
3609 : && GENERIC_ID != GFC_ISYM_C_LOC
3610 : && GENERIC_ID != GFC_ISYM_PRESENT)
3611 : {
3612 : /* Array intrinsics must also have the last upper bound of an
3613 : assumed size array argument. UBOUND and SIZE have to be
3614 : excluded from the check if the second argument is anything
3615 : than a constant. */
3616 :
3617 545641 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3618 : {
3619 378216 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3620 46427 : && arg == expr->value.function.actual
3621 17103 : && arg->next != NULL && arg->next->expr)
3622 : {
3623 8411 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3624 : break;
3625 :
3626 8187 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3627 : break;
3628 :
3629 8187 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3630 8187 : < arg->expr->rank)
3631 : break;
3632 : }
3633 :
3634 375777 : if (arg->expr != NULL
3635 249494 : && arg->expr->rank > 0
3636 496303 : && resolve_assumed_size_actual (arg->expr))
3637 : return false;
3638 : }
3639 : }
3640 : #undef GENERIC_ID
3641 :
3642 247519 : need_full_assumed_size = temp;
3643 :
3644 247519 : if (!check_pure_function(expr))
3645 12 : t = false;
3646 :
3647 : /* Functions without the RECURSIVE attribution are not allowed to
3648 : * call themselves. */
3649 247519 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3650 : {
3651 52295 : gfc_symbol *esym;
3652 52295 : esym = expr->value.function.esym;
3653 :
3654 52295 : if (is_illegal_recursion (esym, gfc_current_ns))
3655 : {
3656 5 : if (esym->attr.entry && esym->ns->entries)
3657 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3658 : " function %qs is not RECURSIVE",
3659 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3660 : else
3661 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3662 : " is not RECURSIVE", esym->name, &expr->where);
3663 :
3664 : t = false;
3665 : }
3666 : }
3667 :
3668 : /* Character lengths of use associated functions may contains references to
3669 : symbols not referenced from the current program unit otherwise. Make sure
3670 : those symbols are marked as referenced. */
3671 :
3672 247519 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3673 3469 : && expr->value.function.esym->attr.use_assoc)
3674 : {
3675 1256 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3676 : }
3677 :
3678 : /* Make sure that the expression has a typespec that works. */
3679 247519 : if (expr->ts.type == BT_UNKNOWN)
3680 : {
3681 930 : if (expr->symtree->n.sym->result
3682 921 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3683 561 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3684 561 : expr->ts = expr->symtree->n.sym->result->ts;
3685 : }
3686 :
3687 : /* These derived types with an incomplete namespace, arising from use
3688 : association, cause gfc_get_derived_vtab to segfault. If the function
3689 : namespace does not suffice, something is badly wrong. */
3690 247519 : if (expr->ts.type == BT_DERIVED
3691 9640 : && !expr->ts.u.derived->ns->proc_name)
3692 : {
3693 3 : gfc_symbol *der;
3694 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3695 3 : if (der)
3696 : {
3697 3 : expr->ts.u.derived->refs--;
3698 3 : expr->ts.u.derived = der;
3699 3 : der->refs++;
3700 : }
3701 : else
3702 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3703 : }
3704 :
3705 247519 : if (!expr->ref && !expr->value.function.isym)
3706 : {
3707 53689 : if (expr->value.function.esym)
3708 52607 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3709 : else
3710 1082 : update_current_proc_array_outer_dependency (sym);
3711 : }
3712 193830 : else if (expr->ref)
3713 : /* typebound procedure: Assume the worst. */
3714 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3715 :
3716 247519 : if (expr->value.function.esym
3717 52607 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3718 26 : gfc_warning (OPT_Wdeprecated_declarations,
3719 : "Using function %qs at %L is deprecated",
3720 : sym->name, &expr->where);
3721 :
3722 : /* Check an external function supplied as a dummy argument has an external
3723 : attribute when a program unit uses 'implicit none (external)'. */
3724 247519 : if (expr->expr_type == EXPR_FUNCTION
3725 247519 : && expr->symtree
3726 247163 : && expr->symtree->n.sym->attr.dummy
3727 574 : && expr->symtree->n.sym->ns->has_implicit_none_export
3728 247520 : && !gfc_is_intrinsic(expr->symtree->n.sym, 0, expr->where))
3729 : {
3730 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
3731 : sym->name, &expr->where);
3732 1 : return false;
3733 : }
3734 :
3735 : return t;
3736 : }
3737 :
3738 :
3739 : /************* Subroutine resolution *************/
3740 :
3741 : static bool
3742 78636 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3743 : {
3744 78636 : code_stack *stack;
3745 78636 : bool saw_block = false;
3746 :
3747 78636 : if (gfc_pure (sym))
3748 : return true;
3749 :
3750 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3751 : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3752 : occurs. Walk up the stack to see if the source code has a nested
3753 : construct. */
3754 :
3755 162197 : for (stack = cs_base; stack; stack = stack->prev)
3756 : {
3757 89218 : if (stack->current->op == EXEC_BLOCK)
3758 : {
3759 1930 : saw_block = true;
3760 1930 : continue;
3761 : }
3762 :
3763 87288 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3764 : {
3765 :
3766 2 : bool is_pure = true;
3767 89218 : is_pure = sym->attr.pure || sym->attr.elemental;
3768 :
3769 2 : if (!is_pure)
3770 : {
3771 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3772 : "is not PURE", loc);
3773 2 : return false;
3774 : }
3775 : }
3776 : }
3777 :
3778 72979 : if (forall_flag)
3779 : {
3780 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3781 : name, loc);
3782 0 : return false;
3783 : }
3784 72979 : else if (gfc_do_concurrent_flag)
3785 : {
3786 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3787 : "PURE", name, loc);
3788 6 : return false;
3789 : }
3790 72973 : else if (gfc_pure (NULL))
3791 : {
3792 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3793 4 : return false;
3794 : }
3795 :
3796 72969 : gfc_unset_implicit_pure (NULL);
3797 72969 : return true;
3798 : }
3799 :
3800 :
3801 : static match
3802 2883 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3803 : {
3804 2883 : gfc_symbol *s;
3805 :
3806 2883 : if (sym->attr.generic)
3807 : {
3808 2882 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3809 2882 : if (s != NULL)
3810 : {
3811 2873 : c->resolved_sym = s;
3812 2873 : if (!pure_subroutine (s, s->name, &c->loc))
3813 : return MATCH_ERROR;
3814 2873 : return MATCH_YES;
3815 : }
3816 :
3817 : /* TODO: Need to search for elemental references in generic interface. */
3818 : }
3819 :
3820 10 : if (sym->attr.intrinsic)
3821 1 : return gfc_intrinsic_sub_interface (c, 0);
3822 :
3823 : return MATCH_NO;
3824 : }
3825 :
3826 :
3827 : static bool
3828 2881 : resolve_generic_s (gfc_code *c)
3829 : {
3830 2881 : gfc_symbol *sym;
3831 2881 : match m;
3832 :
3833 2881 : sym = c->symtree->n.sym;
3834 :
3835 2883 : for (;;)
3836 : {
3837 2883 : m = resolve_generic_s0 (c, sym);
3838 2883 : if (m == MATCH_YES)
3839 : return true;
3840 9 : else if (m == MATCH_ERROR)
3841 : return false;
3842 :
3843 9 : generic:
3844 9 : if (sym->ns->parent == NULL)
3845 : break;
3846 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3847 :
3848 3 : if (sym == NULL)
3849 : break;
3850 2 : if (!generic_sym (sym))
3851 0 : goto generic;
3852 : }
3853 :
3854 : /* Last ditch attempt. See if the reference is to an intrinsic
3855 : that possesses a matching interface. 14.1.2.4 */
3856 7 : sym = c->symtree->n.sym;
3857 :
3858 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3859 : {
3860 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3861 : sym->name, &c->loc);
3862 4 : return false;
3863 : }
3864 :
3865 3 : m = gfc_intrinsic_sub_interface (c, 0);
3866 3 : if (m == MATCH_YES)
3867 : return true;
3868 1 : if (m == MATCH_NO)
3869 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3870 : "intrinsic subroutine interface", sym->name, &c->loc);
3871 :
3872 : return false;
3873 : }
3874 :
3875 :
3876 : /* Resolve a subroutine call known to be specific. */
3877 :
3878 : static match
3879 64010 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3880 : {
3881 64010 : match m;
3882 :
3883 64010 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3884 : {
3885 5723 : if (sym->attr.dummy)
3886 : {
3887 263 : sym->attr.proc = PROC_DUMMY;
3888 263 : goto found;
3889 : }
3890 :
3891 5460 : sym->attr.proc = PROC_EXTERNAL;
3892 5460 : goto found;
3893 : }
3894 :
3895 58287 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3896 58281 : goto found;
3897 :
3898 6 : if (sym->attr.intrinsic)
3899 : {
3900 0 : m = gfc_intrinsic_sub_interface (c, 1);
3901 0 : if (m == MATCH_YES)
3902 : return MATCH_YES;
3903 0 : if (m == MATCH_NO)
3904 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3905 : "with an intrinsic", sym->name, &c->loc);
3906 :
3907 : return MATCH_ERROR;
3908 : }
3909 :
3910 : return MATCH_NO;
3911 :
3912 64004 : found:
3913 64004 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3914 :
3915 64004 : c->resolved_sym = sym;
3916 64004 : if (!pure_subroutine (sym, sym->name, &c->loc))
3917 7 : return MATCH_ERROR;
3918 :
3919 : return MATCH_YES;
3920 : }
3921 :
3922 :
3923 : static bool
3924 64004 : resolve_specific_s (gfc_code *c)
3925 : {
3926 64004 : gfc_symbol *sym;
3927 64004 : match m;
3928 :
3929 64004 : sym = c->symtree->n.sym;
3930 :
3931 64010 : for (;;)
3932 : {
3933 64010 : m = resolve_specific_s0 (c, sym);
3934 64010 : if (m == MATCH_YES)
3935 : return true;
3936 13 : if (m == MATCH_ERROR)
3937 : return false;
3938 :
3939 6 : if (sym->ns->parent == NULL)
3940 : break;
3941 :
3942 6 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3943 :
3944 6 : if (sym == NULL)
3945 : break;
3946 : }
3947 :
3948 0 : sym = c->symtree->n.sym;
3949 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3950 : sym->name, &c->loc);
3951 :
3952 0 : return false;
3953 : }
3954 :
3955 :
3956 : /* Resolve a subroutine call not known to be generic nor specific. */
3957 :
3958 : static bool
3959 15963 : resolve_unknown_s (gfc_code *c)
3960 : {
3961 15963 : gfc_symbol *sym;
3962 :
3963 15963 : sym = c->symtree->n.sym;
3964 :
3965 15963 : if (sym->attr.dummy)
3966 : {
3967 26 : sym->attr.proc = PROC_DUMMY;
3968 26 : goto found;
3969 : }
3970 :
3971 : /* See if we have an intrinsic function reference. */
3972 :
3973 15937 : if (gfc_is_intrinsic (sym, 1, c->loc))
3974 : {
3975 4327 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3976 : return true;
3977 319 : return false;
3978 : }
3979 :
3980 : /* The reference is to an external name. */
3981 :
3982 11610 : found:
3983 11636 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3984 :
3985 11636 : c->resolved_sym = sym;
3986 :
3987 11636 : return pure_subroutine (sym, sym->name, &c->loc);
3988 : }
3989 :
3990 :
3991 :
3992 : static bool
3993 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3994 : gfc_code *c, gfc_namespace *ns)
3995 : {
3996 805 : locus *here;
3997 :
3998 : /* If the type has been imported then its vtype functions are OK. */
3999 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
4000 : return true;
4001 :
4002 : if (e)
4003 791 : here = &e->where;
4004 : else
4005 7 : here = &c->loc;
4006 :
4007 798 : if (s && !s->import_only)
4008 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
4009 :
4010 798 : if (ns->import_state == IMPORT_ONLY
4011 75 : && sym->ns != ns
4012 58 : && (!s || !s->import_only))
4013 : {
4014 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
4015 : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
4016 21 : return false;
4017 : }
4018 777 : else if (ns->import_state == IMPORT_NONE
4019 27 : && sym->ns != ns)
4020 : {
4021 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
4022 : "has IMPORT, NONE", sym->name, here);
4023 12 : return false;
4024 : }
4025 : return true;
4026 : }
4027 :
4028 :
4029 : static bool
4030 7354 : check_import_status (gfc_expr *e)
4031 : {
4032 7354 : gfc_symtree *st;
4033 7354 : gfc_ref *ref;
4034 7354 : gfc_symbol *sym, *der;
4035 7354 : gfc_namespace *ns = gfc_current_ns;
4036 :
4037 7354 : switch (e->expr_type)
4038 : {
4039 727 : case EXPR_VARIABLE:
4040 727 : case EXPR_FUNCTION:
4041 727 : case EXPR_SUBSTRING:
4042 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
4043 :
4044 : /* Check the symbol itself. */
4045 727 : if (sym
4046 727 : && !(ns->proc_name
4047 : && (sym == ns->proc_name))
4048 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4049 : return false;
4050 :
4051 : /* Check the declared derived type. */
4052 717 : if (sym->ts.type == BT_DERIVED)
4053 : {
4054 16 : der = sym->ts.u.derived;
4055 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4056 :
4057 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4058 : return false;
4059 : }
4060 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4061 : {
4062 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4063 : : sym->ts.u.derived;
4064 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4065 :
4066 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4067 : return false;
4068 : }
4069 :
4070 : /* Check the declared derived types of component references. */
4071 724 : for (ref = e->ref; ref; ref = ref->next)
4072 20 : if (ref->type == REF_COMPONENT)
4073 : {
4074 19 : gfc_component *c = ref->u.c.component;
4075 19 : if (c->ts.type == BT_DERIVED)
4076 : {
4077 7 : der = c->ts.u.derived;
4078 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4079 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4080 : return false;
4081 : }
4082 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4083 : {
4084 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4085 : : c->ts.u.derived;
4086 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4087 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4088 : return false;
4089 : }
4090 : }
4091 :
4092 : break;
4093 :
4094 8 : case EXPR_ARRAY:
4095 8 : case EXPR_STRUCTURE:
4096 : /* Check the declared derived type. */
4097 8 : if (e->ts.type == BT_DERIVED)
4098 : {
4099 8 : der = e->ts.u.derived;
4100 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4101 :
4102 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4103 : return false;
4104 : }
4105 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4106 : {
4107 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4108 : : e->ts.u.derived;
4109 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4110 :
4111 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4112 : return false;
4113 : }
4114 :
4115 : break;
4116 :
4117 : /* Either not applicable or resolved away
4118 : case EXPR_OP:
4119 : case EXPR_UNKNOWN:
4120 : case EXPR_CONSTANT:
4121 : case EXPR_NULL:
4122 : case EXPR_COMPCALL:
4123 : case EXPR_PPC: */
4124 :
4125 : default:
4126 : break;
4127 : }
4128 :
4129 : return true;
4130 : }
4131 :
4132 :
4133 : /* If an elemental call has an INTENT_IN argument that has a dependency on an
4134 : argument which is not INTENT_IN and requires a temporary, build a temporary
4135 : for the INTENT_IN actual argument as well. */
4136 :
4137 : static void
4138 : add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **);
4139 :
4140 : static void
4141 5257 : resolve_elemental_dependencies (gfc_code *c)
4142 : {
4143 5257 : gfc_actual_arglist *arg1 = c->ext.actual;
4144 5257 : gfc_actual_arglist *arg2 = NULL;
4145 5257 : gfc_formal_arglist *formal1 = c->resolved_sym->formal;
4146 5257 : gfc_formal_arglist *formal2 = NULL;
4147 5257 : gfc_expr *expr1;
4148 5257 : gfc_expr **expr2;
4149 :
4150 16645 : for (; arg1 && formal1; arg1 = arg1->next, formal1 = formal1->next)
4151 : {
4152 11388 : if (formal1->sym
4153 11388 : && (formal1->sym->attr.intent == INTENT_IN
4154 3536 : || formal1->sym->attr.value))
4155 8110 : continue;
4156 :
4157 3278 : if (!arg1->expr || arg1->expr->expr_type != EXPR_VARIABLE)
4158 0 : continue;
4159 :
4160 3278 : arg2 = c->ext.actual;
4161 3278 : formal2 = c->resolved_sym->formal;
4162 10696 : for (; arg2 && formal2; arg2 = arg2->next, formal2 = formal2->next)
4163 : {
4164 7418 : if (arg2 == arg1 || !arg2->expr
4165 4128 : || !(formal2->sym && formal2->sym->attr.intent == INTENT_IN))
4166 3304 : continue;
4167 :
4168 4114 : expr1 = arg1->expr;
4169 4114 : expr2 = &arg2->expr;
4170 :
4171 : /* If the arg1 has something horrible like a vector index and
4172 : there is a dependency between arg1 and arg2, build a
4173 : temporary from arg2, assign the arg2 to it and use the
4174 : temporary in the call expression. */
4175 2009 : if (expr1->rank && gfc_ref_needs_temporary_p (expr1->ref)
4176 4234 : && gfc_check_dependency (expr1, *expr2, false))
4177 36 : add_temp_assign_before_call (c, gfc_current_ns, expr2);
4178 : }
4179 : }
4180 5257 : }
4181 :
4182 : /* Resolve a subroutine call. Although it was tempting to use the same code
4183 : for functions, subroutines and functions are stored differently and this
4184 : makes things awkward. */
4185 :
4186 :
4187 : static bool
4188 82993 : resolve_call (gfc_code *c)
4189 : {
4190 82993 : bool t;
4191 82993 : procedure_type ptype = PROC_INTRINSIC;
4192 82993 : gfc_symbol *csym, *sym;
4193 82993 : bool no_formal_args;
4194 :
4195 82993 : csym = c->symtree ? c->symtree->n.sym : NULL;
4196 :
4197 82993 : if (csym && csym->ts.type != BT_UNKNOWN)
4198 : {
4199 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4200 : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4201 4 : return false;
4202 : }
4203 :
4204 82989 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4205 : {
4206 17617 : gfc_symtree *st;
4207 17617 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4208 17617 : sym = st ? st->n.sym : NULL;
4209 17617 : if (sym && csym != sym
4210 3 : && sym->ns == gfc_current_ns
4211 3 : && sym->attr.flavor == FL_PROCEDURE
4212 3 : && sym->attr.contained)
4213 : {
4214 3 : sym->refs++;
4215 3 : if (csym->attr.generic)
4216 2 : c->symtree->n.sym = sym;
4217 : else
4218 1 : c->symtree = st;
4219 3 : csym = c->symtree->n.sym;
4220 : }
4221 : }
4222 :
4223 : /* If this ia a deferred TBP, c->expr1 will be set. */
4224 82989 : if (!c->expr1 && csym)
4225 : {
4226 81236 : if (csym->attr.abstract)
4227 : {
4228 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4229 : csym->name, &c->loc);
4230 1 : return false;
4231 : }
4232 :
4233 : /* Subroutines without the RECURSIVE attribution are not allowed to
4234 : call themselves. */
4235 81235 : if (is_illegal_recursion (csym, gfc_current_ns))
4236 : {
4237 4 : if (csym->attr.entry && csym->ns->entries)
4238 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4239 : "as subroutine %qs is not RECURSIVE",
4240 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4241 : else
4242 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4243 : "as it is not RECURSIVE", csym->name, &c->loc);
4244 :
4245 82988 : t = false;
4246 : }
4247 : }
4248 :
4249 : /* Switch off assumed size checking and do this again for certain kinds
4250 : of procedure, once the procedure itself is resolved. */
4251 82988 : need_full_assumed_size++;
4252 :
4253 82988 : if (csym)
4254 82988 : ptype = csym->attr.proc;
4255 :
4256 82988 : no_formal_args = csym && is_external_proc (csym)
4257 15736 : && gfc_sym_get_dummy_args (csym) == NULL;
4258 82988 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4259 : return false;
4260 :
4261 : /* Resume assumed_size checking. */
4262 82954 : need_full_assumed_size--;
4263 :
4264 : /* If 'implicit none (external)' and the symbol is a dummy argument,
4265 : check for an 'external' attribute. */
4266 82954 : if (csym->ns->has_implicit_none_export
4267 4486 : && csym->attr.external == 0 && csym->attr.dummy == 1)
4268 : {
4269 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
4270 : csym->name, &c->loc);
4271 1 : return false;
4272 : }
4273 :
4274 : /* If external, check for usage. */
4275 82953 : if (csym && is_external_proc (csym))
4276 15730 : resolve_global_procedure (csym, &c->loc, 1);
4277 :
4278 : /* If we have an external dummy argument, we want to write out its arguments
4279 : with -fc-prototypes-external. Code like
4280 :
4281 : subroutine foo(a,n)
4282 : external a
4283 : if (n == 1) call a(1)
4284 : if (n == 2) call a(2,3)
4285 : end subroutine foo
4286 :
4287 : is actually legal Fortran, but it is not possible to generate a C23-
4288 : compliant prototype for this, so we just record the fact here and
4289 : handle that during -fc-prototypes-external processing. */
4290 :
4291 82953 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4292 14 : && csym->attr.external)
4293 : {
4294 14 : if (csym->formal)
4295 : {
4296 6 : bool conflict;
4297 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4298 : 0, 0, 0, NULL);
4299 6 : if (conflict)
4300 : {
4301 6 : csym->ext_dummy_arglist_mismatch = 1;
4302 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4303 : "Different argument lists in external dummy "
4304 : "subroutine %s at %L and %L", csym->name,
4305 : &c->loc, &csym->other_loc);
4306 : }
4307 : }
4308 8 : else if (!csym->formal_resolved)
4309 : {
4310 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4311 7 : csym->other_loc = c->loc;
4312 : }
4313 : }
4314 :
4315 82953 : t = true;
4316 82953 : if (c->resolved_sym == NULL)
4317 : {
4318 82848 : c->resolved_isym = NULL;
4319 82848 : switch (procedure_kind (csym))
4320 : {
4321 2881 : case PTYPE_GENERIC:
4322 2881 : t = resolve_generic_s (c);
4323 2881 : break;
4324 :
4325 64004 : case PTYPE_SPECIFIC:
4326 64004 : t = resolve_specific_s (c);
4327 64004 : break;
4328 :
4329 15963 : case PTYPE_UNKNOWN:
4330 15963 : t = resolve_unknown_s (c);
4331 15963 : break;
4332 :
4333 : default:
4334 : gfc_internal_error ("resolve_subroutine(): bad function type");
4335 : }
4336 : }
4337 :
4338 : /* Some checks of elemental subroutine actual arguments. */
4339 82952 : if (!resolve_elemental_actual (NULL, c))
4340 : return false;
4341 :
4342 : /* Deal with complicated dependencies that the scalarizer cannot handle. */
4343 82944 : if (c->resolved_sym && c->resolved_sym->attr.elemental && !no_formal_args
4344 6206 : && c->ext.actual && c->ext.actual->next)
4345 5257 : resolve_elemental_dependencies (c);
4346 :
4347 82944 : if (!c->expr1)
4348 81191 : update_current_proc_array_outer_dependency (csym);
4349 : else
4350 : /* Typebound procedure: Assume the worst. */
4351 1753 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4352 :
4353 82944 : if (c->resolved_sym
4354 82621 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4355 34 : gfc_warning (OPT_Wdeprecated_declarations,
4356 : "Using subroutine %qs at %L is deprecated",
4357 : c->resolved_sym->name, &c->loc);
4358 :
4359 82944 : csym = c->resolved_sym ? c->resolved_sym : csym;
4360 82944 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4361 2 : && csym != gfc_current_ns->proc_name)
4362 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4363 :
4364 : return t;
4365 : }
4366 :
4367 :
4368 : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4369 : op1->shape and op2->shape are non-NULL return true if their shapes
4370 : match. If both op1->shape and op2->shape are non-NULL return false
4371 : if their shapes do not match. If either op1->shape or op2->shape is
4372 : NULL, return true. */
4373 :
4374 : static bool
4375 33290 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4376 : {
4377 33290 : bool t;
4378 33290 : int i;
4379 :
4380 33290 : t = true;
4381 :
4382 33290 : if (op1->shape != NULL && op2->shape != NULL)
4383 : {
4384 43728 : for (i = 0; i < op1->rank; i++)
4385 : {
4386 23307 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4387 : {
4388 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4389 : &op1->where, &op2->where);
4390 3 : t = false;
4391 3 : break;
4392 : }
4393 : }
4394 : }
4395 :
4396 33290 : return t;
4397 : }
4398 :
4399 : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4400 : For example A .AND. B becomes IAND(A, B). */
4401 : static gfc_expr *
4402 668 : logical_to_bitwise (gfc_expr *e)
4403 : {
4404 668 : gfc_expr *tmp, *op1, *op2;
4405 668 : gfc_isym_id isym;
4406 668 : gfc_actual_arglist *args = NULL;
4407 :
4408 668 : gcc_assert (e->expr_type == EXPR_OP);
4409 :
4410 668 : isym = GFC_ISYM_NONE;
4411 668 : op1 = e->value.op.op1;
4412 668 : op2 = e->value.op.op2;
4413 :
4414 668 : switch (e->value.op.op)
4415 : {
4416 : case INTRINSIC_NOT:
4417 : isym = GFC_ISYM_NOT;
4418 : break;
4419 126 : case INTRINSIC_AND:
4420 126 : isym = GFC_ISYM_IAND;
4421 126 : break;
4422 127 : case INTRINSIC_OR:
4423 127 : isym = GFC_ISYM_IOR;
4424 127 : break;
4425 270 : case INTRINSIC_NEQV:
4426 270 : isym = GFC_ISYM_IEOR;
4427 270 : break;
4428 126 : case INTRINSIC_EQV:
4429 : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4430 : Change the old expression to NEQV, which will get replaced by IEOR,
4431 : and wrap it in NOT. */
4432 126 : tmp = gfc_copy_expr (e);
4433 126 : tmp->value.op.op = INTRINSIC_NEQV;
4434 126 : tmp = logical_to_bitwise (tmp);
4435 126 : isym = GFC_ISYM_NOT;
4436 126 : op1 = tmp;
4437 126 : op2 = NULL;
4438 126 : break;
4439 0 : default:
4440 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4441 : }
4442 :
4443 : /* Inherit the original operation's operands as arguments. */
4444 668 : args = gfc_get_actual_arglist ();
4445 668 : args->expr = op1;
4446 668 : if (op2)
4447 : {
4448 523 : args->next = gfc_get_actual_arglist ();
4449 523 : args->next->expr = op2;
4450 : }
4451 :
4452 : /* Convert the expression to a function call. */
4453 668 : e->expr_type = EXPR_FUNCTION;
4454 668 : e->value.function.actual = args;
4455 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4456 668 : e->value.function.name = e->value.function.isym->name;
4457 668 : e->value.function.esym = NULL;
4458 :
4459 : /* Make up a pre-resolved function call symtree if we need to. */
4460 668 : if (!e->symtree || !e->symtree->n.sym)
4461 : {
4462 668 : gfc_symbol *sym;
4463 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4464 668 : sym = e->symtree->n.sym;
4465 668 : sym->result = sym;
4466 668 : sym->attr.flavor = FL_PROCEDURE;
4467 668 : sym->attr.function = 1;
4468 668 : sym->attr.elemental = 1;
4469 668 : sym->attr.pure = 1;
4470 668 : sym->attr.referenced = 1;
4471 668 : gfc_intrinsic_symbol (sym);
4472 668 : gfc_commit_symbol (sym);
4473 : }
4474 :
4475 668 : args->name = e->value.function.isym->formal->name;
4476 668 : if (e->value.function.isym->formal->next)
4477 523 : args->next->name = e->value.function.isym->formal->next->name;
4478 :
4479 668 : return e;
4480 : }
4481 :
4482 : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4483 : candidates in CANDIDATES_LEN. */
4484 : static void
4485 114 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4486 : char **&candidates,
4487 : size_t &candidates_len)
4488 : {
4489 116 : gfc_symtree *p;
4490 :
4491 116 : if (uop == NULL)
4492 : return;
4493 :
4494 : /* Not sure how to properly filter here. Use all for a start.
4495 : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4496 : these as i suppose they don't make terribly sense. */
4497 :
4498 116 : if (uop->n.uop->op != NULL)
4499 2 : vec_push (candidates, candidates_len, uop->name);
4500 :
4501 116 : p = uop->left;
4502 116 : if (p)
4503 36 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4504 :
4505 116 : p = uop->right;
4506 116 : if (p)
4507 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4508 : }
4509 :
4510 : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4511 :
4512 : static const char*
4513 78 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4514 : {
4515 78 : char **candidates = NULL;
4516 78 : size_t candidates_len = 0;
4517 78 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4518 78 : return gfc_closest_fuzzy_match (op, candidates);
4519 : }
4520 :
4521 :
4522 : /* Callback finding an impure function as an operand to an .and. or
4523 : .or. expression. Remember the last function warned about to
4524 : avoid double warnings when recursing. */
4525 :
4526 : static int
4527 193946 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4528 : void *data)
4529 : {
4530 193946 : gfc_expr *f = *e;
4531 193946 : const char *name;
4532 193946 : static gfc_expr *last = NULL;
4533 193946 : bool *found = (bool *) data;
4534 :
4535 193946 : if (f->expr_type == EXPR_FUNCTION)
4536 : {
4537 11996 : *found = 1;
4538 11996 : if (f != last && !gfc_pure_function (f, &name)
4539 13299 : && !gfc_implicit_pure_function (f))
4540 : {
4541 1164 : if (name)
4542 1164 : gfc_warning (OPT_Wfunction_elimination,
4543 : "Impure function %qs at %L might not be evaluated",
4544 : name, &f->where);
4545 : else
4546 0 : gfc_warning (OPT_Wfunction_elimination,
4547 : "Impure function at %L might not be evaluated",
4548 : &f->where);
4549 : }
4550 11996 : last = f;
4551 : }
4552 :
4553 193946 : return 0;
4554 : }
4555 :
4556 : /* Return true if TYPE is character based, false otherwise. */
4557 :
4558 : static int
4559 1373 : is_character_based (bt type)
4560 : {
4561 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4562 : }
4563 :
4564 :
4565 : /* If expression is a hollerith, convert it to character and issue a warning
4566 : for the conversion. */
4567 :
4568 : static void
4569 408 : convert_hollerith_to_character (gfc_expr *e)
4570 : {
4571 408 : if (e->ts.type == BT_HOLLERITH)
4572 : {
4573 108 : gfc_typespec t;
4574 108 : gfc_clear_ts (&t);
4575 108 : t.type = BT_CHARACTER;
4576 108 : t.kind = e->ts.kind;
4577 108 : gfc_convert_type_warn (e, &t, 2, 1);
4578 : }
4579 408 : }
4580 :
4581 : /* Convert to numeric and issue a warning for the conversion. */
4582 :
4583 : static void
4584 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4585 : {
4586 240 : gfc_typespec t;
4587 240 : gfc_clear_ts (&t);
4588 240 : t.type = b->ts.type;
4589 240 : t.kind = b->ts.kind;
4590 240 : gfc_convert_type_warn (a, &t, 2, 1);
4591 240 : }
4592 :
4593 : /* Resolve an operator expression node. This can involve replacing the
4594 : operation with a user defined function call. CHECK_INTERFACES is a
4595 : helper macro. */
4596 :
4597 : #define CHECK_INTERFACES \
4598 : { \
4599 : match m = gfc_extend_expr (e); \
4600 : if (m == MATCH_YES) \
4601 : return true; \
4602 : if (m == MATCH_ERROR) \
4603 : return false; \
4604 : }
4605 :
4606 : static bool
4607 538365 : resolve_operator (gfc_expr *e)
4608 : {
4609 538365 : gfc_expr *op1, *op2;
4610 : /* One error uses 3 names; additional space for wording (also via gettext). */
4611 538365 : bool t = true;
4612 :
4613 : /* Reduce stacked parentheses to single pair */
4614 538365 : while (e->expr_type == EXPR_OP
4615 538523 : && e->value.op.op == INTRINSIC_PARENTHESES
4616 23610 : && e->value.op.op1->expr_type == EXPR_OP
4617 555324 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4618 : {
4619 158 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4620 158 : gfc_replace_expr (e, tmp);
4621 : }
4622 :
4623 : /* Resolve all subnodes-- give them types. */
4624 :
4625 538365 : switch (e->value.op.op)
4626 : {
4627 486038 : default:
4628 486038 : if (!gfc_resolve_expr (e->value.op.op2))
4629 538365 : t = false;
4630 :
4631 : /* Fall through. */
4632 :
4633 538365 : case INTRINSIC_NOT:
4634 538365 : case INTRINSIC_UPLUS:
4635 538365 : case INTRINSIC_UMINUS:
4636 538365 : case INTRINSIC_PARENTHESES:
4637 538365 : if (!gfc_resolve_expr (e->value.op.op1))
4638 : return false;
4639 538204 : if (e->value.op.op1
4640 538195 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4641 : {
4642 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4643 0 : "unary operator %qs", &e->value.op.op1->where,
4644 : gfc_op2string (e->value.op.op));
4645 0 : return false;
4646 : }
4647 538204 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4648 6 : && e->value.op.op == INTRINSIC_UMINUS)
4649 : {
4650 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4651 : &e->value.op.op1->where);
4652 2 : return false;
4653 : }
4654 538202 : break;
4655 : }
4656 :
4657 : /* Typecheck the new node. */
4658 :
4659 538202 : op1 = e->value.op.op1;
4660 538202 : op2 = e->value.op.op2;
4661 538202 : if (op1 == NULL && op2 == NULL)
4662 : return false;
4663 : /* Error out if op2 did not resolve. We already diagnosed op1. */
4664 538193 : if (t == false)
4665 : return false;
4666 :
4667 : /* op1 and op2 cannot both be BOZ. */
4668 538127 : if (op1 && op1->ts.type == BT_BOZ
4669 0 : && op2 && op2->ts.type == BT_BOZ)
4670 : {
4671 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4672 0 : "binary operator %qs", &op1->where, &op2->where,
4673 : gfc_op2string (e->value.op.op));
4674 0 : return false;
4675 : }
4676 :
4677 538127 : if ((op1 && op1->expr_type == EXPR_NULL)
4678 538125 : || (op2 && op2->expr_type == EXPR_NULL))
4679 : {
4680 3 : CHECK_INTERFACES
4681 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4682 3 : return false;
4683 : }
4684 :
4685 538124 : switch (e->value.op.op)
4686 : {
4687 8248 : case INTRINSIC_UPLUS:
4688 8248 : case INTRINSIC_UMINUS:
4689 8248 : if (op1->ts.type == BT_INTEGER
4690 : || op1->ts.type == BT_REAL
4691 : || op1->ts.type == BT_COMPLEX
4692 : || op1->ts.type == BT_UNSIGNED)
4693 : {
4694 8179 : e->ts = op1->ts;
4695 8179 : break;
4696 : }
4697 :
4698 69 : CHECK_INTERFACES
4699 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4700 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4701 43 : return false;
4702 :
4703 156536 : case INTRINSIC_POWER:
4704 156536 : case INTRINSIC_PLUS:
4705 156536 : case INTRINSIC_MINUS:
4706 156536 : case INTRINSIC_TIMES:
4707 156536 : case INTRINSIC_DIVIDE:
4708 :
4709 : /* UNSIGNED cannot appear in a mixed expression without explicit
4710 : conversion. */
4711 156536 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4712 : {
4713 3 : CHECK_INTERFACES
4714 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4715 : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4716 : gfc_typename (op1), gfc_typename (op2));
4717 3 : return false;
4718 : }
4719 :
4720 156533 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4721 : {
4722 : /* Do not perform conversions if operands are not conformable as
4723 : required for the binary intrinsic operators (F2018:10.1.5).
4724 : Defer to a possibly overloading user-defined operator. */
4725 156079 : if (!gfc_op_rank_conformable (op1, op2))
4726 : {
4727 36 : CHECK_INTERFACES
4728 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4729 0 : &op1->where, &op2->where);
4730 0 : return false;
4731 : }
4732 :
4733 156043 : gfc_type_convert_binary (e, 1);
4734 156043 : break;
4735 : }
4736 :
4737 454 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4738 : {
4739 225 : CHECK_INTERFACES
4740 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4741 : "numeric operator %qs at %L",
4742 : gfc_op2string (e->value.op.op), &e->where);
4743 2 : return false;
4744 : }
4745 : else
4746 : {
4747 229 : CHECK_INTERFACES
4748 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4749 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4750 : gfc_typename (op2));
4751 3 : return false;
4752 : }
4753 :
4754 2327 : case INTRINSIC_CONCAT:
4755 2327 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4756 2302 : && op1->ts.kind == op2->ts.kind)
4757 : {
4758 2293 : e->ts.type = BT_CHARACTER;
4759 2293 : e->ts.kind = op1->ts.kind;
4760 2293 : break;
4761 : }
4762 :
4763 34 : CHECK_INTERFACES
4764 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4765 : &e->where, gfc_typename (op1), gfc_typename (op2));
4766 10 : return false;
4767 :
4768 69942 : case INTRINSIC_AND:
4769 69942 : case INTRINSIC_OR:
4770 69942 : case INTRINSIC_EQV:
4771 69942 : case INTRINSIC_NEQV:
4772 69942 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4773 : {
4774 69391 : e->ts.type = BT_LOGICAL;
4775 69391 : e->ts.kind = gfc_kind_max (op1, op2);
4776 69391 : if (op1->ts.kind < e->ts.kind)
4777 140 : gfc_convert_type (op1, &e->ts, 2);
4778 69251 : else if (op2->ts.kind < e->ts.kind)
4779 117 : gfc_convert_type (op2, &e->ts, 2);
4780 :
4781 69391 : if (flag_frontend_optimize &&
4782 58307 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4783 : {
4784 : /* Warn about short-circuiting
4785 : with impure function as second operand. */
4786 52272 : bool op2_f = false;
4787 52272 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4788 : }
4789 : break;
4790 : }
4791 :
4792 : /* Logical ops on integers become bitwise ops with -fdec. */
4793 551 : else if (flag_dec
4794 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4795 : {
4796 523 : e->ts.type = BT_INTEGER;
4797 523 : e->ts.kind = gfc_kind_max (op1, op2);
4798 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4799 289 : gfc_convert_type (op1, &e->ts, 1);
4800 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4801 144 : gfc_convert_type (op2, &e->ts, 1);
4802 523 : e = logical_to_bitwise (e);
4803 523 : goto simplify_op;
4804 : }
4805 :
4806 28 : CHECK_INTERFACES
4807 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4808 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4809 : gfc_typename (op2));
4810 16 : return false;
4811 :
4812 20611 : case INTRINSIC_NOT:
4813 : /* Logical ops on integers become bitwise ops with -fdec. */
4814 20611 : if (flag_dec && op1->ts.type == BT_INTEGER)
4815 : {
4816 19 : e->ts.type = BT_INTEGER;
4817 19 : e->ts.kind = op1->ts.kind;
4818 19 : e = logical_to_bitwise (e);
4819 19 : goto simplify_op;
4820 : }
4821 :
4822 20592 : if (op1->ts.type == BT_LOGICAL)
4823 : {
4824 20586 : e->ts.type = BT_LOGICAL;
4825 20586 : e->ts.kind = op1->ts.kind;
4826 20586 : break;
4827 : }
4828 :
4829 6 : CHECK_INTERFACES
4830 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4831 : gfc_typename (op1));
4832 3 : return false;
4833 :
4834 21743 : case INTRINSIC_GT:
4835 21743 : case INTRINSIC_GT_OS:
4836 21743 : case INTRINSIC_GE:
4837 21743 : case INTRINSIC_GE_OS:
4838 21743 : case INTRINSIC_LT:
4839 21743 : case INTRINSIC_LT_OS:
4840 21743 : case INTRINSIC_LE:
4841 21743 : case INTRINSIC_LE_OS:
4842 21743 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4843 : {
4844 18 : CHECK_INTERFACES
4845 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4846 0 : return false;
4847 : }
4848 :
4849 : /* Fall through. */
4850 :
4851 256726 : case INTRINSIC_EQ:
4852 256726 : case INTRINSIC_EQ_OS:
4853 256726 : case INTRINSIC_NE:
4854 256726 : case INTRINSIC_NE_OS:
4855 :
4856 256726 : if (flag_dec
4857 1038 : && is_character_based (op1->ts.type)
4858 257061 : && is_character_based (op2->ts.type))
4859 : {
4860 204 : convert_hollerith_to_character (op1);
4861 204 : convert_hollerith_to_character (op2);
4862 : }
4863 :
4864 256726 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4865 38940 : && op1->ts.kind == op2->ts.kind)
4866 : {
4867 38903 : e->ts.type = BT_LOGICAL;
4868 38903 : e->ts.kind = gfc_default_logical_kind;
4869 38903 : break;
4870 : }
4871 :
4872 : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4873 217823 : if (op1->ts.type == BT_BOZ)
4874 : {
4875 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4876 : "as an operand of a relational operator"),
4877 : &op1->where))
4878 : return false;
4879 :
4880 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4881 : return false;
4882 :
4883 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4884 : return false;
4885 : }
4886 :
4887 : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4888 217823 : if (op2->ts.type == BT_BOZ)
4889 : {
4890 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4891 : " as an operand of a relational operator"),
4892 : &op2->where))
4893 : return false;
4894 :
4895 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4896 : return false;
4897 :
4898 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4899 : return false;
4900 : }
4901 217823 : if (flag_dec
4902 217823 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4903 120 : convert_to_numeric (op1, op2);
4904 :
4905 217823 : if (flag_dec
4906 217823 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4907 120 : convert_to_numeric (op2, op1);
4908 :
4909 217823 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4910 : {
4911 : /* Do not perform conversions if operands are not conformable as
4912 : required for the binary intrinsic operators (F2018:10.1.5).
4913 : Defer to a possibly overloading user-defined operator. */
4914 216694 : if (!gfc_op_rank_conformable (op1, op2))
4915 : {
4916 70 : CHECK_INTERFACES
4917 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4918 0 : &op1->where, &op2->where);
4919 0 : return false;
4920 : }
4921 :
4922 216624 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4923 : {
4924 1 : CHECK_INTERFACES
4925 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4926 1 : "%s and %s", &op1->where, &op2->where,
4927 : gfc_typename (op1), gfc_typename (op2));
4928 1 : return false;
4929 : }
4930 :
4931 216623 : gfc_type_convert_binary (e, 1);
4932 :
4933 216623 : e->ts.type = BT_LOGICAL;
4934 216623 : e->ts.kind = gfc_default_logical_kind;
4935 :
4936 216623 : if (warn_compare_reals)
4937 : {
4938 70 : gfc_intrinsic_op op = e->value.op.op;
4939 :
4940 : /* Type conversion has made sure that the types of op1 and op2
4941 : agree, so it is only necessary to check the first one. */
4942 70 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4943 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4944 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4945 : {
4946 13 : const char *msg;
4947 :
4948 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4949 : msg = G_("Equality comparison for %s at %L");
4950 : else
4951 6 : msg = G_("Inequality comparison for %s at %L");
4952 :
4953 13 : gfc_warning (OPT_Wcompare_reals, msg,
4954 : gfc_typename (op1), &op1->where);
4955 : }
4956 : }
4957 :
4958 : break;
4959 : }
4960 :
4961 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4962 : {
4963 2 : CHECK_INTERFACES
4964 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4965 : &e->where,
4966 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4967 : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4968 2 : }
4969 : else
4970 : {
4971 1127 : CHECK_INTERFACES
4972 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4973 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4974 : gfc_typename (op2));
4975 : }
4976 :
4977 : return false;
4978 :
4979 303 : case INTRINSIC_USER:
4980 303 : if (e->value.op.uop->op == NULL)
4981 : {
4982 78 : const char *name = e->value.op.uop->name;
4983 78 : const char *guessed;
4984 78 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4985 78 : CHECK_INTERFACES
4986 5 : if (guessed)
4987 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4988 : "%qs?", name, &e->where, guessed);
4989 : else
4990 4 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4991 : }
4992 225 : else if (op2 == NULL)
4993 : {
4994 48 : CHECK_INTERFACES
4995 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4996 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4997 : }
4998 : else
4999 : {
5000 177 : e->value.op.uop->op->sym->attr.referenced = 1;
5001 177 : CHECK_INTERFACES
5002 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
5003 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
5004 : gfc_typename (op2));
5005 : }
5006 :
5007 : return false;
5008 :
5009 23413 : case INTRINSIC_PARENTHESES:
5010 23413 : e->ts = op1->ts;
5011 23413 : if (e->ts.type == BT_CHARACTER)
5012 323 : e->ts.u.cl = op1->ts.u.cl;
5013 : break;
5014 :
5015 0 : default:
5016 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
5017 : }
5018 :
5019 : /* Deal with arrayness of an operand through an operator. */
5020 :
5021 535431 : switch (e->value.op.op)
5022 : {
5023 483253 : case INTRINSIC_PLUS:
5024 483253 : case INTRINSIC_MINUS:
5025 483253 : case INTRINSIC_TIMES:
5026 483253 : case INTRINSIC_DIVIDE:
5027 483253 : case INTRINSIC_POWER:
5028 483253 : case INTRINSIC_CONCAT:
5029 483253 : case INTRINSIC_AND:
5030 483253 : case INTRINSIC_OR:
5031 483253 : case INTRINSIC_EQV:
5032 483253 : case INTRINSIC_NEQV:
5033 483253 : case INTRINSIC_EQ:
5034 483253 : case INTRINSIC_EQ_OS:
5035 483253 : case INTRINSIC_NE:
5036 483253 : case INTRINSIC_NE_OS:
5037 483253 : case INTRINSIC_GT:
5038 483253 : case INTRINSIC_GT_OS:
5039 483253 : case INTRINSIC_GE:
5040 483253 : case INTRINSIC_GE_OS:
5041 483253 : case INTRINSIC_LT:
5042 483253 : case INTRINSIC_LT_OS:
5043 483253 : case INTRINSIC_LE:
5044 483253 : case INTRINSIC_LE_OS:
5045 :
5046 483253 : if (op1->rank == 0 && op2->rank == 0)
5047 429951 : e->rank = 0;
5048 :
5049 483253 : if (op1->rank == 0 && op2->rank != 0)
5050 : {
5051 2621 : e->rank = op2->rank;
5052 :
5053 2621 : if (e->shape == NULL)
5054 2591 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
5055 : }
5056 :
5057 483253 : if (op1->rank != 0 && op2->rank == 0)
5058 : {
5059 17330 : e->rank = op1->rank;
5060 :
5061 17330 : if (e->shape == NULL)
5062 17306 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5063 : }
5064 :
5065 483253 : if (op1->rank != 0 && op2->rank != 0)
5066 : {
5067 33351 : if (op1->rank == op2->rank)
5068 : {
5069 33351 : e->rank = op1->rank;
5070 33351 : if (e->shape == NULL)
5071 : {
5072 33290 : t = compare_shapes (op1, op2);
5073 33290 : if (!t)
5074 3 : e->shape = NULL;
5075 : else
5076 33287 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5077 : }
5078 : }
5079 : else
5080 : {
5081 : /* Allow higher level expressions to work. */
5082 0 : e->rank = 0;
5083 :
5084 : /* Try user-defined operators, and otherwise throw an error. */
5085 0 : CHECK_INTERFACES
5086 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
5087 0 : &op1->where, &op2->where);
5088 0 : return false;
5089 : }
5090 : }
5091 : break;
5092 :
5093 52178 : case INTRINSIC_PARENTHESES:
5094 52178 : case INTRINSIC_NOT:
5095 52178 : case INTRINSIC_UPLUS:
5096 52178 : case INTRINSIC_UMINUS:
5097 : /* Simply copy arrayness attribute */
5098 52178 : e->rank = op1->rank;
5099 52178 : e->corank = op1->corank;
5100 :
5101 52178 : if (e->shape == NULL)
5102 52168 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5103 :
5104 : break;
5105 :
5106 : default:
5107 : break;
5108 : }
5109 :
5110 535973 : simplify_op:
5111 :
5112 : /* Attempt to simplify the expression. */
5113 3 : if (t)
5114 : {
5115 535970 : t = gfc_simplify_expr (e, 0);
5116 : /* Some calls do not succeed in simplification and return false
5117 : even though there is no error; e.g. variable references to
5118 : PARAMETER arrays. */
5119 535970 : if (!gfc_is_constant_expr (e))
5120 489373 : t = true;
5121 : }
5122 : return t;
5123 : }
5124 :
5125 : static bool
5126 170 : resolve_conditional (gfc_expr *expr)
5127 : {
5128 170 : gfc_expr *condition, *true_expr, *false_expr;
5129 :
5130 170 : condition = expr->value.conditional.condition;
5131 170 : true_expr = expr->value.conditional.true_expr;
5132 170 : false_expr = expr->value.conditional.false_expr;
5133 :
5134 340 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5135 340 : || !gfc_resolve_expr (false_expr))
5136 : return false;
5137 :
5138 170 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5139 : {
5140 2 : gfc_error (
5141 : "Condition in conditional expression must be a scalar logical at %L",
5142 : &condition->where);
5143 2 : return false;
5144 : }
5145 :
5146 168 : if (true_expr->ts.type != false_expr->ts.type)
5147 : {
5148 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5149 : "must have the same declared type",
5150 : &true_expr->where, &false_expr->where);
5151 1 : return false;
5152 : }
5153 :
5154 167 : if (true_expr->ts.kind != false_expr->ts.kind)
5155 : {
5156 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5157 : "must have the same kind parameter",
5158 : &true_expr->where, &false_expr->where);
5159 1 : return false;
5160 : }
5161 :
5162 166 : if (true_expr->rank != false_expr->rank)
5163 : {
5164 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5165 : "must have the same rank",
5166 : &true_expr->where, &false_expr->where);
5167 1 : return false;
5168 : }
5169 :
5170 : /* TODO: support more data types for conditional expressions */
5171 165 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5172 165 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5173 67 : && true_expr->ts.type != BT_CHARACTER)
5174 : {
5175 1 : gfc_error (
5176 : "Sorry, only integer, logical, real, complex and character types are "
5177 : "currently supported for conditional expressions at %L",
5178 : &expr->where);
5179 1 : return false;
5180 : }
5181 :
5182 : /* TODO: support arrays in conditional expressions */
5183 164 : if (true_expr->rank > 0)
5184 : {
5185 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5186 : "expressions at %L",
5187 : &expr->where);
5188 1 : return false;
5189 : }
5190 :
5191 163 : expr->ts = true_expr->ts;
5192 163 : expr->rank = true_expr->rank;
5193 163 : return true;
5194 : }
5195 :
5196 : /************** Array resolution subroutines **************/
5197 :
5198 : enum compare_result
5199 : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5200 :
5201 : /* Compare two integer expressions. */
5202 :
5203 : static compare_result
5204 475139 : compare_bound (gfc_expr *a, gfc_expr *b)
5205 : {
5206 475139 : int i;
5207 :
5208 475139 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5209 312206 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5210 : return CMP_UNKNOWN;
5211 :
5212 : /* If either of the types isn't INTEGER, we must have
5213 : raised an error earlier. */
5214 :
5215 215023 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5216 : return CMP_UNKNOWN;
5217 :
5218 215019 : i = mpz_cmp (a->value.integer, b->value.integer);
5219 :
5220 215019 : if (i < 0)
5221 : return CMP_LT;
5222 101076 : if (i > 0)
5223 40170 : return CMP_GT;
5224 : return CMP_EQ;
5225 : }
5226 :
5227 :
5228 : /* Compare an integer expression with an integer. */
5229 :
5230 : static compare_result
5231 75992 : compare_bound_int (gfc_expr *a, int b)
5232 : {
5233 75992 : int i;
5234 :
5235 75992 : if (a == NULL
5236 32913 : || a->expr_type != EXPR_CONSTANT
5237 29960 : || a->ts.type != BT_INTEGER)
5238 : return CMP_UNKNOWN;
5239 :
5240 29960 : i = mpz_cmp_si (a->value.integer, b);
5241 :
5242 29960 : if (i < 0)
5243 : return CMP_LT;
5244 25486 : if (i > 0)
5245 21921 : return CMP_GT;
5246 : return CMP_EQ;
5247 : }
5248 :
5249 :
5250 : /* Compare an integer expression with a mpz_t. */
5251 :
5252 : static compare_result
5253 70597 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5254 : {
5255 70597 : int i;
5256 :
5257 70597 : if (a == NULL
5258 57626 : || a->expr_type != EXPR_CONSTANT
5259 55498 : || a->ts.type != BT_INTEGER)
5260 : return CMP_UNKNOWN;
5261 :
5262 55495 : i = mpz_cmp (a->value.integer, b);
5263 :
5264 55495 : if (i < 0)
5265 : return CMP_LT;
5266 25251 : if (i > 0)
5267 10776 : return CMP_GT;
5268 : return CMP_EQ;
5269 : }
5270 :
5271 :
5272 : /* Compute the last value of a sequence given by a triplet.
5273 : Return 0 if it wasn't able to compute the last value, or if the
5274 : sequence if empty, and 1 otherwise. */
5275 :
5276 : static int
5277 52681 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5278 : gfc_expr *stride, mpz_t last)
5279 : {
5280 52681 : mpz_t rem;
5281 :
5282 52681 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5283 37434 : || end == NULL || end->expr_type != EXPR_CONSTANT
5284 32682 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5285 : return 0;
5286 :
5287 32363 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5288 32362 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5289 : return 0;
5290 :
5291 6791 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5292 : {
5293 25697 : if (compare_bound (start, end) == CMP_GT)
5294 : return 0;
5295 24308 : mpz_set (last, end->value.integer);
5296 24308 : return 1;
5297 : }
5298 :
5299 6665 : if (compare_bound_int (stride, 0) == CMP_GT)
5300 : {
5301 : /* Stride is positive */
5302 5300 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5303 : return 0;
5304 : }
5305 : else
5306 : {
5307 : /* Stride is negative */
5308 1365 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5309 : return 0;
5310 : }
5311 :
5312 6645 : mpz_init (rem);
5313 6645 : mpz_sub (rem, end->value.integer, start->value.integer);
5314 6645 : mpz_tdiv_r (rem, rem, stride->value.integer);
5315 6645 : mpz_sub (last, end->value.integer, rem);
5316 6645 : mpz_clear (rem);
5317 :
5318 6645 : return 1;
5319 : }
5320 :
5321 :
5322 : /* Compare a single dimension of an array reference to the array
5323 : specification. */
5324 :
5325 : static bool
5326 220552 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5327 : {
5328 220552 : mpz_t last_value;
5329 :
5330 220552 : if (ar->dimen_type[i] == DIMEN_STAR)
5331 : {
5332 557 : gcc_assert (ar->stride[i] == NULL);
5333 : /* This implies [*] as [*:] and [*:3] are not possible. */
5334 557 : if (ar->start[i] == NULL)
5335 : {
5336 456 : gcc_assert (ar->end[i] == NULL);
5337 : return true;
5338 : }
5339 : }
5340 :
5341 : /* Given start, end and stride values, calculate the minimum and
5342 : maximum referenced indexes. */
5343 :
5344 220096 : switch (ar->dimen_type[i])
5345 : {
5346 : case DIMEN_VECTOR:
5347 : case DIMEN_THIS_IMAGE:
5348 : break;
5349 :
5350 158818 : case DIMEN_STAR:
5351 158818 : case DIMEN_ELEMENT:
5352 158818 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5353 : {
5354 2 : if (i < as->rank)
5355 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5356 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5357 2 : mpz_get_si (ar->start[i]->value.integer),
5358 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5359 : else
5360 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5361 : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5362 0 : mpz_get_si (ar->start[i]->value.integer),
5363 0 : mpz_get_si (as->lower[i]->value.integer),
5364 0 : i + 1 - as->rank);
5365 : return true;
5366 : }
5367 158816 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5368 : {
5369 39 : if (i < as->rank)
5370 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5371 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5372 39 : mpz_get_si (ar->start[i]->value.integer),
5373 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5374 : else
5375 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5376 : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5377 0 : mpz_get_si (ar->start[i]->value.integer),
5378 0 : mpz_get_si (as->upper[i]->value.integer),
5379 0 : i + 1 - as->rank);
5380 : return true;
5381 : }
5382 :
5383 : break;
5384 :
5385 52726 : case DIMEN_RANGE:
5386 52726 : {
5387 : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5388 : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5389 :
5390 52726 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5391 52726 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5392 :
5393 : /* Check for zero stride, which is not allowed. */
5394 52726 : if (comp_stride_zero == CMP_EQ)
5395 : {
5396 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5397 1 : return false;
5398 : }
5399 :
5400 : /* if start == end || (stride > 0 && start < end)
5401 : || (stride < 0 && start > end),
5402 : then the array section contains at least one element. In this
5403 : case, there is an out-of-bounds access if
5404 : (start < lower || start > upper). */
5405 52725 : if (comp_start_end == CMP_EQ
5406 51963 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5407 49174 : && comp_start_end == CMP_LT)
5408 23071 : || (comp_stride_zero == CMP_LT
5409 23071 : && comp_start_end == CMP_GT))
5410 : {
5411 30999 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5412 : {
5413 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5414 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5415 27 : mpz_get_si (AR_START->value.integer),
5416 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5417 27 : return true;
5418 : }
5419 30972 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5420 : {
5421 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5422 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5423 17 : mpz_get_si (AR_START->value.integer),
5424 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5425 17 : return true;
5426 : }
5427 : }
5428 :
5429 : /* If we can compute the highest index of the array section,
5430 : then it also has to be between lower and upper. */
5431 52681 : mpz_init (last_value);
5432 52681 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5433 : last_value))
5434 : {
5435 30953 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5436 : {
5437 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5438 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5439 : mpz_get_si (last_value),
5440 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5441 3 : mpz_clear (last_value);
5442 3 : return true;
5443 : }
5444 30950 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5445 : {
5446 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5447 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5448 : mpz_get_si (last_value),
5449 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5450 7 : mpz_clear (last_value);
5451 7 : return true;
5452 : }
5453 : }
5454 52671 : mpz_clear (last_value);
5455 :
5456 : #undef AR_START
5457 : #undef AR_END
5458 : }
5459 52671 : break;
5460 :
5461 0 : default:
5462 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5463 : }
5464 :
5465 : return true;
5466 : }
5467 :
5468 :
5469 : /* Compare an array reference with an array specification. */
5470 :
5471 : static bool
5472 434301 : compare_spec_to_ref (gfc_array_ref *ar)
5473 : {
5474 434301 : gfc_array_spec *as;
5475 434301 : int i;
5476 :
5477 434301 : as = ar->as;
5478 434301 : i = as->rank - 1;
5479 : /* TODO: Full array sections are only allowed as actual parameters. */
5480 434301 : if (as->type == AS_ASSUMED_SIZE
5481 5810 : && (/*ar->type == AR_FULL
5482 5810 : ||*/ (ar->type == AR_SECTION
5483 523 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5484 : {
5485 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5486 : "not specified at %L", &ar->where);
5487 5 : return false;
5488 : }
5489 :
5490 434296 : if (ar->type == AR_FULL)
5491 : return true;
5492 :
5493 167398 : if (as->rank != ar->dimen)
5494 : {
5495 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5496 : &ar->where, ar->dimen, as->rank);
5497 28 : return false;
5498 : }
5499 :
5500 : /* ar->codimen == 0 is a local array. */
5501 167370 : if (as->corank != ar->codimen && ar->codimen != 0)
5502 : {
5503 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5504 : &ar->where, ar->codimen, as->corank);
5505 0 : return false;
5506 : }
5507 :
5508 377748 : for (i = 0; i < as->rank; i++)
5509 210379 : if (!check_dimension (i, ar, as))
5510 : return false;
5511 :
5512 : /* Local access has no coarray spec. */
5513 167369 : if (ar->codimen != 0)
5514 19516 : for (i = as->rank; i < as->rank + as->corank; i++)
5515 : {
5516 10175 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5517 7128 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5518 : {
5519 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5520 2 : i + 1 - as->rank, &ar->where);
5521 2 : return false;
5522 : }
5523 10173 : if (!check_dimension (i, ar, as))
5524 : return false;
5525 : }
5526 :
5527 : return true;
5528 : }
5529 :
5530 :
5531 : /* Resolve one part of an array index. */
5532 :
5533 : static bool
5534 747931 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5535 : int force_index_integer_kind)
5536 : {
5537 747931 : gfc_typespec ts;
5538 :
5539 747931 : if (index == NULL)
5540 : return true;
5541 :
5542 221846 : if (!gfc_resolve_expr (index))
5543 : return false;
5544 :
5545 221835 : if (check_scalar && index->rank != 0)
5546 : {
5547 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5548 2 : return false;
5549 : }
5550 :
5551 221833 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5552 : {
5553 4 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5554 : &index->where, gfc_basic_typename (index->ts.type));
5555 4 : return false;
5556 : }
5557 :
5558 221829 : if (index->ts.type == BT_REAL)
5559 657 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5560 : &index->where))
5561 : return false;
5562 :
5563 221829 : if ((index->ts.kind != gfc_index_integer_kind
5564 216780 : && force_index_integer_kind)
5565 190068 : || (index->ts.type != BT_INTEGER
5566 : && index->ts.type != BT_UNKNOWN))
5567 : {
5568 32417 : gfc_clear_ts (&ts);
5569 32417 : ts.type = BT_INTEGER;
5570 32417 : ts.kind = gfc_index_integer_kind;
5571 :
5572 32417 : gfc_convert_type_warn (index, &ts, 2, 0);
5573 : }
5574 :
5575 : return true;
5576 : }
5577 :
5578 : /* Resolve one part of an array index. */
5579 :
5580 : bool
5581 498879 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5582 : {
5583 498879 : return gfc_resolve_index_1 (index, check_scalar, 1);
5584 : }
5585 :
5586 : /* Resolve a dim argument to an intrinsic function. */
5587 :
5588 : bool
5589 23915 : gfc_resolve_dim_arg (gfc_expr *dim)
5590 : {
5591 23915 : if (dim == NULL)
5592 : return true;
5593 :
5594 23915 : if (!gfc_resolve_expr (dim))
5595 : return false;
5596 :
5597 23915 : if (dim->rank != 0)
5598 : {
5599 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5600 0 : return false;
5601 :
5602 : }
5603 :
5604 23915 : if (dim->ts.type != BT_INTEGER)
5605 : {
5606 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5607 0 : return false;
5608 : }
5609 :
5610 23915 : if (dim->ts.kind != gfc_index_integer_kind)
5611 : {
5612 15306 : gfc_typespec ts;
5613 :
5614 15306 : gfc_clear_ts (&ts);
5615 15306 : ts.type = BT_INTEGER;
5616 15306 : ts.kind = gfc_index_integer_kind;
5617 :
5618 15306 : gfc_convert_type_warn (dim, &ts, 2, 0);
5619 : }
5620 :
5621 : return true;
5622 : }
5623 :
5624 : /* Given an expression that contains array references, update those array
5625 : references to point to the right array specifications. While this is
5626 : filled in during matching, this information is difficult to save and load
5627 : in a module, so we take care of it here.
5628 :
5629 : The idea here is that the original array reference comes from the
5630 : base symbol. We traverse the list of reference structures, setting
5631 : the stored reference to references. Component references can
5632 : provide an additional array specification. */
5633 : static void
5634 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5635 :
5636 : static bool
5637 918 : find_array_spec (gfc_expr *e)
5638 : {
5639 918 : gfc_array_spec *as;
5640 918 : gfc_component *c;
5641 918 : gfc_ref *ref;
5642 918 : bool class_as = false;
5643 :
5644 918 : if (e->symtree->n.sym->assoc)
5645 : {
5646 221 : if (e->symtree->n.sym->assoc->target)
5647 221 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5648 221 : resolve_assoc_var (e->symtree->n.sym, false);
5649 : }
5650 :
5651 918 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5652 : {
5653 124 : as = CLASS_DATA (e->symtree->n.sym)->as;
5654 124 : class_as = true;
5655 : }
5656 : else
5657 794 : as = e->symtree->n.sym->as;
5658 :
5659 2093 : for (ref = e->ref; ref; ref = ref->next)
5660 1182 : switch (ref->type)
5661 : {
5662 920 : case REF_ARRAY:
5663 920 : if (as == NULL)
5664 : {
5665 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5666 14 : ? ref->u.ar.where : e->where);
5667 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5668 : &loc);
5669 7 : return false;
5670 : }
5671 :
5672 913 : ref->u.ar.as = as;
5673 913 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5674 : as = NULL;
5675 : break;
5676 :
5677 238 : case REF_COMPONENT:
5678 238 : c = ref->u.c.component;
5679 238 : if (c->attr.dimension)
5680 : {
5681 107 : if (as != NULL && !(class_as && as == c->as))
5682 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5683 107 : as = c->as;
5684 : }
5685 :
5686 : break;
5687 :
5688 : case REF_SUBSTRING:
5689 : case REF_INQUIRY:
5690 : break;
5691 : }
5692 :
5693 911 : if (as != NULL)
5694 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5695 :
5696 : return true;
5697 : }
5698 :
5699 :
5700 : /* Resolve an array reference. */
5701 :
5702 : static bool
5703 435015 : resolve_array_ref (gfc_array_ref *ar)
5704 : {
5705 435015 : int i, check_scalar;
5706 435015 : gfc_expr *e;
5707 :
5708 684050 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5709 : {
5710 249052 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5711 :
5712 : /* Do not force gfc_index_integer_kind for the start. We can
5713 : do fine with any integer kind. This avoids temporary arrays
5714 : created for indexing with a vector. */
5715 249052 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5716 : return false;
5717 249037 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5718 : return false;
5719 249035 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5720 : return false;
5721 :
5722 249035 : e = ar->start[i];
5723 :
5724 249035 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5725 148810 : switch (e->rank)
5726 : {
5727 147712 : case 0:
5728 147712 : ar->dimen_type[i] = DIMEN_ELEMENT;
5729 147712 : break;
5730 :
5731 1098 : case 1:
5732 1098 : ar->dimen_type[i] = DIMEN_VECTOR;
5733 1098 : if (e->expr_type == EXPR_VARIABLE
5734 470 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5735 13 : ar->start[i] = gfc_get_parentheses (e);
5736 : break;
5737 :
5738 0 : default:
5739 0 : gfc_error ("Array index at %L is an array of rank %d",
5740 : &ar->c_where[i], e->rank);
5741 0 : return false;
5742 : }
5743 :
5744 : /* Fill in the upper bound, which may be lower than the
5745 : specified one for something like a(2:10:5), which is
5746 : identical to a(2:7:5). Only relevant for strides not equal
5747 : to one. Don't try a division by zero. */
5748 249035 : if (ar->dimen_type[i] == DIMEN_RANGE
5749 72659 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5750 8553 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5751 8406 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5752 : {
5753 8405 : mpz_t size, end;
5754 :
5755 8405 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5756 : {
5757 6675 : if (ar->end[i] == NULL)
5758 : {
5759 8058 : ar->end[i] =
5760 4029 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5761 : &ar->where);
5762 4029 : mpz_set (ar->end[i]->value.integer, end);
5763 : }
5764 2646 : else if (ar->end[i]->ts.type == BT_INTEGER
5765 2646 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5766 : {
5767 2646 : mpz_set (ar->end[i]->value.integer, end);
5768 : }
5769 : else
5770 0 : gcc_unreachable ();
5771 :
5772 6675 : mpz_clear (size);
5773 6675 : mpz_clear (end);
5774 : }
5775 : }
5776 : }
5777 :
5778 434998 : if (ar->type == AR_FULL)
5779 : {
5780 270547 : if (ar->as->rank == 0)
5781 3615 : ar->type = AR_ELEMENT;
5782 :
5783 : /* Make sure array is the same as array(:,:), this way
5784 : we don't need to special case all the time. */
5785 270547 : ar->dimen = ar->as->rank;
5786 643469 : for (i = 0; i < ar->dimen; i++)
5787 : {
5788 372922 : ar->dimen_type[i] = DIMEN_RANGE;
5789 :
5790 372922 : gcc_assert (ar->start[i] == NULL);
5791 372922 : gcc_assert (ar->end[i] == NULL);
5792 372922 : gcc_assert (ar->stride[i] == NULL);
5793 : }
5794 : }
5795 :
5796 : /* If the reference type is unknown, figure out what kind it is. */
5797 :
5798 434998 : if (ar->type == AR_UNKNOWN)
5799 : {
5800 151246 : ar->type = AR_ELEMENT;
5801 293203 : for (i = 0; i < ar->dimen; i++)
5802 180505 : if (ar->dimen_type[i] == DIMEN_RANGE
5803 180505 : || ar->dimen_type[i] == DIMEN_VECTOR)
5804 : {
5805 38548 : ar->type = AR_SECTION;
5806 38548 : break;
5807 : }
5808 : }
5809 :
5810 434998 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5811 : return false;
5812 :
5813 434962 : if (ar->as->corank && ar->codimen == 0)
5814 : {
5815 2143 : int n;
5816 2143 : ar->codimen = ar->as->corank;
5817 6052 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5818 3909 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5819 : }
5820 :
5821 434962 : if (ar->codimen)
5822 : {
5823 14068 : if (ar->team_type == TEAM_NUMBER)
5824 : {
5825 60 : if (!gfc_resolve_expr (ar->team))
5826 : return false;
5827 :
5828 60 : if (ar->team->rank != 0)
5829 : {
5830 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5831 : &ar->team->where);
5832 0 : return false;
5833 : }
5834 :
5835 60 : if (ar->team->ts.type != BT_INTEGER)
5836 : {
5837 6 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5838 : "type, found %s",
5839 6 : &ar->team->where,
5840 : gfc_basic_typename (ar->team->ts.type));
5841 6 : return false;
5842 : }
5843 : }
5844 14008 : else if (ar->team_type == TEAM_TEAM)
5845 : {
5846 42 : if (!gfc_resolve_expr (ar->team))
5847 : return false;
5848 :
5849 42 : if (ar->team->rank != 0)
5850 : {
5851 3 : gfc_error ("TEAM argument at %L must be scalar",
5852 : &ar->team->where);
5853 3 : return false;
5854 : }
5855 :
5856 39 : if (ar->team->ts.type != BT_DERIVED
5857 36 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5858 36 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5859 : {
5860 3 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5861 : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5862 3 : &ar->team->where,
5863 : gfc_basic_typename (ar->team->ts.type));
5864 3 : return false;
5865 : }
5866 : }
5867 14056 : if (ar->stat)
5868 : {
5869 62 : if (!gfc_resolve_expr (ar->stat))
5870 : return false;
5871 :
5872 62 : if (ar->stat->rank != 0)
5873 : {
5874 3 : gfc_error ("STAT argument at %L must be scalar",
5875 : &ar->stat->where);
5876 3 : return false;
5877 : }
5878 :
5879 59 : if (ar->stat->ts.type != BT_INTEGER)
5880 : {
5881 3 : gfc_error ("STAT argument at %L must be of INTEGER "
5882 : "type, found %s",
5883 3 : &ar->stat->where,
5884 : gfc_basic_typename (ar->stat->ts.type));
5885 3 : return false;
5886 : }
5887 :
5888 56 : if (ar->stat->expr_type != EXPR_VARIABLE)
5889 : {
5890 0 : gfc_error ("STAT's expression at %L must be a variable",
5891 : &ar->stat->where);
5892 0 : return false;
5893 : }
5894 : }
5895 : }
5896 : return true;
5897 : }
5898 :
5899 :
5900 : bool
5901 8895 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5902 : {
5903 8895 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5904 :
5905 8895 : if (ref->u.ss.start != NULL)
5906 : {
5907 8895 : if (!gfc_resolve_expr (ref->u.ss.start))
5908 : return false;
5909 :
5910 8895 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5911 : {
5912 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5913 : &ref->u.ss.start->where);
5914 1 : return false;
5915 : }
5916 :
5917 8894 : if (ref->u.ss.start->rank != 0)
5918 : {
5919 0 : gfc_error ("Substring start index at %L must be scalar",
5920 : &ref->u.ss.start->where);
5921 0 : return false;
5922 : }
5923 :
5924 8894 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5925 8894 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5926 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5927 : {
5928 1 : gfc_error ("Substring start index at %L is less than one",
5929 : &ref->u.ss.start->where);
5930 1 : return false;
5931 : }
5932 : }
5933 :
5934 8893 : if (ref->u.ss.end != NULL)
5935 : {
5936 8699 : if (!gfc_resolve_expr (ref->u.ss.end))
5937 : return false;
5938 :
5939 8699 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5940 : {
5941 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5942 : &ref->u.ss.end->where);
5943 1 : return false;
5944 : }
5945 :
5946 8698 : if (ref->u.ss.end->rank != 0)
5947 : {
5948 0 : gfc_error ("Substring end index at %L must be scalar",
5949 : &ref->u.ss.end->where);
5950 0 : return false;
5951 : }
5952 :
5953 8698 : if (ref->u.ss.length != NULL
5954 8361 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5955 8710 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5956 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5957 : {
5958 4 : gfc_error ("Substring end index at %L exceeds the string length",
5959 : &ref->u.ss.start->where);
5960 4 : return false;
5961 : }
5962 :
5963 8694 : if (compare_bound_mpz_t (ref->u.ss.end,
5964 8694 : gfc_integer_kinds[k].huge) == CMP_GT
5965 8694 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5966 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5967 : {
5968 4 : gfc_error ("Substring end index at %L is too large",
5969 : &ref->u.ss.end->where);
5970 4 : return false;
5971 : }
5972 : /* If the substring has the same length as the original
5973 : variable, the reference itself can be deleted. */
5974 :
5975 8690 : if (ref->u.ss.length != NULL
5976 8353 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5977 9606 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5978 230 : *equal_length = true;
5979 : }
5980 :
5981 : return true;
5982 : }
5983 :
5984 :
5985 : /* This function supplies missing substring charlens. */
5986 :
5987 : void
5988 4576 : gfc_resolve_substring_charlen (gfc_expr *e)
5989 : {
5990 4576 : gfc_ref *char_ref;
5991 4576 : gfc_expr *start, *end;
5992 4576 : gfc_typespec *ts = NULL;
5993 4576 : mpz_t diff;
5994 :
5995 8913 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5996 : {
5997 7066 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5998 : break;
5999 4337 : if (char_ref->type == REF_COMPONENT)
6000 328 : ts = &char_ref->u.c.component->ts;
6001 : }
6002 :
6003 4576 : if (!char_ref || char_ref->type == REF_INQUIRY)
6004 1909 : return;
6005 :
6006 2729 : gcc_assert (char_ref->next == NULL);
6007 :
6008 2729 : if (e->ts.u.cl)
6009 : {
6010 120 : if (e->ts.u.cl->length)
6011 108 : gfc_free_expr (e->ts.u.cl->length);
6012 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
6013 : return;
6014 : }
6015 :
6016 2717 : if (!e->ts.u.cl)
6017 2609 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6018 :
6019 2717 : if (char_ref->u.ss.start)
6020 2717 : start = gfc_copy_expr (char_ref->u.ss.start);
6021 : else
6022 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
6023 :
6024 2717 : if (char_ref->u.ss.end)
6025 2667 : end = gfc_copy_expr (char_ref->u.ss.end);
6026 50 : else if (e->expr_type == EXPR_VARIABLE)
6027 : {
6028 50 : if (!ts)
6029 32 : ts = &e->symtree->n.sym->ts;
6030 50 : end = gfc_copy_expr (ts->u.cl->length);
6031 : }
6032 : else
6033 : end = NULL;
6034 :
6035 2717 : if (!start || !end)
6036 : {
6037 50 : gfc_free_expr (start);
6038 50 : gfc_free_expr (end);
6039 50 : return;
6040 : }
6041 :
6042 : /* Length = (end - start + 1).
6043 : Check first whether it has a constant length. */
6044 2667 : if (gfc_dep_difference (end, start, &diff))
6045 : {
6046 2551 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
6047 : &e->where);
6048 :
6049 2551 : mpz_add_ui (len->value.integer, diff, 1);
6050 2551 : mpz_clear (diff);
6051 2551 : e->ts.u.cl->length = len;
6052 : /* The check for length < 0 is handled below */
6053 : }
6054 : else
6055 : {
6056 116 : e->ts.u.cl->length = gfc_subtract (end, start);
6057 116 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
6058 : gfc_get_int_expr (gfc_charlen_int_kind,
6059 : NULL, 1));
6060 : }
6061 :
6062 : /* F2008, 6.4.1: Both the starting point and the ending point shall
6063 : be within the range 1, 2, ..., n unless the starting point exceeds
6064 : the ending point, in which case the substring has length zero. */
6065 :
6066 2667 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
6067 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
6068 :
6069 2667 : e->ts.u.cl->length->ts.type = BT_INTEGER;
6070 2667 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6071 :
6072 : /* Make sure that the length is simplified. */
6073 2667 : gfc_simplify_expr (e->ts.u.cl->length, 1);
6074 2667 : gfc_resolve_expr (e->ts.u.cl->length);
6075 : }
6076 :
6077 :
6078 : /* Convert an array reference to an array element so that PDT KIND and LEN
6079 : or inquiry references are always scalar. */
6080 :
6081 : static void
6082 27 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
6083 : {
6084 27 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6085 27 : int dim;
6086 :
6087 27 : array_ref->u.ar.type = AR_ELEMENT;
6088 27 : expr->rank = 0;
6089 : /* Suppress the runtime bounds check. */
6090 27 : expr->no_bounds_check = 1;
6091 54 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
6092 : {
6093 27 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
6094 27 : if (array_ref->u.ar.start[dim])
6095 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
6096 :
6097 27 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
6098 9 : array_ref->u.ar.start[dim]
6099 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
6100 : else
6101 18 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
6102 :
6103 27 : if (array_ref->u.ar.end[dim])
6104 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
6105 27 : if (array_ref->u.ar.stride[dim])
6106 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
6107 : }
6108 27 : gfc_free_expr (unity);
6109 27 : }
6110 :
6111 :
6112 : /* Resolve subtype references. */
6113 :
6114 : bool
6115 554341 : gfc_resolve_ref (gfc_expr *expr)
6116 : {
6117 554341 : int current_part_dimension, n_components, seen_part_dimension;
6118 554341 : gfc_ref *ref, **prev, *array_ref;
6119 554341 : bool equal_length;
6120 554341 : gfc_symbol *last_pdt = NULL;
6121 :
6122 1090122 : for (ref = expr->ref; ref; ref = ref->next)
6123 536699 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6124 : {
6125 918 : if (!find_array_spec (expr))
6126 : return false;
6127 : break;
6128 : }
6129 :
6130 1627659 : for (prev = &expr->ref; *prev != NULL;
6131 536765 : prev = *prev == NULL ? prev : &(*prev)->next)
6132 536844 : switch ((*prev)->type)
6133 : {
6134 435015 : case REF_ARRAY:
6135 435015 : if (!resolve_array_ref (&(*prev)->u.ar))
6136 : return false;
6137 : break;
6138 :
6139 : case REF_COMPONENT:
6140 : case REF_INQUIRY:
6141 : break;
6142 :
6143 8614 : case REF_SUBSTRING:
6144 8614 : equal_length = false;
6145 8614 : if (!gfc_resolve_substring (*prev, &equal_length))
6146 : return false;
6147 :
6148 8606 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6149 : {
6150 : /* Remove the reference and move the charlen, if any. */
6151 205 : ref = *prev;
6152 205 : *prev = ref->next;
6153 205 : ref->next = NULL;
6154 205 : expr->ts.u.cl = ref->u.ss.length;
6155 205 : ref->u.ss.length = NULL;
6156 205 : gfc_free_ref_list (ref);
6157 : }
6158 : break;
6159 : }
6160 :
6161 : /* Check constraints on part references. */
6162 :
6163 554255 : current_part_dimension = 0;
6164 554255 : seen_part_dimension = 0;
6165 554255 : n_components = 0;
6166 554255 : array_ref = NULL;
6167 :
6168 : /* Use the declared type of the base symbol to initialize last_pdt when the
6169 : expression is not itself a PDT. This matters for ASSOCIATE variables whose
6170 : component reference may still point to a PDT template. */
6171 554255 : if (expr->expr_type == EXPR_VARIABLE
6172 459741 : && (IS_PDT (expr)
6173 459165 : || (expr->ref && expr->symtree && IS_PDT (expr->symtree->n.sym))))
6174 3059 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6175 :
6176 1090790 : for (ref = expr->ref; ref; ref = ref->next)
6177 : {
6178 536546 : switch (ref->type)
6179 : {
6180 434937 : case REF_ARRAY:
6181 434937 : array_ref = ref;
6182 434937 : switch (ref->u.ar.type)
6183 : {
6184 266930 : case AR_FULL:
6185 : /* Coarray scalar. */
6186 266930 : if (ref->u.ar.as->rank == 0)
6187 : {
6188 : current_part_dimension = 0;
6189 : break;
6190 : }
6191 : /* Fall through. */
6192 308554 : case AR_SECTION:
6193 308554 : current_part_dimension = 1;
6194 308554 : break;
6195 :
6196 126383 : case AR_ELEMENT:
6197 126383 : array_ref = NULL;
6198 126383 : current_part_dimension = 0;
6199 126383 : break;
6200 :
6201 0 : case AR_UNKNOWN:
6202 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6203 : }
6204 :
6205 : break;
6206 :
6207 92291 : case REF_COMPONENT:
6208 92291 : if (current_part_dimension || seen_part_dimension)
6209 : {
6210 : /* F03:C614. */
6211 7333 : if (ref->u.c.component->attr.pointer
6212 7330 : || ref->u.c.component->attr.proc_pointer
6213 7329 : || (ref->u.c.component->ts.type == BT_CLASS
6214 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6215 : {
6216 4 : gfc_error ("Component to the right of a part reference "
6217 : "with nonzero rank must not have the POINTER "
6218 : "attribute at %L", &expr->where);
6219 4 : return false;
6220 : }
6221 7329 : else if (ref->u.c.component->attr.allocatable
6222 7323 : || (ref->u.c.component->ts.type == BT_CLASS
6223 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6224 :
6225 : {
6226 7 : gfc_error ("Component to the right of a part reference "
6227 : "with nonzero rank must not have the ALLOCATABLE "
6228 : "attribute at %L", &expr->where);
6229 7 : return false;
6230 : }
6231 : }
6232 :
6233 : /* Sometimes the component in a component reference is that of the
6234 : pdt_template. Point to the component of pdt_type instead. This
6235 : ensures that the component gets a backend_decl in translation. */
6236 92280 : if (last_pdt)
6237 : {
6238 2996 : gfc_component *cmp = last_pdt->components;
6239 8853 : for (; cmp; cmp = cmp->next)
6240 8584 : if (!strcmp (cmp->name, ref->u.c.component->name))
6241 : {
6242 2727 : ref->u.c.component = cmp;
6243 2727 : break;
6244 : }
6245 2996 : ref->u.c.sym = last_pdt;
6246 : }
6247 :
6248 : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6249 92280 : if (ref->u.c.component->ts.type == BT_DERIVED)
6250 : {
6251 21194 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6252 : {
6253 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6254 : &ref->u.c.component->ts.u.derived,
6255 : NULL) != MATCH_YES)
6256 : return false;
6257 0 : last_pdt = ref->u.c.component->ts.u.derived;
6258 : }
6259 21194 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6260 533 : last_pdt = ref->u.c.component->ts.u.derived;
6261 : else
6262 : last_pdt = NULL;
6263 : }
6264 :
6265 : /* The F08 standard requires(See R425, R431, R435, and in particular
6266 : Note 6.7) that a PDT parameter reference be a scalar even if
6267 : the designator is an array." */
6268 92280 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6269 149 : && (ref->u.c.component->attr.pdt_kind
6270 149 : || ref->u.c.component->attr.pdt_len))
6271 7 : reset_array_ref_to_scalar (expr, array_ref);
6272 :
6273 92280 : n_components++;
6274 92280 : break;
6275 :
6276 : case REF_SUBSTRING:
6277 : break;
6278 :
6279 917 : case REF_INQUIRY:
6280 : /* Implement requirement in note 9.7 of F2018 that the result of the
6281 : LEN inquiry be a scalar. */
6282 917 : if (ref->u.i == INQUIRY_LEN && array_ref
6283 46 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6284 46 : || expr->ts.type == BT_INTEGER))
6285 20 : reset_array_ref_to_scalar (expr, array_ref);
6286 : break;
6287 : }
6288 :
6289 536535 : if (((ref->type == REF_COMPONENT && n_components > 1)
6290 523038 : || ref->next == NULL)
6291 : && current_part_dimension
6292 469143 : && seen_part_dimension)
6293 : {
6294 0 : gfc_error ("Two or more part references with nonzero rank must "
6295 : "not be specified at %L", &expr->where);
6296 0 : return false;
6297 : }
6298 :
6299 536535 : if (ref->type == REF_COMPONENT)
6300 : {
6301 92280 : if (current_part_dimension)
6302 7135 : seen_part_dimension = 1;
6303 :
6304 : /* reset to make sure */
6305 : current_part_dimension = 0;
6306 : }
6307 : }
6308 :
6309 : return true;
6310 : }
6311 :
6312 :
6313 : /* Given an expression, determine its shape. This is easier than it sounds.
6314 : Leaves the shape array NULL if it is not possible to determine the shape. */
6315 :
6316 : static void
6317 2634294 : expression_shape (gfc_expr *e)
6318 : {
6319 2634294 : mpz_t array[GFC_MAX_DIMENSIONS];
6320 2634294 : int i;
6321 :
6322 2634294 : if (e->rank <= 0 || e->shape != NULL)
6323 2453689 : return;
6324 :
6325 719788 : for (i = 0; i < e->rank; i++)
6326 486027 : if (!gfc_array_dimen_size (e, i, &array[i]))
6327 180605 : goto fail;
6328 :
6329 233761 : e->shape = gfc_get_shape (e->rank);
6330 :
6331 233761 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6332 :
6333 233761 : return;
6334 :
6335 180605 : fail:
6336 182300 : for (i--; i >= 0; i--)
6337 1695 : mpz_clear (array[i]);
6338 : }
6339 :
6340 :
6341 : /* Given a variable expression node, compute the rank of the expression by
6342 : examining the base symbol and any reference structures it may have. */
6343 :
6344 : void
6345 2634294 : gfc_expression_rank (gfc_expr *e)
6346 : {
6347 2634294 : gfc_ref *ref, *coarray_ref = nullptr;
6348 2634294 : int i, rank, corank;
6349 :
6350 : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6351 : could lead to serious confusion... */
6352 2634294 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6353 :
6354 2634294 : if (e->ref == NULL)
6355 : {
6356 1937399 : if (e->expr_type == EXPR_ARRAY)
6357 73871 : goto done;
6358 : /* Constructors can have a rank different from one via RESHAPE(). */
6359 :
6360 1863528 : if (e->symtree != NULL)
6361 : {
6362 : /* After errors the ts.u.derived of a CLASS might not be set. */
6363 1863516 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6364 14135 : && e->symtree->n.sym->ts.u.derived
6365 14130 : && CLASS_DATA (e->symtree->n.sym))
6366 1863516 : ? CLASS_DATA (e->symtree->n.sym)->as
6367 : : e->symtree->n.sym->as;
6368 1863516 : if (as)
6369 : {
6370 638 : e->rank = as->rank;
6371 638 : e->corank = as->corank;
6372 638 : goto done;
6373 : }
6374 : }
6375 1862890 : e->rank = 0;
6376 1862890 : e->corank = 0;
6377 1862890 : goto done;
6378 : }
6379 :
6380 : rank = 0;
6381 : corank = 0;
6382 :
6383 1103089 : for (ref = e->ref; ref; ref = ref->next)
6384 : {
6385 807735 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6386 574 : && ref->u.c.component->attr.function && !ref->next)
6387 : {
6388 378 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6389 378 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6390 : }
6391 :
6392 : /* F2018:5.4.7(5): an allocatable or pointer component selector ends the
6393 : codimensions inherited from an enclosing coarray. */
6394 807735 : if (ref->type == REF_COMPONENT)
6395 : {
6396 155511 : gfc_component *comp = ref->u.c.component;
6397 :
6398 155511 : if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
6399 : {
6400 7021 : if (CLASS_DATA (comp)->attr.class_pointer
6401 5560 : || CLASS_DATA (comp)->attr.allocatable)
6402 807735 : coarray_ref = nullptr;
6403 : }
6404 148490 : else if (comp->attr.pointer || comp->attr.allocatable)
6405 807735 : coarray_ref = nullptr;
6406 : }
6407 :
6408 807735 : if (ref->type != REF_ARRAY)
6409 163188 : continue;
6410 :
6411 644547 : if (!coarray_ref && ref->u.ar.as && ref->u.ar.as->corank > 0)
6412 644547 : coarray_ref = ref;
6413 644547 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6414 : {
6415 355170 : rank = ref->u.ar.as->rank;
6416 355170 : break;
6417 : }
6418 :
6419 289377 : if (ref->u.ar.type == AR_SECTION)
6420 : {
6421 : /* Figure out the rank of the section. */
6422 46371 : if (rank != 0)
6423 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6424 :
6425 115552 : for (i = 0; i < ref->u.ar.dimen; i++)
6426 69181 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6427 69181 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6428 60255 : rank++;
6429 :
6430 : break;
6431 : }
6432 : }
6433 : /* The codimensions come from the reference carrying them, which need not be
6434 : the last array reference: a subobject of a coarray is itself a coarray. */
6435 696895 : if (coarray_ref && coarray_ref->u.ar.as->rank != -1)
6436 : {
6437 19457 : for (i = coarray_ref->u.ar.as->rank;
6438 35967 : i < coarray_ref->u.ar.as->rank + coarray_ref->u.ar.as->corank; ++i)
6439 : {
6440 : /* For unknown dimen in non-resolved as assume full corank. */
6441 20478 : if (coarray_ref->u.ar.dimen_type[i] == DIMEN_STAR
6442 19852 : || (coarray_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6443 395 : && !coarray_ref->u.ar.as->resolved))
6444 : {
6445 : corank = coarray_ref->u.ar.as->corank;
6446 : break;
6447 : }
6448 19457 : else if (coarray_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6449 19457 : || coarray_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6450 19359 : || coarray_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6451 16943 : corank++;
6452 2514 : else if (coarray_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6453 0 : gfc_internal_error ("Illegal coarray index");
6454 : }
6455 : }
6456 :
6457 696895 : e->rank = rank;
6458 696895 : e->corank = corank;
6459 :
6460 2634294 : done:
6461 2634294 : expression_shape (e);
6462 2634294 : }
6463 :
6464 :
6465 : /* Given two expressions, check that their rank is conformable, i.e. either
6466 : both have the same rank or at least one is a scalar. */
6467 :
6468 : bool
6469 12252779 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6470 : {
6471 12252779 : if (op1->expr_type == EXPR_VARIABLE)
6472 743531 : gfc_expression_rank (op1);
6473 12252779 : if (op2->expr_type == EXPR_VARIABLE)
6474 448784 : gfc_expression_rank (op2);
6475 :
6476 78983 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6477 12331436 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6478 30 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6479 : }
6480 :
6481 :
6482 : /* Given an expression EXPR that is a variable, figure out what the ultimate
6483 : variable's type is and store it in TS, traversing the reference structures
6484 : if necessary.
6485 :
6486 : We start at the base symbol and store the type. Component references
6487 : overwrite a completely new type. */
6488 :
6489 : static void
6490 1333932 : get_data_ref_type (gfc_expr *expr, gfc_typespec *ts)
6491 : {
6492 1333932 : gfc_ref *ref;
6493 1333932 : gfc_symbol *sym;
6494 1333932 : gfc_component *comp;
6495 1333932 : bool has_inquiry_part;
6496 1333932 : bool has_substring_ref = false;
6497 :
6498 1333932 : if (expr->expr_type != EXPR_VARIABLE
6499 14 : && expr->expr_type != EXPR_FUNCTION
6500 0 : && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
6501 0 : gfc_internal_error ("get_data_ref_type(): Expression isn't a variable");
6502 :
6503 1333932 : sym = expr->symtree->n.sym;
6504 :
6505 1333932 : if (ts != NULL && expr->ts.type == BT_UNKNOWN)
6506 53189 : *ts = sym->ts;
6507 :
6508 : /* Catch left-overs from match_actual_arg, where an actual argument of a
6509 : procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
6510 : needed for structure constructors in DATA statements, where a pointer
6511 : is associated with a data target, and the argument has not been fully
6512 : resolved yet. Components references are dealt with further below. */
6513 53189 : if (ts != NULL
6514 1333932 : && expr->ts.type == BT_PROCEDURE
6515 3076 : && expr->ref == NULL
6516 3076 : && sym->attr.flavor != FL_PROCEDURE
6517 125 : && sym->attr.target)
6518 1 : *ts = sym->ts;
6519 :
6520 1333932 : has_inquiry_part = false;
6521 1850424 : for (ref = expr->ref; ref; ref = ref->next)
6522 517250 : if (ref->type == REF_SUBSTRING)
6523 : has_substring_ref = true;
6524 509642 : else if (ref->type == REF_INQUIRY)
6525 : {
6526 : has_inquiry_part = true;
6527 : break;
6528 : }
6529 :
6530 1851189 : for (ref = expr->ref; ref; ref = ref->next)
6531 517257 : switch (ref->type)
6532 : {
6533 90320 : case REF_COMPONENT:
6534 90320 : comp = ref->u.c.component;
6535 90320 : if (ts != NULL && !has_inquiry_part)
6536 : {
6537 90223 : *ts = comp->ts;
6538 : /* Don't set the string length if a substring reference
6539 : follows. */
6540 90223 : if (ts->type == BT_CHARACTER && has_substring_ref)
6541 294 : ts->u.cl = NULL;
6542 : }
6543 : break;
6544 :
6545 : case REF_ARRAY:
6546 : case REF_INQUIRY:
6547 : case REF_SUBSTRING:
6548 : break;
6549 : }
6550 1333932 : }
6551 :
6552 :
6553 : /* Resolve a variable expression. */
6554 :
6555 : static bool
6556 1349075 : resolve_variable (gfc_expr *e)
6557 : {
6558 1349075 : gfc_symbol *sym;
6559 1349075 : bool t;
6560 :
6561 1349075 : t = true;
6562 :
6563 1349075 : if (e->symtree == NULL)
6564 : return false;
6565 1348600 : sym = e->symtree->n.sym;
6566 :
6567 : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6568 : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6569 1348600 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6570 : {
6571 183 : if (!actual_arg || inquiry_argument)
6572 : {
6573 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6574 : "be used as actual argument", sym->name, &e->where);
6575 2 : return false;
6576 : }
6577 : }
6578 : /* TS 29113, 407b. */
6579 1348417 : else if (e->ts.type == BT_ASSUMED)
6580 : {
6581 571 : if (!actual_arg)
6582 : {
6583 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6584 : "as actual argument", sym->name, &e->where);
6585 20 : return false;
6586 : }
6587 551 : else if (inquiry_argument && !first_actual_arg)
6588 : {
6589 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6590 : for all inquiry functions in resolve_function; the reason is
6591 : that the function-name resolution happens too late in that
6592 : function. */
6593 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6594 : "an inquiry function shall be the first argument",
6595 : sym->name, &e->where);
6596 0 : return false;
6597 : }
6598 : }
6599 : /* TS 29113, C535b. */
6600 1347846 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6601 38443 : && sym->ts.u.derived && CLASS_DATA (sym)
6602 38438 : && CLASS_DATA (sym)->as
6603 15212 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6604 1346876 : || (sym->ts.type != BT_CLASS && sym->as
6605 369316 : && sym->as->type == AS_ASSUMED_RANK))
6606 8064 : && !sym->attr.select_rank_temporary
6607 8064 : && !(sym->assoc && sym->assoc->ar))
6608 : {
6609 8064 : if (!actual_arg
6610 1277 : && !(cs_base && cs_base->current
6611 1276 : && (cs_base->current->op == EXEC_SELECT_RANK
6612 188 : || sym->attr.target)))
6613 : {
6614 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6615 : "actual argument", sym->name, &e->where);
6616 144 : return false;
6617 : }
6618 7920 : else if (inquiry_argument && !first_actual_arg)
6619 : {
6620 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6621 : for all inquiry functions in resolve_function; the reason is
6622 : that the function-name resolution happens too late in that
6623 : function. */
6624 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6625 : "to an inquiry function shall be the first argument",
6626 : sym->name, &e->where);
6627 0 : return false;
6628 : }
6629 : }
6630 :
6631 1348434 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6632 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6633 180 : && e->ref->next == NULL))
6634 : {
6635 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6636 : "a subobject reference", sym->name, &e->ref->u.ar.where);
6637 1 : return false;
6638 : }
6639 : /* TS 29113, 407b. */
6640 1348433 : else if (e->ts.type == BT_ASSUMED && e->ref
6641 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6642 680 : && e->ref->next == NULL))
6643 : {
6644 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6645 : "reference", sym->name, &e->ref->u.ar.where);
6646 7 : return false;
6647 : }
6648 :
6649 : /* TS 29113, C535b. */
6650 1348426 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6651 38443 : && sym->ts.u.derived && CLASS_DATA (sym)
6652 38438 : && CLASS_DATA (sym)->as
6653 15212 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6654 1347456 : || (sym->ts.type != BT_CLASS && sym->as
6655 369852 : && sym->as->type == AS_ASSUMED_RANK))
6656 8204 : && !(sym->assoc && sym->assoc->ar)
6657 8204 : && e->ref
6658 8204 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6659 8200 : && e->ref->next == NULL))
6660 : {
6661 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6662 : "reference", sym->name, &e->ref->u.ar.where);
6663 4 : return false;
6664 : }
6665 :
6666 : /* Guessed type variables are associate_names whose selector had not been
6667 : parsed at the time that the construct was parsed. Now the namespace is
6668 : being resolved, the TKR of the selector will be available for fixup of
6669 : the associate_name. */
6670 1348422 : if (IS_INFERRED_TYPE (e) && e->ref)
6671 : {
6672 410 : gfc_fixup_inferred_type_refs (e);
6673 : /* KIND inquiry ref returns the kind of the target. */
6674 410 : if (e->expr_type == EXPR_CONSTANT)
6675 : return true;
6676 : }
6677 1348012 : else if (IS_INFERRED_TYPE (e)
6678 489 : && sym->ts.type != BT_UNKNOWN
6679 489 : && (sym->ts.type != e->ts.type || sym->ts.kind != e->ts.kind))
6680 : /* No subobject ref, but the expression's typespec was set at parse
6681 : time before the target's actual type/kind was known. Refresh from
6682 : the now-resolved associate-name symbol. */
6683 192 : e->ts = sym->ts;
6684 1347820 : else if (sym->attr.select_type_temporary
6685 9152 : && sym->ns->assoc_name_inferred)
6686 92 : gfc_fixup_inferred_type_refs (e);
6687 :
6688 : /* For variables that are used in an associate (target => object) where
6689 : the object's basetype is array valued while the target is scalar,
6690 : the ts' type of the component refs is still array valued, which
6691 : can't be translated that way. */
6692 1348410 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6693 605 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6694 605 : && sym->assoc->target->ts.u.derived
6695 605 : && CLASS_DATA (sym->assoc->target)
6696 605 : && CLASS_DATA (sym->assoc->target)->as)
6697 : {
6698 : gfc_ref *ref = e->ref;
6699 701 : while (ref)
6700 : {
6701 542 : switch (ref->type)
6702 : {
6703 237 : case REF_COMPONENT:
6704 237 : ref->u.c.sym = sym->ts.u.derived;
6705 : /* Stop the loop. */
6706 237 : ref = NULL;
6707 237 : break;
6708 305 : default:
6709 305 : ref = ref->next;
6710 305 : break;
6711 : }
6712 : }
6713 : }
6714 :
6715 : /* If this is an associate-name, it may be parsed with an array reference
6716 : in error even though the target is scalar. Fail directly in this case.
6717 : TODO Understand why class scalar expressions must be excluded. */
6718 1348410 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6719 : {
6720 12495 : if (sym->ts.type == BT_CLASS)
6721 245 : gfc_fix_class_refs (e);
6722 12495 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6723 2330 : && e->ref->type == REF_ARRAY)
6724 : {
6725 : /* Unambiguously scalar! */
6726 3 : if (sym->assoc->target
6727 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6728 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6729 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6730 : sym->name, &e->where);
6731 : return false;
6732 : }
6733 12492 : else if ((sym->attr.dimension || sym->attr.codimension)
6734 7204 : && (!e->ref || e->ref->type != REF_ARRAY))
6735 : {
6736 : /* This can happen because the parser did not detect that the
6737 : associate name is an array and the expression had no array
6738 : part_ref. */
6739 225 : gfc_ref *ref = gfc_get_ref ();
6740 225 : ref->type = REF_ARRAY;
6741 225 : ref->u.ar.type = AR_FULL;
6742 225 : if (sym->as)
6743 : {
6744 224 : ref->u.ar.as = sym->as;
6745 224 : ref->u.ar.dimen = sym->as->rank;
6746 : }
6747 225 : ref->next = e->ref;
6748 225 : e->ref = ref;
6749 : }
6750 : }
6751 :
6752 1348407 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6753 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6754 :
6755 : /* On the other hand, the parser may not have known this is an array;
6756 : in this case, we have to add a FULL reference. */
6757 1348407 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6758 : {
6759 0 : e->ref = gfc_get_ref ();
6760 0 : e->ref->type = REF_ARRAY;
6761 0 : e->ref->u.ar.type = AR_FULL;
6762 0 : e->ref->u.ar.dimen = 0;
6763 : }
6764 :
6765 : /* Like above, but for class types, where the checking whether an array
6766 : ref is present is more complicated. Furthermore make sure not to add
6767 : the full array ref to _vptr or _len refs. */
6768 1348407 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6769 1023 : && CLASS_DATA (sym)
6770 1023 : && (CLASS_DATA (sym)->attr.dimension
6771 449 : || CLASS_DATA (sym)->attr.codimension)
6772 580 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6773 : {
6774 555 : gfc_ref *ref, *newref;
6775 :
6776 555 : newref = gfc_get_ref ();
6777 555 : newref->type = REF_ARRAY;
6778 555 : newref->u.ar.type = AR_FULL;
6779 555 : newref->u.ar.dimen = 0;
6780 :
6781 : /* Because this is an associate var and the first ref either is a ref to
6782 : the _data component or not, no traversal of the ref chain is
6783 : needed. The array ref needs to be inserted after the _data ref,
6784 : or when that is not present, which may happened for polymorphic
6785 : types, then at the first position. */
6786 555 : ref = e->ref;
6787 555 : if (!ref)
6788 18 : e->ref = newref;
6789 537 : else if (ref->type == REF_COMPONENT
6790 232 : && strcmp ("_data", ref->u.c.component->name) == 0)
6791 : {
6792 232 : if (!ref->next || ref->next->type != REF_ARRAY)
6793 : {
6794 12 : newref->next = ref->next;
6795 12 : ref->next = newref;
6796 : }
6797 : else
6798 : /* Array ref present already. */
6799 220 : gfc_free_ref_list (newref);
6800 : }
6801 305 : else if (ref->type == REF_ARRAY)
6802 : /* Array ref present already. */
6803 305 : gfc_free_ref_list (newref);
6804 : else
6805 : {
6806 0 : newref->next = ref;
6807 0 : e->ref = newref;
6808 : }
6809 : }
6810 1347852 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6811 : {
6812 810 : gfc_ref *ref;
6813 1282 : for (ref = e->ref; ref; ref = ref->next)
6814 562 : if (ref->type == REF_SUBSTRING || ref->type == REF_INQUIRY)
6815 : break;
6816 810 : if (ref == NULL)
6817 720 : e->ts = sym->ts;
6818 : }
6819 :
6820 1348407 : if (e->ref && !gfc_resolve_ref (e))
6821 : return false;
6822 :
6823 1348314 : if (sym->attr.flavor == FL_PROCEDURE
6824 32684 : && (!sym->attr.function
6825 19074 : || (sym->attr.function && sym->result
6826 18619 : && sym->result->attr.proc_pointer
6827 726 : && !sym->result->attr.function)))
6828 : {
6829 13610 : e->ts.type = BT_PROCEDURE;
6830 13610 : goto resolve_procedure;
6831 : }
6832 :
6833 1334704 : if (sym->ts.type != BT_UNKNOWN)
6834 1333932 : get_data_ref_type (e, &e->ts);
6835 772 : else if (sym->attr.flavor == FL_PROCEDURE
6836 12 : && sym->attr.function && sym->result
6837 12 : && sym->result->ts.type != BT_UNKNOWN
6838 10 : && sym->result->attr.proc_pointer)
6839 10 : e->ts = sym->result->ts;
6840 : else
6841 : {
6842 : /* Must be a simple variable reference. */
6843 762 : if (!gfc_set_default_type (sym, 1, sym->ns))
6844 : return false;
6845 633 : e->ts = sym->ts;
6846 : }
6847 :
6848 1334575 : if (check_assumed_size_reference (sym, e))
6849 : return false;
6850 :
6851 : /* Deal with forward references to entries during gfc_resolve_code, to
6852 : satisfy, at least partially, 12.5.2.5. */
6853 1334556 : if (gfc_current_ns->entries
6854 3229 : && current_entry_id == sym->entry_id
6855 1050 : && cs_base
6856 964 : && cs_base->current
6857 964 : && cs_base->current->op != EXEC_ENTRY)
6858 : {
6859 964 : int n;
6860 964 : bool saved_specification_expr;
6861 964 : gfc_symbol *saved_specification_expr_symbol;
6862 :
6863 : /* If the symbol is a dummy... */
6864 964 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6865 : {
6866 : /* If it has not been seen as a dummy, this is an error. */
6867 462 : if (!entry_dummy_seen_p (sym))
6868 : {
6869 5 : if (specification_expr
6870 4 : && specification_expr_symbol
6871 4 : && specification_expr_symbol->attr.dummy
6872 2 : && specification_expr_symbol->ns == gfc_current_ns
6873 7 : && !entry_dummy_seen_p (specification_expr_symbol))
6874 : ;
6875 3 : else if (specification_expr)
6876 2 : gfc_error ("Variable %qs, used in a specification expression"
6877 : ", is referenced at %L before the ENTRY statement "
6878 : "in which it is a parameter",
6879 : sym->name, &cs_base->current->loc);
6880 : else
6881 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6882 : "statement in which it is a parameter",
6883 : sym->name, &cs_base->current->loc);
6884 : t = false;
6885 : }
6886 : }
6887 :
6888 : /* Now do the same check on the specification expressions. */
6889 964 : saved_specification_expr = specification_expr;
6890 964 : saved_specification_expr_symbol = specification_expr_symbol;
6891 964 : specification_expr = true;
6892 964 : specification_expr_symbol = sym;
6893 964 : if (sym->ts.type == BT_CHARACTER
6894 964 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6895 : t = false;
6896 :
6897 964 : if (sym->as)
6898 : {
6899 279 : for (n = 0; n < sym->as->rank; n++)
6900 : {
6901 164 : if (!gfc_resolve_expr (sym->as->lower[n]))
6902 0 : t = false;
6903 164 : if (!gfc_resolve_expr (sym->as->upper[n]))
6904 1 : t = false;
6905 : }
6906 : }
6907 964 : specification_expr = saved_specification_expr;
6908 964 : specification_expr_symbol = saved_specification_expr_symbol;
6909 :
6910 964 : if (t)
6911 : /* Update the symbol's entry level. */
6912 957 : sym->entry_id = current_entry_id + 1;
6913 : }
6914 :
6915 : /* If a symbol has been host_associated mark it. This is used latter,
6916 : to identify if aliasing is possible via host association. */
6917 1334556 : if (sym->attr.flavor == FL_VARIABLE
6918 1295668 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6919 6234 : || !sym->ns->code->ext.block.assoc)
6920 1293560 : && gfc_current_ns->parent
6921 618065 : && (gfc_current_ns->parent == sym->ns
6922 578361 : || (gfc_current_ns->parent->parent
6923 12425 : && gfc_current_ns->parent->parent == sym->ns)))
6924 46415 : sym->attr.host_assoc = 1;
6925 :
6926 1334556 : if (gfc_current_ns->proc_name
6927 1330190 : && sym->attr.dimension
6928 363040 : && (sym->ns != gfc_current_ns
6929 338624 : || sym->attr.use_assoc
6930 334487 : || sym->attr.in_common))
6931 33342 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6932 :
6933 1348166 : resolve_procedure:
6934 1348166 : if (t && !resolve_procedure_expression (e))
6935 : t = false;
6936 :
6937 : /* F2008, C617 and C1229. */
6938 1347052 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6939 1449419 : && gfc_is_coindexed (e))
6940 : {
6941 368 : gfc_ref *ref, *ref2 = NULL;
6942 :
6943 451 : for (ref = e->ref; ref; ref = ref->next)
6944 : {
6945 451 : if (ref->type == REF_COMPONENT)
6946 83 : ref2 = ref;
6947 451 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6948 : break;
6949 : }
6950 :
6951 736 : for ( ; ref; ref = ref->next)
6952 380 : if (ref->type == REF_COMPONENT)
6953 : break;
6954 :
6955 : /* Expression itself is not coindexed object. */
6956 368 : if (ref && e->ts.type == BT_CLASS)
6957 : {
6958 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6959 : &e->where);
6960 3 : t = false;
6961 : }
6962 :
6963 : /* Expression itself is coindexed object. */
6964 : if (ref == NULL)
6965 : {
6966 356 : gfc_component *c;
6967 356 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6968 476 : for ( ; c; c = c->next)
6969 120 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6970 : {
6971 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6972 : "subcomponent at %L", &e->where);
6973 0 : t = false;
6974 0 : break;
6975 : }
6976 : }
6977 : }
6978 :
6979 1348166 : if (t)
6980 1348156 : gfc_expression_rank (e);
6981 :
6982 1348166 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6983 3 : gfc_warning (OPT_Wdeprecated_declarations,
6984 : "Using variable %qs at %L is deprecated",
6985 : sym->name, &e->where);
6986 : /* Simplify cases where access to a parameter array results in a
6987 : single constant. Suppress errors since those will have been
6988 : issued before, as warnings. */
6989 1348166 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6990 : {
6991 2743 : gfc_push_suppress_errors ();
6992 2743 : gfc_simplify_expr (e, 1);
6993 2743 : gfc_pop_suppress_errors ();
6994 : }
6995 :
6996 : return t;
6997 : }
6998 :
6999 :
7000 : /* 'sym' was initially guessed to be derived type but has been corrected
7001 : in resolve_assoc_var to be a class entity or the derived type correcting.
7002 : If a class entity it will certainly need the _data reference or the
7003 : reference derived type symbol correcting in the first component ref if
7004 : a derived type. */
7005 :
7006 : void
7007 920 : gfc_fixup_inferred_type_refs (gfc_expr *e)
7008 : {
7009 920 : gfc_ref *ref, *new_ref;
7010 920 : gfc_symbol *sym, *derived;
7011 920 : gfc_expr *target;
7012 920 : sym = e->symtree->n.sym;
7013 :
7014 : /* An associate_name whose selector is (i) a component ref of a selector
7015 : that is a inferred type associate_name; or (ii) an intrinsic type that
7016 : has been inferred from an inquiry ref. */
7017 920 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7018 : {
7019 318 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
7020 318 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
7021 318 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
7022 : {
7023 60 : ref = e->ref;
7024 : /* A substring misidentified as an array section. */
7025 60 : if (sym->ts.type == BT_CHARACTER
7026 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
7027 6 : && !ref->u.ar.stride[0])
7028 : {
7029 6 : new_ref = gfc_get_ref ();
7030 6 : new_ref->type = REF_SUBSTRING;
7031 6 : new_ref->u.ss.start = ref->u.ar.start[0];
7032 6 : new_ref->u.ss.end = ref->u.ar.end[0];
7033 6 : new_ref->u.ss.length = sym->ts.u.cl;
7034 6 : *ref = *new_ref;
7035 6 : free (new_ref);
7036 : }
7037 : else
7038 : {
7039 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
7040 24 : gfc_error ("Invalid array reference at %L", &e->where);
7041 54 : e->ref = ref->next;
7042 54 : free (ref);
7043 : }
7044 : }
7045 :
7046 : /* It is possible for an inquiry reference to be mistaken for a
7047 : component reference. Correct this now. */
7048 318 : ref = e->ref;
7049 318 : if (ref && ref->type == REF_ARRAY)
7050 138 : ref = ref->next;
7051 186 : if (ref && ref->type == REF_COMPONENT
7052 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
7053 : {
7054 12 : e->symtree->n.sym = sym;
7055 12 : *ref = *new_ref;
7056 12 : gfc_free_ref_list (new_ref);
7057 : }
7058 :
7059 : /* The kind of the associate name is best evaluated directly from the
7060 : selector because of the guesses made in primary.cc, when the type
7061 : is still unknown. */
7062 318 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
7063 : {
7064 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
7065 12 : sym->assoc->target->ts.kind);
7066 12 : gfc_replace_expr (e, ne);
7067 12 : }
7068 174 : else if (ref && ref->type == REF_INQUIRY
7069 150 : && (ref->u.i == INQUIRY_RE || ref->u.i == INQUIRY_IM)
7070 114 : && sym->ts.type == BT_COMPLEX
7071 114 : && e->ts.type == BT_REAL
7072 114 : && e->ts.kind != sym->ts.kind)
7073 : /* primary.cc set the inquiry-result kind to the default real kind
7074 : when the associate-name's type was inferred from %re/%im before
7075 : the target was resolved. Now use the (resolved) selector kind. */
7076 24 : e->ts.kind = sym->ts.kind;
7077 :
7078 : /* Now that the references are all sorted out, set the expression rank
7079 : and return. */
7080 318 : gfc_expression_rank (e);
7081 318 : return;
7082 : }
7083 :
7084 602 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
7085 : : sym->ts.u.derived;
7086 :
7087 : /* Ensure that class symbols have an array spec and ensure that there
7088 : is a _data field reference following class type references. */
7089 602 : if (sym->ts.type == BT_CLASS
7090 196 : && sym->assoc->target->ts.type == BT_CLASS)
7091 : {
7092 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
7093 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
7094 196 : sym->attr.dimension = 0;
7095 196 : sym->attr.codimension = 0;
7096 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
7097 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
7098 196 : if (e->ref && (e->ref->type != REF_COMPONENT
7099 160 : || e->ref->u.c.component->name[0] != '_'))
7100 : {
7101 82 : ref = gfc_get_ref ();
7102 82 : ref->type = REF_COMPONENT;
7103 82 : ref->next = e->ref;
7104 82 : e->ref = ref;
7105 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
7106 : true, true, NULL);
7107 82 : ref->u.c.sym = sym->ts.u.derived;
7108 : }
7109 : }
7110 :
7111 : /* Proceed as far as the first component reference and ensure that the
7112 : correct derived type is being used. */
7113 865 : for (ref = e->ref; ref; ref = ref->next)
7114 829 : if (ref->type == REF_COMPONENT)
7115 : {
7116 566 : if (ref->u.c.component->name[0] != '_')
7117 370 : ref->u.c.sym = derived;
7118 : else
7119 196 : ref->u.c.sym = sym->ts.u.derived;
7120 : break;
7121 : }
7122 :
7123 : /* Verify that the type inference mechanism has not introduced a spurious
7124 : array reference. This can happen with an associate name, whose selector
7125 : is an element of another inferred type. */
7126 602 : target = e->symtree->n.sym->assoc->target;
7127 602 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
7128 190 : && e != target && !target->rank)
7129 : {
7130 : /* First case: array ref after the scalar class or derived
7131 : associate_name. */
7132 190 : if (e->ref && e->ref->type == REF_ARRAY
7133 7 : && e->ref->u.ar.type != AR_ELEMENT)
7134 : {
7135 7 : ref = e->ref;
7136 7 : if (ref->u.ar.type == AR_UNKNOWN)
7137 1 : gfc_error ("Invalid array reference at %L", &e->where);
7138 7 : e->ref = ref->next;
7139 7 : free (ref);
7140 :
7141 : /* If it hasn't a ref to the '_data' field supply one. */
7142 7 : if (sym->ts.type == BT_CLASS
7143 0 : && !(e->ref->type == REF_COMPONENT
7144 0 : && strcmp (e->ref->u.c.component->name, "_data")))
7145 : {
7146 0 : gfc_ref *new_ref;
7147 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
7148 : "_data", true, true, &new_ref);
7149 0 : new_ref->next = e->ref;
7150 0 : e->ref = new_ref;
7151 : }
7152 : }
7153 : /* 2nd case: a ref to the '_data' field followed by an array ref. */
7154 183 : else if (e->ref && e->ref->type == REF_COMPONENT
7155 183 : && strcmp (e->ref->u.c.component->name, "_data") == 0
7156 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
7157 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
7158 : {
7159 0 : ref = e->ref->next;
7160 0 : if (ref->u.ar.type == AR_UNKNOWN)
7161 0 : gfc_error ("Invalid array reference at %L", &e->where);
7162 0 : e->ref->next = e->ref->next->next;
7163 0 : free (ref);
7164 : }
7165 : }
7166 :
7167 : /* Now that all the references are OK, get the expression rank. */
7168 602 : gfc_expression_rank (e);
7169 : }
7170 :
7171 :
7172 : /* Checks to see that the correct symbol has been host associated.
7173 : The only situations where this arises are:
7174 : (i) That in which a twice contained function is parsed after
7175 : the host association is made. On detecting this, change
7176 : the symbol in the expression and convert the array reference
7177 : into an actual arglist if the old symbol is a variable; or
7178 : (ii) That in which an external function is typed but not declared
7179 : explicitly to be external. Here, the old symbol is changed
7180 : from a variable to an external function. */
7181 : static bool
7182 1699256 : check_host_association (gfc_expr *e)
7183 : {
7184 1699256 : gfc_symbol *sym, *old_sym;
7185 1699256 : gfc_symtree *st;
7186 1699256 : int n;
7187 1699256 : gfc_ref *ref;
7188 1699256 : gfc_actual_arglist *arg, *tail = NULL;
7189 1699256 : bool retval = e->expr_type == EXPR_FUNCTION;
7190 :
7191 : /* If the expression is the result of substitution in
7192 : interface.cc(gfc_extend_expr) because there is no way in
7193 : which the host association can be wrong. */
7194 1699256 : if (e->symtree == NULL
7195 1698425 : || e->symtree->n.sym == NULL
7196 1698425 : || e->user_operator)
7197 : return retval;
7198 :
7199 1696645 : old_sym = e->symtree->n.sym;
7200 :
7201 1696645 : if (gfc_current_ns->parent
7202 746593 : && old_sym->ns != gfc_current_ns)
7203 : {
7204 : /* Use the 'USE' name so that renamed module symbols are
7205 : correctly handled. */
7206 93955 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7207 :
7208 93955 : if (sym && old_sym != sym
7209 714 : && sym->attr.flavor == FL_PROCEDURE
7210 111 : && sym->attr.contained)
7211 : {
7212 : /* Clear the shape, since it might not be valid. */
7213 83 : gfc_free_shape (&e->shape, e->rank);
7214 :
7215 : /* Give the expression the right symtree! */
7216 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7217 83 : gcc_assert (st != NULL);
7218 :
7219 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7220 59 : || e->expr_type == EXPR_FUNCTION)
7221 : {
7222 : /* Original was function so point to the new symbol, since
7223 : the actual argument list is already attached to the
7224 : expression. */
7225 30 : e->value.function.esym = NULL;
7226 30 : e->symtree = st;
7227 : }
7228 : else
7229 : {
7230 : /* Original was variable so convert array references into
7231 : an actual arglist. This does not need any checking now
7232 : since resolve_function will take care of it. */
7233 53 : e->value.function.actual = NULL;
7234 53 : e->expr_type = EXPR_FUNCTION;
7235 53 : e->symtree = st;
7236 :
7237 : /* Ambiguity will not arise if the array reference is not
7238 : the last reference. */
7239 55 : for (ref = e->ref; ref; ref = ref->next)
7240 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7241 : break;
7242 :
7243 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7244 17 : && sym->attr.proc == PROC_INTERNAL)
7245 : {
7246 4 : gfc_error ("%qs at %L is host associated at %L into "
7247 : "a contained procedure with an internal "
7248 : "procedure of the same name", sym->name,
7249 : &old_sym->declared_at, &e->where);
7250 4 : return false;
7251 : }
7252 :
7253 13 : if (ref == NULL)
7254 : return false;
7255 :
7256 36 : gcc_assert (ref->type == REF_ARRAY);
7257 :
7258 : /* Grab the start expressions from the array ref and
7259 : copy them into actual arguments. */
7260 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7261 : {
7262 48 : arg = gfc_get_actual_arglist ();
7263 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7264 48 : if (e->value.function.actual == NULL)
7265 36 : tail = e->value.function.actual = arg;
7266 : else
7267 : {
7268 12 : tail->next = arg;
7269 12 : tail = arg;
7270 : }
7271 : }
7272 :
7273 : /* Dump the reference list and set the rank. */
7274 36 : gfc_free_ref_list (e->ref);
7275 36 : e->ref = NULL;
7276 36 : e->rank = sym->as ? sym->as->rank : 0;
7277 36 : e->corank = sym->as ? sym->as->corank : 0;
7278 : }
7279 :
7280 66 : gfc_resolve_expr (e);
7281 66 : sym->refs++;
7282 : }
7283 : /* This case corresponds to a call, from a block or a contained
7284 : procedure, to an external function, which has not been declared
7285 : as being external in the main program but has been typed. */
7286 93872 : else if (sym && old_sym != sym
7287 631 : && !e->ref
7288 359 : && sym->ts.type == BT_UNKNOWN
7289 27 : && old_sym->ts.type != BT_UNKNOWN
7290 19 : && sym->attr.flavor == FL_PROCEDURE
7291 19 : && old_sym->attr.flavor == FL_VARIABLE
7292 7 : && sym->ns->parent == old_sym->ns
7293 7 : && sym->ns->proc_name
7294 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7295 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7296 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7297 : {
7298 6 : old_sym->attr.flavor = FL_PROCEDURE;
7299 6 : old_sym->attr.external = 1;
7300 6 : old_sym->attr.function = 1;
7301 6 : old_sym->result = old_sym;
7302 6 : gfc_resolve_expr (e);
7303 : }
7304 : }
7305 : /* This might have changed! */
7306 1696628 : return e->expr_type == EXPR_FUNCTION;
7307 : }
7308 :
7309 :
7310 : static void
7311 1454 : gfc_resolve_character_operator (gfc_expr *e)
7312 : {
7313 1454 : gfc_expr *op1 = e->value.op.op1;
7314 1454 : gfc_expr *op2 = e->value.op.op2;
7315 1454 : gfc_expr *e1 = NULL;
7316 1454 : gfc_expr *e2 = NULL;
7317 :
7318 1454 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7319 :
7320 1454 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7321 767 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7322 687 : else if (op1->expr_type == EXPR_CONSTANT)
7323 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7324 268 : op1->value.character.length);
7325 :
7326 1454 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7327 755 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7328 699 : else if (op2->expr_type == EXPR_CONSTANT)
7329 468 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7330 468 : op2->value.character.length);
7331 :
7332 1454 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7333 :
7334 1454 : if (!e1 || !e2)
7335 : {
7336 547 : gfc_free_expr (e1);
7337 547 : gfc_free_expr (e2);
7338 :
7339 547 : return;
7340 : }
7341 :
7342 907 : e->ts.u.cl->length = gfc_add (e1, e2);
7343 907 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7344 907 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7345 907 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7346 907 : gfc_resolve_expr (e->ts.u.cl->length);
7347 :
7348 907 : return;
7349 : }
7350 :
7351 :
7352 : /* Ensure that an character expression has a charlen and, if possible, a
7353 : length expression. */
7354 :
7355 : static void
7356 185915 : fixup_charlen (gfc_expr *e)
7357 : {
7358 : /* The cases fall through so that changes in expression type and the need
7359 : for multiple fixes are picked up. In all circumstances, a charlen should
7360 : be available for the middle end to hang a backend_decl on. */
7361 185915 : switch (e->expr_type)
7362 : {
7363 1454 : case EXPR_OP:
7364 1454 : gfc_resolve_character_operator (e);
7365 : /* FALLTHRU */
7366 :
7367 1521 : case EXPR_ARRAY:
7368 1521 : if (e->expr_type == EXPR_ARRAY)
7369 67 : gfc_resolve_character_array_constructor (e);
7370 : /* FALLTHRU */
7371 :
7372 1978 : case EXPR_SUBSTRING:
7373 1978 : if (!e->ts.u.cl && e->ref)
7374 453 : gfc_resolve_substring_charlen (e);
7375 : /* FALLTHRU */
7376 :
7377 185915 : default:
7378 185915 : if (!e->ts.u.cl)
7379 183941 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7380 :
7381 185915 : break;
7382 : }
7383 185915 : }
7384 :
7385 :
7386 : /* Update an actual argument to include the passed-object for type-bound
7387 : procedures at the right position. */
7388 :
7389 : static gfc_actual_arglist*
7390 3038 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7391 : const char *name)
7392 : {
7393 3062 : gcc_assert (argpos > 0);
7394 :
7395 3062 : if (argpos == 1)
7396 : {
7397 2913 : gfc_actual_arglist* result;
7398 :
7399 2913 : result = gfc_get_actual_arglist ();
7400 2913 : result->expr = po;
7401 2913 : result->next = lst;
7402 2913 : if (name)
7403 514 : result->name = name;
7404 :
7405 : return result;
7406 : }
7407 :
7408 149 : if (lst)
7409 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7410 : else
7411 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7412 : return lst;
7413 : }
7414 :
7415 :
7416 : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7417 :
7418 : static gfc_expr*
7419 7431 : extract_compcall_passed_object (gfc_expr* e)
7420 : {
7421 7431 : gfc_expr* po;
7422 :
7423 7431 : if (e->expr_type == EXPR_UNKNOWN)
7424 : {
7425 0 : gfc_error ("Error in typebound call at %L",
7426 : &e->where);
7427 0 : return NULL;
7428 : }
7429 :
7430 7431 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7431 :
7432 7431 : if (e->value.compcall.base_object)
7433 1668 : po = gfc_copy_expr (e->value.compcall.base_object);
7434 : else
7435 : {
7436 5763 : po = gfc_get_expr ();
7437 5763 : po->expr_type = EXPR_VARIABLE;
7438 5763 : po->symtree = e->symtree;
7439 5763 : po->ref = gfc_copy_ref (e->ref);
7440 5763 : po->where = e->where;
7441 : }
7442 :
7443 7431 : if (!gfc_resolve_expr (po))
7444 3 : return NULL;
7445 :
7446 : return po;
7447 : }
7448 :
7449 :
7450 : /* Update the arglist of an EXPR_COMPCALL expression to include the
7451 : passed-object. */
7452 :
7453 : static bool
7454 3420 : update_compcall_arglist (gfc_expr* e)
7455 : {
7456 3420 : gfc_expr* po;
7457 3420 : gfc_typebound_proc* tbp;
7458 :
7459 3420 : tbp = e->value.compcall.tbp;
7460 :
7461 3420 : if (tbp->error)
7462 : return false;
7463 :
7464 3419 : po = extract_compcall_passed_object (e);
7465 3419 : if (!po)
7466 : return false;
7467 :
7468 3419 : if (tbp->nopass || e->value.compcall.ignore_pass)
7469 : {
7470 1170 : gfc_free_expr (po);
7471 1170 : return true;
7472 : }
7473 :
7474 2249 : if (tbp->pass_arg_num <= 0)
7475 : return false;
7476 :
7477 2248 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7478 : tbp->pass_arg_num,
7479 : tbp->pass_arg);
7480 :
7481 2248 : return true;
7482 : }
7483 :
7484 :
7485 : /* Extract the passed object from a PPC call (a copy of it). */
7486 :
7487 : static gfc_expr*
7488 85 : extract_ppc_passed_object (gfc_expr *e)
7489 : {
7490 85 : gfc_expr *po;
7491 85 : gfc_ref **ref;
7492 :
7493 85 : po = gfc_get_expr ();
7494 85 : po->expr_type = EXPR_VARIABLE;
7495 85 : po->symtree = e->symtree;
7496 85 : po->ref = gfc_copy_ref (e->ref);
7497 85 : po->where = e->where;
7498 :
7499 : /* Remove PPC reference. */
7500 85 : ref = &po->ref;
7501 91 : while ((*ref)->next)
7502 6 : ref = &(*ref)->next;
7503 85 : gfc_free_ref_list (*ref);
7504 85 : *ref = NULL;
7505 :
7506 85 : if (!gfc_resolve_expr (po))
7507 0 : return NULL;
7508 :
7509 : return po;
7510 : }
7511 :
7512 :
7513 : /* Update the actual arglist of a procedure pointer component to include the
7514 : passed-object. */
7515 :
7516 : static bool
7517 594 : update_ppc_arglist (gfc_expr* e)
7518 : {
7519 594 : gfc_expr* po;
7520 594 : gfc_component *ppc;
7521 594 : gfc_typebound_proc* tb;
7522 :
7523 594 : ppc = gfc_get_proc_ptr_comp (e);
7524 594 : if (!ppc)
7525 : return false;
7526 :
7527 594 : tb = ppc->tb;
7528 :
7529 594 : if (tb->error)
7530 : return false;
7531 592 : else if (tb->nopass)
7532 : return true;
7533 :
7534 85 : po = extract_ppc_passed_object (e);
7535 85 : if (!po)
7536 : return false;
7537 :
7538 : /* F08:R739. */
7539 85 : if (po->rank != 0)
7540 : {
7541 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7542 0 : return false;
7543 : }
7544 :
7545 : /* F08:C611. */
7546 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7547 : {
7548 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7549 : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7550 1 : return false;
7551 : }
7552 :
7553 84 : gcc_assert (tb->pass_arg_num > 0);
7554 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7555 : tb->pass_arg_num,
7556 : tb->pass_arg);
7557 :
7558 84 : return true;
7559 : }
7560 :
7561 :
7562 : /* Check that the object a TBP is called on is valid, i.e. it must not be
7563 : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7564 :
7565 : static bool
7566 3431 : check_typebound_baseobject (gfc_expr* e)
7567 : {
7568 3431 : gfc_expr* base;
7569 3431 : bool return_value = false;
7570 :
7571 3431 : base = extract_compcall_passed_object (e);
7572 3431 : if (!base)
7573 : return false;
7574 :
7575 3428 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7576 : {
7577 1 : gfc_error ("Error in typebound call at %L", &e->where);
7578 1 : goto cleanup;
7579 : }
7580 :
7581 3427 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7582 1 : return false;
7583 :
7584 : /* F08:C611. */
7585 3426 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7586 : {
7587 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7588 : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7589 3 : goto cleanup;
7590 : }
7591 :
7592 : /* F08:C1230. If the procedure called is NOPASS,
7593 : the base object must be scalar. */
7594 3423 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7595 : {
7596 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7597 : " be scalar", &e->where);
7598 1 : goto cleanup;
7599 : }
7600 :
7601 : return_value = true;
7602 :
7603 3427 : cleanup:
7604 3427 : gfc_free_expr (base);
7605 3427 : return return_value;
7606 : }
7607 :
7608 :
7609 : /* Resolve a call to a type-bound procedure, either function or subroutine,
7610 : statically from the data in an EXPR_COMPCALL expression. The adapted
7611 : arglist and the target-procedure symtree are returned. */
7612 :
7613 : static bool
7614 3420 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7615 : gfc_actual_arglist** actual)
7616 : {
7617 3420 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7618 3420 : gcc_assert (!e->value.compcall.tbp->is_generic);
7619 :
7620 : /* Update the actual arglist for PASS. */
7621 3420 : if (!update_compcall_arglist (e))
7622 : return false;
7623 :
7624 3418 : *actual = e->value.compcall.actual;
7625 3418 : *target = e->value.compcall.tbp->u.specific;
7626 :
7627 3418 : gfc_free_ref_list (e->ref);
7628 3418 : e->ref = NULL;
7629 3418 : e->value.compcall.actual = NULL;
7630 :
7631 : /* If we find a deferred typebound procedure, check for derived types
7632 : that an overriding typebound procedure has not been missed. */
7633 3418 : if (e->value.compcall.name
7634 3418 : && !e->value.compcall.tbp->non_overridable
7635 3400 : && e->value.compcall.base_object
7636 834 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7637 : {
7638 541 : gfc_symtree *st;
7639 541 : gfc_symbol *derived;
7640 :
7641 : /* Use the derived type of the base_object. */
7642 541 : derived = e->value.compcall.base_object->ts.u.derived;
7643 541 : st = NULL;
7644 :
7645 : /* If necessary, go through the inheritance chain. */
7646 1631 : while (!st && derived)
7647 : {
7648 : /* Look for the typebound procedure 'name'. */
7649 549 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7650 541 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7651 : e->value.compcall.name);
7652 549 : if (!st)
7653 8 : derived = gfc_get_derived_super_type (derived);
7654 : }
7655 :
7656 : /* Now find the specific name in the derived type namespace. */
7657 541 : if (st && st->n.tb && st->n.tb->u.specific)
7658 541 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7659 541 : derived->ns, 1, &st);
7660 541 : if (st)
7661 541 : *target = st;
7662 : }
7663 :
7664 3418 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7665 3418 : && !e->value.compcall.tbp->deferred)
7666 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7667 : " itself recursively. Declare it RECURSIVE or use"
7668 : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7669 :
7670 : return true;
7671 : }
7672 :
7673 :
7674 : /* Get the ultimate declared type from an expression. In addition,
7675 : return the last class/derived type reference and the copy of the
7676 : reference list. If check_types is set true, derived types are
7677 : identified as well as class references. */
7678 : static gfc_symbol*
7679 3333 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7680 : gfc_expr *e, bool check_types)
7681 : {
7682 3333 : gfc_symbol *declared;
7683 3333 : gfc_ref *ref;
7684 :
7685 3333 : declared = NULL;
7686 3333 : if (class_ref)
7687 2900 : *class_ref = NULL;
7688 3333 : if (new_ref)
7689 2607 : *new_ref = gfc_copy_ref (e->ref);
7690 :
7691 4128 : for (ref = e->ref; ref; ref = ref->next)
7692 : {
7693 795 : if (ref->type != REF_COMPONENT)
7694 292 : continue;
7695 :
7696 503 : if ((ref->u.c.component->ts.type == BT_CLASS
7697 256 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7698 428 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7699 : {
7700 354 : declared = ref->u.c.component->ts.u.derived;
7701 354 : if (class_ref)
7702 332 : *class_ref = ref;
7703 : }
7704 : }
7705 :
7706 3333 : if (declared == NULL)
7707 3005 : declared = e->symtree->n.sym->ts.u.derived;
7708 :
7709 3333 : return declared;
7710 : }
7711 :
7712 :
7713 : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7714 : which of the specific bindings (if any) matches the arglist and transform
7715 : the expression into a call of that binding. */
7716 :
7717 : static bool
7718 3422 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7719 : {
7720 3422 : gfc_typebound_proc* genproc;
7721 3422 : const char* genname;
7722 3422 : gfc_symtree *st;
7723 3422 : gfc_symbol *derived;
7724 :
7725 3422 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7726 3422 : genname = e->value.compcall.name;
7727 3422 : genproc = e->value.compcall.tbp;
7728 :
7729 3422 : if (!genproc->is_generic)
7730 : return true;
7731 :
7732 : /* Try the bindings on this type and in the inheritance hierarchy. */
7733 445 : for (; genproc; genproc = genproc->overridden)
7734 : {
7735 443 : gfc_tbp_generic* g;
7736 :
7737 443 : gcc_assert (genproc->is_generic);
7738 677 : for (g = genproc->u.generic; g; g = g->next)
7739 : {
7740 667 : gfc_symbol* target;
7741 667 : gfc_actual_arglist* args;
7742 667 : bool matches;
7743 :
7744 667 : gcc_assert (g->specific);
7745 :
7746 667 : if (g->specific->error)
7747 0 : continue;
7748 :
7749 667 : target = g->specific->u.specific->n.sym;
7750 :
7751 : /* Get the right arglist by handling PASS/NOPASS. */
7752 667 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7753 667 : if (!g->specific->nopass)
7754 : {
7755 581 : gfc_expr* po;
7756 581 : po = extract_compcall_passed_object (e);
7757 581 : if (!po)
7758 : {
7759 0 : gfc_free_actual_arglist (args);
7760 0 : return false;
7761 : }
7762 :
7763 581 : gcc_assert (g->specific->pass_arg_num > 0);
7764 581 : gcc_assert (!g->specific->error);
7765 581 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7766 : g->specific->pass_arg);
7767 : }
7768 1339 : resolve_actual_arglist (args, target->attr.proc,
7769 667 : is_external_proc (target)
7770 5 : && gfc_sym_get_dummy_args (target) == NULL);
7771 :
7772 : /* Check if this arglist matches the formal. */
7773 667 : matches = gfc_arglist_matches_symbol (&args, target);
7774 :
7775 : /* Clean up and break out of the loop if we've found it. */
7776 667 : gfc_free_actual_arglist (args);
7777 667 : if (matches)
7778 : {
7779 433 : e->value.compcall.tbp = g->specific;
7780 433 : genname = g->specific_st->name;
7781 : /* Pass along the name for CLASS methods, where the vtab
7782 : procedure pointer component has to be referenced. */
7783 433 : if (name)
7784 161 : *name = genname;
7785 433 : goto success;
7786 : }
7787 : }
7788 : }
7789 :
7790 : /* Nothing matching found! */
7791 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7792 : " %qs at %L", genname, &e->where);
7793 2 : return false;
7794 :
7795 433 : success:
7796 : /* Make sure that we have the right specific instance for the name. */
7797 433 : derived = get_declared_from_expr (NULL, NULL, e, true);
7798 :
7799 433 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7800 433 : if (st)
7801 433 : e->value.compcall.tbp = st->n.tb;
7802 :
7803 : return true;
7804 : }
7805 :
7806 :
7807 : /* Resolve a call to a type-bound subroutine. */
7808 :
7809 : static bool
7810 1768 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7811 : {
7812 1768 : gfc_actual_arglist* newactual;
7813 1768 : gfc_symtree* target;
7814 :
7815 : /* Check that's really a SUBROUTINE. */
7816 1768 : if (!c->expr1->value.compcall.tbp->subroutine)
7817 : {
7818 17 : if (!c->expr1->value.compcall.tbp->is_generic
7819 15 : && c->expr1->value.compcall.tbp->u.specific
7820 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7821 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7822 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7823 : else
7824 : {
7825 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7826 : c->expr1->value.compcall.name, &c->loc);
7827 5 : return false;
7828 : }
7829 : }
7830 :
7831 1763 : if (!check_typebound_baseobject (c->expr1))
7832 : return false;
7833 :
7834 : /* Pass along the name for CLASS methods, where the vtab
7835 : procedure pointer component has to be referenced. */
7836 1756 : if (name)
7837 480 : *name = c->expr1->value.compcall.name;
7838 :
7839 1756 : if (!resolve_typebound_generic_call (c->expr1, name))
7840 : return false;
7841 :
7842 : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7843 1755 : if (overridable)
7844 371 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7845 :
7846 : /* Transform into an ordinary EXEC_CALL for now. */
7847 :
7848 1755 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7849 : return false;
7850 :
7851 1753 : c->ext.actual = newactual;
7852 1753 : c->symtree = target;
7853 1753 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7854 :
7855 1753 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7856 :
7857 1753 : gfc_free_expr (c->expr1);
7858 1753 : c->expr1 = gfc_get_expr ();
7859 1753 : c->expr1->expr_type = EXPR_FUNCTION;
7860 1753 : c->expr1->symtree = target;
7861 1753 : c->expr1->where = c->loc;
7862 :
7863 1753 : return resolve_call (c);
7864 : }
7865 :
7866 :
7867 : /* Resolve a component-call expression. */
7868 : static bool
7869 1675 : resolve_compcall (gfc_expr* e, const char **name)
7870 : {
7871 1675 : gfc_actual_arglist* newactual;
7872 1675 : gfc_symtree* target;
7873 :
7874 : /* Check that's really a FUNCTION. */
7875 1675 : if (!e->value.compcall.tbp->function)
7876 : {
7877 7 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7878 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7879 : &e->where);
7880 : return false;
7881 : }
7882 :
7883 :
7884 : /* These must not be assign-calls! */
7885 1668 : gcc_assert (!e->value.compcall.assign);
7886 :
7887 1668 : if (!check_typebound_baseobject (e))
7888 : return false;
7889 :
7890 : /* Pass along the name for CLASS methods, where the vtab
7891 : procedure pointer component has to be referenced. */
7892 1666 : if (name)
7893 864 : *name = e->value.compcall.name;
7894 :
7895 1666 : if (!resolve_typebound_generic_call (e, name))
7896 : return false;
7897 1665 : gcc_assert (!e->value.compcall.tbp->is_generic);
7898 :
7899 : /* Take the rank from the function's symbol. */
7900 1665 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7901 : {
7902 155 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7903 155 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7904 : }
7905 :
7906 : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7907 : arglist to the TBP's binding target. */
7908 :
7909 1665 : if (!resolve_typebound_static (e, &target, &newactual))
7910 : return false;
7911 :
7912 1665 : e->value.function.actual = newactual;
7913 1665 : e->value.function.name = NULL;
7914 1665 : e->value.function.esym = target->n.sym;
7915 1665 : e->value.function.isym = NULL;
7916 1665 : e->symtree = target;
7917 1665 : e->ts = target->n.sym->ts;
7918 1665 : e->expr_type = EXPR_FUNCTION;
7919 :
7920 : /* Resolution is not necessary if this is a class subroutine; this
7921 : function only has to identify the specific proc. Resolution of
7922 : the call will be done next in resolve_typebound_call. */
7923 1665 : return gfc_resolve_expr (e);
7924 : }
7925 :
7926 :
7927 : static bool resolve_fl_derived (gfc_symbol *sym);
7928 :
7929 :
7930 : /* Resolve a typebound function, or 'method'. First separate all
7931 : the non-CLASS references by calling resolve_compcall directly. */
7932 :
7933 : static bool
7934 1675 : resolve_typebound_function (gfc_expr* e)
7935 : {
7936 1675 : gfc_symbol *declared;
7937 1675 : gfc_component *c;
7938 1675 : gfc_ref *new_ref;
7939 1675 : gfc_ref *class_ref;
7940 1675 : gfc_symtree *st;
7941 1675 : const char *name;
7942 1675 : gfc_typespec ts;
7943 1675 : gfc_expr *expr;
7944 1675 : bool overridable;
7945 :
7946 1675 : st = e->symtree;
7947 :
7948 : /* Deal with typebound operators for CLASS objects. */
7949 1675 : expr = e->value.compcall.base_object;
7950 1675 : overridable = !e->value.compcall.tbp->non_overridable;
7951 1675 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7952 : {
7953 : /* Since the typebound operators are generic, we have to ensure
7954 : that any delays in resolution are corrected and that the vtab
7955 : is present. */
7956 184 : ts = expr->ts;
7957 184 : declared = ts.u.derived;
7958 184 : if (!resolve_fl_derived (declared))
7959 : return false;
7960 :
7961 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7962 184 : if (c->ts.u.derived == NULL)
7963 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7964 :
7965 184 : if (!resolve_compcall (e, &name))
7966 : return false;
7967 :
7968 : /* Use the generic name if it is there. */
7969 184 : name = name ? name : e->value.function.esym->name;
7970 184 : e->symtree = expr->symtree;
7971 184 : e->ref = gfc_copy_ref (expr->ref);
7972 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7973 :
7974 : /* Trim away the extraneous references that emerge from nested
7975 : use of interface.cc (extend_expr). */
7976 184 : if (class_ref && class_ref->next)
7977 : {
7978 0 : gfc_free_ref_list (class_ref->next);
7979 0 : class_ref->next = NULL;
7980 : }
7981 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7982 : {
7983 0 : gfc_free_ref_list (e->ref);
7984 0 : e->ref = NULL;
7985 : }
7986 :
7987 184 : gfc_add_vptr_component (e);
7988 184 : gfc_add_component_ref (e, name);
7989 184 : e->value.function.esym = NULL;
7990 184 : if (expr->expr_type != EXPR_VARIABLE)
7991 80 : e->base_expr = expr;
7992 : return true;
7993 : }
7994 :
7995 1491 : if (st == NULL)
7996 195 : return resolve_compcall (e, NULL);
7997 :
7998 1296 : if (!gfc_resolve_ref (e))
7999 : return false;
8000 :
8001 : /* It can happen that a generic, typebound procedure is marked as overridable
8002 : with all of the specific procedures being non-overridable. If this is the
8003 : case, it is safe to resolve the compcall. */
8004 1296 : if (!expr && overridable
8005 1288 : && e->value.compcall.tbp->is_generic
8006 198 : && e->value.compcall.tbp->u.generic->specific
8007 197 : && e->value.compcall.tbp->u.generic->specific->non_overridable)
8008 : {
8009 : gfc_tbp_generic *g = e->value.compcall.tbp->u.generic;
8010 6 : for (; g; g = g->next)
8011 4 : if (!g->specific->non_overridable)
8012 : break;
8013 2 : if (g == NULL && resolve_compcall (e, &name))
8014 : return true;
8015 : }
8016 :
8017 : /* Get the CLASS declared type. */
8018 1294 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
8019 :
8020 1294 : if (!resolve_fl_derived (declared))
8021 : return false;
8022 :
8023 : /* Weed out cases of the ultimate component being a derived type. */
8024 1294 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8025 1200 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8026 : {
8027 614 : gfc_free_ref_list (new_ref);
8028 614 : return resolve_compcall (e, NULL);
8029 : }
8030 :
8031 680 : c = gfc_find_component (declared, "_data", true, true, NULL);
8032 :
8033 : /* Treat the call as if it is a typebound procedure, in order to roll
8034 : out the correct name for the specific function. */
8035 680 : if (!resolve_compcall (e, &name))
8036 : {
8037 3 : gfc_free_ref_list (new_ref);
8038 3 : return false;
8039 : }
8040 677 : ts = e->ts;
8041 :
8042 677 : if (overridable)
8043 : {
8044 : /* Convert the expression to a procedure pointer component call. */
8045 675 : e->value.function.esym = NULL;
8046 675 : e->symtree = st;
8047 :
8048 675 : if (new_ref)
8049 125 : e->ref = new_ref;
8050 :
8051 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8052 675 : gfc_add_vptr_component (e);
8053 675 : gfc_add_component_ref (e, name);
8054 :
8055 : /* Recover the typespec for the expression. This is really only
8056 : necessary for generic procedures, where the additional call
8057 : to gfc_add_component_ref seems to throw the collection of the
8058 : correct typespec. */
8059 675 : e->ts = ts;
8060 : }
8061 2 : else if (new_ref)
8062 0 : gfc_free_ref_list (new_ref);
8063 :
8064 : return true;
8065 : }
8066 :
8067 : /* Resolve a typebound subroutine, or 'method'. First separate all
8068 : the non-CLASS references by calling resolve_typebound_call
8069 : directly. */
8070 :
8071 : static bool
8072 1768 : resolve_typebound_subroutine (gfc_code *code)
8073 : {
8074 1768 : gfc_symbol *declared;
8075 1768 : gfc_component *c;
8076 1768 : gfc_ref *new_ref;
8077 1768 : gfc_ref *class_ref;
8078 1768 : gfc_symtree *st;
8079 1768 : const char *name;
8080 1768 : gfc_typespec ts;
8081 1768 : gfc_expr *expr;
8082 1768 : bool overridable;
8083 :
8084 1768 : st = code->expr1->symtree;
8085 :
8086 : /* Deal with typebound operators for CLASS objects. */
8087 1768 : expr = code->expr1->value.compcall.base_object;
8088 1768 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
8089 1768 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
8090 : {
8091 : /* If the base_object is not a variable, the corresponding actual
8092 : argument expression must be stored in e->base_expression so
8093 : that the corresponding tree temporary can be used as the base
8094 : object in gfc_conv_procedure_call. */
8095 109 : if (expr->expr_type != EXPR_VARIABLE)
8096 : {
8097 : gfc_actual_arglist *args;
8098 :
8099 : args= code->expr1->value.function.actual;
8100 : for (; args; args = args->next)
8101 : if (expr == args->expr)
8102 : expr = args->expr;
8103 : }
8104 :
8105 : /* Since the typebound operators are generic, we have to ensure
8106 : that any delays in resolution are corrected and that the vtab
8107 : is present. */
8108 109 : declared = expr->ts.u.derived;
8109 109 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
8110 109 : if (c->ts.u.derived == NULL)
8111 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
8112 :
8113 109 : if (!resolve_typebound_call (code, &name, NULL))
8114 : return false;
8115 :
8116 : /* Use the generic name if it is there. */
8117 109 : name = name ? name : code->expr1->value.function.esym->name;
8118 109 : code->expr1->symtree = expr->symtree;
8119 109 : code->expr1->ref = gfc_copy_ref (expr->ref);
8120 :
8121 : /* Trim away the extraneous references that emerge from nested
8122 : use of interface.cc (extend_expr). */
8123 109 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
8124 109 : if (class_ref && class_ref->next)
8125 : {
8126 0 : gfc_free_ref_list (class_ref->next);
8127 0 : class_ref->next = NULL;
8128 : }
8129 109 : else if (code->expr1->ref && !class_ref)
8130 : {
8131 18 : gfc_free_ref_list (code->expr1->ref);
8132 18 : code->expr1->ref = NULL;
8133 : }
8134 :
8135 : /* Now use the procedure in the vtable. */
8136 109 : gfc_add_vptr_component (code->expr1);
8137 109 : gfc_add_component_ref (code->expr1, name);
8138 109 : code->expr1->value.function.esym = NULL;
8139 109 : if (expr->expr_type != EXPR_VARIABLE)
8140 0 : code->expr1->base_expr = expr;
8141 : return true;
8142 : }
8143 :
8144 1659 : if (st == NULL)
8145 346 : return resolve_typebound_call (code, NULL, NULL);
8146 :
8147 1313 : if (!gfc_resolve_ref (code->expr1))
8148 : return false;
8149 :
8150 : /* Get the CLASS declared type. */
8151 1313 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
8152 :
8153 : /* Weed out cases of the ultimate component being a derived type. */
8154 1313 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8155 1248 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8156 : {
8157 937 : gfc_free_ref_list (new_ref);
8158 937 : return resolve_typebound_call (code, NULL, NULL);
8159 : }
8160 :
8161 376 : if (!resolve_typebound_call (code, &name, &overridable))
8162 : {
8163 5 : gfc_free_ref_list (new_ref);
8164 5 : return false;
8165 : }
8166 371 : ts = code->expr1->ts;
8167 :
8168 371 : if (overridable)
8169 : {
8170 : /* Convert the expression to a procedure pointer component call. */
8171 369 : code->expr1->value.function.esym = NULL;
8172 369 : code->expr1->symtree = st;
8173 :
8174 369 : if (new_ref)
8175 93 : code->expr1->ref = new_ref;
8176 :
8177 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8178 369 : gfc_add_vptr_component (code->expr1);
8179 369 : gfc_add_component_ref (code->expr1, name);
8180 :
8181 : /* Recover the typespec for the expression. This is really only
8182 : necessary for generic procedures, where the additional call
8183 : to gfc_add_component_ref seems to throw the collection of the
8184 : correct typespec. */
8185 369 : code->expr1->ts = ts;
8186 : }
8187 2 : else if (new_ref)
8188 0 : gfc_free_ref_list (new_ref);
8189 :
8190 : return true;
8191 : }
8192 :
8193 :
8194 : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8195 :
8196 : static bool
8197 124 : resolve_ppc_call (gfc_code* c)
8198 : {
8199 124 : gfc_component *comp;
8200 :
8201 124 : comp = gfc_get_proc_ptr_comp (c->expr1);
8202 124 : gcc_assert (comp != NULL);
8203 :
8204 124 : c->resolved_sym = c->expr1->symtree->n.sym;
8205 124 : c->expr1->expr_type = EXPR_VARIABLE;
8206 :
8207 124 : if (!comp->attr.subroutine)
8208 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8209 :
8210 124 : if (!gfc_resolve_ref (c->expr1))
8211 : return false;
8212 :
8213 124 : if (!update_ppc_arglist (c->expr1))
8214 : return false;
8215 :
8216 123 : c->ext.actual = c->expr1->value.compcall.actual;
8217 :
8218 123 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8219 123 : !(comp->ts.interface
8220 93 : && comp->ts.interface->formal)))
8221 : return false;
8222 :
8223 123 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8224 : return false;
8225 :
8226 122 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8227 :
8228 122 : return true;
8229 : }
8230 :
8231 :
8232 : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8233 :
8234 : static bool
8235 470 : resolve_expr_ppc (gfc_expr* e)
8236 : {
8237 470 : gfc_component *comp;
8238 :
8239 470 : comp = gfc_get_proc_ptr_comp (e);
8240 470 : gcc_assert (comp != NULL);
8241 :
8242 : /* Convert to EXPR_FUNCTION. */
8243 470 : e->expr_type = EXPR_FUNCTION;
8244 470 : e->value.function.isym = NULL;
8245 470 : e->value.function.actual = e->value.compcall.actual;
8246 470 : e->ts = comp->ts;
8247 470 : if (comp->as != NULL)
8248 : {
8249 28 : e->rank = comp->as->rank;
8250 28 : e->corank = comp->as->corank;
8251 : }
8252 :
8253 470 : if (!comp->attr.function)
8254 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8255 :
8256 470 : if (!gfc_resolve_ref (e))
8257 : return false;
8258 :
8259 470 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8260 470 : !(comp->ts.interface
8261 469 : && comp->ts.interface->formal)))
8262 : return false;
8263 :
8264 470 : if (!update_ppc_arglist (e))
8265 : return false;
8266 :
8267 468 : if (!check_pure_function(e))
8268 : return false;
8269 :
8270 467 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8271 :
8272 467 : return true;
8273 : }
8274 :
8275 :
8276 : static bool
8277 12330 : gfc_is_expandable_expr (gfc_expr *e)
8278 : {
8279 12330 : gfc_constructor *con;
8280 :
8281 12330 : if (e->expr_type == EXPR_ARRAY)
8282 : {
8283 : /* Traverse the constructor looking for variables that are flavor
8284 : parameter. Parameters must be expanded since they are fully used at
8285 : compile time. */
8286 12330 : con = gfc_constructor_first (e->value.constructor);
8287 32619 : for (; con; con = gfc_constructor_next (con))
8288 : {
8289 14277 : if (con->expr->expr_type == EXPR_VARIABLE
8290 5533 : && con->expr->symtree
8291 5533 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8292 5533 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8293 : return true;
8294 8744 : if (con->expr->expr_type == EXPR_ARRAY
8295 8744 : && gfc_is_expandable_expr (con->expr))
8296 : return true;
8297 : }
8298 : }
8299 :
8300 : return false;
8301 : }
8302 :
8303 :
8304 : /* Sometimes variables in specification expressions of the result
8305 : of module procedures in submodules wind up not being the 'real'
8306 : dummy. Find this, if possible, in the namespace of the first
8307 : formal argument. */
8308 :
8309 : static void
8310 4731 : fixup_unique_dummy (gfc_expr *e)
8311 : {
8312 4731 : gfc_symtree *st = NULL;
8313 4731 : gfc_symbol *s = NULL;
8314 :
8315 4731 : if (e->symtree->n.sym->ns->proc_name
8316 4731 : && e->symtree->n.sym->ns->proc_name->formal)
8317 4731 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8318 :
8319 4731 : if (s != NULL)
8320 4731 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8321 :
8322 4731 : if (st != NULL
8323 14 : && st->n.sym != NULL
8324 14 : && st->n.sym->attr.dummy)
8325 14 : e->symtree = st;
8326 4731 : }
8327 :
8328 :
8329 : /* Resolve an expression. That is, make sure that types of operands agree
8330 : with their operators, intrinsic operators are converted to function calls
8331 : for overloaded types and unresolved function references are resolved. */
8332 :
8333 : bool
8334 7090448 : gfc_resolve_expr (gfc_expr *e)
8335 : {
8336 7090448 : bool t;
8337 7090448 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8338 :
8339 7090448 : if (e == NULL || e->do_not_resolve_again)
8340 : return true;
8341 :
8342 : /* inquiry_argument only applies to variables. */
8343 5132919 : inquiry_save = inquiry_argument;
8344 5132919 : actual_arg_save = actual_arg;
8345 5132919 : first_actual_arg_save = first_actual_arg;
8346 :
8347 5132919 : if (e->expr_type != EXPR_VARIABLE)
8348 : {
8349 3783808 : inquiry_argument = false;
8350 3783808 : actual_arg = false;
8351 3783808 : first_actual_arg = false;
8352 : }
8353 1349111 : else if (e->symtree != NULL
8354 1348636 : && *e->symtree->name == '@'
8355 5461 : && e->symtree->n.sym->attr.dummy)
8356 : {
8357 : /* Deal with submodule specification expressions that are not
8358 : found to be referenced in module.cc(read_cleanup). */
8359 4731 : fixup_unique_dummy (e);
8360 : }
8361 :
8362 5132919 : switch (e->expr_type)
8363 : {
8364 538365 : case EXPR_OP:
8365 538365 : t = resolve_operator (e);
8366 538365 : break;
8367 :
8368 170 : case EXPR_CONDITIONAL:
8369 170 : t = resolve_conditional (e);
8370 170 : break;
8371 :
8372 1699256 : case EXPR_FUNCTION:
8373 1699256 : case EXPR_VARIABLE:
8374 :
8375 1699256 : if (check_host_association (e))
8376 350181 : t = resolve_function (e);
8377 : else
8378 1349075 : t = resolve_variable (e);
8379 :
8380 1699256 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8381 7403 : && e->ref->type != REF_SUBSTRING)
8382 2174 : gfc_resolve_substring_charlen (e);
8383 :
8384 : break;
8385 :
8386 1675 : case EXPR_COMPCALL:
8387 1675 : t = resolve_typebound_function (e);
8388 1675 : break;
8389 :
8390 508 : case EXPR_SUBSTRING:
8391 508 : t = gfc_resolve_ref (e);
8392 508 : break;
8393 :
8394 : case EXPR_CONSTANT:
8395 : case EXPR_NULL:
8396 : t = true;
8397 : break;
8398 :
8399 470 : case EXPR_PPC:
8400 470 : t = resolve_expr_ppc (e);
8401 470 : break;
8402 :
8403 74100 : case EXPR_ARRAY:
8404 74100 : t = false;
8405 74100 : if (!gfc_resolve_ref (e))
8406 : break;
8407 :
8408 74100 : t = gfc_resolve_array_constructor (e);
8409 : /* Also try to expand a constructor. */
8410 74100 : if (t)
8411 : {
8412 73998 : gfc_expression_rank (e);
8413 73998 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8414 69240 : gfc_expand_constructor (e, false);
8415 : }
8416 :
8417 : /* This provides the opportunity for the length of constructors with
8418 : character valued function elements to propagate the string length
8419 : to the expression. */
8420 73998 : if (t && e->ts.type == BT_CHARACTER)
8421 : {
8422 : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8423 : here rather then add a duplicate test for it above. */
8424 10892 : gfc_expand_constructor (e, false);
8425 10892 : t = gfc_resolve_character_array_constructor (e);
8426 : }
8427 :
8428 : break;
8429 :
8430 16824 : case EXPR_STRUCTURE:
8431 16824 : t = gfc_resolve_ref (e);
8432 16824 : if (!t)
8433 : break;
8434 :
8435 16824 : t = resolve_structure_cons (e, 0);
8436 16824 : if (!t)
8437 : break;
8438 :
8439 16812 : t = gfc_simplify_expr (e, 0);
8440 16812 : break;
8441 :
8442 0 : default:
8443 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8444 : }
8445 :
8446 5132919 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8447 185915 : fixup_charlen (e);
8448 :
8449 5132919 : inquiry_argument = inquiry_save;
8450 5132919 : actual_arg = actual_arg_save;
8451 5132919 : first_actual_arg = first_actual_arg_save;
8452 :
8453 : /* For some reason, resolving these expressions a second time mangles
8454 : the typespec of the expression itself. */
8455 5132919 : if (t && e->expr_type == EXPR_VARIABLE
8456 1346211 : && e->symtree->n.sym->attr.select_rank_temporary
8457 3470 : && UNLIMITED_POLY (e->symtree->n.sym))
8458 83 : e->do_not_resolve_again = 1;
8459 :
8460 5130349 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8461 7354 : t = check_import_status (e);
8462 :
8463 : return t;
8464 : }
8465 :
8466 :
8467 : /* Resolve an expression from an iterator. They must be scalar and have
8468 : INTEGER or (optionally) REAL type. */
8469 :
8470 : static bool
8471 155429 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8472 : const char *name_msgid)
8473 : {
8474 155429 : if (!gfc_resolve_expr (expr))
8475 : return false;
8476 :
8477 155424 : if (expr->rank != 0)
8478 : {
8479 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8480 0 : return false;
8481 : }
8482 :
8483 155424 : if (expr->ts.type != BT_INTEGER)
8484 : {
8485 317 : if (expr->ts.type == BT_REAL)
8486 : {
8487 317 : if (real_ok)
8488 314 : return gfc_notify_std (GFC_STD_F95_DEL,
8489 : "%s at %L must be integer",
8490 314 : _(name_msgid), &expr->where);
8491 : else
8492 : {
8493 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8494 : &expr->where);
8495 3 : return false;
8496 : }
8497 : }
8498 : else
8499 : {
8500 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8501 0 : return false;
8502 : }
8503 : }
8504 : return true;
8505 : }
8506 :
8507 :
8508 : /* Resolve the expressions in an iterator structure. If REAL_OK is
8509 : false allow only INTEGER type iterators, otherwise allow REAL types.
8510 : Set own_scope to true for ac-implied-do and data-implied-do as those
8511 : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8512 :
8513 : bool
8514 38866 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8515 : {
8516 38866 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8517 : return false;
8518 :
8519 38862 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8520 38862 : _("iterator variable")))
8521 : return false;
8522 :
8523 38856 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8524 : "Start expression in DO loop"))
8525 : return false;
8526 :
8527 38855 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8528 : "End expression in DO loop"))
8529 : return false;
8530 :
8531 38852 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8532 : "Step expression in DO loop"))
8533 : return false;
8534 :
8535 : /* Convert start, end, and step to the same type as var. */
8536 38851 : if (iter->start->ts.kind != iter->var->ts.kind
8537 38522 : || iter->start->ts.type != iter->var->ts.type)
8538 393 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8539 :
8540 38851 : if (iter->end->ts.kind != iter->var->ts.kind
8541 38549 : || iter->end->ts.type != iter->var->ts.type)
8542 345 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8543 :
8544 38851 : if (iter->step->ts.kind != iter->var->ts.kind
8545 38559 : || iter->step->ts.type != iter->var->ts.type)
8546 358 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8547 :
8548 38851 : if (iter->step->expr_type == EXPR_CONSTANT)
8549 : {
8550 37728 : if ((iter->step->ts.type == BT_INTEGER
8551 37615 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8552 75341 : || (iter->step->ts.type == BT_REAL
8553 113 : && mpfr_sgn (iter->step->value.real) == 0))
8554 : {
8555 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8556 3 : &iter->step->where);
8557 3 : return false;
8558 : }
8559 : }
8560 :
8561 38848 : if (iter->start->expr_type == EXPR_CONSTANT
8562 35704 : && iter->end->expr_type == EXPR_CONSTANT
8563 27886 : && iter->step->expr_type == EXPR_CONSTANT)
8564 : {
8565 27619 : int sgn, cmp;
8566 27619 : if (iter->start->ts.type == BT_INTEGER)
8567 : {
8568 27564 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8569 27564 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8570 : }
8571 : else
8572 : {
8573 55 : sgn = mpfr_sgn (iter->step->value.real);
8574 55 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8575 : }
8576 27619 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8577 146 : gfc_warning (OPT_Wzerotrip,
8578 : "DO loop at %L will be executed zero times",
8579 146 : &iter->step->where);
8580 : }
8581 :
8582 38848 : if (iter->end->expr_type == EXPR_CONSTANT
8583 28254 : && iter->end->ts.type == BT_INTEGER
8584 28199 : && iter->step->expr_type == EXPR_CONSTANT
8585 27889 : && iter->step->ts.type == BT_INTEGER
8586 27889 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8587 27518 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8588 : {
8589 26732 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8590 26732 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8591 :
8592 26732 : if (is_step_positive
8593 26361 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8594 7 : gfc_warning (OPT_Wundefined_do_loop,
8595 : "DO loop at %L is undefined as it overflows",
8596 7 : &iter->step->where);
8597 : else if (!is_step_positive
8598 371 : && mpz_cmp (iter->end->value.integer,
8599 371 : gfc_integer_kinds[k].min_int) == 0)
8600 7 : gfc_warning (OPT_Wundefined_do_loop,
8601 : "DO loop at %L is undefined as it underflows",
8602 7 : &iter->step->where);
8603 : }
8604 :
8605 38848 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
8606 : VALUE_USED);
8607 38848 : gfc_value_used_expr (iter->start, VALUE_USED);
8608 38848 : gfc_value_used_expr (iter->end, VALUE_USED);
8609 38848 : gfc_value_used_expr (iter->step, VALUE_USED);
8610 :
8611 38848 : return true;
8612 : }
8613 :
8614 :
8615 : /* Traversal function for find_forall_index. f == 2 signals that
8616 : that variable itself is not to be checked - only the references. */
8617 :
8618 : static bool
8619 42892 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8620 : {
8621 42892 : if (expr->expr_type != EXPR_VARIABLE)
8622 : return false;
8623 :
8624 : /* A scalar assignment */
8625 18243 : if (!expr->ref || *f == 1)
8626 : {
8627 12157 : if (expr->symtree->n.sym == sym)
8628 : return true;
8629 : else
8630 8117 : return false;
8631 : }
8632 :
8633 6086 : if (*f == 2)
8634 1731 : *f = 1;
8635 : return false;
8636 : }
8637 :
8638 :
8639 : /* Check whether the FORALL index appears in the expression or not.
8640 : Returns true if SYM is found in EXPR. */
8641 :
8642 : bool
8643 27246 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8644 : {
8645 27246 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8646 : return true;
8647 : else
8648 : return false;
8649 : }
8650 :
8651 : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8652 : This constraint specifies rules for variables in locality-specs. */
8653 :
8654 : static int
8655 927 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8656 : {
8657 927 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8658 :
8659 927 : if ((*expr)->expr_type == EXPR_VARIABLE)
8660 : {
8661 22 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8662 22 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8663 24 : list; list = list->next)
8664 : {
8665 5 : if (list->expr->symtree->n.sym == sym)
8666 : {
8667 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8668 : "must not appear in LOCAL locality-spec at %L",
8669 : sym->name, &(*expr)->where, &list->expr->where);
8670 3 : *walk_subtrees = 0;
8671 3 : return 1;
8672 : }
8673 : }
8674 : }
8675 :
8676 924 : *walk_subtrees = 1;
8677 924 : return 0;
8678 : }
8679 :
8680 : static int
8681 4442 : check_default_none_expr (gfc_expr **e, int *, void *data)
8682 : {
8683 4442 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8684 :
8685 4442 : if ((*e)->expr_type == EXPR_VARIABLE)
8686 : {
8687 2148 : gfc_symbol *sym = (*e)->symtree->n.sym;
8688 :
8689 2148 : if (d->sym_hash->contains (sym))
8690 1275 : sym->mark = 1;
8691 :
8692 873 : else if (d->default_none)
8693 : {
8694 8 : gfc_namespace *ns2 = d->ns;
8695 13 : while (ns2)
8696 : {
8697 8 : if (ns2 == sym->ns)
8698 : break;
8699 5 : ns2 = ns2->parent;
8700 : }
8701 :
8702 : /* A DO CONCURRENT iterator cannot appear in a locality spec.
8703 : Use d->code (the DO CONCURRENT node) rather than sym->ns->code,
8704 : which may be a different code type (e.g. EXEC_ASSOCIATE) whose
8705 : ext union would be read incorrectly. */
8706 8 : for (gfc_forall_iterator *iter = d->code->ext.concur.forall_iterator;
8707 17 : iter; iter = iter->next)
8708 : {
8709 10 : if (!iter->var || !iter->var->symtree)
8710 0 : continue;
8711 10 : const char *iter_name = iter->var->symtree->name;
8712 : /* Shadow iterators (from inline type-spec: integer :: i = ...)
8713 : store the iterator with a leading underscore internally; the
8714 : user-visible name does not have the underscore. */
8715 10 : if (iter->shadow)
8716 0 : iter_name++;
8717 10 : if (strcmp (sym->name, iter_name) == 0)
8718 1 : return 0;
8719 : }
8720 :
8721 : /* A named constant is not a variable, so skip test. */
8722 7 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8723 : {
8724 2 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8725 : "of DO CONCURRENT at %L but required due to "
8726 : "DEFAULT (NONE)",
8727 : sym->name, &(*e)->where, &d->code->loc);
8728 2 : d->sym_hash->add (sym);
8729 : }
8730 : }
8731 : }
8732 : return 0;
8733 : }
8734 :
8735 : static void
8736 278 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8737 : {
8738 278 : struct check_default_none_data data;
8739 278 : data.code = code;
8740 278 : data.sym_hash = new hash_set<gfc_symbol *>;
8741 278 : data.ns = ns;
8742 278 : data.default_none = code->ext.concur.default_none;
8743 :
8744 1390 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8745 : {
8746 1112 : const char *name;
8747 1112 : switch (locality)
8748 : {
8749 : case LOCALITY_LOCAL: name = "LOCAL"; break;
8750 278 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8751 278 : case LOCALITY_SHARED: name = "SHARED"; break;
8752 278 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8753 : default: gcc_unreachable ();
8754 : }
8755 :
8756 1503 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8757 391 : list = list->next)
8758 : {
8759 391 : gfc_expr *expr = list->expr;
8760 :
8761 391 : if (locality == LOCALITY_REDUCE
8762 72 : && (expr->expr_type == EXPR_FUNCTION
8763 48 : || expr->expr_type == EXPR_OP))
8764 35 : continue;
8765 :
8766 367 : if (!gfc_resolve_expr (expr))
8767 3 : continue;
8768 :
8769 364 : if (expr->expr_type != EXPR_VARIABLE
8770 364 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8771 364 : || (expr->ref
8772 151 : && (expr->ref->type != REF_ARRAY
8773 151 : || expr->ref->u.ar.type != AR_FULL
8774 147 : || expr->ref->next)))
8775 : {
8776 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8777 : name, &expr->where);
8778 4 : continue;
8779 : }
8780 :
8781 360 : gfc_symbol *sym = expr->symtree->n.sym;
8782 :
8783 360 : if (data.sym_hash->contains (sym))
8784 : {
8785 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8786 : "locality-spec", sym->name, &expr->where);
8787 4 : continue;
8788 : }
8789 :
8790 356 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8791 716 : iter; iter = iter->next)
8792 : {
8793 360 : if (iter->var->symtree->n.sym == sym)
8794 : {
8795 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8796 : "locality-spec", sym->name, &expr->where);
8797 1 : continue;
8798 : }
8799 :
8800 359 : data.sym_hash->add (iter->var->symtree->n.sym);
8801 : }
8802 :
8803 356 : if (locality == LOCALITY_LOCAL
8804 356 : || locality == LOCALITY_LOCAL_INIT
8805 356 : || locality == LOCALITY_REDUCE)
8806 : {
8807 198 : if (sym->attr.optional)
8808 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8809 : "locality-spec at %L",
8810 : sym->name, name, &expr->where);
8811 :
8812 198 : if (sym->attr.dimension
8813 66 : && sym->as
8814 66 : && sym->as->type == AS_ASSUMED_SIZE)
8815 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8816 : "locality-spec at %L",
8817 : sym->name, name, &expr->where);
8818 :
8819 198 : gfc_check_vardef_context (expr, false, false, false, name);
8820 : }
8821 :
8822 198 : if (locality == LOCALITY_LOCAL
8823 : || locality == LOCALITY_LOCAL_INIT)
8824 : {
8825 181 : symbol_attribute attr = gfc_expr_attr (expr);
8826 :
8827 181 : if (attr.allocatable)
8828 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8829 : "locality-spec at %L",
8830 : sym->name, name, &expr->where);
8831 :
8832 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8833 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8834 : " for %qs in %s locality-spec at %L",
8835 : sym->name, name, &expr->where);
8836 :
8837 177 : else if (attr.codimension)
8838 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8839 : "at %L",
8840 : sym->name, name, &expr->where);
8841 :
8842 177 : else if (expr->ts.type == BT_DERIVED
8843 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8844 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8845 : "locality-spec at %L",
8846 : sym->name, name, &expr->where);
8847 :
8848 177 : else if (gfc_has_ultimate_allocatable (expr))
8849 4 : gfc_error ("Type with ultimate allocatable component not "
8850 : "permitted for %qs in %s locality-spec at %L",
8851 : sym->name, name, &expr->where);
8852 : }
8853 :
8854 175 : else if (locality == LOCALITY_REDUCE)
8855 : {
8856 17 : if (sym->attr.asynchronous)
8857 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8858 : "REDUCE locality-spec at %L",
8859 : sym->name, &expr->where);
8860 17 : if (sym->attr.volatile_)
8861 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8862 : "locality-spec at %L", sym->name, &expr->where);
8863 : }
8864 :
8865 356 : data.sym_hash->add (sym);
8866 : }
8867 :
8868 1112 : if (locality == LOCALITY_LOCAL)
8869 : {
8870 278 : gcc_assert (locality == 0);
8871 :
8872 278 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8873 575 : iter; iter = iter->next)
8874 : {
8875 297 : gfc_expr_walker (&iter->start,
8876 : do_concur_locality_specs_f2023,
8877 : &data);
8878 :
8879 297 : gfc_expr_walker (&iter->end,
8880 : do_concur_locality_specs_f2023,
8881 : &data);
8882 :
8883 297 : gfc_expr_walker (&iter->stride,
8884 : do_concur_locality_specs_f2023,
8885 : &data);
8886 : }
8887 :
8888 278 : if (code->expr1)
8889 7 : gfc_expr_walker (&code->expr1,
8890 : do_concur_locality_specs_f2023,
8891 : &data);
8892 : }
8893 : }
8894 :
8895 278 : gfc_expr *reduce_op = NULL;
8896 :
8897 278 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8898 326 : list; list = list->next)
8899 : {
8900 48 : gfc_expr *expr = list->expr;
8901 :
8902 48 : if (expr->expr_type != EXPR_VARIABLE)
8903 : {
8904 24 : reduce_op = expr;
8905 24 : continue;
8906 : }
8907 :
8908 24 : if (reduce_op->expr_type == EXPR_OP)
8909 : {
8910 17 : switch (reduce_op->value.op.op)
8911 : {
8912 17 : case INTRINSIC_PLUS:
8913 17 : case INTRINSIC_TIMES:
8914 17 : if (!gfc_numeric_ts (&expr->ts))
8915 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8916 3 : "got %s", expr->symtree->n.sym->name,
8917 : &expr->where, gfc_basic_typename (expr->ts.type));
8918 : break;
8919 0 : case INTRINSIC_AND:
8920 0 : case INTRINSIC_OR:
8921 0 : case INTRINSIC_EQV:
8922 0 : case INTRINSIC_NEQV:
8923 0 : if (expr->ts.type != BT_LOGICAL)
8924 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8925 0 : "got %qs", expr->symtree->n.sym->name,
8926 : &expr->where, gfc_basic_typename (expr->ts.type));
8927 : break;
8928 0 : default:
8929 0 : gcc_unreachable ();
8930 : }
8931 : }
8932 :
8933 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8934 : {
8935 7 : switch (reduce_op->value.function.isym->id)
8936 : {
8937 6 : case GFC_ISYM_MIN:
8938 6 : case GFC_ISYM_MAX:
8939 6 : if (expr->ts.type != BT_INTEGER
8940 : && expr->ts.type != BT_REAL
8941 : && expr->ts.type != BT_CHARACTER)
8942 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8943 : "in REDUCE with MIN/MAX at %L, got %s",
8944 2 : expr->symtree->n.sym->name, &expr->where,
8945 : gfc_basic_typename (expr->ts.type));
8946 : break;
8947 1 : case GFC_ISYM_IAND:
8948 1 : case GFC_ISYM_IOR:
8949 1 : case GFC_ISYM_IEOR:
8950 1 : if (expr->ts.type != BT_INTEGER)
8951 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8952 : "IAND/IOR/IEOR at %L, got %s",
8953 1 : expr->symtree->n.sym->name, &expr->where,
8954 : gfc_basic_typename (expr->ts.type));
8955 : break;
8956 0 : default:
8957 0 : gcc_unreachable ();
8958 : }
8959 : }
8960 :
8961 : else
8962 0 : gcc_unreachable ();
8963 : }
8964 :
8965 1390 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8966 : {
8967 1503 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8968 391 : list = list->next)
8969 : {
8970 391 : if (list->expr->expr_type == EXPR_VARIABLE)
8971 367 : list->expr->symtree->n.sym->mark = 0;
8972 : }
8973 : }
8974 :
8975 278 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8976 : check_default_none_expr, &data);
8977 :
8978 1668 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8979 : {
8980 1112 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8981 1503 : while (*plist)
8982 : {
8983 391 : gfc_expr *expr = (*plist)->expr;
8984 391 : if (expr->expr_type == EXPR_VARIABLE)
8985 : {
8986 367 : gfc_symbol *sym = expr->symtree->n.sym;
8987 367 : if (sym->mark == 0)
8988 : {
8989 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8990 : "locality-spec at %L is not used",
8991 : sym->name, &expr->where);
8992 70 : gfc_expr_list *tmp = *plist;
8993 70 : *plist = (*plist)->next;
8994 70 : gfc_free_expr (tmp->expr);
8995 70 : free (tmp);
8996 70 : continue;
8997 70 : }
8998 : }
8999 321 : plist = &((*plist)->next);
9000 : }
9001 : }
9002 :
9003 556 : delete data.sym_hash;
9004 278 : }
9005 :
9006 : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
9007 : to be a scalar INTEGER variable. The subscripts and stride are scalar
9008 : INTEGERs, and if stride is a constant it must be nonzero.
9009 : Furthermore "A subscript or stride in a forall-triplet-spec shall
9010 : not contain a reference to any index-name in the
9011 : forall-triplet-spec-list in which it appears." (7.5.4.1) */
9012 :
9013 : static void
9014 2271 : resolve_forall_iterators (gfc_forall_iterator *it)
9015 : {
9016 2271 : gfc_forall_iterator *iter, *iter2;
9017 :
9018 6460 : for (iter = it; iter; iter = iter->next)
9019 : {
9020 4189 : if (gfc_resolve_expr (iter->var)
9021 4189 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
9022 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
9023 : &iter->var->where);
9024 :
9025 4189 : if (gfc_resolve_expr (iter->start)
9026 4189 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
9027 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
9028 : &iter->start->where);
9029 4189 : if (iter->var->ts.kind != iter->start->ts.kind)
9030 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
9031 :
9032 4189 : if (gfc_resolve_expr (iter->end)
9033 4189 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
9034 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
9035 : &iter->end->where);
9036 4189 : if (iter->var->ts.kind != iter->end->ts.kind)
9037 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
9038 :
9039 4189 : if (gfc_resolve_expr (iter->stride))
9040 : {
9041 4189 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
9042 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
9043 : &iter->stride->where, "INTEGER");
9044 :
9045 4189 : if (iter->stride->expr_type == EXPR_CONSTANT
9046 4185 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
9047 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
9048 : &iter->stride->where);
9049 : }
9050 4189 : if (iter->var->ts.kind != iter->stride->ts.kind)
9051 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
9052 :
9053 4189 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
9054 : VALUE_USED);
9055 4189 : gfc_value_used_expr (iter->start, VALUE_USED);
9056 4189 : gfc_value_used_expr (iter->end, VALUE_USED);
9057 4189 : gfc_value_used_expr (iter->stride, VALUE_USED);
9058 : }
9059 :
9060 6460 : for (iter = it; iter; iter = iter->next)
9061 11222 : for (iter2 = iter; iter2; iter2 = iter2->next)
9062 : {
9063 7033 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
9064 7031 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
9065 14062 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
9066 6 : gfc_error ("FORALL index %qs may not appear in triplet "
9067 6 : "specification at %L", iter->var->symtree->name,
9068 6 : &iter2->start->where);
9069 : }
9070 2271 : }
9071 :
9072 :
9073 : /* Given a pointer to a symbol that is a derived type, see if it's
9074 : inaccessible, i.e. if it's defined in another module and the components are
9075 : PRIVATE. The search is recursive if necessary. Returns zero if no
9076 : inaccessible components are found, nonzero otherwise. */
9077 :
9078 : static bool
9079 1358 : derived_inaccessible (gfc_symbol *sym)
9080 : {
9081 1358 : gfc_component *c;
9082 :
9083 1358 : if (sym->attr.use_assoc && sym->attr.private_comp)
9084 : return 1;
9085 :
9086 4013 : for (c = sym->components; c; c = c->next)
9087 : {
9088 : /* Prevent an infinite loop through this function. */
9089 2668 : if (c->ts.type == BT_DERIVED
9090 289 : && (c->attr.pointer || c->attr.allocatable)
9091 72 : && sym == c->ts.u.derived)
9092 72 : continue;
9093 :
9094 2596 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
9095 : return 1;
9096 : }
9097 :
9098 : return 0;
9099 : }
9100 :
9101 :
9102 : /* Resolve the argument of a deallocate expression. The expression must be
9103 : a pointer or a full array. */
9104 :
9105 : static bool
9106 8516 : resolve_deallocate_expr (gfc_expr *e)
9107 : {
9108 8516 : symbol_attribute attr;
9109 8516 : int allocatable, pointer;
9110 8516 : gfc_ref *ref;
9111 8516 : gfc_symbol *sym;
9112 8516 : gfc_component *c;
9113 8516 : bool unlimited;
9114 :
9115 8516 : if (!gfc_resolve_expr (e))
9116 : return false;
9117 :
9118 8516 : if (e->expr_type != EXPR_VARIABLE)
9119 0 : goto bad;
9120 :
9121 8516 : sym = e->symtree->n.sym;
9122 8516 : unlimited = UNLIMITED_POLY(sym);
9123 :
9124 8516 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
9125 : {
9126 1604 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9127 1604 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9128 : }
9129 : else
9130 : {
9131 6912 : allocatable = sym->attr.allocatable;
9132 6912 : pointer = sym->attr.pointer;
9133 : }
9134 17105 : for (ref = e->ref; ref; ref = ref->next)
9135 : {
9136 8589 : switch (ref->type)
9137 : {
9138 6407 : case REF_ARRAY:
9139 6407 : if (ref->u.ar.type != AR_FULL
9140 6645 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
9141 238 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
9142 : allocatable = 0;
9143 : break;
9144 :
9145 2182 : case REF_COMPONENT:
9146 2182 : c = ref->u.c.component;
9147 2182 : if (c->ts.type == BT_CLASS)
9148 : {
9149 303 : allocatable = CLASS_DATA (c)->attr.allocatable;
9150 303 : pointer = CLASS_DATA (c)->attr.class_pointer;
9151 : }
9152 : else
9153 : {
9154 1879 : allocatable = c->attr.allocatable;
9155 1879 : pointer = c->attr.pointer;
9156 : }
9157 : break;
9158 :
9159 : case REF_SUBSTRING:
9160 : case REF_INQUIRY:
9161 8589 : allocatable = 0;
9162 : break;
9163 : }
9164 : }
9165 :
9166 8516 : attr = gfc_expr_attr (e);
9167 :
9168 8516 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
9169 : {
9170 3 : bad:
9171 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9172 : &e->where);
9173 3 : return false;
9174 : }
9175 :
9176 : /* F2008, C644. */
9177 8513 : if (gfc_is_coindexed (e))
9178 : {
9179 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
9180 1 : return false;
9181 : }
9182 :
9183 8512 : if (pointer
9184 10916 : && !gfc_check_vardef_context (e, true, true, false,
9185 2404 : _("DEALLOCATE object")))
9186 : return false;
9187 8510 : if (!gfc_check_vardef_context (e, false, true, false,
9188 8510 : _("DEALLOCATE object")))
9189 : return false;
9190 :
9191 : return true;
9192 : }
9193 :
9194 :
9195 : /* Returns true if the expression e contains a reference to the symbol sym. */
9196 : static bool
9197 47456 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
9198 : {
9199 47456 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
9200 2081 : return true;
9201 :
9202 : return false;
9203 : }
9204 :
9205 : bool
9206 20080 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
9207 : {
9208 20080 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
9209 : }
9210 :
9211 : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
9212 : of character expressions. */
9213 : static bool
9214 20552 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
9215 : {
9216 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
9217 : }
9218 :
9219 :
9220 : /* Given the expression node e for an allocatable/pointer of derived type to be
9221 : allocated, get the expression node to be initialized afterwards (needed for
9222 : derived types with default initializers, and derived types with allocatable
9223 : components that need nullification.) */
9224 :
9225 : gfc_expr *
9226 5951 : gfc_expr_to_initialize (gfc_expr *e)
9227 : {
9228 5951 : gfc_expr *result;
9229 5951 : gfc_ref *ref;
9230 5951 : int i;
9231 :
9232 5951 : result = gfc_copy_expr (e);
9233 :
9234 : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
9235 11788 : for (ref = result->ref; ref; ref = ref->next)
9236 9267 : if (ref->type == REF_ARRAY && ref->next == NULL)
9237 : {
9238 3430 : if (ref->u.ar.dimen == 0
9239 89 : && ref->u.ar.as && ref->u.ar.as->corank)
9240 : return result;
9241 :
9242 3341 : ref->u.ar.type = AR_FULL;
9243 :
9244 7534 : for (i = 0; i < ref->u.ar.dimen; i++)
9245 4193 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
9246 :
9247 : break;
9248 : }
9249 :
9250 5862 : gfc_free_shape (&result->shape, result->rank);
9251 :
9252 : /* Recalculate rank, shape, etc. */
9253 5862 : gfc_resolve_expr (result);
9254 5862 : return result;
9255 : }
9256 :
9257 :
9258 : /* If the last ref of an expression is an array ref, return a copy of the
9259 : expression with that one removed. Otherwise, a copy of the original
9260 : expression. This is used for allocate-expressions and pointer assignment
9261 : LHS, where there may be an array specification that needs to be stripped
9262 : off when using gfc_check_vardef_context. */
9263 :
9264 : static gfc_expr*
9265 28301 : remove_last_array_ref (gfc_expr* e)
9266 : {
9267 28301 : gfc_expr* e2;
9268 28301 : gfc_ref** r;
9269 :
9270 28301 : e2 = gfc_copy_expr (e);
9271 36656 : for (r = &e2->ref; *r; r = &(*r)->next)
9272 25137 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9273 : {
9274 16782 : gfc_free_ref_list (*r);
9275 16782 : *r = NULL;
9276 16782 : break;
9277 : }
9278 :
9279 28301 : return e2;
9280 : }
9281 :
9282 :
9283 : /* Used in resolve_allocate_expr to check that a allocation-object and
9284 : a source-expr are conformable. This does not catch all possible
9285 : cases; in particular a runtime checking is needed. */
9286 :
9287 : static bool
9288 1952 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9289 : {
9290 1952 : gfc_ref *tail;
9291 1952 : bool scalar;
9292 :
9293 2768 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9294 :
9295 : /* If MOLD= is present and is not scalar, and the allocate-object has an
9296 : explicit-shape-spec, the ranks need not agree. This may be unintended,
9297 : so let's emit a warning if -Wsurprising is given. */
9298 1952 : scalar = !tail || tail->type == REF_COMPONENT;
9299 1952 : if (e1->mold && e1->rank > 0
9300 166 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9301 : {
9302 27 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9303 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9304 : "but MOLD= expression at %L has rank %d",
9305 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9306 : &e1->where, e1->rank);
9307 : return true;
9308 : }
9309 :
9310 : /* First compare rank. */
9311 1922 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9312 2 : || (!tail && e1->rank != e2->rank))
9313 : {
9314 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9315 : "same rank as the allocate-object at %L",
9316 : &e1->where, &e2->where);
9317 7 : return false;
9318 : }
9319 :
9320 1915 : if (e1->shape)
9321 : {
9322 1397 : int i;
9323 1397 : mpz_t s;
9324 :
9325 1397 : mpz_init (s);
9326 :
9327 3237 : for (i = 0; i < e1->rank; i++)
9328 : {
9329 1403 : if (tail->u.ar.start[i] == NULL)
9330 : break;
9331 :
9332 443 : if (tail->u.ar.end[i])
9333 : {
9334 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9335 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9336 54 : mpz_add_ui (s, s, 1);
9337 : }
9338 : else
9339 : {
9340 389 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9341 : }
9342 :
9343 443 : if (mpz_cmp (e1->shape[i], s) != 0)
9344 : {
9345 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9346 : "have the same shape", &e1->where, &e2->where);
9347 0 : mpz_clear (s);
9348 0 : return false;
9349 : }
9350 : }
9351 :
9352 1397 : mpz_clear (s);
9353 : }
9354 :
9355 : return true;
9356 : }
9357 :
9358 :
9359 : /* Resolve the expression in an ALLOCATE statement, doing the additional
9360 : checks to see whether the expression is OK or not. The expression must
9361 : have a trailing array reference that gives the size of the array. */
9362 :
9363 : static bool
9364 17739 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9365 : {
9366 17739 : int i, pointer, allocatable, dimension, is_abstract;
9367 17739 : int codimension;
9368 17739 : bool coindexed;
9369 17739 : bool unlimited;
9370 17739 : symbol_attribute attr;
9371 17739 : gfc_ref *ref, *ref2;
9372 17739 : gfc_expr *e2;
9373 17739 : gfc_array_ref *ar;
9374 17739 : gfc_symbol *sym = NULL;
9375 17739 : gfc_alloc *a;
9376 17739 : gfc_component *c;
9377 17739 : bool t;
9378 :
9379 : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9380 : checking of coarrays. */
9381 22729 : for (ref = e->ref; ref; ref = ref->next)
9382 18454 : if (ref->next == NULL)
9383 : break;
9384 :
9385 17739 : if (ref && ref->type == REF_ARRAY)
9386 12269 : ref->u.ar.in_allocate = true;
9387 :
9388 17739 : if (!gfc_resolve_expr (e))
9389 1 : goto failure;
9390 :
9391 : /* Make sure the expression is allocatable or a pointer. If it is
9392 : pointer, the next-to-last reference must be a pointer. */
9393 :
9394 17738 : ref2 = NULL;
9395 17738 : if (e->symtree)
9396 17738 : sym = e->symtree->n.sym;
9397 :
9398 : /* Check whether ultimate component is abstract and CLASS. */
9399 35476 : is_abstract = 0;
9400 :
9401 : /* Is the allocate-object unlimited polymorphic? */
9402 17738 : unlimited = UNLIMITED_POLY(e);
9403 :
9404 17738 : if (e->expr_type != EXPR_VARIABLE)
9405 : {
9406 0 : allocatable = 0;
9407 0 : attr = gfc_expr_attr (e);
9408 0 : pointer = attr.pointer;
9409 0 : dimension = attr.dimension;
9410 0 : codimension = attr.codimension;
9411 : }
9412 : else
9413 : {
9414 17738 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9415 : {
9416 3534 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9417 3534 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9418 3534 : dimension = CLASS_DATA (sym)->attr.dimension;
9419 3534 : codimension = CLASS_DATA (sym)->attr.codimension;
9420 3534 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9421 : }
9422 : else
9423 : {
9424 14204 : allocatable = sym->attr.allocatable;
9425 14204 : pointer = sym->attr.pointer;
9426 14204 : dimension = sym->attr.dimension;
9427 14204 : codimension = sym->attr.codimension;
9428 : }
9429 :
9430 17738 : coindexed = false;
9431 :
9432 36186 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9433 : {
9434 18450 : switch (ref->type)
9435 : {
9436 13794 : case REF_ARRAY:
9437 13794 : if (ref->u.ar.codimen > 0)
9438 : {
9439 819 : int n;
9440 1120 : for (n = ref->u.ar.dimen;
9441 1120 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9442 860 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9443 : {
9444 : coindexed = true;
9445 : break;
9446 : }
9447 : }
9448 :
9449 13794 : if (ref->next != NULL)
9450 1527 : pointer = 0;
9451 : break;
9452 :
9453 4656 : case REF_COMPONENT:
9454 : /* F2008, C644. */
9455 4656 : if (coindexed)
9456 : {
9457 2 : gfc_error ("Coindexed allocatable object at %L",
9458 : &e->where);
9459 2 : goto failure;
9460 : }
9461 :
9462 4654 : c = ref->u.c.component;
9463 4654 : if (c->ts.type == BT_CLASS)
9464 : {
9465 1012 : allocatable = CLASS_DATA (c)->attr.allocatable;
9466 1012 : pointer = CLASS_DATA (c)->attr.class_pointer;
9467 1012 : dimension = CLASS_DATA (c)->attr.dimension;
9468 1012 : codimension = CLASS_DATA (c)->attr.codimension;
9469 1012 : is_abstract = CLASS_DATA (c)->attr.abstract;
9470 : }
9471 : else
9472 : {
9473 3642 : allocatable = c->attr.allocatable;
9474 3642 : pointer = c->attr.pointer;
9475 3642 : dimension = c->attr.dimension;
9476 3642 : codimension = c->attr.codimension;
9477 3642 : is_abstract = c->attr.abstract;
9478 : }
9479 : break;
9480 :
9481 0 : case REF_SUBSTRING:
9482 0 : case REF_INQUIRY:
9483 0 : allocatable = 0;
9484 0 : pointer = 0;
9485 0 : break;
9486 : }
9487 : }
9488 : }
9489 :
9490 : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9491 : pointer or an allocatable variable. */
9492 17736 : if (allocatable == 0 && pointer == 0)
9493 : {
9494 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9495 : &e->where);
9496 4 : goto failure;
9497 : }
9498 :
9499 : /* Some checks for the SOURCE tag. */
9500 17732 : if (code->expr3)
9501 : {
9502 : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9503 : rank as allocate-object". This would require the MOLD argument to
9504 : NULL() as source-expr for subsequent checking. However, even the
9505 : resulting disassociated pointer or unallocated array has no shape that
9506 : could be used for SOURCE= or MOLD=. */
9507 3954 : if (code->expr3->expr_type == EXPR_NULL)
9508 : {
9509 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9510 : &code->expr3->where);
9511 4 : goto failure;
9512 : }
9513 :
9514 : /* Check F03:C631. */
9515 3950 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9516 : {
9517 10 : gfc_error ("Type of entity at %L is type incompatible with "
9518 10 : "source-expr at %L", &e->where, &code->expr3->where);
9519 10 : goto failure;
9520 : }
9521 :
9522 : /* Check F03:C632 and restriction following Note 6.18. */
9523 3940 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9524 7 : goto failure;
9525 :
9526 : /* Check F03:C633. */
9527 3933 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9528 : {
9529 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9530 : "shall have the same kind type parameter",
9531 : &e->where, &code->expr3->where);
9532 1 : goto failure;
9533 : }
9534 :
9535 : /* Check F2008, C642. */
9536 3932 : if (code->expr3->ts.type == BT_DERIVED
9537 3932 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9538 1222 : || (code->expr3->ts.u.derived->from_intmod
9539 : == INTMOD_ISO_FORTRAN_ENV
9540 0 : && code->expr3->ts.u.derived->intmod_sym_id
9541 : == ISOFORTRAN_LOCK_TYPE)))
9542 : {
9543 0 : gfc_error ("The source-expr at %L shall neither be of type "
9544 : "LOCK_TYPE nor have a LOCK_TYPE component if "
9545 : "allocate-object at %L is a coarray",
9546 0 : &code->expr3->where, &e->where);
9547 0 : goto failure;
9548 : }
9549 :
9550 : /* Check F2008:C639: "Corresponding kind type parameters of
9551 : allocate-object and source-expr shall have the same values." */
9552 3932 : if (e->ts.type == BT_CHARACTER
9553 822 : && !e->ts.deferred
9554 162 : && e->ts.u.cl->length
9555 162 : && code->expr3->ts.type == BT_CHARACTER
9556 4094 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9557 : "SOURCE= or MOLD= specifier"))
9558 17 : goto failure;
9559 :
9560 : /* Check TS18508, C702/C703. */
9561 3915 : if (code->expr3->ts.type == BT_DERIVED
9562 5137 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9563 1222 : || (code->expr3->ts.u.derived->from_intmod
9564 : == INTMOD_ISO_FORTRAN_ENV
9565 0 : && code->expr3->ts.u.derived->intmod_sym_id
9566 : == ISOFORTRAN_EVENT_TYPE)))
9567 : {
9568 0 : gfc_error ("The source-expr at %L shall neither be of type "
9569 : "EVENT_TYPE nor have a EVENT_TYPE component if "
9570 : "allocate-object at %L is a coarray",
9571 0 : &code->expr3->where, &e->where);
9572 0 : goto failure;
9573 : }
9574 : }
9575 :
9576 : /* Check F08:C629. */
9577 17693 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9578 159 : && !code->expr3)
9579 : {
9580 2 : gcc_assert (e->ts.type == BT_CLASS);
9581 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9582 : "type-spec or source-expr", sym->name, &e->where);
9583 2 : goto failure;
9584 : }
9585 :
9586 : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9587 : if and only if each allocate-object is a dummy argument for which the
9588 : corresponding type parameter is assumed. */
9589 17691 : if (code->ext.alloc.ts.type == BT_CHARACTER
9590 533 : && code->ext.alloc.ts.u.cl->length != NULL
9591 518 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9592 23 : && e->ts.u.cl->length == NULL
9593 2 : && e->symtree->n.sym->attr.dummy)
9594 : {
9595 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9596 : "shall be an asterisk as allocate object %qs at %L is a "
9597 : "dummy argument with assumed type parameter",
9598 : sym->name, &e->where);
9599 2 : goto failure;
9600 : }
9601 :
9602 : /* Check F08:C632. */
9603 17689 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9604 60 : && !UNLIMITED_POLY (e))
9605 : {
9606 36 : int cmp = 0;
9607 :
9608 36 : if (!e->ts.u.cl->length)
9609 15 : goto failure;
9610 :
9611 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9612 21 : code->ext.alloc.ts.u.cl->length);
9613 21 : if (cmp == 1 || cmp == -1)
9614 : {
9615 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9616 : "character-length parameter as in the declaration",
9617 : sym->name, &e->where);
9618 2 : goto failure;
9619 : }
9620 : }
9621 :
9622 : /* In the variable definition context checks, gfc_expr_attr is used
9623 : on the expression. This is fooled by the array specification
9624 : present in e, thus we have to eliminate that one temporarily. */
9625 17672 : e2 = remove_last_array_ref (e);
9626 17672 : t = true;
9627 17672 : if (t && pointer)
9628 3933 : t = gfc_check_vardef_context (e2, true, true, false,
9629 3933 : _("ALLOCATE object"));
9630 3933 : if (t)
9631 17664 : t = gfc_check_vardef_context (e2, false, true, false,
9632 17664 : _("ALLOCATE object"));
9633 17672 : gfc_free_expr (e2);
9634 17672 : if (!t)
9635 11 : goto failure;
9636 :
9637 17661 : code->ext.alloc.expr3_not_explicit = 0;
9638 17661 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9639 1686 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9640 : {
9641 : /* For class arrays, the initialization with SOURCE is done
9642 : using _copy and trans_call. It is convenient to exploit that
9643 : when the allocated type is different from the declared type but
9644 : no SOURCE exists by setting expr3. */
9645 341 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9646 341 : code->ext.alloc.expr3_not_explicit = 1;
9647 : }
9648 17320 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9649 2690 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9650 6 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9651 : {
9652 : /* We have to zero initialize the integer variable. */
9653 2 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9654 2 : code->ext.alloc.expr3_not_explicit = 1;
9655 : }
9656 :
9657 17661 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9658 : {
9659 : /* Make sure the vtab symbol is present when
9660 : the module variables are generated. */
9661 3086 : gfc_typespec ts = e->ts;
9662 3086 : if (code->expr3)
9663 1343 : ts = code->expr3->ts;
9664 1743 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9665 768 : ts = code->ext.alloc.ts;
9666 :
9667 : /* Finding the vtab also publishes the type's symbol. Therefore this
9668 : statement is necessary. */
9669 3086 : gfc_find_derived_vtab (ts.u.derived);
9670 3086 : }
9671 14575 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9672 : {
9673 : /* Again, make sure the vtab symbol is present when
9674 : the module variables are generated. */
9675 440 : gfc_typespec *ts = NULL;
9676 440 : if (code->expr3)
9677 353 : ts = &code->expr3->ts;
9678 : else
9679 87 : ts = &code->ext.alloc.ts;
9680 :
9681 440 : gcc_assert (ts);
9682 :
9683 : /* Finding the vtab also publishes the type's symbol. Therefore this
9684 : statement is necessary. */
9685 440 : gfc_find_vtab (ts);
9686 : }
9687 :
9688 17661 : if (dimension == 0 && codimension == 0)
9689 5423 : goto success;
9690 :
9691 : /* Make sure the last reference node is an array specification. */
9692 :
9693 12238 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9694 10987 : || (dimension && ref2->u.ar.dimen == 0))
9695 : {
9696 : /* F08:C633. */
9697 1251 : if (code->expr3)
9698 : {
9699 1250 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9700 : "in ALLOCATE statement at %L", &e->where))
9701 0 : goto failure;
9702 1250 : if (code->expr3->rank != 0)
9703 1249 : *array_alloc_wo_spec = true;
9704 : else
9705 : {
9706 1 : gfc_error ("Array specification or array-valued SOURCE= "
9707 : "expression required in ALLOCATE statement at %L",
9708 : &e->where);
9709 1 : goto failure;
9710 : }
9711 : }
9712 : else
9713 : {
9714 1 : gfc_error ("Array specification required in ALLOCATE statement "
9715 : "at %L", &e->where);
9716 1 : goto failure;
9717 : }
9718 : }
9719 :
9720 : /* Make sure that the array section reference makes sense in the
9721 : context of an ALLOCATE specification. */
9722 :
9723 12236 : ar = &ref2->u.ar;
9724 :
9725 12236 : if (codimension)
9726 1300 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9727 : {
9728 754 : switch (ar->dimen_type[i])
9729 : {
9730 2 : case DIMEN_THIS_IMAGE:
9731 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9732 : "at %L", &e->where);
9733 2 : goto failure;
9734 :
9735 98 : case DIMEN_RANGE:
9736 : /* F2018:R937:
9737 : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9738 : */
9739 98 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9740 : {
9741 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9742 : "at %L", &e->where);
9743 8 : goto failure;
9744 : }
9745 90 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9746 : {
9747 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9748 2 : &ar->start[i]->where);
9749 2 : goto failure;
9750 : }
9751 : break;
9752 :
9753 108 : case DIMEN_ELEMENT:
9754 108 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9755 : {
9756 100 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9757 100 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9758 : {
9759 1 : gfc_error ("Upper cobound is less than lower cobound "
9760 : "of 1 at %L", &ar->start[i]->where);
9761 1 : goto failure;
9762 : }
9763 : }
9764 : break;
9765 :
9766 : case DIMEN_STAR:
9767 : break;
9768 :
9769 0 : default:
9770 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9771 : &e->where);
9772 0 : goto failure;
9773 :
9774 : }
9775 : }
9776 29829 : for (i = 0; i < ar->dimen; i++)
9777 : {
9778 17610 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9779 14871 : goto check_symbols;
9780 :
9781 2739 : switch (ar->dimen_type[i])
9782 : {
9783 : case DIMEN_ELEMENT:
9784 : break;
9785 :
9786 2473 : case DIMEN_RANGE:
9787 2473 : if (ar->start[i] != NULL
9788 2473 : && ar->end[i] != NULL
9789 2472 : && ar->stride[i] == NULL)
9790 : break;
9791 :
9792 : /* Fall through. */
9793 :
9794 1 : case DIMEN_UNKNOWN:
9795 1 : case DIMEN_VECTOR:
9796 1 : case DIMEN_STAR:
9797 1 : case DIMEN_THIS_IMAGE:
9798 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9799 : &e->where);
9800 1 : goto failure;
9801 : }
9802 :
9803 2472 : check_symbols:
9804 45659 : for (a = code->ext.alloc.list; a; a = a->next)
9805 : {
9806 28053 : sym = a->expr->symtree->n.sym;
9807 :
9808 : /* TODO - check derived type components. */
9809 28053 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9810 9543 : continue;
9811 :
9812 18510 : if ((ar->start[i] != NULL
9813 17829 : && gfc_find_var_in_expr (sym, ar->start[i]))
9814 36336 : || (ar->end[i] != NULL
9815 2723 : && gfc_find_var_in_expr (sym, ar->end[i])))
9816 : {
9817 3 : gfc_error ("%qs must not appear in the array specification at "
9818 : "%L in the same ALLOCATE statement where it is "
9819 : "itself allocated", sym->name, &ar->where);
9820 3 : goto failure;
9821 : }
9822 : }
9823 : }
9824 :
9825 12413 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9826 : {
9827 933 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9828 739 : || ar->dimen_type[i] == DIMEN_RANGE)
9829 : {
9830 194 : if (i == (ar->dimen + ar->codimen - 1))
9831 : {
9832 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9833 : "statement at %L", &e->where);
9834 0 : goto failure;
9835 : }
9836 194 : continue;
9837 : }
9838 :
9839 545 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9840 545 : && ar->stride[i] == NULL)
9841 : break;
9842 :
9843 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9844 : &e->where);
9845 0 : goto failure;
9846 : }
9847 :
9848 12219 : success:
9849 17642 : gfc_used_in_allocate_expr (e, &e->where, ALLOCATED_ALLOCATE_STMT);
9850 :
9851 17642 : if (code->expr3)
9852 4110 : gfc_value_set_at (e->symtree->n.sym, &code->expr3->where, VALUE_VARDEF);
9853 :
9854 : return true;
9855 :
9856 17739 : failure:
9857 : return false;
9858 : }
9859 :
9860 :
9861 : static void
9862 20899 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9863 : {
9864 20899 : gfc_expr *stat, *errmsg, *pe, *qe;
9865 20899 : gfc_alloc *a, *p, *q;
9866 :
9867 20899 : stat = code->expr1;
9868 20899 : errmsg = code->expr2;
9869 :
9870 : /* Check the stat variable. */
9871 20899 : if (stat)
9872 : {
9873 661 : if (!gfc_check_vardef_context (stat, false, false, false,
9874 661 : _("STAT variable")))
9875 8 : goto done_stat;
9876 :
9877 653 : if (stat->ts.type != BT_INTEGER
9878 644 : || stat->rank > 0)
9879 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9880 : "variable", &stat->where);
9881 :
9882 653 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9883 0 : goto done_stat;
9884 :
9885 : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9886 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9887 : */
9888 1354 : for (p = code->ext.alloc.list; p; p = p->next)
9889 708 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9890 : {
9891 9 : gfc_ref *ref1, *ref2;
9892 9 : bool found = true;
9893 :
9894 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9895 7 : ref1 = ref1->next, ref2 = ref2->next)
9896 : {
9897 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9898 5 : continue;
9899 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9900 : {
9901 : found = false;
9902 : break;
9903 : }
9904 : }
9905 :
9906 9 : if (found)
9907 : {
9908 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9909 : "the same %s statement", &stat->where, fcn, fcn);
9910 7 : break;
9911 : }
9912 : }
9913 : }
9914 :
9915 20238 : done_stat:
9916 :
9917 : /* Check the errmsg variable. */
9918 20899 : if (errmsg)
9919 : {
9920 150 : if (!stat)
9921 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9922 : &errmsg->where);
9923 :
9924 150 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9925 150 : _("ERRMSG variable")))
9926 6 : goto done_errmsg;
9927 :
9928 : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9929 : F18:R930 errmsg-variable is scalar-default-char-variable
9930 : F18:R906 default-char-variable is variable
9931 : F18:C906 default-char-variable shall be default character. */
9932 144 : if (errmsg->ts.type != BT_CHARACTER
9933 142 : || errmsg->rank > 0
9934 141 : || errmsg->ts.kind != gfc_default_character_kind)
9935 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9936 : "variable", &errmsg->where);
9937 :
9938 144 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9939 0 : goto done_errmsg;
9940 :
9941 : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9942 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9943 : */
9944 286 : for (p = code->ext.alloc.list; p; p = p->next)
9945 147 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9946 : {
9947 9 : gfc_ref *ref1, *ref2;
9948 9 : bool found = true;
9949 :
9950 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9951 7 : ref1 = ref1->next, ref2 = ref2->next)
9952 : {
9953 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9954 4 : continue;
9955 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9956 : {
9957 : found = false;
9958 : break;
9959 : }
9960 : }
9961 :
9962 9 : if (found)
9963 : {
9964 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9965 : "the same %s statement", &errmsg->where, fcn, fcn);
9966 5 : break;
9967 : }
9968 : }
9969 : }
9970 :
9971 20749 : done_errmsg:
9972 :
9973 : /* Check that an allocate-object appears only once in the statement. */
9974 :
9975 47154 : for (p = code->ext.alloc.list; p; p = p->next)
9976 : {
9977 26255 : pe = p->expr;
9978 35607 : for (q = p->next; q; q = q->next)
9979 : {
9980 9352 : qe = q->expr;
9981 9352 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9982 : {
9983 : /* This is a potential collision. */
9984 2094 : gfc_ref *pr = pe->ref;
9985 2094 : gfc_ref *qr = qe->ref;
9986 :
9987 : /* Follow the references until
9988 : a) They start to differ, in which case there is no error;
9989 : you can deallocate a%b and a%c in a single statement
9990 : b) Both of them stop, which is an error
9991 : c) One of them stops, which is also an error. */
9992 4518 : while (1)
9993 : {
9994 3306 : if (pr == NULL && qr == NULL)
9995 : {
9996 7 : gfc_error ("Allocate-object at %L also appears at %L",
9997 : &pe->where, &qe->where);
9998 7 : break;
9999 : }
10000 3299 : else if (pr != NULL && qr == NULL)
10001 : {
10002 2 : gfc_error ("Allocate-object at %L is subobject of"
10003 : " object at %L", &pe->where, &qe->where);
10004 2 : break;
10005 : }
10006 3297 : else if (pr == NULL && qr != NULL)
10007 : {
10008 2 : gfc_error ("Allocate-object at %L is subobject of"
10009 : " object at %L", &qe->where, &pe->where);
10010 2 : break;
10011 : }
10012 : /* Here, pr != NULL && qr != NULL */
10013 3295 : gcc_assert(pr->type == qr->type);
10014 3295 : if (pr->type == REF_ARRAY)
10015 : {
10016 : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
10017 : which are legal. */
10018 1065 : gcc_assert (qr->type == REF_ARRAY);
10019 :
10020 1065 : if (pr->next && qr->next)
10021 : {
10022 : int i;
10023 : gfc_array_ref *par = &(pr->u.ar);
10024 : gfc_array_ref *qar = &(qr->u.ar);
10025 :
10026 1840 : for (i=0; i<par->dimen; i++)
10027 : {
10028 954 : if ((par->start[i] != NULL
10029 0 : || qar->start[i] != NULL)
10030 1908 : && gfc_dep_compare_expr (par->start[i],
10031 954 : qar->start[i]) != 0)
10032 168 : goto break_label;
10033 : }
10034 : }
10035 : }
10036 : else
10037 : {
10038 2230 : if (pr->u.c.component->name != qr->u.c.component->name)
10039 : break;
10040 : }
10041 :
10042 1212 : pr = pr->next;
10043 1212 : qr = qr->next;
10044 1212 : }
10045 9352 : break_label:
10046 : ;
10047 : }
10048 : }
10049 : }
10050 :
10051 20899 : if (strcmp (fcn, "ALLOCATE") == 0)
10052 : {
10053 14679 : bool arr_alloc_wo_spec = false;
10054 :
10055 : /* Resolve and mark as used the length of the type spec. */
10056 14679 : if (code->ext.alloc.ts.type == BT_CHARACTER)
10057 : {
10058 491 : gfc_expr *length = code->ext.alloc.ts.u.cl->length;
10059 491 : gfc_resolve_expr (length);
10060 491 : gfc_value_used_expr (length, VALUE_USED);
10061 : }
10062 :
10063 : /* Resolving the expr3 in the loop over all objects to allocate would
10064 : execute loop invariant code for each loop item. Therefore do it just
10065 : once here. */
10066 14679 : if (code->expr3 && code->expr3->mold
10067 363 : && code->expr3->ts.type == BT_DERIVED
10068 30 : && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
10069 : {
10070 : /* Default initialization via MOLD (non-polymorphic). */
10071 28 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
10072 28 : if (rhs != NULL)
10073 : {
10074 9 : gfc_resolve_expr (rhs);
10075 9 : gfc_free_expr (code->expr3);
10076 9 : code->expr3 = rhs;
10077 : }
10078 : }
10079 32418 : for (a = code->ext.alloc.list; a; a = a->next)
10080 17739 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
10081 :
10082 14679 : if (arr_alloc_wo_spec && code->expr3)
10083 : {
10084 : /* Mark the allocate to have to take the array specification
10085 : from the expr3. */
10086 1243 : code->ext.alloc.arr_spec_from_expr3 = 1;
10087 : }
10088 : }
10089 : else
10090 : {
10091 14736 : for (a = code->ext.alloc.list; a; a = a->next)
10092 8516 : resolve_deallocate_expr (a->expr);
10093 : }
10094 20899 : }
10095 :
10096 :
10097 : /************ SELECT CASE resolution subroutines ************/
10098 :
10099 : /* Callback function for our mergesort variant. Determines interval
10100 : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
10101 : op1 > op2. Assumes we're not dealing with the default case.
10102 : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
10103 : There are nine situations to check. */
10104 :
10105 : static int
10106 1582 : compare_cases (const gfc_case *op1, const gfc_case *op2)
10107 : {
10108 1582 : int retval;
10109 :
10110 1582 : if (op1->low == NULL) /* op1 = (:L) */
10111 : {
10112 : /* op2 = (:N), so overlap. */
10113 52 : retval = 0;
10114 : /* op2 = (M:) or (M:N), L < M */
10115 52 : if (op2->low != NULL
10116 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10117 : retval = -1;
10118 : }
10119 1530 : else if (op1->high == NULL) /* op1 = (K:) */
10120 : {
10121 : /* op2 = (M:), so overlap. */
10122 10 : retval = 0;
10123 : /* op2 = (:N) or (M:N), K > N */
10124 10 : if (op2->high != NULL
10125 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10126 : retval = 1;
10127 : }
10128 : else /* op1 = (K:L) */
10129 : {
10130 1520 : if (op2->low == NULL) /* op2 = (:N), K > N */
10131 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10132 18 : ? 1 : 0;
10133 1502 : else if (op2->high == NULL) /* op2 = (M:), L < M */
10134 10 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10135 10 : ? -1 : 0;
10136 : else /* op2 = (M:N) */
10137 : {
10138 1492 : retval = 0;
10139 : /* L < M */
10140 1492 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10141 : retval = -1;
10142 : /* K > N */
10143 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10144 438 : retval = 1;
10145 : }
10146 : }
10147 :
10148 1582 : return retval;
10149 : }
10150 :
10151 :
10152 : /* Merge-sort a double linked case list, detecting overlap in the
10153 : process. LIST is the head of the double linked case list before it
10154 : is sorted. Returns the head of the sorted list if we don't see any
10155 : overlap, or NULL otherwise. */
10156 :
10157 : static gfc_case *
10158 653 : check_case_overlap (gfc_case *list)
10159 : {
10160 653 : gfc_case *p, *q, *e, *tail;
10161 653 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
10162 :
10163 : /* If the passed list was empty, return immediately. */
10164 653 : if (!list)
10165 : return NULL;
10166 :
10167 : overlap_seen = 0;
10168 : insize = 1;
10169 :
10170 : /* Loop unconditionally. The only exit from this loop is a return
10171 : statement, when we've finished sorting the case list. */
10172 1359 : for (;;)
10173 : {
10174 1006 : p = list;
10175 1006 : list = NULL;
10176 1006 : tail = NULL;
10177 :
10178 : /* Count the number of merges we do in this pass. */
10179 1006 : nmerges = 0;
10180 :
10181 : /* Loop while there exists a merge to be done. */
10182 2540 : while (p)
10183 : {
10184 1534 : int i;
10185 :
10186 : /* Count this merge. */
10187 1534 : nmerges++;
10188 :
10189 : /* Cut the list in two pieces by stepping INSIZE places
10190 : forward in the list, starting from P. */
10191 1534 : psize = 0;
10192 1534 : q = p;
10193 3221 : for (i = 0; i < insize; i++)
10194 : {
10195 2253 : psize++;
10196 2253 : q = q->right;
10197 2253 : if (!q)
10198 : break;
10199 : }
10200 1534 : qsize = insize;
10201 :
10202 : /* Now we have two lists. Merge them! */
10203 5036 : while (psize > 0 || (qsize > 0 && q != NULL))
10204 : {
10205 : /* See from which the next case to merge comes from. */
10206 811 : if (psize == 0)
10207 : {
10208 : /* P is empty so the next case must come from Q. */
10209 811 : e = q;
10210 811 : q = q->right;
10211 811 : qsize--;
10212 : }
10213 2691 : else if (qsize == 0 || q == NULL)
10214 : {
10215 : /* Q is empty. */
10216 1109 : e = p;
10217 1109 : p = p->right;
10218 1109 : psize--;
10219 : }
10220 : else
10221 : {
10222 1582 : cmp = compare_cases (p, q);
10223 1582 : if (cmp < 0)
10224 : {
10225 : /* The whole case range for P is less than the
10226 : one for Q. */
10227 1140 : e = p;
10228 1140 : p = p->right;
10229 1140 : psize--;
10230 : }
10231 442 : else if (cmp > 0)
10232 : {
10233 : /* The whole case range for Q is greater than
10234 : the case range for P. */
10235 438 : e = q;
10236 438 : q = q->right;
10237 438 : qsize--;
10238 : }
10239 : else
10240 : {
10241 : /* The cases overlap, or they are the same
10242 : element in the list. Either way, we must
10243 : issue an error and get the next case from P. */
10244 : /* FIXME: Sort P and Q by line number. */
10245 4 : gfc_error ("CASE label at %L overlaps with CASE "
10246 : "label at %L", &p->where, &q->where);
10247 4 : overlap_seen = 1;
10248 4 : e = p;
10249 4 : p = p->right;
10250 4 : psize--;
10251 : }
10252 : }
10253 :
10254 : /* Add the next element to the merged list. */
10255 3502 : if (tail)
10256 2496 : tail->right = e;
10257 : else
10258 : list = e;
10259 3502 : e->left = tail;
10260 3502 : tail = e;
10261 : }
10262 :
10263 : /* P has now stepped INSIZE places along, and so has Q. So
10264 : they're the same. */
10265 : p = q;
10266 : }
10267 1006 : tail->right = NULL;
10268 :
10269 : /* If we have done only one merge or none at all, we've
10270 : finished sorting the cases. */
10271 1006 : if (nmerges <= 1)
10272 : {
10273 653 : if (!overlap_seen)
10274 : return list;
10275 : else
10276 4 : return NULL;
10277 : }
10278 :
10279 : /* Otherwise repeat, merging lists twice the size. */
10280 353 : insize *= 2;
10281 353 : }
10282 : }
10283 :
10284 :
10285 : /* Check to see if an expression is suitable for use in a CASE statement.
10286 : Makes sure that all case expressions are scalar constants of the same
10287 : type. Return false if anything is wrong. */
10288 :
10289 : static bool
10290 3327 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10291 : {
10292 3327 : if (e == NULL) return true;
10293 :
10294 3234 : if (e->ts.type != case_expr->ts.type)
10295 : {
10296 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10297 : &e->where, gfc_basic_typename (case_expr->ts.type));
10298 4 : return false;
10299 : }
10300 :
10301 : /* C805 (R808) For a given case-construct, each case-value shall be of
10302 : the same type as case-expr. For character type, length differences
10303 : are allowed, but the kind type parameters shall be the same. */
10304 :
10305 3230 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10306 : {
10307 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10308 : &e->where, case_expr->ts.kind);
10309 4 : return false;
10310 : }
10311 :
10312 : /* Convert the case value kind to that of case expression kind,
10313 : if needed */
10314 :
10315 3226 : if (e->ts.kind != case_expr->ts.kind)
10316 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10317 :
10318 3226 : if (e->rank != 0)
10319 : {
10320 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10321 : &e->where);
10322 0 : return false;
10323 : }
10324 :
10325 : return true;
10326 : }
10327 :
10328 :
10329 : /* Given a completely parsed select statement, we:
10330 :
10331 : - Validate all expressions and code within the SELECT.
10332 : - Make sure that the selection expression is not of the wrong type.
10333 : - Make sure that no case ranges overlap.
10334 : - Eliminate unreachable cases and unreachable code resulting from
10335 : removing case labels.
10336 :
10337 : The standard does allow unreachable cases, e.g. CASE (5:3). But
10338 : they are a hassle for code generation, and to prevent that, we just
10339 : cut them out here. This is not necessary for overlapping cases
10340 : because they are illegal and we never even try to generate code.
10341 :
10342 : We have the additional caveat that a SELECT construct could have
10343 : been a computed GOTO in the source code. Fortunately we can fairly
10344 : easily work around that here: The case_expr for a "real" SELECT CASE
10345 : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10346 : we have to do is make sure that the case_expr is a scalar integer
10347 : expression. */
10348 :
10349 : static void
10350 694 : resolve_select (gfc_code *code, bool select_type)
10351 : {
10352 694 : gfc_code *body;
10353 694 : gfc_expr *case_expr;
10354 694 : gfc_case *cp, *default_case, *tail, *head;
10355 694 : int seen_unreachable;
10356 694 : int seen_logical;
10357 694 : int ncases;
10358 694 : bt type;
10359 694 : bool t;
10360 :
10361 694 : if (code->expr1 == NULL)
10362 : {
10363 : /* This was actually a computed GOTO statement. */
10364 5 : case_expr = code->expr2;
10365 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10366 3 : gfc_error ("Selection expression in computed GOTO statement "
10367 : "at %L must be a scalar integer expression",
10368 : &case_expr->where);
10369 :
10370 : /* Further checking is not necessary because this SELECT was built
10371 : by the compiler, so it should always be OK. Just move the
10372 : case_expr from expr2 to expr so that we can handle computed
10373 : GOTOs as normal SELECTs from here on. */
10374 5 : code->expr1 = code->expr2;
10375 5 : code->expr2 = NULL;
10376 5 : gfc_value_used_expr (code->expr1, VALUE_USED);
10377 5 : return;
10378 : }
10379 :
10380 689 : case_expr = code->expr1;
10381 689 : type = case_expr->ts.type;
10382 :
10383 : /* F08:C830. */
10384 689 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10385 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10386 :
10387 : {
10388 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10389 : &case_expr->where, gfc_typename (case_expr));
10390 :
10391 : /* Punt. Going on here just produce more garbage error messages. */
10392 0 : return;
10393 : }
10394 :
10395 : /* F08:R842. */
10396 689 : if (!select_type && case_expr->rank != 0)
10397 : {
10398 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10399 : "expression", &case_expr->where);
10400 :
10401 : /* Punt. */
10402 1 : return;
10403 : }
10404 :
10405 : /* Raise a warning if an INTEGER case value exceeds the range of
10406 : the case-expr. Later, all expressions will be promoted to the
10407 : largest kind of all case-labels. */
10408 :
10409 688 : if (type == BT_INTEGER)
10410 1945 : for (body = code->block; body; body = body->block)
10411 2874 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10412 : {
10413 1473 : if (cp->low
10414 1473 : && gfc_check_integer_range (cp->low->value.integer,
10415 : case_expr->ts.kind) != ARITH_OK)
10416 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10417 6 : "not in the range of %s", &cp->low->where,
10418 : gfc_typename (case_expr));
10419 :
10420 1473 : if (cp->high
10421 1188 : && cp->low != cp->high
10422 1581 : && gfc_check_integer_range (cp->high->value.integer,
10423 : case_expr->ts.kind) != ARITH_OK)
10424 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10425 0 : "not in the range of %s", &cp->high->where,
10426 : gfc_typename (case_expr));
10427 : }
10428 :
10429 : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10430 : of the SELECT CASE expression and its CASE values. Walk the lists
10431 : of case values, and if we find a mismatch, promote case_expr to
10432 : the appropriate kind. */
10433 :
10434 688 : if (type == BT_LOGICAL || type == BT_INTEGER)
10435 : {
10436 2131 : for (body = code->block; body; body = body->block)
10437 : {
10438 : /* Walk the case label list. */
10439 3135 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10440 : {
10441 : /* Intercept the DEFAULT case. It does not have a kind. */
10442 1608 : if (cp->low == NULL && cp->high == NULL)
10443 293 : continue;
10444 :
10445 : /* Unreachable case ranges are discarded, so ignore. */
10446 1270 : if (cp->low != NULL && cp->high != NULL
10447 1222 : && cp->low != cp->high
10448 1380 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10449 33 : continue;
10450 :
10451 1282 : if (cp->low != NULL
10452 1282 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10453 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10454 :
10455 1282 : if (cp->high != NULL
10456 1282 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10457 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10458 : }
10459 : }
10460 : }
10461 :
10462 : /* Assume there is no DEFAULT case. */
10463 688 : default_case = NULL;
10464 688 : head = tail = NULL;
10465 688 : ncases = 0;
10466 688 : seen_logical = 0;
10467 :
10468 2520 : for (body = code->block; body; body = body->block)
10469 : {
10470 : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10471 1832 : t = true;
10472 1832 : seen_unreachable = 0;
10473 :
10474 : /* Walk the case label list, making sure that all case labels
10475 : are legal. */
10476 3851 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10477 : {
10478 : /* Count the number of cases in the whole construct. */
10479 2030 : ncases++;
10480 :
10481 : /* Intercept the DEFAULT case. */
10482 2030 : if (cp->low == NULL && cp->high == NULL)
10483 : {
10484 363 : if (default_case != NULL)
10485 : {
10486 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10487 : "by a second DEFAULT CASE at %L",
10488 : &default_case->where, &cp->where);
10489 0 : t = false;
10490 0 : break;
10491 : }
10492 : else
10493 : {
10494 363 : default_case = cp;
10495 363 : continue;
10496 : }
10497 : }
10498 :
10499 : /* Deal with single value cases and case ranges. Errors are
10500 : issued from the validation function. */
10501 1667 : if (!validate_case_label_expr (cp->low, case_expr)
10502 1667 : || !validate_case_label_expr (cp->high, case_expr))
10503 : {
10504 : t = false;
10505 : break;
10506 : }
10507 :
10508 1659 : if (type == BT_LOGICAL
10509 78 : && ((cp->low == NULL || cp->high == NULL)
10510 76 : || cp->low != cp->high))
10511 : {
10512 2 : gfc_error ("Logical range in CASE statement at %L is not "
10513 : "allowed",
10514 1 : cp->low ? &cp->low->where : &cp->high->where);
10515 2 : t = false;
10516 2 : break;
10517 : }
10518 :
10519 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10520 : {
10521 76 : int value;
10522 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10523 76 : if (value & seen_logical)
10524 : {
10525 1 : gfc_error ("Constant logical value in CASE statement "
10526 : "is repeated at %L",
10527 : &cp->low->where);
10528 1 : t = false;
10529 1 : break;
10530 : }
10531 75 : seen_logical |= value;
10532 : }
10533 :
10534 1612 : if (cp->low != NULL && cp->high != NULL
10535 1565 : && cp->low != cp->high
10536 1768 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10537 : {
10538 35 : if (warn_surprising)
10539 1 : gfc_warning (OPT_Wsurprising,
10540 : "Range specification at %L can never be matched",
10541 : &cp->where);
10542 :
10543 35 : cp->unreachable = 1;
10544 35 : seen_unreachable = 1;
10545 : }
10546 : else
10547 : {
10548 : /* If the case range can be matched, it can also overlap with
10549 : other cases. To make sure it does not, we put it in a
10550 : double linked list here. We sort that with a merge sort
10551 : later on to detect any overlapping cases. */
10552 1621 : if (!head)
10553 : {
10554 653 : head = tail = cp;
10555 653 : head->right = head->left = NULL;
10556 : }
10557 : else
10558 : {
10559 968 : tail->right = cp;
10560 968 : tail->right->left = tail;
10561 968 : tail = tail->right;
10562 968 : tail->right = NULL;
10563 : }
10564 : }
10565 : }
10566 :
10567 : /* It there was a failure in the previous case label, give up
10568 : for this case label list. Continue with the next block. */
10569 1832 : if (!t)
10570 11 : continue;
10571 :
10572 : /* See if any case labels that are unreachable have been seen.
10573 : If so, we eliminate them. This is a bit of a kludge because
10574 : the case lists for a single case statement (label) is a
10575 : single forward linked lists. */
10576 1821 : if (seen_unreachable)
10577 : {
10578 : /* Advance until the first case in the list is reachable. */
10579 69 : while (body->ext.block.case_list != NULL
10580 69 : && body->ext.block.case_list->unreachable)
10581 : {
10582 34 : gfc_case *n = body->ext.block.case_list;
10583 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10584 34 : n->next = NULL;
10585 34 : gfc_free_case_list (n);
10586 : }
10587 :
10588 : /* Strip all other unreachable cases. */
10589 35 : if (body->ext.block.case_list)
10590 : {
10591 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10592 : {
10593 1 : if (cp->next->unreachable)
10594 : {
10595 1 : gfc_case *n = cp->next;
10596 1 : cp->next = cp->next->next;
10597 1 : n->next = NULL;
10598 1 : gfc_free_case_list (n);
10599 : }
10600 : }
10601 : }
10602 : }
10603 : }
10604 :
10605 : /* See if there were overlapping cases. If the check returns NULL,
10606 : there was overlap. In that case we don't do anything. If head
10607 : is non-NULL, we prepend the DEFAULT case. The sorted list can
10608 : then used during code generation for SELECT CASE constructs with
10609 : a case expression of a CHARACTER type. */
10610 688 : if (head)
10611 : {
10612 653 : head = check_case_overlap (head);
10613 :
10614 : /* Prepend the default_case if it is there. */
10615 653 : if (head != NULL && default_case)
10616 : {
10617 346 : default_case->left = NULL;
10618 346 : default_case->right = head;
10619 346 : head->left = default_case;
10620 : }
10621 : }
10622 :
10623 : /* Eliminate dead blocks that may be the result if we've seen
10624 : unreachable case labels for a block. */
10625 2486 : for (body = code; body && body->block; body = body->block)
10626 : {
10627 1798 : if (body->block->ext.block.case_list == NULL)
10628 : {
10629 : /* Cut the unreachable block from the code chain. */
10630 34 : gfc_code *c = body->block;
10631 34 : body->block = c->block;
10632 :
10633 : /* Kill the dead block, but not the blocks below it. */
10634 34 : c->block = NULL;
10635 34 : gfc_free_statements (c);
10636 : }
10637 : }
10638 :
10639 : /* More than two cases is legal but insane for logical selects.
10640 : Issue a warning for it. */
10641 688 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10642 0 : gfc_warning (OPT_Wsurprising,
10643 : "Logical SELECT CASE block at %L has more that two cases",
10644 : &code->loc);
10645 :
10646 : /* Finally, mark the expression as used. */
10647 688 : gfc_value_used_expr (case_expr, VALUE_USED);
10648 : }
10649 :
10650 :
10651 : /* Check if a derived type is extensible. */
10652 :
10653 : bool
10654 24845 : gfc_type_is_extensible (gfc_symbol *sym)
10655 : {
10656 24845 : return !(sym->attr.is_bind_c || sym->attr.sequence
10657 24829 : || (sym->attr.is_class
10658 2226 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10659 : }
10660 :
10661 :
10662 : static void
10663 : resolve_types (gfc_namespace *ns);
10664 :
10665 : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10666 : correct as well as possibly the array-spec. */
10667 :
10668 : static void
10669 13343 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10670 : {
10671 13343 : gfc_expr* target;
10672 :
10673 13343 : gcc_assert (sym->assoc);
10674 13343 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10675 :
10676 13343 : if (sym->assoc->target
10677 8041 : && sym->assoc->target->expr_type == EXPR_FUNCTION
10678 598 : && sym->assoc->target->symtree
10679 598 : && sym->assoc->target->symtree->n.sym
10680 598 : && sym->assoc->target->symtree->n.sym->attr.generic)
10681 : {
10682 33 : if (gfc_resolve_expr (sym->assoc->target))
10683 33 : sym->ts = sym->assoc->target->ts;
10684 : else
10685 : {
10686 0 : gfc_error ("%s could not be resolved to a specific function at %L",
10687 0 : sym->assoc->target->symtree->n.sym->name,
10688 0 : &sym->assoc->target->where);
10689 0 : return;
10690 : }
10691 : }
10692 :
10693 : /* If this is for SELECT TYPE, the target may not yet be set. In that
10694 : case, return. Resolution will be called later manually again when
10695 : this is done. */
10696 13343 : target = sym->assoc->target;
10697 13343 : if (!target)
10698 : return;
10699 8041 : gcc_assert (!sym->assoc->dangling);
10700 :
10701 8041 : if (resolve_target && !gfc_resolve_expr (target))
10702 : return;
10703 :
10704 8036 : if (sym->assoc->ar)
10705 : {
10706 : int dim;
10707 : gfc_array_ref *ar = sym->assoc->ar;
10708 68 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10709 : {
10710 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10711 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10712 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10713 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10714 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10715 : "remapping of associate name %s at %L",
10716 : sym->name, &sym->declared_at);
10717 : }
10718 : }
10719 :
10720 : /* For variable targets, we get some attributes from the target. */
10721 8036 : if (target->expr_type == EXPR_VARIABLE
10722 1152 : || (target->expr_type == EXPR_OP
10723 305 : && target->value.op.op == INTRINSIC_PARENTHESES
10724 74 : && target->value.op.op1->expr_type == EXPR_VARIABLE))
10725 : {
10726 6945 : gfc_symbol *tsym, *dsym;
10727 :
10728 6945 : tsym = target->expr_type == EXPR_VARIABLE ? target->symtree->n.sym :
10729 61 : target->value.op.op1->symtree->n.sym;
10730 :
10731 6945 : if (gfc_expr_attr (target).proc_pointer)
10732 : {
10733 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10734 : tsym->name, &target->where);
10735 0 : return;
10736 : }
10737 :
10738 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10739 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10740 6946 : && dsym->attr.flavor == FL_DERIVED)
10741 : {
10742 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10743 : tsym->name, &target->where);
10744 1 : return;
10745 : }
10746 :
10747 6944 : if (tsym->attr.flavor == FL_PROCEDURE)
10748 : {
10749 73 : bool is_error = true;
10750 73 : if (tsym->attr.function && tsym->result == tsym)
10751 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10752 137 : if (tsym == ns->proc_name)
10753 : {
10754 : is_error = false;
10755 : break;
10756 : }
10757 64 : if (is_error)
10758 : {
10759 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10760 : tsym->name, &target->where);
10761 13 : return;
10762 : }
10763 : }
10764 :
10765 6931 : if (target->expr_type == EXPR_VARIABLE)
10766 : {
10767 6872 : sym->attr.asynchronous = tsym->attr.asynchronous;
10768 6872 : sym->attr.volatile_ = tsym->attr.volatile_;
10769 :
10770 13744 : sym->attr.target = tsym->attr.target
10771 6872 : || gfc_expr_attr (target).pointer;
10772 6872 : if (is_subref_array (target))
10773 421 : sym->attr.subref_array_pointer = 1;
10774 : }
10775 : }
10776 1091 : else if (target->ts.type == BT_PROCEDURE)
10777 : {
10778 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10779 : &target->where);
10780 0 : return;
10781 : }
10782 :
10783 8022 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10784 : {
10785 : /* By now, the type of the target has been fixed up. */
10786 314 : symbol_attribute attr;
10787 :
10788 314 : if (sym->ts.type == BT_DERIVED
10789 181 : && target->ts.type == BT_CLASS
10790 31 : && !UNLIMITED_POLY (target))
10791 : {
10792 : /* Inferred to be derived type but the target has type class. */
10793 31 : sym->ts = CLASS_DATA (target)->ts;
10794 31 : if (!sym->as)
10795 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10796 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10797 31 : sym->attr.dimension = target->rank ? 1 : 0;
10798 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10799 : target->corank);
10800 31 : sym->as = NULL;
10801 : }
10802 283 : else if (target->ts.type == BT_DERIVED
10803 150 : && target->symtree && target->symtree->n.sym
10804 126 : && target->symtree->n.sym->ts.type == BT_CLASS
10805 0 : && IS_INFERRED_TYPE (target)
10806 0 : && target->ref && target->ref->next
10807 0 : && target->ref->next->type == REF_ARRAY
10808 0 : && !target->ref->next->next)
10809 : {
10810 : /* A inferred type selector whose symbol has been determined to be
10811 : a class array but which only has an array reference. Change the
10812 : associate name and the selector to class type. */
10813 0 : sym->ts = target->ts;
10814 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10815 0 : sym->attr.dimension = target->rank ? 1 : 0;
10816 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10817 : target->corank);
10818 0 : sym->as = NULL;
10819 0 : target->ts = sym->ts;
10820 : }
10821 283 : else if ((target->ts.type == BT_DERIVED)
10822 133 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10823 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10824 : /* Confirmed to be either a derived type or misidentified to be a
10825 : scalar class object, when the selector is a class array. */
10826 156 : sym->ts = target->ts;
10827 127 : else if (sym->assoc->inferred_type
10828 120 : && (sym->ts.type == BT_COMPLEX
10829 78 : || sym->ts.type == BT_CHARACTER)
10830 66 : && target->ts.type == sym->ts.type
10831 66 : && sym->ts.kind != target->ts.kind)
10832 : /* The inferred type was set from a %re, %im or %len inquiry on
10833 : the associate name with the default kind, before the target's
10834 : actual type was known. Now that the target has been resolved,
10835 : update the kind to match. */
10836 6 : sym->ts = target->ts;
10837 : }
10838 :
10839 :
10840 8022 : if (target->expr_type == EXPR_NULL)
10841 : {
10842 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10843 1 : return;
10844 : }
10845 8021 : else if (target->ts.type == BT_UNKNOWN)
10846 : {
10847 2 : gfc_error ("Selector at %L has no type", &target->where);
10848 2 : return;
10849 : }
10850 :
10851 : /* Get type if this was not already set. Note that it can be
10852 : some other type than the target in case this is a SELECT TYPE
10853 : selector! So we must not update when the type is already there. */
10854 8019 : if (sym->ts.type == BT_UNKNOWN)
10855 259 : sym->ts = target->ts;
10856 :
10857 8019 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10858 :
10859 : /* See if this is a valid association-to-variable. */
10860 16038 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10861 6872 : && !gfc_has_vector_subscript (target))
10862 8046 : || gfc_is_ptr_fcn (target));
10863 :
10864 : /* A type parameter inquiry is not a variable. */
10865 8019 : if (sym->assoc->variable && target->expr_type == EXPR_VARIABLE)
10866 15227 : for (gfc_ref *ref = target->ref; ref; ref = ref->next)
10867 8406 : if (ref->type == REF_INQUIRY
10868 24 : && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
10869 : {
10870 24 : sym->assoc->variable = false;
10871 24 : break;
10872 : }
10873 :
10874 : /* Finally resolve if this is an array or not. */
10875 8019 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10876 237 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10877 : {
10878 142 : gfc_expression_rank (target);
10879 142 : if (target->ts.type == BT_DERIVED
10880 95 : && !sym->as
10881 95 : && target->symtree->n.sym->as)
10882 : {
10883 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10884 0 : sym->attr.dimension = 1;
10885 : }
10886 142 : else if (target->ts.type == BT_CLASS
10887 47 : && CLASS_DATA (target)->as)
10888 : {
10889 0 : target->rank = CLASS_DATA (target)->as->rank;
10890 0 : target->corank = CLASS_DATA (target)->as->corank;
10891 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10892 : {
10893 0 : sym->ts = target->ts;
10894 0 : sym->attr.dimension = 0;
10895 : }
10896 : }
10897 : }
10898 :
10899 :
10900 8019 : if (sym->attr.dimension && target->rank == 0)
10901 : {
10902 : /* primary.cc makes the assumption that a reference to an associate
10903 : name followed by a left parenthesis is an array reference. */
10904 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10905 : {
10906 12 : gfc_expression_rank (sym->assoc->target);
10907 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10908 12 : if (!sym->attr.dimension && sym->as)
10909 0 : sym->as = NULL;
10910 : }
10911 :
10912 17 : if (sym->attr.dimension && target->rank == 0)
10913 : {
10914 5 : if (sym->ts.type != BT_CHARACTER)
10915 5 : gfc_error ("Associate-name %qs at %L is used as array",
10916 : sym->name, &sym->declared_at);
10917 5 : sym->attr.dimension = 0;
10918 5 : return;
10919 : }
10920 : }
10921 :
10922 : /* We cannot deal with class selectors that need temporaries. */
10923 8014 : if (target->ts.type == BT_CLASS
10924 8014 : && gfc_ref_needs_temporary_p (target->ref))
10925 : {
10926 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10927 : "yet implemented", &target->where);
10928 1 : return;
10929 : }
10930 :
10931 8013 : if (target->ts.type == BT_CLASS)
10932 2890 : gfc_fix_class_refs (target);
10933 :
10934 8013 : if ((target->rank > 0 || target->corank > 0)
10935 2840 : && !sym->attr.select_rank_temporary)
10936 : {
10937 2840 : gfc_array_spec *as;
10938 : /* The rank may be incorrectly guessed at parsing, therefore make sure
10939 : it is corrected now. */
10940 2840 : if (sym->ts.type != BT_CLASS
10941 2237 : && (!sym->as || sym->as->corank != target->corank))
10942 : {
10943 163 : if (!sym->as)
10944 156 : sym->as = gfc_get_array_spec ();
10945 163 : as = sym->as;
10946 163 : as->rank = target->rank;
10947 163 : as->type = AS_DEFERRED;
10948 163 : as->corank = target->corank;
10949 163 : sym->attr.dimension = 1;
10950 163 : if (as->corank != 0)
10951 7 : sym->attr.codimension = 1;
10952 : }
10953 2677 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10954 602 : && (!CLASS_DATA (sym)->as
10955 602 : || CLASS_DATA (sym)->as->corank != target->corank))
10956 : {
10957 0 : if (!CLASS_DATA (sym)->as)
10958 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10959 0 : as = CLASS_DATA (sym)->as;
10960 0 : as->rank = target->rank;
10961 0 : as->type = AS_DEFERRED;
10962 0 : as->corank = target->corank;
10963 0 : CLASS_DATA (sym)->attr.dimension = 1;
10964 0 : if (as->corank != 0)
10965 0 : CLASS_DATA (sym)->attr.codimension = 1;
10966 : }
10967 : }
10968 5173 : else if (!sym->attr.select_rank_temporary)
10969 : {
10970 : /* target's rank is 0, but the type of the sym is still array valued,
10971 : which has to be corrected. */
10972 3748 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10973 736 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10974 : {
10975 24 : gfc_array_spec *as;
10976 24 : symbol_attribute attr;
10977 : /* The associated variable's type is still the array type
10978 : correct this now. */
10979 24 : gfc_typespec *ts = &target->ts;
10980 24 : gfc_ref *ref;
10981 : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10982 : */
10983 24 : bool internal_ref = true;
10984 :
10985 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10986 : {
10987 48 : switch (ref->type)
10988 : {
10989 24 : case REF_COMPONENT:
10990 24 : ts = &ref->u.c.component->ts;
10991 24 : internal_ref
10992 24 : = target->ref == ref && ref->next
10993 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10994 : break;
10995 24 : case REF_ARRAY:
10996 24 : if (ts->type == BT_CLASS)
10997 0 : ts = &ts->u.derived->components->ts;
10998 24 : if (internal_ref && ref->u.ar.codimen > 0)
10999 0 : for (int i = ref->u.ar.dimen;
11000 : internal_ref
11001 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
11002 : ++i)
11003 0 : internal_ref
11004 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
11005 : break;
11006 : default:
11007 : break;
11008 : }
11009 : }
11010 : /* Only rewrite the type of this symbol, when the refs are not the
11011 : internal ones for class and co-array this-image. */
11012 24 : if (!internal_ref)
11013 : {
11014 : /* Create a scalar instance of the current class type. Because
11015 : the rank of a class array goes into its name, the type has to
11016 : be rebuilt. The alternative of (re-)setting just the
11017 : attributes and as in the current type, destroys the type also
11018 : in other places. */
11019 0 : as = NULL;
11020 0 : sym->ts = *ts;
11021 0 : sym->ts.type = BT_CLASS;
11022 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
11023 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
11024 0 : sym->as = NULL;
11025 : }
11026 : }
11027 : }
11028 :
11029 : /* Mark this as an associate variable. */
11030 8013 : sym->attr.associate_var = 1;
11031 :
11032 : /* Fix up the type-spec for CHARACTER types. */
11033 8013 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
11034 : {
11035 563 : gfc_ref *ref;
11036 853 : for (ref = target->ref; ref; ref = ref->next)
11037 316 : if (ref->type == REF_SUBSTRING
11038 74 : && (ref->u.ss.start == NULL
11039 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
11040 74 : || ref->u.ss.end == NULL
11041 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
11042 : break;
11043 :
11044 563 : if (!sym->ts.u.cl)
11045 182 : sym->ts.u.cl = target->ts.u.cl;
11046 :
11047 563 : if (sym->ts.deferred
11048 231 : && sym->ts.u.cl == target->ts.u.cl)
11049 : {
11050 116 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
11051 116 : sym->ts.deferred = 1;
11052 : }
11053 :
11054 563 : if (!sym->ts.u.cl->length
11055 369 : && !sym->ts.deferred
11056 138 : && target->expr_type == EXPR_CONSTANT)
11057 : {
11058 30 : sym->ts.u.cl->length =
11059 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
11060 30 : target->value.character.length);
11061 : }
11062 533 : else if (((!sym->ts.u.cl->length
11063 194 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11064 345 : && target->expr_type != EXPR_VARIABLE)
11065 403 : || ref)
11066 : {
11067 156 : if (!sym->ts.deferred)
11068 : {
11069 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
11070 45 : sym->ts.deferred = 1;
11071 : }
11072 :
11073 : /* This is reset in trans-stmt.cc after the assignment
11074 : of the target expression to the associate name. */
11075 156 : if (ref && sym->as)
11076 26 : sym->attr.pointer = 1;
11077 : else
11078 130 : sym->attr.allocatable = 1;
11079 : }
11080 : }
11081 :
11082 8013 : if (sym->ts.type == BT_CLASS
11083 1484 : && IS_INFERRED_TYPE (target)
11084 13 : && target->ts.type == BT_DERIVED
11085 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
11086 0 : && target->ref && target->ref->next && !target->ref->next->next
11087 0 : && target->ref->next->type == REF_ARRAY)
11088 0 : target->ts = target->symtree->n.sym->ts;
11089 :
11090 : /* If the target is a good class object, so is the associate variable. */
11091 8013 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
11092 1291 : sym->attr.class_ok = 1;
11093 :
11094 : /* If the target is a contiguous pointer, so is the associate variable. */
11095 8013 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
11096 3 : sym->attr.contiguous = 1;
11097 : }
11098 :
11099 :
11100 : /* Ensure that SELECT TYPE expressions have the correct rank and a full
11101 : array reference, where necessary. The symbols are artificial and so
11102 : the dimension attribute and arrayspec can also be set. In addition,
11103 : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
11104 : This is corrected here as well.*/
11105 :
11106 : static void
11107 1755 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
11108 : gfc_ref *ref)
11109 : {
11110 1755 : gfc_ref *nref = (*expr1)->ref;
11111 1755 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
11112 1755 : gfc_symbol *sym2;
11113 1755 : gfc_expr *selector = gfc_copy_expr (expr2);
11114 :
11115 1755 : (*expr1)->rank = rank;
11116 1755 : (*expr1)->corank = corank;
11117 1755 : if (selector)
11118 : {
11119 336 : gfc_resolve_expr (selector);
11120 336 : if (selector->expr_type == EXPR_OP
11121 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
11122 2 : sym2 = selector->value.op.op1->symtree->n.sym;
11123 334 : else if (selector->expr_type == EXPR_VARIABLE
11124 7 : || selector->expr_type == EXPR_FUNCTION)
11125 334 : sym2 = selector->symtree->n.sym;
11126 : else
11127 0 : gcc_unreachable ();
11128 : }
11129 : else
11130 : sym2 = NULL;
11131 :
11132 1755 : if (sym1->ts.type == BT_CLASS)
11133 : {
11134 1755 : if ((*expr1)->ts.type != BT_CLASS)
11135 13 : (*expr1)->ts = sym1->ts;
11136 :
11137 1755 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
11138 1755 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
11139 1755 : if (CLASS_DATA (sym1)->as == NULL && sym2)
11140 1 : CLASS_DATA (sym1)->as
11141 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
11142 : }
11143 : else
11144 : {
11145 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
11146 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
11147 0 : if (sym1->as == NULL && sym2)
11148 0 : sym1->as = gfc_copy_array_spec (sym2->as);
11149 : }
11150 :
11151 3168 : for (; nref; nref = nref->next)
11152 2832 : if (nref->next == NULL)
11153 : break;
11154 :
11155 1755 : if (ref && nref && nref->type != REF_ARRAY)
11156 6 : nref->next = gfc_copy_ref (ref);
11157 1749 : else if (ref && !nref)
11158 327 : (*expr1)->ref = gfc_copy_ref (ref);
11159 1422 : else if (ref && nref->u.ar.codimen != corank)
11160 : {
11161 976 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
11162 915 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
11163 61 : nref->u.ar.codimen = corank;
11164 : }
11165 1755 : }
11166 :
11167 :
11168 : static gfc_expr *
11169 6964 : build_loc_call (gfc_expr *sym_expr)
11170 : {
11171 6964 : gfc_expr *loc_call;
11172 6964 : loc_call = gfc_get_expr ();
11173 6964 : loc_call->expr_type = EXPR_FUNCTION;
11174 6964 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
11175 6964 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
11176 6964 : loc_call->symtree->n.sym->attr.intrinsic = 1;
11177 6964 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
11178 6964 : gfc_commit_symbol (loc_call->symtree->n.sym);
11179 6964 : loc_call->ts.type = BT_INTEGER;
11180 6964 : loc_call->ts.kind = gfc_index_integer_kind;
11181 6964 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
11182 6964 : loc_call->value.function.actual = gfc_get_actual_arglist ();
11183 6964 : loc_call->value.function.actual->expr = sym_expr;
11184 6964 : loc_call->where = sym_expr->where;
11185 6964 : return loc_call;
11186 : }
11187 :
11188 : /* Resolve a SELECT TYPE statement. */
11189 :
11190 : static void
11191 3135 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
11192 : {
11193 3135 : gfc_symbol *selector_type;
11194 3135 : gfc_code *body, *new_st, *if_st, *tail;
11195 3135 : gfc_code *class_is = NULL, *default_case = NULL;
11196 3135 : gfc_case *c;
11197 3135 : gfc_symtree *st;
11198 3135 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
11199 3135 : gfc_namespace *ns;
11200 3135 : int error = 0;
11201 3135 : int rank = 0, corank = 0;
11202 3135 : gfc_ref* ref = NULL;
11203 3135 : gfc_expr *selector_expr = NULL;
11204 3135 : gfc_code *old_code = code;
11205 :
11206 3135 : ns = code->ext.block.ns;
11207 3135 : if (code->expr2)
11208 : {
11209 : /* Set this, or coarray checks in resolve will fail. */
11210 688 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
11211 : }
11212 3135 : gfc_resolve (ns);
11213 :
11214 : /* Check for F03:C813. */
11215 3135 : if (code->expr1->ts.type != BT_CLASS
11216 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
11217 : {
11218 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
11219 : "at %L", &code->loc);
11220 42 : return;
11221 : }
11222 :
11223 : /* Prevent segfault, when class type is not initialized due to previous
11224 : error. */
11225 3122 : if (!code->expr1->symtree->n.sym->attr.class_ok
11226 3120 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
11227 : return;
11228 :
11229 3115 : if (code->expr2)
11230 : {
11231 679 : gfc_ref *ref2 = NULL;
11232 1568 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
11233 889 : if (ref->type == REF_COMPONENT
11234 453 : && ref->u.c.component->ts.type == BT_CLASS)
11235 889 : ref2 = ref;
11236 :
11237 679 : if (ref2)
11238 : {
11239 359 : if (code->expr1->symtree->n.sym->attr.untyped)
11240 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
11241 359 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
11242 : }
11243 : else
11244 : {
11245 320 : if (code->expr1->symtree->n.sym->attr.untyped)
11246 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
11247 : /* Sometimes the selector expression is given the typespec of the
11248 : '_data' field, which is logical enough but inappropriate here. */
11249 320 : if (code->expr2->ts.type == BT_DERIVED
11250 73 : && code->expr2->symtree
11251 73 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
11252 73 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
11253 320 : selector_type = CLASS_DATA (code->expr2)
11254 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
11255 : }
11256 :
11257 679 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
11258 : {
11259 322 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
11260 322 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
11261 322 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
11262 : }
11263 :
11264 : /* F2008: C803 The selector expression must not be coindexed. */
11265 679 : if (gfc_is_coindexed (code->expr2))
11266 : {
11267 4 : gfc_error ("Selector at %L must not be coindexed",
11268 4 : &code->expr2->where);
11269 4 : return;
11270 : }
11271 :
11272 : }
11273 : else
11274 : {
11275 2436 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
11276 :
11277 2436 : if (gfc_is_coindexed (code->expr1))
11278 : {
11279 0 : gfc_error ("Selector at %L must not be coindexed",
11280 0 : &code->expr1->where);
11281 0 : return;
11282 : }
11283 : }
11284 :
11285 : /* Loop over TYPE IS / CLASS IS cases. */
11286 8651 : for (body = code->block; body; body = body->block)
11287 : {
11288 5541 : c = body->ext.block.case_list;
11289 :
11290 5541 : if (!error)
11291 : {
11292 : /* Check for repeated cases. */
11293 8566 : for (tail = code->block; tail; tail = tail->block)
11294 : {
11295 8566 : gfc_case *d = tail->ext.block.case_list;
11296 8566 : if (tail == body)
11297 : break;
11298 :
11299 3034 : if (c->ts.type == d->ts.type
11300 516 : && ((c->ts.type == BT_DERIVED
11301 418 : && c->ts.u.derived && d->ts.u.derived
11302 418 : && !strcmp (c->ts.u.derived->name,
11303 : d->ts.u.derived->name))
11304 515 : || c->ts.type == BT_UNKNOWN
11305 515 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11306 55 : && c->ts.kind == d->ts.kind)))
11307 : {
11308 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11309 : &c->where, &d->where);
11310 1 : return;
11311 : }
11312 : }
11313 : }
11314 :
11315 : /* Check F03:C815. */
11316 3502 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11317 2388 : && selector_type
11318 2388 : && !selector_type->attr.unlimited_polymorphic
11319 7605 : && !gfc_type_is_extensible (c->ts.u.derived))
11320 : {
11321 1 : gfc_error ("Derived type %qs at %L must be extensible",
11322 1 : c->ts.u.derived->name, &c->where);
11323 1 : error++;
11324 1 : continue;
11325 : }
11326 :
11327 : /* Check F03:C816. */
11328 5545 : if (c->ts.type != BT_UNKNOWN
11329 3869 : && selector_type && !selector_type->attr.unlimited_polymorphic
11330 7607 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11331 2064 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11332 : {
11333 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11334 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11335 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11336 : else
11337 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11338 : gfc_basic_typename (c->ts.type), &c->where);
11339 6 : error++;
11340 6 : continue;
11341 : }
11342 :
11343 : /* Check F03:C814. */
11344 5533 : if (c->ts.type == BT_CHARACTER
11345 742 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11346 : {
11347 0 : gfc_error ("The type-spec at %L shall specify that each length "
11348 : "type parameter is assumed", &c->where);
11349 0 : error++;
11350 0 : continue;
11351 : }
11352 :
11353 : /* Intercept the DEFAULT case. */
11354 5533 : if (c->ts.type == BT_UNKNOWN)
11355 : {
11356 : /* Check F03:C818. */
11357 1670 : if (default_case)
11358 : {
11359 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11360 : "by a second DEFAULT CASE at %L",
11361 1 : &default_case->ext.block.case_list->where, &c->where);
11362 1 : error++;
11363 1 : continue;
11364 : }
11365 :
11366 : default_case = body;
11367 : }
11368 : }
11369 :
11370 3110 : if (error > 0)
11371 : return;
11372 :
11373 : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11374 : target if present. If there are any EXIT statements referring to the
11375 : SELECT TYPE construct, this is no problem because the gfc_code
11376 : reference stays the same and EXIT is equally possible from the BLOCK
11377 : it is changed to. */
11378 3107 : code->op = EXEC_BLOCK;
11379 3107 : if (code->expr2)
11380 : {
11381 675 : gfc_association_list* assoc;
11382 :
11383 675 : assoc = gfc_get_association_list ();
11384 675 : assoc->st = code->expr1->symtree;
11385 675 : assoc->target = gfc_copy_expr (code->expr2);
11386 675 : assoc->target->where = code->expr2->where;
11387 : /* assoc->variable will be set by resolve_assoc_var. */
11388 :
11389 675 : code->ext.block.assoc = assoc;
11390 675 : code->expr1->symtree->n.sym->assoc = assoc;
11391 :
11392 675 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11393 : }
11394 : else
11395 2432 : code->ext.block.assoc = NULL;
11396 :
11397 : /* Ensure that the selector rank and arrayspec are available to
11398 : correct expressions in which they might be missing. */
11399 3107 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11400 : {
11401 336 : rank = code->expr2->rank;
11402 336 : corank = code->expr2->corank;
11403 620 : for (ref = code->expr2->ref; ref; ref = ref->next)
11404 611 : if (ref->next == NULL)
11405 : break;
11406 336 : if (ref && ref->type == REF_ARRAY)
11407 327 : ref = gfc_copy_ref (ref);
11408 :
11409 : /* Fixup expr1 if necessary. */
11410 336 : if (rank || corank)
11411 336 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11412 : }
11413 2771 : else if (code->expr1->rank || code->expr1->corank)
11414 : {
11415 904 : rank = code->expr1->rank;
11416 904 : corank = code->expr1->corank;
11417 904 : for (ref = code->expr1->ref; ref; ref = ref->next)
11418 904 : if (ref->next == NULL)
11419 : break;
11420 904 : if (ref && ref->type == REF_ARRAY)
11421 904 : ref = gfc_copy_ref (ref);
11422 : }
11423 :
11424 3107 : gfc_expr *orig_expr1 = code->expr1;
11425 :
11426 : /* Add EXEC_SELECT to switch on type. */
11427 3107 : new_st = gfc_get_code (code->op);
11428 3107 : new_st->expr1 = code->expr1;
11429 3107 : new_st->expr2 = code->expr2;
11430 3107 : new_st->block = code->block;
11431 3107 : code->expr1 = code->expr2 = NULL;
11432 3107 : code->block = NULL;
11433 3107 : if (!ns->code)
11434 3107 : ns->code = new_st;
11435 : else
11436 0 : ns->code->next = new_st;
11437 3107 : code = new_st;
11438 3107 : code->op = EXEC_SELECT_TYPE;
11439 :
11440 : /* Use the intrinsic LOC function to generate an integer expression
11441 : for the vtable of the selector. Note that the rank of the selector
11442 : expression has to be set to zero. */
11443 3107 : gfc_add_vptr_component (code->expr1);
11444 3107 : code->expr1->rank = 0;
11445 3107 : code->expr1->corank = 0;
11446 3107 : code->expr1 = build_loc_call (code->expr1);
11447 3107 : selector_expr = code->expr1->value.function.actual->expr;
11448 :
11449 : /* Loop over TYPE IS / CLASS IS cases. */
11450 8632 : for (body = code->block; body; body = body->block)
11451 : {
11452 5525 : gfc_symbol *vtab;
11453 5525 : c = body->ext.block.case_list;
11454 :
11455 : /* Generate an index integer expression for address of the
11456 : TYPE/CLASS vtable and store it in c->low. The hash expression
11457 : is stored in c->high and is used to resolve intrinsic cases. */
11458 5525 : if (c->ts.type != BT_UNKNOWN)
11459 : {
11460 3857 : gfc_expr *e;
11461 3857 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11462 : {
11463 2379 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11464 2379 : gcc_assert (vtab);
11465 2379 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11466 2379 : c->ts.u.derived->hash_value);
11467 : }
11468 : else
11469 : {
11470 1478 : vtab = gfc_find_vtab (&c->ts);
11471 1478 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11472 1478 : e = CLASS_DATA (vtab)->initializer;
11473 1478 : c->high = gfc_copy_expr (e);
11474 1478 : if (c->high->ts.kind != gfc_integer_4_kind)
11475 : {
11476 1 : gfc_typespec ts;
11477 1 : ts.kind = gfc_integer_4_kind;
11478 1 : ts.type = BT_INTEGER;
11479 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11480 : }
11481 : }
11482 :
11483 3857 : e = gfc_lval_expr_from_sym (vtab);
11484 3857 : c->low = build_loc_call (e);
11485 : }
11486 : else
11487 1668 : continue;
11488 :
11489 : /* Associate temporary to selector. This should only be done
11490 : when this case is actually true, so build a new ASSOCIATE
11491 : that does precisely this here (instead of using the
11492 : 'global' one). */
11493 :
11494 : /* First check the derived type import status. */
11495 3857 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11496 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11497 : {
11498 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11499 6 : c->ts.u.derived->name);
11500 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11501 : gfc_current_ns))
11502 6 : error++;
11503 : }
11504 :
11505 3857 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11506 3857 : if (c->ts.type == BT_CLASS)
11507 348 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11508 348 : c->ts.u.derived->name, var_name);
11509 3509 : else if (c->ts.type == BT_DERIVED)
11510 2031 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11511 2031 : c->ts.u.derived->name, var_name);
11512 1478 : else if (c->ts.type == BT_CHARACTER)
11513 : {
11514 742 : HOST_WIDE_INT charlen = 0;
11515 742 : if (c->ts.u.cl && c->ts.u.cl->length
11516 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11517 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11518 742 : snprintf (name, sizeof (name),
11519 : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11520 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11521 : var_name);
11522 : }
11523 : else
11524 736 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11525 : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11526 :
11527 3857 : st = gfc_find_symtree (ns->sym_root, name);
11528 3857 : gcc_assert (st->n.sym->assoc);
11529 3857 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11530 3857 : st->n.sym->assoc->target->where = selector_expr->where;
11531 3857 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11532 : {
11533 3509 : gfc_add_data_component (st->n.sym->assoc->target);
11534 : /* Fixup the target expression if necessary. */
11535 3509 : if (rank || corank)
11536 1419 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11537 : ref);
11538 : }
11539 :
11540 3857 : new_st = gfc_get_code (EXEC_BLOCK);
11541 3857 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11542 3857 : new_st->ext.block.ns->code = body->next;
11543 3857 : body->next = new_st;
11544 :
11545 : /* Chain in the new list only if it is marked as dangling. Otherwise
11546 : there is a CASE label overlap and this is already used. Just ignore,
11547 : the error is diagnosed elsewhere. */
11548 3857 : if (st->n.sym->assoc->dangling)
11549 : {
11550 3856 : new_st->ext.block.assoc = st->n.sym->assoc;
11551 3856 : st->n.sym->assoc->dangling = 0;
11552 : }
11553 :
11554 3857 : resolve_assoc_var (st->n.sym, false);
11555 : }
11556 :
11557 : /* Take out CLASS IS cases for separate treatment. */
11558 : body = code;
11559 8632 : while (body && body->block)
11560 : {
11561 5525 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11562 : {
11563 : /* Add to class_is list. */
11564 348 : if (class_is == NULL)
11565 : {
11566 317 : class_is = body->block;
11567 317 : tail = class_is;
11568 : }
11569 : else
11570 : {
11571 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11572 31 : tail->block = body->block;
11573 31 : tail = tail->block;
11574 : }
11575 : /* Remove from EXEC_SELECT list. */
11576 348 : body->block = body->block->block;
11577 348 : tail->block = NULL;
11578 : }
11579 : else
11580 : body = body->block;
11581 : }
11582 :
11583 3107 : if (class_is)
11584 : {
11585 317 : gfc_symbol *vtab;
11586 :
11587 317 : if (!default_case)
11588 : {
11589 : /* Add a default case to hold the CLASS IS cases. */
11590 315 : for (tail = code; tail->block; tail = tail->block) ;
11591 207 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11592 207 : tail = tail->block;
11593 207 : tail->ext.block.case_list = gfc_get_case ();
11594 207 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11595 207 : tail->next = NULL;
11596 207 : default_case = tail;
11597 : }
11598 :
11599 : /* More than one CLASS IS block? */
11600 317 : if (class_is->block)
11601 : {
11602 37 : gfc_code **c1,*c2;
11603 37 : bool swapped;
11604 : /* Sort CLASS IS blocks by extension level. */
11605 36 : do
11606 : {
11607 37 : swapped = false;
11608 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11609 : {
11610 61 : c2 = (*c1)->block;
11611 : /* F03:C817 (check for doubles). */
11612 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11613 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11614 : {
11615 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11616 : "statement at %L",
11617 : &c2->ext.block.case_list->where);
11618 1 : return;
11619 : }
11620 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11621 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11622 : {
11623 : /* Swap. */
11624 24 : (*c1)->block = c2->block;
11625 24 : c2->block = *c1;
11626 24 : *c1 = c2;
11627 24 : swapped = true;
11628 : }
11629 : }
11630 : }
11631 : while (swapped);
11632 : }
11633 :
11634 : /* Generate IF chain. */
11635 316 : if_st = gfc_get_code (EXEC_IF);
11636 316 : new_st = if_st;
11637 662 : for (body = class_is; body; body = body->block)
11638 : {
11639 346 : new_st->block = gfc_get_code (EXEC_IF);
11640 346 : new_st = new_st->block;
11641 : /* Set up IF condition: Call _gfortran_is_extension_of. */
11642 346 : new_st->expr1 = gfc_get_expr ();
11643 346 : new_st->expr1->expr_type = EXPR_FUNCTION;
11644 346 : new_st->expr1->ts.type = BT_LOGICAL;
11645 346 : new_st->expr1->ts.kind = 4;
11646 346 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11647 346 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11648 346 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11649 : /* Set up arguments. */
11650 346 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11651 346 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11652 346 : new_st->expr1->value.function.actual->expr->where = code->loc;
11653 346 : new_st->expr1->where = code->loc;
11654 346 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11655 346 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11656 346 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11657 346 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11658 346 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11659 346 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11660 : /* Set up types in formal arg list. */
11661 346 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11662 346 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11663 346 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11664 346 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11665 :
11666 346 : new_st->next = body->next;
11667 : }
11668 316 : if (default_case->next)
11669 : {
11670 110 : new_st->block = gfc_get_code (EXEC_IF);
11671 110 : new_st = new_st->block;
11672 110 : new_st->next = default_case->next;
11673 : }
11674 :
11675 : /* Replace CLASS DEFAULT code by the IF chain. */
11676 316 : default_case->next = if_st;
11677 : }
11678 :
11679 : /* Resolve the internal code. This cannot be done earlier because
11680 : it requires that the sym->assoc of selectors is set already. */
11681 3106 : gfc_current_ns = ns;
11682 3106 : gfc_resolve_blocks (code->block, gfc_current_ns);
11683 3106 : gfc_current_ns = old_ns;
11684 :
11685 3106 : free (ref);
11686 : }
11687 :
11688 :
11689 : /* Resolve a SELECT RANK statement. */
11690 :
11691 : static void
11692 1048 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11693 : {
11694 1048 : gfc_namespace *ns;
11695 1048 : gfc_code *body, *new_st, *tail;
11696 1048 : gfc_case *c;
11697 1048 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11698 1048 : char name[2 * GFC_MAX_SYMBOL_LEN];
11699 1048 : gfc_symtree *st;
11700 1048 : gfc_expr *selector_expr = NULL;
11701 1048 : int case_value;
11702 1048 : HOST_WIDE_INT charlen = 0;
11703 :
11704 1048 : ns = code->ext.block.ns;
11705 1048 : gfc_resolve (ns);
11706 :
11707 1048 : code->op = EXEC_BLOCK;
11708 1048 : if (code->expr2)
11709 : {
11710 42 : gfc_association_list* assoc;
11711 :
11712 42 : assoc = gfc_get_association_list ();
11713 42 : assoc->st = code->expr1->symtree;
11714 42 : assoc->target = gfc_copy_expr (code->expr2);
11715 42 : assoc->target->where = code->expr2->where;
11716 : /* assoc->variable will be set by resolve_assoc_var. */
11717 :
11718 42 : code->ext.block.assoc = assoc;
11719 42 : code->expr1->symtree->n.sym->assoc = assoc;
11720 :
11721 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11722 : }
11723 : else
11724 1006 : code->ext.block.assoc = NULL;
11725 :
11726 : /* Loop over RANK cases. Note that returning on the errors causes a
11727 : cascade of further errors because the case blocks do not compile
11728 : correctly. */
11729 3416 : for (body = code->block; body; body = body->block)
11730 : {
11731 2368 : c = body->ext.block.case_list;
11732 2368 : if (c->low)
11733 1425 : case_value = (int) mpz_get_si (c->low->value.integer);
11734 : else
11735 : case_value = -2;
11736 :
11737 : /* Check for repeated cases. */
11738 5950 : for (tail = code->block; tail; tail = tail->block)
11739 : {
11740 5950 : gfc_case *d = tail->ext.block.case_list;
11741 5950 : int case_value2;
11742 :
11743 5950 : if (tail == body)
11744 : break;
11745 :
11746 : /* Check F2018: C1153. */
11747 3582 : if (!c->low && !d->low)
11748 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11749 : &c->where, &d->where);
11750 :
11751 3582 : if (!c->low || !d->low)
11752 1289 : continue;
11753 :
11754 : /* Check F2018: C1153. */
11755 2293 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11756 2293 : if ((case_value == case_value2) && case_value == -1)
11757 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11758 : &c->where, &d->where);
11759 2292 : else if (case_value == case_value2)
11760 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11761 : case_value, &c->where, &d->where);
11762 : }
11763 :
11764 2368 : if (!c->low)
11765 943 : continue;
11766 :
11767 : /* Check F2018: C1155. */
11768 1425 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11769 1425 : || gfc_expr_attr (code->expr1).pointer))
11770 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11771 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11772 : }
11773 :
11774 : /* Add EXEC_SELECT to switch on rank. */
11775 1048 : new_st = gfc_get_code (code->op);
11776 1048 : new_st->expr1 = code->expr1;
11777 1048 : new_st->expr2 = code->expr2;
11778 1048 : new_st->block = code->block;
11779 1048 : code->expr1 = code->expr2 = NULL;
11780 1048 : code->block = NULL;
11781 1048 : if (!ns->code)
11782 1048 : ns->code = new_st;
11783 : else
11784 0 : ns->code->next = new_st;
11785 1048 : code = new_st;
11786 1048 : code->op = EXEC_SELECT_RANK;
11787 :
11788 1048 : selector_expr = code->expr1;
11789 :
11790 : /* Loop over SELECT RANK cases. */
11791 3416 : for (body = code->block; body; body = body->block)
11792 : {
11793 2368 : c = body->ext.block.case_list;
11794 2368 : int case_value;
11795 :
11796 : /* Pass on the default case. */
11797 2368 : if (c->low == NULL)
11798 943 : continue;
11799 :
11800 : /* Associate temporary to selector. This should only be done
11801 : when this case is actually true, so build a new ASSOCIATE
11802 : that does precisely this here (instead of using the
11803 : 'global' one). */
11804 1425 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11805 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11806 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11807 :
11808 1425 : if (c->ts.type == BT_CLASS)
11809 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11810 1280 : else if (c->ts.type == BT_DERIVED)
11811 116 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11812 1164 : else if (c->ts.type != BT_CHARACTER)
11813 605 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11814 : else
11815 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11816 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11817 :
11818 1425 : case_value = (int) mpz_get_si (c->low->value.integer);
11819 1425 : if (case_value >= 0)
11820 1392 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11821 : else
11822 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11823 :
11824 1425 : st = gfc_find_symtree (ns->sym_root, name);
11825 1425 : gcc_assert (st->n.sym->assoc);
11826 :
11827 1425 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11828 1425 : st->n.sym->assoc->target->where = selector_expr->where;
11829 :
11830 1425 : new_st = gfc_get_code (EXEC_BLOCK);
11831 1425 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11832 1425 : new_st->ext.block.ns->code = body->next;
11833 1425 : body->next = new_st;
11834 :
11835 : /* Chain in the new list only if it is marked as dangling. Otherwise
11836 : there is a CASE label overlap and this is already used. Just ignore,
11837 : the error is diagnosed elsewhere. */
11838 1425 : if (st->n.sym->assoc->dangling)
11839 : {
11840 1423 : new_st->ext.block.assoc = st->n.sym->assoc;
11841 1423 : st->n.sym->assoc->dangling = 0;
11842 : }
11843 :
11844 1425 : resolve_assoc_var (st->n.sym, false);
11845 : }
11846 :
11847 1048 : gfc_current_ns = ns;
11848 1048 : gfc_resolve_blocks (code->block, gfc_current_ns);
11849 1048 : gfc_current_ns = old_ns;
11850 1048 : }
11851 :
11852 :
11853 : /* Resolve a transfer statement. This is making sure that:
11854 : -- a derived type being transferred has only non-pointer components
11855 : -- a derived type being transferred doesn't have private components, unless
11856 : it's being transferred from the module where the type was defined
11857 : -- we're not trying to transfer a whole assumed size array. */
11858 :
11859 : static void
11860 47666 : resolve_transfer (gfc_code *code)
11861 : {
11862 47666 : gfc_symbol *sym, *derived;
11863 47666 : gfc_ref *ref;
11864 47666 : gfc_expr *exp;
11865 47666 : bool write = false;
11866 47666 : bool formatted = false;
11867 47666 : gfc_dt *dt = code->ext.dt;
11868 47666 : gfc_symbol *dtio_sub = NULL;
11869 :
11870 47666 : exp = code->expr1;
11871 :
11872 95338 : while (exp != NULL && exp->expr_type == EXPR_OP
11873 48600 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11874 6 : exp = exp->value.op.op1;
11875 :
11876 47666 : if (exp && exp->expr_type == EXPR_NULL
11877 2 : && code->ext.dt)
11878 : {
11879 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11880 : &exp->where);
11881 2 : return;
11882 : }
11883 :
11884 47664 : if (dt && (dt->dt_io_kind->value.iokind == M_WRITE
11885 47512 : || dt->dt_io_kind->value.iokind == M_PRINT))
11886 39906 : gfc_value_used_expr (exp, VALUE_USED);
11887 :
11888 47664 : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11889 : && exp->expr_type != EXPR_FUNCTION
11890 : && exp->expr_type != EXPR_ARRAY
11891 : && exp->expr_type != EXPR_STRUCTURE))
11892 : return;
11893 :
11894 26450 : if (dt && dt->dt_io_kind->value.iokind == M_READ)
11895 : {
11896 : /* If we are reading, the variable will be changed. Note that
11897 : code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE
11898 : statement -- but in this case, we are not reading, either. */
11899 7606 : if (!gfc_check_vardef_context (exp, false, false, false,
11900 7606 : _("item in READ")))
11901 : return;
11902 :
11903 7602 : gfc_expr_set_at (exp, &exp->where, VALUE_READ);
11904 : }
11905 :
11906 26446 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11907 26446 : || exp->expr_type == EXPR_FUNCTION
11908 22047 : || exp->expr_type == EXPR_ARRAY
11909 48493 : ? &exp->ts : &exp->symtree->n.sym->ts;
11910 :
11911 : /* Go to actual component transferred. */
11912 34315 : for (ref = exp->ref; ref; ref = ref->next)
11913 7869 : if (ref->type == REF_COMPONENT)
11914 2229 : ts = &ref->u.c.component->ts;
11915 :
11916 26446 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11917 26298 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11918 : {
11919 720 : derived = ts->u.derived;
11920 :
11921 : /* Determine when to use the formatted DTIO procedure. */
11922 720 : if (dt && (dt->format_expr || dt->format_label))
11923 645 : formatted = true;
11924 :
11925 720 : write = dt->dt_io_kind->value.iokind == M_WRITE
11926 720 : || dt->dt_io_kind->value.iokind == M_PRINT;
11927 720 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11928 :
11929 720 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11930 : {
11931 450 : dt->udtio = exp;
11932 450 : sym = exp->symtree->n.sym->ns->proc_name;
11933 : /* Check to see if this is a nested DTIO call, with the
11934 : dummy as the io-list object. */
11935 450 : if (sym && sym == dtio_sub && sym->formal
11936 30 : && sym->formal->sym == exp->symtree->n.sym
11937 30 : && exp->ref == NULL)
11938 : {
11939 0 : if (!sym->attr.recursive)
11940 : {
11941 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11942 : sym->name, &sym->declared_at);
11943 0 : return;
11944 : }
11945 : }
11946 : }
11947 : }
11948 :
11949 26446 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11950 : {
11951 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11952 : "it is processed by a defined input/output procedure",
11953 : &code->loc);
11954 3 : return;
11955 : }
11956 :
11957 26443 : if (ts->type == BT_DERIVED)
11958 : {
11959 : /* Check that transferred derived type doesn't contain POINTER
11960 : components unless it is processed by a defined input/output
11961 : procedure". */
11962 688 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11963 : {
11964 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11965 : "components unless it is processed by a defined "
11966 : "input/output procedure", &code->loc);
11967 2 : return;
11968 : }
11969 :
11970 : /* F08:C935. */
11971 686 : if (ts->u.derived->attr.proc_pointer_comp)
11972 : {
11973 2 : gfc_error ("Data transfer element at %L cannot have "
11974 : "procedure pointer components", &code->loc);
11975 2 : return;
11976 : }
11977 :
11978 684 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11979 : {
11980 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11981 : "components unless it is processed by a defined "
11982 : "input/output procedure", &code->loc);
11983 6 : return;
11984 : }
11985 :
11986 : /* C_PTR and C_FUNPTR have private components which means they cannot
11987 : be printed. However, if -std=gnu and not -pedantic, allow
11988 : the component to be printed to help debugging. */
11989 678 : if (ts->u.derived->ts.f90_type == BT_VOID)
11990 : {
11991 4 : gfc_error ("Data transfer element at %L "
11992 : "cannot have PRIVATE components", &code->loc);
11993 4 : return;
11994 : }
11995 674 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11996 : {
11997 4 : gfc_error ("Data transfer element at %L cannot have "
11998 : "PRIVATE components unless it is processed by "
11999 : "a defined input/output procedure", &code->loc);
12000 4 : return;
12001 : }
12002 : }
12003 :
12004 26425 : if (exp->expr_type == EXPR_STRUCTURE)
12005 : return;
12006 :
12007 26380 : if (exp->expr_type == EXPR_ARRAY)
12008 : return;
12009 :
12010 25998 : sym = exp->symtree->n.sym;
12011 :
12012 25998 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
12013 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
12014 : {
12015 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
12016 : "an assumed-size array", &code->loc);
12017 1 : return;
12018 : }
12019 :
12020 : }
12021 :
12022 :
12023 : /*********** Toplevel code resolution subroutines ***********/
12024 :
12025 : /* Find the set of labels that are reachable from this block. We also
12026 : record the last statement in each block. */
12027 :
12028 : static void
12029 701679 : find_reachable_labels (gfc_code *block)
12030 : {
12031 701679 : gfc_code *c;
12032 :
12033 701679 : if (!block)
12034 : return;
12035 :
12036 433857 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
12037 :
12038 : /* Collect labels in this block. We don't keep those corresponding
12039 : to END {IF|SELECT}, these are checked in resolve_branch by going
12040 : up through the code_stack. */
12041 1589296 : for (c = block; c; c = c->next)
12042 : {
12043 1155439 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
12044 3716 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
12045 : }
12046 :
12047 : /* Merge with labels from parent block. */
12048 433857 : if (cs_base->prev)
12049 : {
12050 355682 : gcc_assert (cs_base->prev->reachable_labels);
12051 355682 : bitmap_ior_into (cs_base->reachable_labels,
12052 : cs_base->prev->reachable_labels);
12053 : }
12054 : }
12055 :
12056 : static void
12057 197 : resolve_lock_unlock_event (gfc_code *code)
12058 : {
12059 197 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
12060 197 : && (code->expr1->ts.type != BT_DERIVED
12061 137 : || code->expr1->expr_type != EXPR_VARIABLE
12062 137 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12063 136 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
12064 136 : || code->expr1->rank != 0
12065 181 : || (!gfc_is_coarray (code->expr1) &&
12066 46 : !gfc_is_coindexed (code->expr1))))
12067 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
12068 4 : &code->expr1->where);
12069 193 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
12070 58 : && (code->expr1->ts.type != BT_DERIVED
12071 58 : || code->expr1->expr_type != EXPR_VARIABLE
12072 58 : || code->expr1->ts.u.derived->from_intmod
12073 : != INTMOD_ISO_FORTRAN_ENV
12074 58 : || code->expr1->ts.u.derived->intmod_sym_id
12075 : != ISOFORTRAN_EVENT_TYPE
12076 58 : || code->expr1->rank != 0))
12077 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
12078 : &code->expr1->where);
12079 34 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
12080 209 : && !gfc_is_coindexed (code->expr1))
12081 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
12082 0 : &code->expr1->where);
12083 193 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
12084 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
12085 0 : "coindexed", &code->expr1->where);
12086 :
12087 : /* Check STAT. */
12088 197 : if (code->expr2
12089 54 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
12090 54 : || code->expr2->expr_type != EXPR_VARIABLE))
12091 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12092 : &code->expr2->where);
12093 :
12094 197 : if (code->expr2
12095 251 : && !gfc_check_vardef_context (code->expr2, false, false, false,
12096 54 : _("STAT variable")))
12097 : return;
12098 :
12099 : /* Check ERRMSG. */
12100 197 : if (code->expr3
12101 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
12102 2 : || code->expr3->expr_type != EXPR_VARIABLE))
12103 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12104 : &code->expr3->where);
12105 :
12106 197 : if (code->expr3
12107 199 : && !gfc_check_vardef_context (code->expr3, false, false, false,
12108 2 : _("ERRMSG variable")))
12109 : return;
12110 :
12111 : /* Check for LOCK the ACQUIRED_LOCK. */
12112 197 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12113 22 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
12114 22 : || code->expr4->expr_type != EXPR_VARIABLE))
12115 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
12116 : "variable", &code->expr4->where);
12117 :
12118 173 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12119 219 : && !gfc_check_vardef_context (code->expr4, false, false, false,
12120 22 : _("ACQUIRED_LOCK variable")))
12121 : return;
12122 :
12123 : /* Check for EVENT WAIT the UNTIL_COUNT. */
12124 197 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
12125 : {
12126 36 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
12127 36 : || code->expr4->rank != 0)
12128 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
12129 0 : "expression", &code->expr4->where);
12130 : }
12131 : }
12132 :
12133 : static void
12134 316 : resolve_team_argument (gfc_expr *team)
12135 : {
12136 316 : gfc_resolve_expr (team);
12137 316 : if (team->rank != 0 || team->ts.type != BT_DERIVED
12138 309 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12139 309 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
12140 : {
12141 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
12142 : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
12143 : &team->where);
12144 : }
12145 316 : }
12146 :
12147 : static void
12148 1578 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
12149 : gfc_expr *e)
12150 : {
12151 1578 : gfc_resolve_expr (e);
12152 1578 : if (e
12153 141 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
12154 126 : || e->expr_type != EXPR_VARIABLE))
12155 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
12156 : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
12157 : exp_kind);
12158 1578 : }
12159 :
12160 : void
12161 789 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
12162 : {
12163 789 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
12164 789 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
12165 : gfc_default_character_kind,
12166 : sync_stat->errmsg);
12167 789 : }
12168 :
12169 : static void
12170 328 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
12171 : gfc_expr *e)
12172 : {
12173 328 : gfc_resolve_expr (e);
12174 328 : if (e
12175 195 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
12176 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
12177 : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
12178 328 : }
12179 :
12180 : static void
12181 164 : resolve_form_team (gfc_code *code)
12182 : {
12183 164 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
12184 : code->expr1);
12185 164 : resolve_team_argument (code->expr2);
12186 164 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
12187 : code->expr3);
12188 164 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12189 164 : }
12190 :
12191 : static void resolve_block_construct (gfc_code *);
12192 :
12193 : static void
12194 107 : resolve_change_team (gfc_code *code)
12195 : {
12196 107 : resolve_team_argument (code->expr1);
12197 107 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
12198 214 : resolve_block_construct (code);
12199 : /* Map the coarray bounds as selected. */
12200 110 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
12201 3 : if (a->ar)
12202 : {
12203 3 : gfc_array_spec *src = a->ar->as, *dst;
12204 3 : if (a->st->n.sym->ts.type == BT_CLASS)
12205 0 : dst = CLASS_DATA (a->st->n.sym)->as;
12206 : else
12207 3 : dst = a->st->n.sym->as;
12208 3 : dst->corank = src->corank;
12209 3 : dst->cotype = src->cotype;
12210 6 : for (int i = 0; i < src->corank; ++i)
12211 : {
12212 3 : dst->lower[dst->rank + i] = src->lower[i];
12213 3 : dst->upper[dst->rank + i] = src->upper[i];
12214 3 : src->lower[i] = src->upper[i] = nullptr;
12215 : }
12216 3 : gfc_free_array_spec (src);
12217 3 : free (a->ar);
12218 3 : a->ar = nullptr;
12219 3 : dst->resolved = false;
12220 3 : gfc_resolve_array_spec (dst, 0);
12221 : }
12222 107 : }
12223 :
12224 : static void
12225 45 : resolve_sync_team (gfc_code *code)
12226 : {
12227 45 : resolve_team_argument (code->expr1);
12228 45 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12229 45 : }
12230 :
12231 : static void
12232 105 : resolve_end_team (gfc_code *code)
12233 : {
12234 105 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12235 105 : }
12236 :
12237 : static void
12238 54 : resolve_critical (gfc_code *code)
12239 : {
12240 54 : gfc_symtree *symtree;
12241 54 : gfc_symbol *lock_type;
12242 54 : char name[GFC_MAX_SYMBOL_LEN];
12243 54 : static int serial = 0;
12244 :
12245 54 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12246 :
12247 54 : if (flag_coarray != GFC_FCOARRAY_LIB)
12248 30 : return;
12249 :
12250 24 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12251 : GFC_PREFIX ("lock_type"));
12252 24 : if (symtree)
12253 12 : lock_type = symtree->n.sym;
12254 : else
12255 : {
12256 12 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
12257 : false) != 0)
12258 0 : gcc_unreachable ();
12259 12 : lock_type = symtree->n.sym;
12260 12 : lock_type->attr.flavor = FL_DERIVED;
12261 12 : lock_type->attr.zero_comp = 1;
12262 12 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
12263 12 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
12264 : }
12265 :
12266 24 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
12267 24 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
12268 0 : gcc_unreachable ();
12269 :
12270 24 : code->resolved_sym = symtree->n.sym;
12271 24 : symtree->n.sym->attr.flavor = FL_VARIABLE;
12272 24 : symtree->n.sym->attr.referenced = 1;
12273 24 : symtree->n.sym->attr.artificial = 1;
12274 24 : symtree->n.sym->attr.codimension = 1;
12275 24 : symtree->n.sym->ts.type = BT_DERIVED;
12276 24 : symtree->n.sym->ts.u.derived = lock_type;
12277 24 : symtree->n.sym->as = gfc_get_array_spec ();
12278 24 : symtree->n.sym->as->corank = 1;
12279 24 : symtree->n.sym->as->type = AS_EXPLICIT;
12280 24 : symtree->n.sym->as->cotype = AS_EXPLICIT;
12281 24 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
12282 : NULL, 1);
12283 24 : gfc_commit_symbols();
12284 : }
12285 :
12286 :
12287 : static void
12288 1393 : resolve_sync (gfc_code *code)
12289 : {
12290 : /* Check imageset. The * case matches expr1 == NULL. */
12291 1393 : if (code->expr1)
12292 : {
12293 77 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
12294 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
12295 : "INTEGER expression", &code->expr1->where);
12296 77 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
12297 33 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
12298 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
12299 : &code->expr1->where);
12300 76 : else if (code->expr1->expr_type == EXPR_ARRAY
12301 76 : && gfc_simplify_expr (code->expr1, 0))
12302 : {
12303 20 : gfc_constructor *cons;
12304 20 : cons = gfc_constructor_first (code->expr1->value.constructor);
12305 60 : for (; cons; cons = gfc_constructor_next (cons))
12306 20 : if (cons->expr->expr_type == EXPR_CONSTANT
12307 20 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
12308 0 : gfc_error ("Imageset argument at %L must between 1 and "
12309 : "num_images()", &cons->expr->where);
12310 : }
12311 : }
12312 :
12313 : /* Check STAT. */
12314 1393 : gfc_resolve_expr (code->expr2);
12315 1393 : if (code->expr2)
12316 : {
12317 143 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12318 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12319 : &code->expr2->where);
12320 : else
12321 142 : gfc_check_vardef_context (code->expr2, false, false, false,
12322 142 : _("STAT variable"));
12323 : }
12324 :
12325 : /* Check ERRMSG. */
12326 1393 : gfc_resolve_expr (code->expr3);
12327 1393 : if (code->expr3)
12328 : {
12329 90 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12330 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12331 : &code->expr3->where);
12332 : else
12333 86 : gfc_check_vardef_context (code->expr3, false, false, false,
12334 86 : _("ERRMSG variable"));
12335 : }
12336 1393 : }
12337 :
12338 :
12339 : /* Given a branch to a label, see if the branch is conforming.
12340 : The code node describes where the branch is located. */
12341 :
12342 : static void
12343 112300 : resolve_branch (gfc_st_label *label, gfc_code *code)
12344 : {
12345 112300 : code_stack *stack;
12346 :
12347 112300 : if (label == NULL)
12348 : return;
12349 :
12350 : /* Step one: is this a valid branching target? */
12351 :
12352 2514 : if (label->defined == ST_LABEL_UNKNOWN)
12353 : {
12354 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12355 : &code->loc);
12356 4 : return;
12357 : }
12358 :
12359 2510 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12360 : {
12361 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12362 : "for the branch statement at %L", &label->where, &code->loc);
12363 4 : return;
12364 : }
12365 :
12366 : /* Step two: make sure this branch is not a branch to itself ;-) */
12367 :
12368 2506 : if (code->here == label)
12369 : {
12370 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12371 : &code->loc);
12372 0 : return;
12373 : }
12374 :
12375 : /* Step three: See if the label is in the same block as the
12376 : branching statement. The hard work has been done by setting up
12377 : the bitmap reachable_labels. */
12378 :
12379 2506 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12380 : {
12381 : /* Check now whether there is a CRITICAL construct; if so, check
12382 : whether the label is still visible outside of the CRITICAL block,
12383 : which is invalid. */
12384 6375 : for (stack = cs_base; stack; stack = stack->prev)
12385 : {
12386 3937 : if (stack->current->op == EXEC_CRITICAL
12387 3937 : && bitmap_bit_p (stack->reachable_labels, label->value))
12388 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12389 : "label at %L", &code->loc, &label->where);
12390 3935 : else if (stack->current->op == EXEC_DO_CONCURRENT
12391 3935 : && bitmap_bit_p (stack->reachable_labels, label->value))
12392 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12393 : "for label at %L", &code->loc, &label->where);
12394 3935 : else if (stack->current->op == EXEC_CHANGE_TEAM
12395 3935 : && bitmap_bit_p (stack->reachable_labels, label->value))
12396 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12397 : "for label at %L", &code->loc, &label->where);
12398 : }
12399 :
12400 : return;
12401 : }
12402 :
12403 : /* Step four: If we haven't found the label in the bitmap, it may
12404 : still be the label of the END of the enclosing block, in which
12405 : case we find it by going up the code_stack. */
12406 :
12407 167 : for (stack = cs_base; stack; stack = stack->prev)
12408 : {
12409 131 : if (stack->current->next && stack->current->next->here == label)
12410 : break;
12411 101 : if (stack->current->op == EXEC_CRITICAL)
12412 : {
12413 : /* Note: A label at END CRITICAL does not leave the CRITICAL
12414 : construct as END CRITICAL is still part of it. */
12415 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12416 : " at %L", &code->loc, &label->where);
12417 2 : return;
12418 : }
12419 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12420 : {
12421 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12422 : "label at %L", &code->loc, &label->where);
12423 0 : return;
12424 : }
12425 : }
12426 :
12427 66 : if (stack)
12428 : {
12429 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12430 : return;
12431 : }
12432 :
12433 : /* The label is not in an enclosing block, so illegal. This was
12434 : allowed in Fortran 66, so we allow it as extension. No
12435 : further checks are necessary in this case. */
12436 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12437 : "as the GOTO statement at %L", &label->where,
12438 : &code->loc);
12439 36 : return;
12440 : }
12441 :
12442 :
12443 : /* Check whether EXPR1 has the same shape as EXPR2. */
12444 :
12445 : static bool
12446 1479 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12447 : {
12448 1479 : mpz_t shape[GFC_MAX_DIMENSIONS];
12449 1479 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12450 1479 : bool result = false;
12451 1479 : int i;
12452 :
12453 : /* Compare the rank. */
12454 1479 : if (expr1->rank != expr2->rank)
12455 : return result;
12456 :
12457 : /* Compare the size of each dimension. */
12458 2835 : for (i=0; i<expr1->rank; i++)
12459 : {
12460 1507 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12461 151 : goto ignore;
12462 :
12463 1356 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12464 0 : goto ignore;
12465 :
12466 1356 : if (mpz_cmp (shape[i], shape2[i]))
12467 0 : goto over;
12468 : }
12469 :
12470 : /* When either of the two expression is an assumed size array, we
12471 : ignore the comparison of dimension sizes. */
12472 1328 : ignore:
12473 : result = true;
12474 :
12475 1479 : over:
12476 1479 : gfc_clear_shape (shape, i);
12477 1479 : gfc_clear_shape (shape2, i);
12478 1479 : return result;
12479 : }
12480 :
12481 :
12482 : /* Check whether a WHERE assignment target or a WHERE mask expression
12483 : has the same shape as the outermost WHERE mask expression. */
12484 :
12485 : static void
12486 515 : resolve_where (gfc_code *code, gfc_expr *mask)
12487 : {
12488 515 : gfc_code *cblock;
12489 515 : gfc_code *cnext;
12490 515 : gfc_expr *e = NULL;
12491 :
12492 515 : cblock = code->block;
12493 :
12494 : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12495 : In case of nested WHERE, only the outermost one is stored. */
12496 515 : if (mask == NULL) /* outermost WHERE */
12497 459 : e = cblock->expr1;
12498 : else /* inner WHERE */
12499 515 : e = mask;
12500 :
12501 1399 : while (cblock)
12502 : {
12503 884 : if (cblock->expr1)
12504 : {
12505 : /* Check if the mask-expr has a consistent shape with the
12506 : outermost WHERE mask-expr. */
12507 720 : if (!resolve_where_shape (cblock->expr1, e))
12508 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12509 0 : &cblock->expr1->where);
12510 : }
12511 :
12512 : /* the assignment statement of a WHERE statement, or the first
12513 : statement in where-body-construct of a WHERE construct */
12514 884 : cnext = cblock->next;
12515 1745 : while (cnext)
12516 : {
12517 861 : switch (cnext->op)
12518 : {
12519 : /* WHERE assignment statement */
12520 759 : case EXEC_ASSIGN:
12521 :
12522 : /* Check shape consistent for WHERE assignment target. */
12523 759 : if (e && !resolve_where_shape (cnext->expr1, e))
12524 0 : gfc_error ("WHERE assignment target at %L has "
12525 0 : "inconsistent shape", &cnext->expr1->where);
12526 :
12527 759 : if (cnext->op == EXEC_ASSIGN
12528 759 : && gfc_may_be_finalized (cnext->expr1->ts))
12529 0 : cnext->expr1->must_finalize = 1;
12530 :
12531 : break;
12532 :
12533 :
12534 46 : case EXEC_ASSIGN_CALL:
12535 46 : resolve_call (cnext);
12536 46 : if (!cnext->resolved_sym->attr.elemental)
12537 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12538 2 : &cnext->ext.actual->expr->where);
12539 : break;
12540 :
12541 : /* WHERE or WHERE construct is part of a where-body-construct */
12542 56 : case EXEC_WHERE:
12543 56 : resolve_where (cnext, e);
12544 56 : break;
12545 :
12546 0 : default:
12547 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12548 : &cnext->loc);
12549 : }
12550 : /* the next statement within the same where-body-construct */
12551 861 : cnext = cnext->next;
12552 : }
12553 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12554 884 : cblock = cblock->block;
12555 : }
12556 515 : }
12557 :
12558 :
12559 : /* Resolve assignment in FORALL construct.
12560 : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12561 : FORALL index variables. */
12562 :
12563 : static void
12564 2400 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12565 : {
12566 2400 : int n;
12567 2400 : gfc_symbol *forall_index;
12568 :
12569 6822 : for (n = 0; n < nvar; n++)
12570 : {
12571 4422 : forall_index = var_expr[n]->symtree->n.sym;
12572 :
12573 : /* Check whether the assignment target is one of the FORALL index
12574 : variable. */
12575 4422 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12576 4422 : && (code->expr1->symtree->n.sym == forall_index))
12577 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12578 : &code->expr1->where);
12579 : else
12580 : {
12581 : /* If one of the FORALL index variables doesn't appear in the
12582 : assignment variable, then there could be a many-to-one
12583 : assignment. Emit a warning rather than an error because the
12584 : mask could be resolving this problem.
12585 : DO NOT emit this warning for DO CONCURRENT - reduction-like
12586 : many-to-one assignments are semantically valid (formalized with
12587 : the REDUCE locality-spec in Fortran 2023). */
12588 4422 : if (!find_forall_index (code->expr1, forall_index, 0)
12589 4422 : && !gfc_do_concurrent_flag)
12590 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12591 : "left side of the assignment at %L and so might "
12592 : "cause multiple assignment to this object",
12593 0 : var_expr[n]->symtree->name, &code->expr1->where);
12594 : }
12595 : }
12596 2400 : }
12597 :
12598 :
12599 : /* Resolve WHERE statement in FORALL construct. */
12600 :
12601 : static void
12602 53 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12603 : gfc_expr **var_expr)
12604 : {
12605 53 : gfc_code *cblock;
12606 53 : gfc_code *cnext;
12607 :
12608 53 : cblock = code->block;
12609 125 : while (cblock)
12610 : {
12611 : /* the assignment statement of a WHERE statement, or the first
12612 : statement in where-body-construct of a WHERE construct */
12613 72 : cnext = cblock->next;
12614 144 : while (cnext)
12615 : {
12616 72 : switch (cnext->op)
12617 : {
12618 : /* WHERE assignment statement */
12619 72 : case EXEC_ASSIGN:
12620 72 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12621 :
12622 72 : if (cnext->op == EXEC_ASSIGN
12623 72 : && gfc_may_be_finalized (cnext->expr1->ts))
12624 0 : cnext->expr1->must_finalize = 1;
12625 :
12626 : break;
12627 :
12628 : /* WHERE operator assignment statement */
12629 0 : case EXEC_ASSIGN_CALL:
12630 0 : resolve_call (cnext);
12631 0 : if (!cnext->resolved_sym->attr.elemental)
12632 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12633 0 : &cnext->ext.actual->expr->where);
12634 : break;
12635 :
12636 : /* WHERE or WHERE construct is part of a where-body-construct */
12637 0 : case EXEC_WHERE:
12638 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12639 0 : break;
12640 :
12641 0 : default:
12642 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12643 : &cnext->loc);
12644 : }
12645 : /* the next statement within the same where-body-construct */
12646 72 : cnext = cnext->next;
12647 : }
12648 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12649 72 : cblock = cblock->block;
12650 : }
12651 53 : }
12652 :
12653 :
12654 : /* Traverse the FORALL body to check whether the following errors exist:
12655 : 1. For assignment, check if a many-to-one assignment happens.
12656 : 2. For WHERE statement, check the WHERE body to see if there is any
12657 : many-to-one assignment. */
12658 :
12659 : static void
12660 2271 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12661 : {
12662 2271 : gfc_code *c;
12663 :
12664 2271 : c = code->block->next;
12665 4964 : while (c)
12666 : {
12667 2693 : switch (c->op)
12668 : {
12669 2328 : case EXEC_ASSIGN:
12670 2328 : case EXEC_POINTER_ASSIGN:
12671 2328 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12672 :
12673 2328 : if (c->op == EXEC_ASSIGN
12674 2328 : && gfc_may_be_finalized (c->expr1->ts))
12675 0 : c->expr1->must_finalize = 1;
12676 :
12677 : break;
12678 :
12679 0 : case EXEC_ASSIGN_CALL:
12680 0 : resolve_call (c);
12681 0 : break;
12682 :
12683 : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12684 : there is no need to handle it here. */
12685 : case EXEC_FORALL:
12686 : break;
12687 53 : case EXEC_WHERE:
12688 53 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12689 53 : break;
12690 : default:
12691 : break;
12692 : }
12693 : /* The next statement in the FORALL body. */
12694 2693 : c = c->next;
12695 : }
12696 2271 : }
12697 :
12698 :
12699 : /* Counts the number of iterators needed inside a forall construct, including
12700 : nested forall constructs. This is used to allocate the needed memory
12701 : in gfc_resolve_forall. */
12702 :
12703 : static int gfc_count_forall_iterators (gfc_code *code);
12704 :
12705 : /* Return the deepest nested FORALL/DO CONCURRENT iterator count in CODE's
12706 : next-chain, descending into block arms such as IF/ELSE branches. */
12707 :
12708 : static int
12709 2511 : gfc_max_forall_iterators_in_chain (gfc_code *code)
12710 : {
12711 2511 : int max_iters = 0;
12712 :
12713 5479 : for (gfc_code *c = code; c; c = c->next)
12714 : {
12715 2968 : int sub_iters = 0;
12716 :
12717 2968 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12718 94 : sub_iters = gfc_count_forall_iterators (c);
12719 2874 : else if (c->op == EXEC_BLOCK)
12720 : {
12721 : /* BLOCK/ASSOCIATE bodies live in the block namespace code chain,
12722 : not in the generic c->block arm list used by IF/SELECT. */
12723 40 : if (c->ext.block.ns && c->ext.block.ns->code)
12724 40 : sub_iters = gfc_max_forall_iterators_in_chain (c->ext.block.ns->code);
12725 : }
12726 2834 : else if (c->block)
12727 367 : for (gfc_code *b = c->block; b; b = b->block)
12728 : {
12729 200 : int arm_iters = gfc_max_forall_iterators_in_chain (b->next);
12730 200 : if (arm_iters > sub_iters)
12731 : sub_iters = arm_iters;
12732 : }
12733 :
12734 2968 : if (sub_iters > max_iters)
12735 : max_iters = sub_iters;
12736 : }
12737 :
12738 2511 : return max_iters;
12739 : }
12740 :
12741 :
12742 : static int
12743 2271 : gfc_count_forall_iterators (gfc_code *code)
12744 : {
12745 2271 : int current_iters = 0;
12746 2271 : gfc_forall_iterator *fa;
12747 :
12748 2271 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12749 :
12750 6460 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12751 4189 : current_iters++;
12752 :
12753 2271 : return current_iters + gfc_max_forall_iterators_in_chain (code->block->next);
12754 : }
12755 :
12756 :
12757 : /* Given a FORALL construct.
12758 : 1) Resolve the FORALL iterator.
12759 : 2) Check for shadow index-name(s) and update code block.
12760 : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12761 :
12762 : /* Shadow variable that replace_forall_var substitutes in; set by
12763 : replace_in_expr_recursive before each traversal. */
12764 :
12765 : static gfc_symtree *forall_shadow_st;
12766 :
12767 : /* gfc_traverse_expr callback: point a reference to OLD_SYM at the
12768 : construct-scoped shadow variable. */
12769 :
12770 : static bool
12771 594 : replace_forall_var (gfc_expr *expr, gfc_symbol *old_sym,
12772 : int *f ATTRIBUTE_UNUSED)
12773 : {
12774 594 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12775 : {
12776 162 : expr->symtree = forall_shadow_st;
12777 162 : expr->ts = forall_shadow_st->n.sym->ts;
12778 : }
12779 :
12780 594 : return false;
12781 : }
12782 :
12783 :
12784 : /* Replace every reference to OLD_SYM in EXPR with NEW_ST. Traversal is
12785 : left to gfc_traverse_expr so that all expression forms are covered;
12786 : character length type parameters are skipped since those belong to
12787 : declarations that may be shared outside the construct. */
12788 :
12789 : static void
12790 654 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym,
12791 : gfc_symtree *new_st)
12792 : {
12793 654 : if (!expr)
12794 : return;
12795 :
12796 264 : forall_shadow_st = new_st;
12797 264 : gfc_traverse_expr (expr, old_sym, replace_forall_var, -1);
12798 : }
12799 :
12800 :
12801 : /* Walk code tree and replace all variable references */
12802 :
12803 : static void
12804 144 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12805 : {
12806 144 : if (!code)
12807 : return;
12808 :
12809 294 : for (gfc_code *c = code; c; c = c->next)
12810 : {
12811 : /* Replace in expressions associated with this code node */
12812 150 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12813 150 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12814 150 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12815 150 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12816 :
12817 : /* Handle special code types with additional expressions */
12818 150 : switch (c->op)
12819 : {
12820 0 : case EXEC_DO:
12821 0 : if (c->ext.iterator)
12822 : {
12823 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12824 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12825 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12826 : }
12827 : break;
12828 :
12829 0 : case EXEC_CALL:
12830 0 : case EXEC_ASSIGN_CALL:
12831 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12832 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12833 : break;
12834 :
12835 6 : case EXEC_SELECT:
12836 6 : case EXEC_SELECT_TYPE:
12837 6 : case EXEC_SELECT_RANK:
12838 12 : for (gfc_code *b = c->block; b; b = b->block)
12839 : {
12840 12 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12841 : {
12842 6 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12843 6 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12844 : }
12845 6 : replace_in_code_recursive (b->next, old_sym, new_st);
12846 : }
12847 : break;
12848 :
12849 18 : case EXEC_IF:
12850 18 : case EXEC_WHERE:
12851 : /* Each block in the chain holds its condition or mask in EXPR1
12852 : and its body in NEXT; the trailing ELSE/ELSEWHERE has no
12853 : condition. The generic recursion below only reaches the first
12854 : branch, so walk the whole chain here. */
12855 48 : for (gfc_code *b = c->block; b; b = b->block)
12856 : {
12857 30 : replace_in_expr_recursive (b->expr1, old_sym, new_st);
12858 30 : replace_in_code_recursive (b->next, old_sym, new_st);
12859 : }
12860 : break;
12861 :
12862 6 : case EXEC_ALLOCATE:
12863 6 : case EXEC_DEALLOCATE:
12864 : /* Bounds and lengths of the allocate-objects. */
12865 12 : for (gfc_alloc *al = c->ext.alloc.list; al; al = al->next)
12866 6 : replace_in_expr_recursive (al->expr, old_sym, new_st);
12867 : break;
12868 :
12869 0 : case EXEC_FORALL:
12870 0 : case EXEC_DO_CONCURRENT:
12871 0 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12872 : {
12873 0 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12874 0 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12875 0 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12876 : }
12877 : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12878 : they'll be handled separately */
12879 : break;
12880 :
12881 12 : case EXEC_BLOCK:
12882 : /* Replace in ASSOCIATE selector expressions and the body.
12883 : The body of an EXEC_BLOCK lives in c->ext.block.ns->code, not
12884 : c->block->next, so without this case both selectors and body
12885 : are silently skipped, leaving shadow iterator references unreplaced
12886 : and producing wrong values at runtime. */
12887 12 : for (gfc_association_list *alist = c->ext.block.assoc;
12888 18 : alist; alist = alist->next)
12889 6 : replace_in_expr_recursive (alist->target, old_sym, new_st);
12890 12 : if (c->ext.block.ns)
12891 12 : replace_in_code_recursive (c->ext.block.ns->code, old_sym, new_st);
12892 : break;
12893 :
12894 : default:
12895 : break;
12896 : }
12897 :
12898 : /* Recurse into blocks */
12899 150 : if (c->block)
12900 24 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12901 : }
12902 : }
12903 :
12904 :
12905 : /* Replace all references to outer_sym with shadow_st in the given code. */
12906 :
12907 : static void
12908 72 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12909 : gfc_symtree *shadow_st)
12910 : {
12911 : /* Use custom recursive walker to ensure we visit ALL expressions */
12912 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12913 0 : }
12914 :
12915 :
12916 : static void
12917 2271 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12918 : {
12919 2271 : static gfc_expr **var_expr;
12920 2271 : static int total_var = 0;
12921 2271 : static int nvar = 0;
12922 2271 : int i, old_nvar, tmp;
12923 2271 : gfc_forall_iterator *fa;
12924 2271 : bool shadow = false;
12925 :
12926 2271 : old_nvar = nvar;
12927 :
12928 : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12929 2271 : if (code->op == EXEC_FORALL
12930 2271 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12931 : return;
12932 :
12933 : /* Start to resolve a FORALL construct */
12934 : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12935 : forall_save==0 means we're not nested in a FORALL in the current scope,
12936 : but nvar==0 ensures we're not nested in a parent scope either (prevents
12937 : double allocation when FORALL is nested inside DO CONCURRENT). */
12938 2271 : if (forall_save == 0 && nvar == 0)
12939 : {
12940 : /* Count the total number of FORALL indices in the nested FORALL
12941 : construct in order to allocate the VAR_EXPR with proper size. */
12942 2177 : total_var = gfc_count_forall_iterators (code);
12943 :
12944 : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12945 2177 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12946 : }
12947 :
12948 : /* The information about FORALL iterator, including FORALL indices start,
12949 : end and stride. An outer FORALL indice cannot appear in start, end or
12950 : stride. Check for a shadow index-name. */
12951 6460 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12952 : {
12953 : /* Fortran 2008: C738 (R753). */
12954 4189 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12955 : {
12956 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12957 : "of type integer", &fa->var->where);
12958 2 : continue;
12959 : }
12960 :
12961 : /* Check if any outer FORALL index name is the same as the current
12962 : one. Skip this check if the iterator is a shadow variable (from
12963 : DO CONCURRENT type spec) which may not have a symtree yet. */
12964 7198 : for (i = 0; i < nvar; i++)
12965 : {
12966 3011 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12967 3011 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12968 0 : gfc_error ("An outer FORALL construct already has an index "
12969 : "with this name %L", &fa->var->where);
12970 : }
12971 :
12972 4187 : if (fa->shadow)
12973 72 : shadow = true;
12974 :
12975 : /* Record the current FORALL index. */
12976 4187 : var_expr[nvar] = gfc_copy_expr (fa->var);
12977 :
12978 4187 : nvar++;
12979 :
12980 : /* No memory leak. */
12981 4187 : gcc_assert (nvar <= total_var);
12982 : }
12983 :
12984 : /* Need to walk the code and replace references to the index-name with
12985 : references to the shadow index-name. This must be done BEFORE resolving
12986 : the body so that resolution uses the correct shadow variables. */
12987 2271 : if (shadow)
12988 : {
12989 : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
12990 150 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12991 : {
12992 78 : if (fa->shadow)
12993 : {
12994 72 : gfc_symtree *shadow_st;
12995 72 : const char *shadow_name_str;
12996 72 : char *outer_name;
12997 :
12998 : /* fa->var now points to the shadow variable "_name". */
12999 72 : shadow_name_str = fa->var->symtree->name;
13000 72 : shadow_st = fa->var->symtree;
13001 :
13002 72 : if (shadow_name_str[0] != '_')
13003 0 : gfc_internal_error ("Expected shadow variable name to start with _");
13004 :
13005 72 : outer_name = (char *) alloca (strlen (shadow_name_str));
13006 72 : strcpy (outer_name, shadow_name_str + 1);
13007 :
13008 : /* Find the ITERATOR symbol in the current namespace.
13009 : This is the local DO CONCURRENT variable that body expressions reference. */
13010 72 : gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name);
13011 :
13012 72 : if (!iter_st)
13013 : /* No iterator variable found - this shouldn't happen */
13014 0 : continue;
13015 :
13016 72 : gfc_symbol *iter_sym = iter_st->n.sym;
13017 :
13018 : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
13019 72 : if (code->block && code->block->next)
13020 72 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
13021 : }
13022 : }
13023 : }
13024 :
13025 : /* Resolve the FORALL body. */
13026 2271 : gfc_resolve_forall_body (code, nvar, var_expr);
13027 :
13028 : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
13029 2271 : gfc_resolve_blocks (code->block, ns);
13030 :
13031 2271 : tmp = nvar;
13032 2271 : nvar = old_nvar;
13033 : /* Free only the VAR_EXPRs allocated in this frame. */
13034 6458 : for (i = nvar; i < tmp; i++)
13035 4187 : gfc_free_expr (var_expr[i]);
13036 :
13037 2271 : if (nvar == 0)
13038 : {
13039 : /* We are in the outermost FORALL construct. */
13040 2177 : gcc_assert (forall_save == 0);
13041 :
13042 : /* VAR_EXPR is not needed any more. */
13043 2177 : free (var_expr);
13044 2177 : total_var = 0;
13045 : }
13046 : }
13047 :
13048 :
13049 : /* Resolve a BLOCK construct statement. */
13050 :
13051 : static void
13052 8548 : resolve_block_construct (gfc_code* code)
13053 : {
13054 8548 : gfc_namespace *ns = code->ext.block.ns;
13055 :
13056 : /* For an ASSOCIATE block, the associations (and their targets) will be
13057 : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
13058 : namespace. However, marking variables as used ans defined requires
13059 : passing ext.block.assoc. */
13060 8548 : gfc_resolve (ns, code->ext.block.assoc);
13061 8441 : }
13062 :
13063 : /* Mark everything in an association list as used and set if applicable,
13064 : respectively. */
13065 :
13066 : static void
13067 315522 : mark_assoc_used (gfc_association_list *a)
13068 : {
13069 322621 : while (a != NULL)
13070 : {
13071 7099 : gfc_symbol *n_sym = a->st->n.sym;
13072 7099 : if (n_sym->attr.value_used != VALUE_UNUSED)
13073 5051 : gfc_value_used_expr (a->target, n_sym->attr.value_used);
13074 :
13075 7099 : if (a->variable && n_sym->attr.value_set != VALUE_UNSET)
13076 1366 : gfc_expr_set_at (a->target, &n_sym->other_loc, n_sym->attr.value_set);
13077 :
13078 7099 : a = a->next;
13079 : }
13080 315522 : }
13081 :
13082 : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
13083 : DO code nodes. */
13084 :
13085 : void
13086 337736 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
13087 : {
13088 337736 : bool t;
13089 :
13090 687075 : for (; b; b = b->block)
13091 : {
13092 349339 : t = gfc_resolve_expr (b->expr1);
13093 349339 : if (!gfc_resolve_expr (b->expr2))
13094 0 : t = false;
13095 :
13096 349339 : switch (b->op)
13097 : {
13098 241322 : case EXEC_IF:
13099 241322 : if (t && b->expr1 != NULL
13100 236984 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
13101 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
13102 : &b->expr1->where);
13103 : break;
13104 :
13105 770 : case EXEC_WHERE:
13106 770 : if (t
13107 770 : && b->expr1 != NULL
13108 637 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
13109 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
13110 : &b->expr1->where);
13111 : break;
13112 :
13113 76 : case EXEC_GOTO:
13114 76 : resolve_branch (b->label1, b);
13115 76 : break;
13116 :
13117 0 : case EXEC_BLOCK:
13118 0 : resolve_block_construct (b);
13119 0 : break;
13120 :
13121 : case EXEC_SELECT:
13122 : case EXEC_SELECT_TYPE:
13123 : case EXEC_SELECT_RANK:
13124 : case EXEC_FORALL:
13125 : case EXEC_DO:
13126 : case EXEC_DO_WHILE:
13127 : case EXEC_DO_CONCURRENT:
13128 : case EXEC_CRITICAL:
13129 : case EXEC_READ:
13130 : case EXEC_WRITE:
13131 : case EXEC_IOLENGTH:
13132 : case EXEC_WAIT:
13133 : break;
13134 :
13135 2710 : case EXEC_OMP_ATOMIC:
13136 2710 : case EXEC_OACC_ATOMIC:
13137 2710 : {
13138 : /* Verify this before calling gfc_resolve_code, which might
13139 : change it. */
13140 2710 : gcc_assert (b->op == EXEC_OMP_ATOMIC
13141 : || (b->next && b->next->op == EXEC_ASSIGN));
13142 : }
13143 : break;
13144 :
13145 : case EXEC_OACC_PARALLEL_LOOP:
13146 : case EXEC_OACC_PARALLEL:
13147 : case EXEC_OACC_KERNELS_LOOP:
13148 : case EXEC_OACC_KERNELS:
13149 : case EXEC_OACC_SERIAL_LOOP:
13150 : case EXEC_OACC_SERIAL:
13151 : case EXEC_OACC_DATA:
13152 : case EXEC_OACC_HOST_DATA:
13153 : case EXEC_OACC_LOOP:
13154 : case EXEC_OACC_UPDATE:
13155 : case EXEC_OACC_WAIT:
13156 : case EXEC_OACC_CACHE:
13157 : case EXEC_OACC_ENTER_DATA:
13158 : case EXEC_OACC_EXIT_DATA:
13159 : case EXEC_OACC_ROUTINE:
13160 : case EXEC_OACC_INIT:
13161 : case EXEC_OACC_SHUTDOWN:
13162 : case EXEC_OACC_SET:
13163 : case EXEC_OMP_ALLOCATE:
13164 : case EXEC_OMP_ALLOCATORS:
13165 : case EXEC_OMP_ASSUME:
13166 : case EXEC_OMP_CRITICAL:
13167 : case EXEC_OMP_DISPATCH:
13168 : case EXEC_OMP_DISTRIBUTE:
13169 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13170 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13171 : case EXEC_OMP_DISTRIBUTE_SIMD:
13172 : case EXEC_OMP_DO:
13173 : case EXEC_OMP_DO_SIMD:
13174 : case EXEC_OMP_ERROR:
13175 : case EXEC_OMP_LOOP:
13176 : case EXEC_OMP_MASKED:
13177 : case EXEC_OMP_MASKED_TASKLOOP:
13178 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13179 : case EXEC_OMP_MASTER:
13180 : case EXEC_OMP_MASTER_TASKLOOP:
13181 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13182 : case EXEC_OMP_ORDERED:
13183 : case EXEC_OMP_PARALLEL:
13184 : case EXEC_OMP_PARALLEL_DO:
13185 : case EXEC_OMP_PARALLEL_DO_SIMD:
13186 : case EXEC_OMP_PARALLEL_LOOP:
13187 : case EXEC_OMP_PARALLEL_MASKED:
13188 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13189 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13190 : case EXEC_OMP_PARALLEL_MASTER:
13191 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13192 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13193 : case EXEC_OMP_PARALLEL_SECTIONS:
13194 : case EXEC_OMP_PARALLEL_WORKSHARE:
13195 : case EXEC_OMP_SECTIONS:
13196 : case EXEC_OMP_SIMD:
13197 : case EXEC_OMP_SCOPE:
13198 : case EXEC_OMP_SINGLE:
13199 : case EXEC_OMP_TARGET:
13200 : case EXEC_OMP_TARGET_DATA:
13201 : case EXEC_OMP_TARGET_ENTER_DATA:
13202 : case EXEC_OMP_TARGET_EXIT_DATA:
13203 : case EXEC_OMP_TARGET_PARALLEL:
13204 : case EXEC_OMP_TARGET_PARALLEL_DO:
13205 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13206 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13207 : case EXEC_OMP_TARGET_SIMD:
13208 : case EXEC_OMP_TARGET_TEAMS:
13209 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13210 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13211 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13212 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13213 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13214 : case EXEC_OMP_TARGET_UPDATE:
13215 : case EXEC_OMP_TASK:
13216 : case EXEC_OMP_TASKGROUP:
13217 : case EXEC_OMP_TASKLOOP:
13218 : case EXEC_OMP_TASKLOOP_SIMD:
13219 : case EXEC_OMP_TASKWAIT:
13220 : case EXEC_OMP_TASKYIELD:
13221 : case EXEC_OMP_TEAMS:
13222 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13223 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13224 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13225 : case EXEC_OMP_TEAMS_LOOP:
13226 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13227 : case EXEC_OMP_TILE:
13228 : case EXEC_OMP_UNROLL:
13229 : case EXEC_OMP_WORKSHARE:
13230 : break;
13231 :
13232 0 : default:
13233 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
13234 : }
13235 349339 : gfc_value_used_expr (b->expr1, VALUE_USED);
13236 349339 : gfc_value_used_expr (b->expr2, VALUE_USED);
13237 349339 : gfc_resolve_code (b->next, ns);
13238 : }
13239 337736 : }
13240 :
13241 : bool
13242 0 : caf_possible_reallocate (gfc_expr *e)
13243 : {
13244 0 : symbol_attribute caf_attr;
13245 0 : gfc_ref *last_arr_ref = nullptr;
13246 :
13247 0 : caf_attr = gfc_caf_attr (e);
13248 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
13249 : return false;
13250 :
13251 : /* Only full array refs can indicate a needed reallocation. */
13252 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
13253 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
13254 0 : last_arr_ref = ref;
13255 :
13256 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
13257 : }
13258 :
13259 : /* Does everything to resolve an ordinary assignment. Returns true
13260 : if this is an interface assignment. */
13261 : static bool
13262 289351 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
13263 : {
13264 289351 : bool rval = false;
13265 289351 : gfc_expr *lhs;
13266 289351 : gfc_expr *rhs;
13267 289351 : int n;
13268 289351 : gfc_ref *ref;
13269 289351 : symbol_attribute attr;
13270 :
13271 289351 : if (gfc_extend_assign (code, ns))
13272 : {
13273 924 : gfc_expr** rhsptr;
13274 :
13275 924 : if (code->op == EXEC_ASSIGN_CALL)
13276 : {
13277 469 : lhs = code->ext.actual->expr;
13278 469 : rhsptr = &code->ext.actual->next->expr;
13279 : }
13280 : else
13281 : {
13282 455 : gfc_actual_arglist* args;
13283 455 : gfc_typebound_proc* tbp;
13284 :
13285 455 : gcc_assert (code->op == EXEC_COMPCALL);
13286 :
13287 455 : args = code->expr1->value.compcall.actual;
13288 455 : lhs = args->expr;
13289 455 : rhsptr = &args->next->expr;
13290 :
13291 455 : tbp = code->expr1->value.compcall.tbp;
13292 455 : gcc_assert (!tbp->is_generic);
13293 : }
13294 :
13295 : /* Make a temporary rhs when there is a default initializer
13296 : and rhs is the same symbol as the lhs. */
13297 924 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
13298 513 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
13299 442 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
13300 1218 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
13301 60 : *rhsptr = gfc_get_parentheses (*rhsptr);
13302 :
13303 : return true;
13304 : }
13305 :
13306 288427 : lhs = code->expr1;
13307 288427 : rhs = code->expr2;
13308 :
13309 288427 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
13310 267586 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
13311 23664 : && !lhs->symtree->n.sym->attr.proc_pointer
13312 312091 : && gfc_expr_attr (lhs).proc_pointer)
13313 : {
13314 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
13315 : "pointer component",
13316 : &lhs->where);
13317 1 : return false;
13318 : }
13319 :
13320 340203 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
13321 252161 : && rhs->ts.type == BT_CHARACTER
13322 288819 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
13323 : {
13324 : /* Use of -fdec-char-conversions allows assignment of character data
13325 : to non-character variables. This not permitted for nonconstant
13326 : strings. */
13327 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
13328 : gfc_typename (lhs), &rhs->where);
13329 29 : return false;
13330 : }
13331 :
13332 288397 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
13333 : {
13334 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
13335 : gfc_typename (lhs), &rhs->where);
13336 0 : return false;
13337 : }
13338 :
13339 : /* Handle the case of a BOZ literal on the RHS. */
13340 288397 : if (rhs->ts.type == BT_BOZ)
13341 : {
13342 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
13343 : "statement value nor an actual argument of "
13344 : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
13345 : &rhs->where))
13346 : return false;
13347 :
13348 1 : switch (lhs->ts.type)
13349 : {
13350 0 : case BT_INTEGER:
13351 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
13352 : return false;
13353 : break;
13354 1 : case BT_REAL:
13355 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
13356 : return false;
13357 : break;
13358 0 : default:
13359 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13360 0 : return false;
13361 : }
13362 : }
13363 :
13364 288395 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13365 : {
13366 67 : HOST_WIDE_INT llen = 0, rlen = 0;
13367 67 : if (lhs->ts.u.cl != NULL
13368 67 : && lhs->ts.u.cl->length != NULL
13369 56 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13370 56 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13371 :
13372 67 : if (rhs->expr_type == EXPR_CONSTANT)
13373 29 : rlen = rhs->value.character.length;
13374 :
13375 38 : else if (rhs->ts.u.cl != NULL
13376 38 : && rhs->ts.u.cl->length != NULL
13377 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13378 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13379 :
13380 67 : if (rlen && llen && rlen > llen)
13381 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13382 : "CHARACTER expression will be truncated "
13383 : "in assignment (%wd/%wd) at %L",
13384 : llen, rlen, &code->loc);
13385 : }
13386 :
13387 : /* Ensure that a vector index expression for the lvalue is evaluated
13388 : to a temporary if the lvalue symbol is referenced in it. */
13389 288395 : if (lhs->rank)
13390 : {
13391 114769 : for (ref = lhs->ref; ref; ref= ref->next)
13392 61422 : if (ref->type == REF_ARRAY)
13393 : {
13394 134828 : for (n = 0; n < ref->u.ar.dimen; n++)
13395 79625 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13396 79855 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13397 230 : ref->u.ar.start[n]))
13398 14 : ref->u.ar.start[n]
13399 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13400 : }
13401 : }
13402 :
13403 288395 : if (gfc_pure (NULL))
13404 : {
13405 3621 : if (lhs->ts.type == BT_DERIVED
13406 136 : && lhs->expr_type == EXPR_VARIABLE
13407 136 : && lhs->ts.u.derived->attr.pointer_comp
13408 4 : && rhs->expr_type == EXPR_VARIABLE
13409 3624 : && (gfc_impure_variable (rhs->symtree->n.sym)
13410 2 : || gfc_is_coindexed (rhs)))
13411 : {
13412 : /* F2008, C1283. */
13413 2 : if (gfc_is_coindexed (rhs))
13414 1 : gfc_error ("Coindexed expression at %L is assigned to "
13415 : "a derived type variable with a POINTER "
13416 : "component in a PURE procedure",
13417 : &rhs->where);
13418 : else
13419 : /* F2008, C1283 (4). */
13420 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13421 : "shall not be used as the expr at %L of an intrinsic "
13422 : "assignment statement in which the variable is of a "
13423 : "derived type if the derived type has a pointer "
13424 : "component at any level of component selection.",
13425 : &rhs->where);
13426 : return rval;
13427 : }
13428 :
13429 : /* Fortran 2008, C1283. */
13430 3619 : if (gfc_is_coindexed (lhs))
13431 : {
13432 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13433 : "procedure", &rhs->where);
13434 1 : return rval;
13435 : }
13436 : }
13437 :
13438 288392 : if (gfc_implicit_pure (NULL))
13439 : {
13440 7516 : if (lhs->expr_type == EXPR_VARIABLE
13441 7516 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13442 5382 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13443 256 : gfc_unset_implicit_pure (NULL);
13444 :
13445 7516 : if (lhs->ts.type == BT_DERIVED
13446 366 : && lhs->expr_type == EXPR_VARIABLE
13447 366 : && lhs->ts.u.derived->attr.pointer_comp
13448 7 : && rhs->expr_type == EXPR_VARIABLE
13449 7523 : && (gfc_impure_variable (rhs->symtree->n.sym)
13450 7 : || gfc_is_coindexed (rhs)))
13451 0 : gfc_unset_implicit_pure (NULL);
13452 :
13453 : /* Fortran 2008, C1283. */
13454 7516 : if (gfc_is_coindexed (lhs))
13455 0 : gfc_unset_implicit_pure (NULL);
13456 : }
13457 :
13458 : /* F2008, 7.2.1.2. */
13459 288392 : attr = gfc_expr_attr (lhs);
13460 288392 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13461 : {
13462 1036 : if (attr.codimension)
13463 : {
13464 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13465 : "permitted", &lhs->where);
13466 1 : return false;
13467 : }
13468 1035 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13469 : "polymorphic variable at %L", &lhs->where))
13470 : return false;
13471 1034 : if (!flag_realloc_lhs)
13472 : {
13473 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13474 : "requires %<-frealloc-lhs%>", &lhs->where);
13475 1 : return false;
13476 : }
13477 : }
13478 287356 : else if (lhs->ts.type == BT_CLASS)
13479 : {
13480 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13481 : "assignment at %L - check that there is a matching specific "
13482 : "subroutine for %<=%> operator", &lhs->where);
13483 9 : return false;
13484 : }
13485 :
13486 288380 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13487 :
13488 : /* F2008, Section 7.2.1.2. */
13489 288380 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13490 : {
13491 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13492 : "component in assignment at %L", &lhs->where);
13493 1 : return false;
13494 : }
13495 :
13496 : /* Assign the 'data' of a class object to a derived type. */
13497 288379 : if (lhs->ts.type == BT_DERIVED
13498 7452 : && rhs->ts.type == BT_CLASS
13499 180 : && (rhs->expr_type != EXPR_ARRAY
13500 174 : && rhs->expr_type != EXPR_OP))
13501 168 : gfc_add_data_component (rhs);
13502 :
13503 : /* Make sure there is a vtable and, in particular, a _copy for the
13504 : rhs type. */
13505 288379 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13506 622 : gfc_find_vtab (&rhs->ts);
13507 :
13508 288379 : gfc_check_assign (lhs, rhs, 1);
13509 :
13510 288379 : return false;
13511 : }
13512 :
13513 :
13514 : /* Add a component reference onto an expression. */
13515 :
13516 : static void
13517 647 : add_comp_ref (gfc_expr *e, gfc_component *c)
13518 : {
13519 647 : gfc_ref **ref;
13520 647 : ref = &(e->ref);
13521 871 : while (*ref)
13522 224 : ref = &((*ref)->next);
13523 647 : *ref = gfc_get_ref ();
13524 647 : (*ref)->type = REF_COMPONENT;
13525 647 : (*ref)->u.c.sym = e->ts.u.derived;
13526 647 : (*ref)->u.c.component = c;
13527 647 : e->ts = c->ts;
13528 :
13529 : /* Add a full array ref, as necessary. */
13530 647 : if (c->as)
13531 : {
13532 84 : gfc_add_full_array_ref (e, c->as);
13533 84 : e->rank = c->as->rank;
13534 84 : e->corank = c->as->corank;
13535 : }
13536 647 : }
13537 :
13538 :
13539 : /* Build an assignment. Keep the argument 'op' for future use, so that
13540 : pointer assignments can be made. */
13541 :
13542 : static gfc_code *
13543 976 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13544 : gfc_component *comp1, gfc_component *comp2, locus loc)
13545 : {
13546 976 : gfc_code *this_code;
13547 :
13548 976 : this_code = gfc_get_code (op);
13549 976 : this_code->next = NULL;
13550 976 : this_code->expr1 = gfc_copy_expr (expr1);
13551 976 : this_code->expr2 = gfc_copy_expr (expr2);
13552 976 : this_code->loc = loc;
13553 976 : if (comp1 && comp2)
13554 : {
13555 288 : add_comp_ref (this_code->expr1, comp1);
13556 288 : add_comp_ref (this_code->expr2, comp2);
13557 : }
13558 :
13559 976 : return this_code;
13560 : }
13561 :
13562 :
13563 : /* Makes a temporary variable expression based on the characteristics of
13564 : a given variable expression. If allocatable is set, the temporary is
13565 : unconditionally allocatable*/
13566 :
13567 : static gfc_expr*
13568 464 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
13569 : bool allocatable = false)
13570 : {
13571 464 : static int serial = 0;
13572 464 : char name[GFC_MAX_SYMBOL_LEN];
13573 464 : gfc_symtree *tmp;
13574 464 : gfc_array_spec *as;
13575 464 : gfc_array_ref *aref;
13576 464 : gfc_ref *ref;
13577 :
13578 464 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13579 464 : gfc_get_sym_tree (name, ns, &tmp, false);
13580 464 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13581 :
13582 464 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13583 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13584 : NULL,
13585 0 : e->value.character.length);
13586 :
13587 464 : as = NULL;
13588 464 : ref = NULL;
13589 464 : aref = NULL;
13590 :
13591 : /* Obtain the arrayspec for the temporary. */
13592 464 : if (e->rank && e->expr_type != EXPR_ARRAY
13593 : && e->expr_type != EXPR_FUNCTION
13594 : && e->expr_type != EXPR_OP)
13595 : {
13596 52 : aref = gfc_find_array_ref (e);
13597 52 : if (e->expr_type == EXPR_VARIABLE
13598 52 : && e->symtree->n.sym->as == aref->as)
13599 : as = aref->as;
13600 : else
13601 : {
13602 0 : for (ref = e->ref; ref; ref = ref->next)
13603 0 : if (ref->type == REF_COMPONENT
13604 0 : && ref->u.c.component->as == aref->as)
13605 : {
13606 : as = aref->as;
13607 : break;
13608 : }
13609 : }
13610 : }
13611 :
13612 : /* Add the attributes and the arrayspec to the temporary. */
13613 464 : tmp->n.sym->attr = gfc_expr_attr (e);
13614 464 : tmp->n.sym->attr.function = 0;
13615 464 : tmp->n.sym->attr.proc_pointer = 0;
13616 464 : tmp->n.sym->attr.result = 0;
13617 464 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13618 464 : tmp->n.sym->attr.dummy = 0;
13619 464 : tmp->n.sym->attr.use_assoc = 0;
13620 464 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13621 :
13622 :
13623 464 : if (as && !allocatable)
13624 : {
13625 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13626 52 : if (!ref)
13627 52 : ref = e->ref;
13628 52 : if (as->type == AS_DEFERRED)
13629 46 : tmp->n.sym->attr.allocatable = 1;
13630 : }
13631 412 : else if ((e->rank || e->corank)
13632 130 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13633 24 : || e->expr_type == EXPR_OP || allocatable))
13634 : {
13635 130 : tmp->n.sym->as = gfc_get_array_spec ();
13636 130 : tmp->n.sym->as->type = AS_DEFERRED;
13637 130 : tmp->n.sym->as->rank = e->rank;
13638 130 : tmp->n.sym->as->corank = e->corank;
13639 130 : tmp->n.sym->attr.allocatable = 1;
13640 130 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13641 260 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13642 : }
13643 : else
13644 282 : tmp->n.sym->attr.dimension = 0;
13645 :
13646 464 : gfc_set_sym_referenced (tmp->n.sym);
13647 464 : gfc_commit_symbol (tmp->n.sym);
13648 464 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13649 :
13650 : /* Should the lhs be a section, use its array ref for the
13651 : temporary expression. */
13652 464 : if (aref && aref->type != AR_FULL && !allocatable)
13653 : {
13654 6 : gfc_free_ref_list (e->ref);
13655 6 : e->ref = gfc_copy_ref (ref);
13656 : }
13657 464 : return e;
13658 : }
13659 :
13660 :
13661 : /* Helper function to take an argument in a subroutine call with a dependency
13662 : on another argument, copy it to an allocatable temporary and use the
13663 : temporary in the call expression. The new code is embedded in a block to
13664 : ensure local, automatic deallocation. */
13665 :
13666 : static void
13667 36 : add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,
13668 : gfc_expr **rhsptr)
13669 : {
13670 36 : gfc_namespace *block_ns;
13671 36 : gfc_expr *tmp_var;
13672 :
13673 : /* Wrap the new code in a block so that the temporary is deallocated. */
13674 36 : block_ns = gfc_build_block_ns (ns);
13675 :
13676 : /* As it stands, the block_ns does not not stand up to resolution because the
13677 : the assignment would be converted to a call and, in any case, the modified
13678 : call fails in gfc_check_conformance. */
13679 36 : block_ns->resolved = 1;
13680 :
13681 : /* Assign the original expression to the temporary. */
13682 36 : tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);
13683 72 : block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,
13684 36 : NULL, NULL, (*rhsptr)->where);
13685 :
13686 : /* Transfer the call to the block and terminate block code. */
13687 36 : *rhsptr = gfc_copy_expr (tmp_var);
13688 36 : block_ns->code->next = gfc_get_code (EXEC_NOP);
13689 36 : *(block_ns->code->next) = *code;
13690 36 : block_ns->code->next->next = NULL;
13691 :
13692 : /* Convert the original code to execute the block. */
13693 36 : code->op = EXEC_BLOCK;
13694 36 : code->ext.block.ns = block_ns;
13695 36 : code->ext.block.assoc = NULL;
13696 36 : code->expr1 = code->expr2 = NULL;
13697 36 : }
13698 :
13699 :
13700 : /* Add one line of code to the code chain, making sure that 'head' and
13701 : 'tail' are appropriately updated. */
13702 :
13703 : static void
13704 650 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13705 : {
13706 650 : gcc_assert (this_code);
13707 650 : if (*head == NULL)
13708 302 : *head = *tail = *this_code;
13709 : else
13710 348 : *tail = gfc_append_code (*tail, *this_code);
13711 650 : *this_code = NULL;
13712 650 : }
13713 :
13714 :
13715 : /* Generate a final call from a variable expression */
13716 :
13717 : static void
13718 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13719 : {
13720 81 : gfc_code *this_code;
13721 81 : gfc_expr *final_expr = NULL;
13722 81 : gfc_expr *size_expr;
13723 81 : gfc_expr *fini_coarray;
13724 :
13725 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13726 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13727 75 : return;
13728 :
13729 : /* Now generate the finalizer call. */
13730 6 : this_code = gfc_get_code (EXEC_CALL);
13731 6 : this_code->symtree = final_expr->symtree;
13732 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13733 :
13734 : //* Expression to be finalized */
13735 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13736 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13737 :
13738 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13739 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13740 6 : size_expr = gfc_get_expr ();
13741 6 : size_expr->where = gfc_current_locus;
13742 6 : size_expr->expr_type = EXPR_OP;
13743 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13744 6 : size_expr->value.op.op1
13745 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13746 : "storage_size", gfc_current_locus, 2,
13747 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13748 : gfc_get_int_expr (gfc_index_integer_kind,
13749 : NULL, 0));
13750 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13751 : gfc_character_storage_size);
13752 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13753 6 : size_expr->ts = size_expr->value.op.op1->ts;
13754 6 : this_code->ext.actual->next->expr = size_expr;
13755 :
13756 : /* fini_coarray */
13757 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13758 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13759 : &tmp_expr->where);
13760 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13761 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13762 :
13763 6 : add_code_to_chain (&this_code, head, tail);
13764 :
13765 : }
13766 :
13767 : /* Counts the potential number of part array references that would
13768 : result from resolution of typebound defined assignments. */
13769 :
13770 :
13771 : static int
13772 249 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13773 : {
13774 249 : gfc_component *c;
13775 249 : int c_depth = 0, t_depth;
13776 :
13777 596 : for (c= derived->components; c; c = c->next)
13778 : {
13779 347 : if ((!gfc_bt_struct (c->ts.type)
13780 267 : || c->attr.pointer
13781 267 : || c->attr.allocatable
13782 266 : || c->attr.proc_pointer_comp
13783 266 : || c->attr.class_pointer
13784 266 : || c->attr.proc_pointer)
13785 81 : && !c->attr.defined_assign_comp)
13786 81 : continue;
13787 :
13788 266 : if (c->as && c_depth == 0)
13789 266 : c_depth = 1;
13790 :
13791 266 : if (c->ts.u.derived->attr.defined_assign_comp)
13792 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13793 : c->as ? 1 : 0);
13794 : else
13795 : t_depth = 0;
13796 :
13797 266 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13798 : }
13799 249 : return depth + c_depth;
13800 : }
13801 :
13802 :
13803 : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13804 : "An intrinsic assignment where the variable is of derived type is performed
13805 : as if each component of the variable were assigned from the corresponding
13806 : component of expr using pointer assignment (10.2.2) for each pointer
13807 : component, defined assignment for each nonpointer nonallocatable component
13808 : of a type that has a type-bound defined assignment consistent with the
13809 : component, intrinsic assignment for each other nonpointer nonallocatable
13810 : component, and intrinsic assignment for each allocated coarray component.
13811 : For unallocated coarray components, the corresponding component of the
13812 : variable shall be unallocated. For a noncoarray allocatable component the
13813 : following sequence of operations is applied.
13814 : (1) If the component of the variable is allocated, it is deallocated.
13815 : (2) If the component of the value of expr is allocated, the
13816 : corresponding component of the variable is allocated with the same
13817 : dynamic type and type parameters as the component of the value of
13818 : expr. If it is an array, it is allocated with the same bounds. The
13819 : value of the component of the value of expr is then assigned to the
13820 : corresponding component of the variable using defined assignment if
13821 : the declared type of the component has a type-bound defined
13822 : assignment consistent with the component, and intrinsic assignment
13823 : for the dynamic type of that component otherwise."
13824 :
13825 : The pointer assignments are taken care of by the intrinsic assignment of the
13826 : structure itself. This function recursively adds defined assignments where
13827 : required. The recursion is accomplished by calling gfc_resolve_code.
13828 :
13829 : When the lhs in a defined assignment has intent INOUT or is intent OUT
13830 : and the component of 'var' is finalizable, we need a temporary for the
13831 : lhs. In pseudo-code for an assignment var = expr:
13832 :
13833 : ! Confine finalization of temporaries, as far as possible.
13834 : Enclose the code for the assignment in a block
13835 : ! Only call function 'expr' once.
13836 : #if ('expr is not a constant or an variable)
13837 : temp_expr = expr
13838 : expr = temp_x
13839 : ! Do the intrinsic assignment
13840 : #if typeof ('var') has a typebound final subroutine
13841 : finalize (var)
13842 : var = expr
13843 : ! Now do the component assignments
13844 : #do over derived type components [%cmp]
13845 : #if (cmp is a pointer of any kind)
13846 : continue
13847 : build the assignment
13848 : resolve the code
13849 : #if the code is a typebound assignment
13850 : #if (arg1 is INOUT or finalizable OUT && !t1)
13851 : t1 = var
13852 : arg1 = t1
13853 : deal with allocatation or not of var and this component
13854 : #elseif the code is an assignment by itself
13855 : #if this component does not need finalization
13856 : delete code and continue
13857 : #else
13858 : remove the leading assignment
13859 : #endif
13860 : commit the code
13861 : #if (t1 and (arg1 is INOUT or finalizable OUT))
13862 : var%cmp = t1%cmp
13863 : #enddo
13864 : put all code chunks involving t1 to the top of the generated code
13865 : insert the generated block in place of the original code
13866 : */
13867 :
13868 : static bool
13869 393 : is_finalizable_type (gfc_typespec ts)
13870 : {
13871 393 : gfc_component *c;
13872 :
13873 393 : if (ts.type != BT_DERIVED)
13874 : return false;
13875 :
13876 : /* (1) Check for FINAL subroutines. */
13877 393 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13878 : return true;
13879 :
13880 : /* (2) Check for components of finalizable type. */
13881 815 : for (c = ts.u.derived->components; c; c = c->next)
13882 476 : if (c->ts.type == BT_DERIVED
13883 249 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13884 248 : && c->ts.u.derived->f2k_derived
13885 248 : && c->ts.u.derived->f2k_derived->finalizers)
13886 : return true;
13887 :
13888 : return false;
13889 : }
13890 :
13891 : /* The temporary assignments have to be put on top of the additional
13892 : code to avoid the result being changed by the intrinsic assignment.
13893 : */
13894 : static int component_assignment_level = 0;
13895 : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13896 : static bool finalizable_comp;
13897 :
13898 : static void
13899 194 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13900 : {
13901 194 : gfc_component *comp1, *comp2;
13902 194 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13903 194 : gfc_code *tmp_code = NULL;
13904 194 : gfc_expr *t1 = NULL;
13905 194 : gfc_expr *tmp_expr = NULL;
13906 194 : int error_count, depth;
13907 194 : bool finalizable_lhs;
13908 194 : bool use_finalize_only;
13909 :
13910 194 : gfc_get_errors (NULL, &error_count);
13911 :
13912 : /* Filter out continuing processing after an error. */
13913 194 : if (error_count
13914 194 : || (*code)->expr1->ts.type != BT_DERIVED
13915 194 : || (*code)->expr2->ts.type != BT_DERIVED)
13916 146 : return;
13917 :
13918 : /* TODO: Handle more than one part array reference in assignments. */
13919 194 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13920 194 : (*code)->expr1->rank ? 1 : 0);
13921 194 : if (depth > 1)
13922 : {
13923 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13924 : "done because multiple part array references would "
13925 : "occur in intermediate expressions.", &(*code)->loc);
13926 6 : return;
13927 : }
13928 :
13929 188 : if (!component_assignment_level)
13930 140 : finalizable_comp = true;
13931 :
13932 : /* Build a block so that function result temporaries are finalized
13933 : locally on exiting the rather than enclosing scope. */
13934 188 : if (!component_assignment_level)
13935 : {
13936 140 : ns = gfc_build_block_ns (ns);
13937 140 : tmp_code = gfc_get_code (EXEC_NOP);
13938 140 : *tmp_code = **code;
13939 140 : tmp_code->next = NULL;
13940 140 : (*code)->op = EXEC_BLOCK;
13941 140 : (*code)->ext.block.ns = ns;
13942 140 : (*code)->ext.block.assoc = NULL;
13943 140 : (*code)->expr1 = (*code)->expr2 = NULL;
13944 140 : ns->code = tmp_code;
13945 140 : code = &ns->code;
13946 : }
13947 :
13948 188 : component_assignment_level++;
13949 :
13950 188 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13951 :
13952 : /* When the lhs is finalized as a whole and none of its components needs the
13953 : structure copy to handle it (no pointer or allocatable components), the
13954 : copy can be done component by component. The whole-derived-type assignment
13955 : then only finalizes the lhs and a component with a defined assignment keeps
13956 : its post-finalization value for the INTENT (OUT) finalization in that
13957 : defined assignment. */
13958 188 : use_finalize_only = finalizable_lhs;
13959 188 : if (use_finalize_only)
13960 66 : for (comp1 = (*code)->expr1->ts.u.derived->components; comp1;
13961 42 : comp1 = comp1->next)
13962 42 : if (comp1->attr.pointer || comp1->attr.allocatable
13963 42 : || comp1->attr.proc_pointer_comp || comp1->attr.class_pointer
13964 42 : || comp1->attr.proc_pointer)
13965 : {
13966 : use_finalize_only = false;
13967 : break;
13968 : }
13969 :
13970 : /* Create a temporary so that functions get called only once. */
13971 188 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13972 188 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13973 : {
13974 : /* Assign the rhs to the temporary. */
13975 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13976 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13977 : {
13978 : /* Use allocate on assignment for the sake of simplicity. The
13979 : temporary must not take on the optional attribute. Assume
13980 : that the assignment is guarded by a PRESENT condition if the
13981 : lhs is optional. */
13982 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13983 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
13984 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13985 : }
13986 162 : this_code = build_assignment (EXEC_ASSIGN,
13987 : tmp_expr, (*code)->expr2,
13988 81 : NULL, NULL, (*code)->loc);
13989 81 : this_code->expr2->must_finalize = 1;
13990 : /* Add the code and substitute the rhs expression. */
13991 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13992 81 : gfc_free_expr ((*code)->expr2);
13993 81 : (*code)->expr2 = tmp_expr;
13994 : }
13995 :
13996 : /* Do the intrinsic assignment. This is not needed if the lhs is one
13997 : of the temporaries generated here, since the intrinsic assignment
13998 : to the final result already does this. */
13999 188 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
14000 : {
14001 188 : if (finalizable_lhs)
14002 24 : (*code)->expr1->must_finalize = 1;
14003 188 : this_code = build_assignment (EXEC_ASSIGN,
14004 : (*code)->expr1, (*code)->expr2,
14005 : NULL, NULL, (*code)->loc);
14006 188 : if (use_finalize_only)
14007 24 : this_code->expr1->finalize_only = 1;
14008 188 : add_code_to_chain (&this_code, &head, &tail);
14009 : }
14010 :
14011 188 : comp1 = (*code)->expr1->ts.u.derived->components;
14012 188 : comp2 = (*code)->expr2->ts.u.derived->components;
14013 :
14014 461 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
14015 : {
14016 273 : bool inout = false;
14017 273 : bool finalizable_out = false;
14018 :
14019 : /* The intrinsic assignment does the right thing for pointers
14020 : of all kinds and allocatable components. */
14021 273 : if (!gfc_bt_struct (comp1->ts.type)
14022 206 : || comp1->attr.pointer
14023 206 : || comp1->attr.allocatable
14024 205 : || comp1->attr.proc_pointer_comp
14025 205 : || comp1->attr.class_pointer
14026 205 : || comp1->attr.proc_pointer)
14027 : {
14028 : /* With finalize_only the whole-derived-type assignment does not copy
14029 : the components, so emit the copy for this one here. Only plain
14030 : components reach this point, since use_finalize_only excludes
14031 : pointer and allocatable components. */
14032 68 : if (use_finalize_only)
14033 : {
14034 24 : this_code = build_assignment (EXEC_ASSIGN,
14035 : (*code)->expr1, (*code)->expr2,
14036 12 : comp1, comp2, (*code)->loc);
14037 12 : add_code_to_chain (&this_code, &head, &tail);
14038 : }
14039 68 : continue;
14040 : }
14041 :
14042 410 : finalizable_comp = is_finalizable_type (comp1->ts)
14043 205 : && !finalizable_lhs;
14044 :
14045 : /* Make an assignment for this component. */
14046 410 : this_code = build_assignment (EXEC_ASSIGN,
14047 : (*code)->expr1, (*code)->expr2,
14048 205 : comp1, comp2, (*code)->loc);
14049 :
14050 : /* Convert the assignment if there is a defined assignment for
14051 : this type. Otherwise, using the call from gfc_resolve_code,
14052 : recurse into its components. */
14053 205 : gfc_resolve_code (this_code, ns);
14054 :
14055 205 : if (this_code->op == EXEC_ASSIGN_CALL)
14056 : {
14057 150 : gfc_formal_arglist *dummy_args;
14058 150 : gfc_symbol *rsym;
14059 : /* Check that there is a typebound defined assignment. If not,
14060 : then this must be a module defined assignment. We cannot
14061 : use the defined_assign_comp attribute here because it must
14062 : be this derived type that has the defined assignment and not
14063 : a parent type. */
14064 150 : if (!(comp1->ts.u.derived->f2k_derived
14065 : && comp1->ts.u.derived->f2k_derived
14066 150 : ->tb_op[INTRINSIC_ASSIGN]))
14067 : {
14068 1 : gfc_free_statements (this_code);
14069 1 : this_code = NULL;
14070 1 : continue;
14071 : }
14072 :
14073 : /* If the first argument of the subroutine has intent INOUT
14074 : a temporary must be generated and used instead. */
14075 149 : rsym = this_code->resolved_sym;
14076 149 : dummy_args = gfc_sym_get_dummy_args (rsym);
14077 274 : finalizable_out = gfc_may_be_finalized (comp1->ts)
14078 24 : && dummy_args
14079 173 : && dummy_args->sym->attr.intent == INTENT_OUT;
14080 274 : inout = dummy_args
14081 274 : && dummy_args->sym->attr.intent == INTENT_INOUT;
14082 : /* With finalize_only the lhs component keeps its post-finalization
14083 : value, so the defined assignment can finalize it directly through
14084 : its INTENT (OUT) argument and no temporary is needed. */
14085 78 : if ((inout || (finalizable_out && !use_finalize_only))
14086 71 : && !comp1->attr.allocatable)
14087 : {
14088 71 : gfc_code *temp_code;
14089 71 : inout = true;
14090 :
14091 : /* Build the temporary required for the assignment and put
14092 : it at the head of the generated code. */
14093 71 : if (!t1)
14094 : {
14095 71 : gfc_namespace *tmp_ns = ns;
14096 71 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
14097 0 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
14098 71 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
14099 71 : t1->symtree->n.sym->attr.artificial = 1;
14100 142 : temp_code = build_assignment (EXEC_ASSIGN,
14101 : t1, (*code)->expr1,
14102 71 : NULL, NULL, (*code)->loc);
14103 :
14104 : /* For allocatable LHS, check whether it is allocated. Note
14105 : that allocatable components with defined assignment are
14106 : not yet support. See PR 57696. */
14107 71 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
14108 : {
14109 24 : gfc_code *block;
14110 24 : gfc_expr *e =
14111 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
14112 24 : block = gfc_get_code (EXEC_IF);
14113 24 : block->block = gfc_get_code (EXEC_IF);
14114 24 : block->block->expr1
14115 48 : = gfc_build_intrinsic_call (ns,
14116 : GFC_ISYM_ALLOCATED, "allocated",
14117 24 : (*code)->loc, 1, e);
14118 24 : block->block->next = temp_code;
14119 24 : temp_code = block;
14120 : }
14121 71 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
14122 : }
14123 :
14124 : /* Replace the first actual arg with the component of the
14125 : temporary. */
14126 71 : gfc_free_expr (this_code->ext.actual->expr);
14127 71 : this_code->ext.actual->expr = gfc_copy_expr (t1);
14128 71 : add_comp_ref (this_code->ext.actual->expr, comp1);
14129 :
14130 : /* If the LHS variable is allocatable and wasn't allocated and
14131 : the temporary is allocatable, pointer assign the address of
14132 : the freshly allocated LHS to the temporary. */
14133 71 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
14134 71 : && gfc_expr_attr ((*code)->expr1).allocatable)
14135 : {
14136 18 : gfc_code *block;
14137 18 : gfc_expr *cond;
14138 :
14139 18 : cond = gfc_get_expr ();
14140 18 : cond->ts.type = BT_LOGICAL;
14141 18 : cond->ts.kind = gfc_default_logical_kind;
14142 18 : cond->expr_type = EXPR_OP;
14143 18 : cond->where = (*code)->loc;
14144 18 : cond->value.op.op = INTRINSIC_NOT;
14145 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
14146 : GFC_ISYM_ALLOCATED, "allocated",
14147 18 : (*code)->loc, 1, gfc_copy_expr (t1));
14148 18 : block = gfc_get_code (EXEC_IF);
14149 18 : block->block = gfc_get_code (EXEC_IF);
14150 18 : block->block->expr1 = cond;
14151 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14152 : t1, (*code)->expr1,
14153 18 : NULL, NULL, (*code)->loc);
14154 18 : add_code_to_chain (&block, &head, &tail);
14155 : }
14156 : }
14157 : }
14158 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
14159 : {
14160 : /* Don't add intrinsic assignments since they are already
14161 : effected by the intrinsic assignment of the structure, unless
14162 : finalization is required or, with finalize_only, the structure
14163 : assignment does not copy the components. */
14164 7 : if (finalizable_comp)
14165 0 : this_code->expr1->must_finalize = 1;
14166 7 : else if (!use_finalize_only)
14167 : {
14168 1 : gfc_free_statements (this_code);
14169 1 : this_code = NULL;
14170 1 : continue;
14171 : }
14172 : }
14173 : else
14174 : {
14175 : /* Resolution has expanded an assignment of a derived type with
14176 : defined assigned components. Remove the redundant, leading
14177 : assignment. */
14178 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
14179 48 : gfc_code *tmp = this_code;
14180 48 : this_code = this_code->next;
14181 48 : tmp->next = NULL;
14182 48 : gfc_free_statements (tmp);
14183 : }
14184 :
14185 203 : add_code_to_chain (&this_code, &head, &tail);
14186 :
14187 203 : if (t1 && (inout || (finalizable_out && !use_finalize_only)))
14188 : {
14189 : /* Transfer the value to the final result. */
14190 142 : this_code = build_assignment (EXEC_ASSIGN,
14191 : (*code)->expr1, t1,
14192 71 : comp1, comp2, (*code)->loc);
14193 71 : this_code->expr1->must_finalize = 0;
14194 71 : add_code_to_chain (&this_code, &head, &tail);
14195 : }
14196 : }
14197 :
14198 : /* Put the temporary assignments at the top of the generated code. */
14199 188 : if (tmp_head && component_assignment_level == 1)
14200 : {
14201 114 : gfc_append_code (tmp_head, head);
14202 114 : head = tmp_head;
14203 114 : tmp_head = tmp_tail = NULL;
14204 : }
14205 :
14206 : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
14207 : not accidentally deallocated. Hence, nullify t1. */
14208 71 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
14209 259 : && gfc_expr_attr ((*code)->expr1).allocatable)
14210 : {
14211 18 : gfc_code *block;
14212 18 : gfc_expr *cond;
14213 18 : gfc_expr *e;
14214 :
14215 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
14216 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
14217 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
14218 18 : block = gfc_get_code (EXEC_IF);
14219 18 : block->block = gfc_get_code (EXEC_IF);
14220 18 : block->block->expr1 = cond;
14221 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14222 : t1, gfc_get_null_expr (&(*code)->loc),
14223 18 : NULL, NULL, (*code)->loc);
14224 18 : gfc_append_code (tail, block);
14225 18 : tail = block;
14226 : }
14227 :
14228 188 : component_assignment_level--;
14229 :
14230 : /* Make an explicit final call for the function result. */
14231 188 : if (tmp_expr)
14232 81 : generate_final_call (tmp_expr, &head, &tail);
14233 :
14234 188 : if (tmp_code)
14235 : {
14236 140 : ns->code = head;
14237 140 : return;
14238 : }
14239 :
14240 : /* Now attach the remaining code chain to the input code. Step on
14241 : to the end of the new code since resolution is complete. */
14242 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
14243 48 : tail->next = (*code)->next;
14244 : /* Overwrite 'code' because this would place the intrinsic assignment
14245 : before the temporary for the lhs is created. */
14246 48 : gfc_free_expr ((*code)->expr1);
14247 48 : gfc_free_expr ((*code)->expr2);
14248 48 : **code = *head;
14249 48 : if (head != tail)
14250 48 : free (head);
14251 48 : *code = tail;
14252 : }
14253 :
14254 :
14255 : /* F2008: Pointer function assignments are of the form:
14256 : ptr_fcn (args) = expr
14257 : This function breaks these assignments into two statements:
14258 : temporary_pointer => ptr_fcn(args)
14259 : temporary_pointer = expr */
14260 :
14261 : static bool
14262 289599 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
14263 : {
14264 289599 : gfc_expr *tmp_ptr_expr;
14265 289599 : gfc_code *this_code;
14266 289599 : gfc_component *comp;
14267 289599 : gfc_symbol *s;
14268 :
14269 289599 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
14270 : return false;
14271 :
14272 : /* Even if standard does not support this feature, continue to build
14273 : the two statements to avoid upsetting frontend_passes.c. */
14274 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
14275 : "%L", &(*code)->loc);
14276 :
14277 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
14278 :
14279 205 : if (comp)
14280 6 : s = comp->ts.interface;
14281 : else
14282 199 : s = (*code)->expr1->symtree->n.sym;
14283 :
14284 205 : if (s == NULL || !s->result->attr.pointer)
14285 : {
14286 5 : gfc_error ("The function result on the lhs of the assignment at "
14287 : "%L must have the pointer attribute.",
14288 5 : &(*code)->expr1->where);
14289 5 : (*code)->op = EXEC_NOP;
14290 5 : return false;
14291 : }
14292 :
14293 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
14294 :
14295 : /* get_temp_from_expression is set up for ordinary assignments. To that
14296 : end, where array bounds are not known, arrays are made allocatable.
14297 : Change the temporary to a pointer here. */
14298 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
14299 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
14300 200 : tmp_ptr_expr->where = (*code)->loc;
14301 :
14302 : /* A new charlen is required to ensure that the variable string length
14303 : is different to that of the original lhs for deferred results. */
14304 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
14305 : {
14306 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
14307 60 : tmp_ptr_expr->ts.deferred = 1;
14308 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
14309 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
14310 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
14311 : }
14312 :
14313 400 : this_code = build_assignment (EXEC_ASSIGN,
14314 : tmp_ptr_expr, (*code)->expr2,
14315 200 : NULL, NULL, (*code)->loc);
14316 200 : this_code->next = (*code)->next;
14317 200 : (*code)->next = this_code;
14318 200 : (*code)->op = EXEC_POINTER_ASSIGN;
14319 200 : (*code)->expr2 = (*code)->expr1;
14320 200 : (*code)->expr1 = tmp_ptr_expr;
14321 :
14322 200 : return true;
14323 : }
14324 :
14325 :
14326 : /* Deferred character length assignments from an operator expression
14327 : require a temporary because the character length of the lhs can
14328 : change in the course of the assignment. */
14329 :
14330 : static bool
14331 288427 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
14332 : {
14333 288427 : gfc_expr *tmp_expr;
14334 288427 : gfc_code *this_code;
14335 :
14336 288427 : if (!((*code)->expr1->ts.type == BT_CHARACTER
14337 27766 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
14338 860 : && (*code)->expr2->ts.type == BT_CHARACTER
14339 859 : && (*code)->expr2->expr_type == EXPR_OP))
14340 : return false;
14341 :
14342 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
14343 : return false;
14344 :
14345 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
14346 : return false;
14347 :
14348 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
14349 22 : tmp_expr->where = (*code)->loc;
14350 :
14351 : /* A new charlen is required to ensure that the variable string
14352 : length is different to that of the original lhs. */
14353 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
14354 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
14355 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
14356 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
14357 :
14358 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
14359 :
14360 22 : this_code = build_assignment (EXEC_ASSIGN,
14361 22 : (*code)->expr1,
14362 : gfc_copy_expr (tmp_expr),
14363 : NULL, NULL, (*code)->loc);
14364 :
14365 22 : (*code)->expr1 = tmp_expr;
14366 :
14367 22 : this_code->next = (*code)->next;
14368 22 : (*code)->next = this_code;
14369 :
14370 22 : return true;
14371 : }
14372 :
14373 : static void mark_lhs_assignments_set (gfc_code *code);
14374 :
14375 : /* Given a block of code, recursively resolve everything pointed to by this
14376 : code block. */
14377 :
14378 : void
14379 701679 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
14380 : {
14381 701679 : int omp_workshare_save;
14382 701679 : int forall_save, do_concurrent_save;
14383 701679 : code_stack frame;
14384 701679 : bool t;
14385 701679 : gfc_code *orig_code = code;
14386 :
14387 701679 : frame.prev = cs_base;
14388 701679 : frame.head = code;
14389 701679 : cs_base = &frame;
14390 :
14391 701679 : find_reachable_labels (code);
14392 :
14393 2559071 : for (; code; code = code->next)
14394 : {
14395 1155714 : frame.current = code;
14396 1155714 : forall_save = forall_flag;
14397 1155714 : do_concurrent_save = gfc_do_concurrent_flag;
14398 :
14399 1155714 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
14400 : {
14401 2271 : if (code->op == EXEC_FORALL)
14402 1993 : forall_flag = 1;
14403 278 : else if (code->op == EXEC_DO_CONCURRENT)
14404 278 : gfc_do_concurrent_flag = 1;
14405 2271 : gfc_resolve_forall (code, ns, forall_save);
14406 2271 : if (code->op == EXEC_FORALL)
14407 1993 : forall_flag = 2;
14408 278 : else if (code->op == EXEC_DO_CONCURRENT)
14409 278 : gfc_do_concurrent_flag = 2;
14410 : }
14411 1153443 : else if (code->op == EXEC_OMP_METADIRECTIVE)
14412 145 : for (gfc_omp_variant *variant
14413 : = code->ext.omp_variants;
14414 469 : variant; variant = variant->next)
14415 324 : gfc_resolve_code (variant->code, ns);
14416 1153298 : else if (code->block)
14417 : {
14418 335468 : omp_workshare_save = -1;
14419 335468 : switch (code->op)
14420 : {
14421 10119 : case EXEC_OACC_PARALLEL_LOOP:
14422 10119 : case EXEC_OACC_PARALLEL:
14423 10119 : case EXEC_OACC_KERNELS_LOOP:
14424 10119 : case EXEC_OACC_KERNELS:
14425 10119 : case EXEC_OACC_SERIAL_LOOP:
14426 10119 : case EXEC_OACC_SERIAL:
14427 10119 : case EXEC_OACC_DATA:
14428 10119 : case EXEC_OACC_HOST_DATA:
14429 10119 : case EXEC_OACC_LOOP:
14430 10119 : gfc_resolve_oacc_blocks (code, ns);
14431 10119 : break;
14432 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
14433 54 : omp_workshare_save = omp_workshare_flag;
14434 54 : omp_workshare_flag = 1;
14435 54 : gfc_resolve_omp_parallel_blocks (code, ns);
14436 54 : break;
14437 6060 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14438 6060 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14439 6060 : case EXEC_OMP_MASKED_TASKLOOP:
14440 6060 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14441 6060 : case EXEC_OMP_MASTER_TASKLOOP:
14442 6060 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14443 6060 : case EXEC_OMP_PARALLEL:
14444 6060 : case EXEC_OMP_PARALLEL_DO:
14445 6060 : case EXEC_OMP_PARALLEL_DO_SIMD:
14446 6060 : case EXEC_OMP_PARALLEL_LOOP:
14447 6060 : case EXEC_OMP_PARALLEL_MASKED:
14448 6060 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14449 6060 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14450 6060 : case EXEC_OMP_PARALLEL_MASTER:
14451 6060 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14452 6060 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14453 6060 : case EXEC_OMP_PARALLEL_SECTIONS:
14454 6060 : case EXEC_OMP_TARGET_PARALLEL:
14455 6060 : case EXEC_OMP_TARGET_PARALLEL_DO:
14456 6060 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14457 6060 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14458 6060 : case EXEC_OMP_TARGET_TEAMS:
14459 6060 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14460 6060 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14461 6060 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14462 6060 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14463 6060 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14464 6060 : case EXEC_OMP_TASK:
14465 6060 : case EXEC_OMP_TASKLOOP:
14466 6060 : case EXEC_OMP_TASKLOOP_SIMD:
14467 6060 : case EXEC_OMP_TEAMS:
14468 6060 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14469 6060 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14470 6060 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14471 6060 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14472 6060 : case EXEC_OMP_TEAMS_LOOP:
14473 6060 : omp_workshare_save = omp_workshare_flag;
14474 6060 : omp_workshare_flag = 0;
14475 6060 : gfc_resolve_omp_parallel_blocks (code, ns);
14476 6060 : break;
14477 3073 : case EXEC_OMP_DISTRIBUTE:
14478 3073 : case EXEC_OMP_DISTRIBUTE_SIMD:
14479 3073 : case EXEC_OMP_DO:
14480 3073 : case EXEC_OMP_DO_SIMD:
14481 3073 : case EXEC_OMP_LOOP:
14482 3073 : case EXEC_OMP_SIMD:
14483 3073 : case EXEC_OMP_TARGET_SIMD:
14484 3073 : case EXEC_OMP_TILE:
14485 3073 : case EXEC_OMP_UNROLL:
14486 3073 : gfc_resolve_omp_do_blocks (code, ns);
14487 3073 : break;
14488 : case EXEC_SELECT_TYPE:
14489 : case EXEC_SELECT_RANK:
14490 : /* Blocks are handled in resolve_select_type/rank because we
14491 : have to transform the SELECT TYPE into ASSOCIATE first. */
14492 : break;
14493 : case EXEC_DO_CONCURRENT:
14494 : gfc_do_concurrent_flag = 1;
14495 : gfc_resolve_blocks (code->block, ns);
14496 : gfc_do_concurrent_flag = 2;
14497 : break;
14498 39 : case EXEC_OMP_WORKSHARE:
14499 39 : omp_workshare_save = omp_workshare_flag;
14500 39 : omp_workshare_flag = 1;
14501 : /* FALL THROUGH */
14502 312005 : default:
14503 312005 : gfc_resolve_blocks (code->block, ns);
14504 312005 : break;
14505 : }
14506 :
14507 331311 : if (omp_workshare_save != -1)
14508 6153 : omp_workshare_flag = omp_workshare_save;
14509 : }
14510 1155714 : start:
14511 1155919 : t = true;
14512 1155919 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14513 1154482 : t = gfc_resolve_expr (code->expr1);
14514 :
14515 1155919 : forall_flag = forall_save;
14516 1155919 : gfc_do_concurrent_flag = do_concurrent_save;
14517 :
14518 1155919 : if (!gfc_resolve_expr (code->expr2))
14519 646 : t = false;
14520 :
14521 1155919 : if (code->op == EXEC_ALLOCATE
14522 1155919 : && !gfc_resolve_expr (code->expr3))
14523 : t = false;
14524 :
14525 1155919 : switch (code->op)
14526 : {
14527 : case EXEC_NOP:
14528 : case EXEC_END_BLOCK:
14529 : case EXEC_END_NESTED_BLOCK:
14530 : case EXEC_CYCLE:
14531 : break;
14532 :
14533 221361 : case EXEC_STOP:
14534 221361 : case EXEC_ERROR_STOP:
14535 221361 : if (code->expr1 != NULL && t)
14536 : {
14537 200871 : if (!(code->expr1->ts.type == BT_CHARACTER
14538 : || code->expr1->ts.type == BT_INTEGER))
14539 1 : gfc_error ("STOP code at %L must be either INTEGER or CHARACTER "
14540 : "type", &code->expr1->where);
14541 200870 : else if (code->expr1->rank != 0)
14542 0 : gfc_error ("STOP code at %L must be scalar",
14543 : &code->expr1->where);
14544 200870 : else if (code->expr1->ts.type == BT_CHARACTER
14545 498 : && code->expr1->ts.kind != gfc_default_character_kind)
14546 0 : gfc_error ("STOP code at %L must be default character KIND=%d",
14547 : &code->expr1->where, (int) gfc_default_character_kind);
14548 200870 : else if (code->expr1->ts.type == BT_INTEGER
14549 200372 : && code->expr1->ts.kind != gfc_default_integer_kind)
14550 8 : gfc_notify_std (GFC_STD_F2018, "STOP code at %L must be default "
14551 : "integer KIND=%d", &code->expr1->where,
14552 : (int) gfc_default_integer_kind);
14553 : }
14554 221361 : if (code->expr2 != NULL
14555 37 : && (code->expr2->ts.type != BT_LOGICAL
14556 37 : || code->expr2->rank != 0))
14557 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14558 : &code->expr2->where);
14559 :
14560 : /* Fall through. */
14561 221391 : case EXEC_PAUSE:
14562 221391 : gfc_value_used_expr (code->expr1, VALUE_USED);
14563 221391 : break;
14564 :
14565 : case EXEC_EXIT:
14566 : case EXEC_CONTINUE:
14567 : case EXEC_DT_END:
14568 : case EXEC_ASSIGN_CALL:
14569 : break;
14570 :
14571 54 : case EXEC_CRITICAL:
14572 54 : resolve_critical (code);
14573 54 : break;
14574 :
14575 1393 : case EXEC_SYNC_ALL:
14576 1393 : case EXEC_SYNC_IMAGES:
14577 1393 : case EXEC_SYNC_MEMORY:
14578 1393 : resolve_sync (code);
14579 1393 : break;
14580 :
14581 197 : case EXEC_LOCK:
14582 197 : case EXEC_UNLOCK:
14583 197 : case EXEC_EVENT_POST:
14584 197 : case EXEC_EVENT_WAIT:
14585 197 : resolve_lock_unlock_event (code);
14586 197 : break;
14587 :
14588 : case EXEC_FAIL_IMAGE:
14589 : break;
14590 :
14591 164 : case EXEC_FORM_TEAM:
14592 164 : resolve_form_team (code);
14593 164 : break;
14594 :
14595 107 : case EXEC_CHANGE_TEAM:
14596 107 : resolve_change_team (code);
14597 107 : break;
14598 :
14599 105 : case EXEC_END_TEAM:
14600 105 : resolve_end_team (code);
14601 105 : break;
14602 :
14603 45 : case EXEC_SYNC_TEAM:
14604 45 : resolve_sync_team (code);
14605 45 : break;
14606 :
14607 1491 : case EXEC_ENTRY:
14608 : /* Keep track of which entry we are up to. */
14609 1491 : current_entry_id = code->ext.entry->id;
14610 1491 : break;
14611 :
14612 459 : case EXEC_WHERE:
14613 459 : resolve_where (code, NULL);
14614 459 : break;
14615 :
14616 1304 : case EXEC_GOTO:
14617 1304 : if (code->expr1 != NULL)
14618 : {
14619 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14620 76 : || code->expr1->ts.type != BT_INTEGER
14621 76 : || (code->expr1->ref
14622 1 : && code->expr1->ref->type == REF_ARRAY)
14623 75 : || code->expr1->symtree == NULL
14624 75 : || (code->expr1->symtree->n.sym
14625 75 : && (code->expr1->symtree->n.sym->attr.flavor
14626 75 : == FL_PARAMETER)))
14627 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14628 : "scalar INTEGER variable", &code->expr1->where);
14629 74 : else if (code->expr1->symtree->n.sym
14630 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14631 1 : gfc_error ("Variable %qs has not been assigned a target "
14632 : "label at %L", code->expr1->symtree->n.sym->name,
14633 : &code->expr1->where);
14634 : }
14635 : else
14636 1226 : resolve_branch (code->label1, code);
14637 : break;
14638 :
14639 3266 : case EXEC_RETURN:
14640 3266 : if (code->expr1 != NULL
14641 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14642 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14643 : "INTEGER return specifier", &code->expr1->where);
14644 : break;
14645 :
14646 : case EXEC_INIT_ASSIGN:
14647 : case EXEC_END_PROCEDURE:
14648 : break;
14649 :
14650 290783 : case EXEC_ASSIGN:
14651 290783 : if (!t)
14652 : break;
14653 :
14654 290099 : if (flag_coarray == GFC_FCOARRAY_LIB
14655 290099 : && gfc_is_coindexed (code->expr1))
14656 : {
14657 : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14658 : coindexed variable. */
14659 500 : code->op = EXEC_CALL;
14660 500 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14661 : true);
14662 500 : code->resolved_sym = code->symtree->n.sym;
14663 500 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14664 500 : code->resolved_sym->attr.intrinsic = 1;
14665 500 : code->resolved_sym->attr.subroutine = 1;
14666 500 : code->resolved_isym
14667 500 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14668 500 : gfc_commit_symbol (code->resolved_sym);
14669 500 : code->ext.actual = gfc_get_actual_arglist ();
14670 500 : code->ext.actual->expr = code->expr1;
14671 500 : code->ext.actual->next = gfc_get_actual_arglist ();
14672 500 : if (code->expr2->expr_type != EXPR_VARIABLE
14673 500 : && code->expr2->expr_type != EXPR_CONSTANT)
14674 : {
14675 : /* Convert assignments of expr1[...] = expr2 into
14676 : tvar = expr2
14677 : expr1[...] = tvar
14678 : when expr2 is not trivial. */
14679 54 : gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
14680 54 : gfc_code next_code = *code;
14681 54 : gfc_code *rhs_code
14682 108 : = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
14683 54 : NULL, code->expr2->where);
14684 54 : *code = *rhs_code;
14685 54 : code->next = rhs_code;
14686 54 : *rhs_code = next_code;
14687 :
14688 54 : rhs_code->ext.actual->next->expr = tvar;
14689 54 : rhs_code->expr1 = NULL;
14690 54 : rhs_code->expr2 = NULL;
14691 : }
14692 : else
14693 : {
14694 446 : code->ext.actual->next->expr = code->expr2;
14695 :
14696 446 : code->expr1 = NULL;
14697 446 : code->expr2 = NULL;
14698 : }
14699 : break;
14700 : }
14701 :
14702 289599 : if (code->expr1->ts.type == BT_CLASS)
14703 1163 : gfc_find_vtab (&code->expr2->ts);
14704 :
14705 : /* If this is a pointer function in an lvalue variable context,
14706 : the new code will have to be resolved afresh. This is also the
14707 : case with an error, where the code is transformed into NOP to
14708 : prevent ICEs downstream. */
14709 289599 : if (resolve_ptr_fcn_assign (&code, ns)
14710 289599 : || code->op == EXEC_NOP)
14711 205 : goto start;
14712 :
14713 289394 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14714 289394 : _("assignment")))
14715 : break;
14716 :
14717 289351 : if (resolve_ordinary_assign (code, ns))
14718 : {
14719 924 : if (omp_workshare_flag)
14720 : {
14721 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14722 1 : "at %L", &code->loc);
14723 1 : break;
14724 : }
14725 923 : if (code->op == EXEC_COMPCALL)
14726 455 : goto compcall;
14727 : else
14728 468 : goto call;
14729 : }
14730 :
14731 : /* Check for dependencies in deferred character length array
14732 : assignments and generate a temporary, if necessary. */
14733 288427 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14734 : break;
14735 :
14736 : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14737 288405 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14738 7455 : && code->expr1->ts.u.derived
14739 7455 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14740 194 : generate_component_assignments (&code, ns);
14741 288211 : else if (code->op == EXEC_ASSIGN)
14742 : {
14743 288211 : if (gfc_may_be_finalized (code->expr1->ts))
14744 1344 : code->expr1->must_finalize = 1;
14745 288211 : if (code->expr2->expr_type == EXPR_ARRAY
14746 288211 : && gfc_may_be_finalized (code->expr2->ts))
14747 73 : code->expr2->must_finalize = 1;
14748 : }
14749 :
14750 : break;
14751 :
14752 126 : case EXEC_LABEL_ASSIGN:
14753 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14754 0 : gfc_error ("Label %d referenced at %L is never defined",
14755 : code->label1->value, &code->label1->where);
14756 126 : if (t
14757 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14758 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14759 126 : || code->expr1->symtree->n.sym->ts.kind
14760 126 : != gfc_default_integer_kind
14761 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14762 125 : || code->expr1->symtree->n.sym->as != NULL))
14763 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14764 : "default INTEGER variable", &code->expr1->where);
14765 : break;
14766 :
14767 10634 : case EXEC_POINTER_ASSIGN:
14768 10634 : {
14769 10634 : gfc_expr* e;
14770 :
14771 10634 : if (!t)
14772 : break;
14773 :
14774 : /* This is both a variable definition and pointer assignment
14775 : context, so check both of them. For rank remapping, a final
14776 : array ref may be present on the LHS and fool gfc_expr_attr
14777 : used in gfc_check_vardef_context. Remove it. */
14778 10629 : e = remove_last_array_ref (code->expr1);
14779 21258 : t = gfc_check_vardef_context (e, true, false, false,
14780 10629 : _("pointer assignment"));
14781 10629 : if (t)
14782 10600 : t = gfc_check_vardef_context (e, false, false, false,
14783 10600 : _("pointer assignment"));
14784 10629 : gfc_free_expr (e);
14785 :
14786 10629 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14787 :
14788 10487 : if (!t)
14789 : break;
14790 :
14791 : /* Assigning a class object always is a regular assign. */
14792 10487 : if (code->expr2->ts.type == BT_CLASS
14793 606 : && code->expr1->ts.type == BT_CLASS
14794 509 : && CLASS_DATA (code->expr2)
14795 508 : && !CLASS_DATA (code->expr2)->attr.dimension
14796 11148 : && !(gfc_expr_attr (code->expr1).proc_pointer
14797 55 : && code->expr2->expr_type == EXPR_VARIABLE
14798 43 : && code->expr2->symtree->n.sym->attr.flavor
14799 43 : == FL_PROCEDURE))
14800 340 : code->op = EXEC_ASSIGN;
14801 : break;
14802 : }
14803 :
14804 72 : case EXEC_ARITHMETIC_IF:
14805 72 : {
14806 72 : gfc_expr *e = code->expr1;
14807 :
14808 72 : gfc_resolve_expr (e);
14809 72 : if (e->expr_type == EXPR_NULL)
14810 1 : gfc_error ("Invalid NULL at %L", &e->where);
14811 :
14812 72 : if (t && (e->rank > 0
14813 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14814 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14815 : "REAL or INTEGER expression", &e->where);
14816 :
14817 72 : resolve_branch (code->label1, code);
14818 72 : resolve_branch (code->label2, code);
14819 72 : resolve_branch (code->label3, code);
14820 : }
14821 72 : break;
14822 :
14823 235096 : case EXEC_IF:
14824 235096 : if (t && code->expr1 != NULL
14825 0 : && (code->expr1->ts.type != BT_LOGICAL
14826 0 : || code->expr1->rank != 0))
14827 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14828 : &code->expr1->where);
14829 : break;
14830 :
14831 81194 : case EXEC_CALL:
14832 81194 : call:
14833 81194 : resolve_call (code);
14834 81194 : break;
14835 :
14836 1768 : case EXEC_COMPCALL:
14837 1768 : compcall:
14838 1768 : resolve_typebound_subroutine (code);
14839 1768 : break;
14840 :
14841 124 : case EXEC_CALL_PPC:
14842 124 : resolve_ppc_call (code);
14843 124 : break;
14844 :
14845 694 : case EXEC_SELECT:
14846 : /* Select is complicated. Also, a SELECT construct could be
14847 : a transformed computed GOTO. */
14848 694 : resolve_select (code, false);
14849 694 : break;
14850 :
14851 3135 : case EXEC_SELECT_TYPE:
14852 3135 : resolve_select_type (code, ns);
14853 3135 : break;
14854 :
14855 1048 : case EXEC_SELECT_RANK:
14856 1048 : resolve_select_rank (code, ns);
14857 1048 : break;
14858 :
14859 8441 : case EXEC_BLOCK:
14860 8441 : resolve_block_construct (code);
14861 8441 : break;
14862 :
14863 33366 : case EXEC_DO:
14864 33366 : if (code->ext.iterator != NULL)
14865 : {
14866 33366 : gfc_iterator *iter = code->ext.iterator;
14867 33366 : if (gfc_resolve_iterator (iter, true, false))
14868 33352 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14869 : true);
14870 : }
14871 : break;
14872 :
14873 537 : case EXEC_DO_WHILE:
14874 537 : if (code->expr1 == NULL)
14875 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14876 : "DO WHILE");
14877 537 : if (t
14878 537 : && (code->expr1->rank != 0
14879 537 : || code->expr1->ts.type != BT_LOGICAL))
14880 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14881 : "a scalar LOGICAL expression", &code->expr1->where);
14882 : break;
14883 :
14884 14681 : case EXEC_ALLOCATE:
14885 14681 : if (t)
14886 14679 : resolve_allocate_deallocate (code, "ALLOCATE");
14887 :
14888 : break;
14889 :
14890 6220 : case EXEC_DEALLOCATE:
14891 6220 : if (t)
14892 6220 : resolve_allocate_deallocate (code, "DEALLOCATE");
14893 :
14894 : break;
14895 :
14896 3961 : case EXEC_OPEN:
14897 3961 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14898 : break;
14899 :
14900 3734 : resolve_branch (code->ext.open->err, code);
14901 3734 : break;
14902 :
14903 3154 : case EXEC_CLOSE:
14904 3154 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14905 : break;
14906 :
14907 3120 : resolve_branch (code->ext.close->err, code);
14908 3120 : break;
14909 :
14910 2857 : case EXEC_BACKSPACE:
14911 2857 : case EXEC_ENDFILE:
14912 2857 : case EXEC_REWIND:
14913 2857 : case EXEC_FLUSH:
14914 2857 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14915 : break;
14916 :
14917 2791 : resolve_branch (code->ext.filepos->err, code);
14918 2791 : break;
14919 :
14920 838 : case EXEC_INQUIRE:
14921 838 : if (!gfc_resolve_inquire (code->ext.inquire))
14922 : break;
14923 :
14924 790 : resolve_branch (code->ext.inquire->err, code);
14925 790 : break;
14926 :
14927 92 : case EXEC_IOLENGTH:
14928 92 : gcc_assert (code->ext.inquire != NULL);
14929 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14930 : break;
14931 :
14932 90 : resolve_branch (code->ext.inquire->err, code);
14933 90 : break;
14934 :
14935 89 : case EXEC_WAIT:
14936 89 : if (!gfc_resolve_wait (code->ext.wait))
14937 : break;
14938 :
14939 74 : resolve_branch (code->ext.wait->err, code);
14940 74 : resolve_branch (code->ext.wait->end, code);
14941 74 : resolve_branch (code->ext.wait->eor, code);
14942 74 : break;
14943 :
14944 33653 : case EXEC_READ:
14945 33653 : case EXEC_WRITE:
14946 33653 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14947 : break;
14948 :
14949 33345 : resolve_branch (code->ext.dt->err, code);
14950 33345 : resolve_branch (code->ext.dt->end, code);
14951 33345 : resolve_branch (code->ext.dt->eor, code);
14952 33345 : break;
14953 :
14954 47666 : case EXEC_TRANSFER:
14955 47666 : resolve_transfer (code);
14956 47666 : break;
14957 :
14958 2271 : case EXEC_DO_CONCURRENT:
14959 2271 : case EXEC_FORALL:
14960 2271 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14961 :
14962 2271 : if (code->expr1 != NULL
14963 732 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14964 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14965 : "expression", &code->expr1->where);
14966 :
14967 2271 : if (code->op == EXEC_DO_CONCURRENT)
14968 278 : resolve_locality_spec (code, ns);
14969 : break;
14970 :
14971 13538 : case EXEC_OACC_PARALLEL_LOOP:
14972 13538 : case EXEC_OACC_PARALLEL:
14973 13538 : case EXEC_OACC_KERNELS_LOOP:
14974 13538 : case EXEC_OACC_KERNELS:
14975 13538 : case EXEC_OACC_SERIAL_LOOP:
14976 13538 : case EXEC_OACC_SERIAL:
14977 13538 : case EXEC_OACC_DATA:
14978 13538 : case EXEC_OACC_HOST_DATA:
14979 13538 : case EXEC_OACC_LOOP:
14980 13538 : case EXEC_OACC_UPDATE:
14981 13538 : case EXEC_OACC_WAIT:
14982 13538 : case EXEC_OACC_CACHE:
14983 13538 : case EXEC_OACC_ENTER_DATA:
14984 13538 : case EXEC_OACC_EXIT_DATA:
14985 13538 : case EXEC_OACC_ATOMIC:
14986 13538 : case EXEC_OACC_DECLARE:
14987 13538 : case EXEC_OACC_INIT:
14988 13538 : case EXEC_OACC_SHUTDOWN:
14989 13538 : case EXEC_OACC_SET:
14990 13538 : gfc_resolve_oacc_directive (code, ns);
14991 13538 : break;
14992 :
14993 17415 : case EXEC_OMP_ALLOCATE:
14994 17415 : case EXEC_OMP_ALLOCATORS:
14995 17415 : case EXEC_OMP_ASSUME:
14996 17415 : case EXEC_OMP_ATOMIC:
14997 17415 : case EXEC_OMP_BARRIER:
14998 17415 : case EXEC_OMP_CANCEL:
14999 17415 : case EXEC_OMP_CANCELLATION_POINT:
15000 17415 : case EXEC_OMP_CRITICAL:
15001 17415 : case EXEC_OMP_FLUSH:
15002 17415 : case EXEC_OMP_DEPOBJ:
15003 17415 : case EXEC_OMP_DISPATCH:
15004 17415 : case EXEC_OMP_DISTRIBUTE:
15005 17415 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
15006 17415 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
15007 17415 : case EXEC_OMP_DISTRIBUTE_SIMD:
15008 17415 : case EXEC_OMP_DO:
15009 17415 : case EXEC_OMP_DO_SIMD:
15010 17415 : case EXEC_OMP_ERROR:
15011 17415 : case EXEC_OMP_INTEROP:
15012 17415 : case EXEC_OMP_LOOP:
15013 17415 : case EXEC_OMP_MASTER:
15014 17415 : case EXEC_OMP_MASTER_TASKLOOP:
15015 17415 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
15016 17415 : case EXEC_OMP_MASKED:
15017 17415 : case EXEC_OMP_MASKED_TASKLOOP:
15018 17415 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
15019 17415 : case EXEC_OMP_METADIRECTIVE:
15020 17415 : case EXEC_OMP_ORDERED:
15021 17415 : case EXEC_OMP_SCAN:
15022 17415 : case EXEC_OMP_SCOPE:
15023 17415 : case EXEC_OMP_SECTIONS:
15024 17415 : case EXEC_OMP_SIMD:
15025 17415 : case EXEC_OMP_SINGLE:
15026 17415 : case EXEC_OMP_TARGET:
15027 17415 : case EXEC_OMP_TARGET_DATA:
15028 17415 : case EXEC_OMP_TARGET_ENTER_DATA:
15029 17415 : case EXEC_OMP_TARGET_EXIT_DATA:
15030 17415 : case EXEC_OMP_TARGET_PARALLEL:
15031 17415 : case EXEC_OMP_TARGET_PARALLEL_DO:
15032 17415 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
15033 17415 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
15034 17415 : case EXEC_OMP_TARGET_SIMD:
15035 17415 : case EXEC_OMP_TARGET_TEAMS:
15036 17415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
15037 17415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
15038 17415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
15039 17415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
15040 17415 : case EXEC_OMP_TARGET_TEAMS_LOOP:
15041 17415 : case EXEC_OMP_TARGET_UPDATE:
15042 17415 : case EXEC_OMP_TASK:
15043 17415 : case EXEC_OMP_TASKGROUP:
15044 17415 : case EXEC_OMP_TASKLOOP:
15045 17415 : case EXEC_OMP_TASKLOOP_SIMD:
15046 17415 : case EXEC_OMP_TASKWAIT:
15047 17415 : case EXEC_OMP_TASKYIELD:
15048 17415 : case EXEC_OMP_TEAMS:
15049 17415 : case EXEC_OMP_TEAMS_DISTRIBUTE:
15050 17415 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
15051 17415 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
15052 17415 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
15053 17415 : case EXEC_OMP_TEAMS_LOOP:
15054 17415 : case EXEC_OMP_TILE:
15055 17415 : case EXEC_OMP_UNROLL:
15056 17415 : case EXEC_OMP_WORKSHARE:
15057 17415 : gfc_resolve_omp_directive (code, ns);
15058 17415 : break;
15059 :
15060 3934 : case EXEC_OMP_PARALLEL:
15061 3934 : case EXEC_OMP_PARALLEL_DO:
15062 3934 : case EXEC_OMP_PARALLEL_DO_SIMD:
15063 3934 : case EXEC_OMP_PARALLEL_LOOP:
15064 3934 : case EXEC_OMP_PARALLEL_MASKED:
15065 3934 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
15066 3934 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
15067 3934 : case EXEC_OMP_PARALLEL_MASTER:
15068 3934 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
15069 3934 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
15070 3934 : case EXEC_OMP_PARALLEL_SECTIONS:
15071 3934 : case EXEC_OMP_PARALLEL_WORKSHARE:
15072 3934 : omp_workshare_save = omp_workshare_flag;
15073 3934 : omp_workshare_flag = 0;
15074 3934 : gfc_resolve_omp_directive (code, ns);
15075 3934 : omp_workshare_flag = omp_workshare_save;
15076 3934 : break;
15077 :
15078 0 : default:
15079 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
15080 : }
15081 1155713 : gfc_value_used_expr (code->expr2, VALUE_USED);
15082 1155713 : gfc_value_used_expr (code->expr3, VALUE_USED);
15083 1155713 : gfc_value_used_expr (code->expr4, VALUE_USED);
15084 : }
15085 :
15086 701678 : mark_lhs_assignments_set (orig_code);
15087 :
15088 701678 : cs_base = frame.prev;
15089 701678 : }
15090 :
15091 :
15092 : /* Resolve initial values and make sure they are compatible with
15093 : the variable. */
15094 :
15095 : static void
15096 1953579 : resolve_values (gfc_symbol *sym)
15097 : {
15098 1953579 : bool t;
15099 :
15100 1953579 : if (sym->value == NULL)
15101 : return;
15102 :
15103 447613 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
15104 14 : gfc_warning (OPT_Wdeprecated_declarations,
15105 : "Using parameter %qs declared at %L is deprecated",
15106 : sym->name, &sym->declared_at);
15107 :
15108 447613 : if (sym->value->expr_type == EXPR_STRUCTURE)
15109 41191 : t= resolve_structure_cons (sym->value, 1);
15110 : else
15111 406422 : t = gfc_resolve_expr (sym->value);
15112 :
15113 447613 : if (!t)
15114 : return;
15115 :
15116 447611 : gfc_check_assign_symbol (sym, NULL, sym->value);
15117 : }
15118 :
15119 :
15120 : /* Verify any BIND(C) derived types in the namespace so we can report errors
15121 : for them once, rather than for each variable declared of that type. */
15122 :
15123 : static void
15124 1922726 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
15125 : {
15126 1922726 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
15127 86903 : && derived_sym->attr.is_bind_c == 1)
15128 27891 : verify_bind_c_derived_type (derived_sym);
15129 :
15130 1922726 : return;
15131 : }
15132 :
15133 :
15134 : /* Check the interfaces of DTIO procedures associated with derived
15135 : type 'sym'. These procedures can either have typebound bindings or
15136 : can appear in DTIO generic interfaces. */
15137 :
15138 : static void
15139 1954549 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
15140 : {
15141 1954549 : if (!sym || sym->attr.flavor != FL_DERIVED)
15142 : return;
15143 :
15144 96681 : gfc_check_dtio_interfaces (sym);
15145 :
15146 96681 : return;
15147 : }
15148 :
15149 : /* Auxiliary function, checks if an argument decays to a pointer. */
15150 :
15151 : static bool
15152 70418 : decays_to_pointer (gfc_symbol *sym)
15153 : {
15154 70418 : if (!sym->as)
15155 : return true;
15156 :
15157 19603 : if (sym->as->type == AS_ASSUMED_SHAPE)
15158 : return false;
15159 :
15160 15846 : if (sym->as->type == AS_ASSUMED_RANK)
15161 : return false;
15162 :
15163 10748 : if (sym->as->type == AS_DEFERRED && sym->attr.dummy)
15164 968 : return false;
15165 :
15166 : return true;
15167 : }
15168 :
15169 : /* Helper function, returns true if the types conform according to the C
15170 : standard, when they are not equal on the Fortran side. If we decide to
15171 : include or exclude any types from this, this is the place to change. */
15172 :
15173 : static bool
15174 390 : c_types_conform (gfc_typespec *ts1, gfc_typespec *ts2)
15175 : {
15176 390 : if (ts1->type == BT_ASSUMED || ts2->type == BT_ASSUMED)
15177 : return true;
15178 :
15179 384 : if (ts1->kind == ts2->kind
15180 : && (ts1->type == BT_CHARACTER || ts1->type == BT_INTEGER
15181 : || ts1->type == BT_UNSIGNED)
15182 : && (ts2->type == BT_CHARACTER || ts2->type == BT_INTEGER
15183 : || ts2->type == BT_UNSIGNED))
15184 384 : return true;
15185 :
15186 : return false;
15187 :
15188 : }
15189 :
15190 : /* Check argument lists of BIND(C) procedures against each other, return
15191 : false if they do not. */
15192 :
15193 : static bool
15194 12876 : compare_c_binding_arglists (gfc_symbol *osym, gfc_symbol *nsym)
15195 : {
15196 12876 : gfc_formal_arglist *oarg, *narg;
15197 12876 : bool ret = true;
15198 12876 : locus *oloc, *nloc;
15199 :
15200 12876 : oarg = osym->formal;
15201 12876 : narg = nsym->formal;
15202 12876 : oloc = &osym->declared_at;
15203 12876 : nloc = &nsym->declared_at;
15204 48095 : for ( ; oarg && narg ; oarg = oarg->next, narg = narg->next)
15205 : {
15206 35219 : oloc = &oarg->sym->declared_at;
15207 35219 : nloc = &narg->sym->declared_at;
15208 :
15209 35219 : if (!gfc_compare_types (&oarg->sym->ts, &narg->sym->ts)
15210 35219 : && (pedantic || !c_types_conform (&oarg->sym->ts, &narg->sym->ts)))
15211 : {
15212 24 : gfc_error ("Type mismatch in argument %qs at %L (%s/%s) "
15213 8 : "originally declared at %L", narg->sym->name,
15214 8 : nloc, gfc_typename (&narg->sym->ts),
15215 8 : gfc_typename (&oarg->sym->ts), oloc);
15216 8 : ret = false;
15217 8 : continue;
15218 : }
15219 35211 : if (oarg->sym->attr.value != narg->sym->attr.value)
15220 : {
15221 1 : gfc_error ("VALUE attribute mismatch in argument %qs at %L "
15222 : "originally declared at %L",narg->sym->name,
15223 : nloc, oloc);
15224 1 : ret = false;
15225 1 : continue;
15226 : }
15227 :
15228 : /* According to the Fortran standard, ranks have to match for arguments.
15229 : In this case, this makes little sense because both decay to C
15230 : pointers. Only issue an error if -pedantic or if the argument does
15231 : not decay to a pointer. Same thing for CFI_desc arrays, which include
15232 : assumed rank. */
15233 :
15234 35210 : int orank = gfc_symbol_rank (oarg->sym);
15235 35210 : int nrank = gfc_symbol_rank (narg->sym);
15236 35210 : if (orank != nrank && pedantic)
15237 : {
15238 1 : gfc_error ("Rank mismatch in argument %qs (%d/%d) at %L originally "
15239 1 : "declared at %L", narg->sym->name, nrank, orank, nloc,
15240 : oloc);
15241 1 : ret = false;
15242 1 : continue;
15243 : }
15244 :
15245 : /* Confusion between CFI_desc and "normal" arrays. */
15246 :
15247 35209 : if (decays_to_pointer (oarg->sym) != decays_to_pointer (narg->sym))
15248 : {
15249 1 : gfc_error ("Array specification mismatch in argument %qs at %L "
15250 : "originally declared at %L", narg->sym->name,
15251 : nloc, oloc);
15252 1 : ret = false;
15253 1 : continue;
15254 : }
15255 : }
15256 :
15257 12876 : if (oarg && !narg)
15258 : {
15259 0 : gfc_error ("Not enough arguments for procedure %qs with binding label "
15260 : "%qs after %L, originally declared at %L", nsym->name,
15261 0 : nsym->binding_label, nloc, &oarg->sym->declared_at);
15262 0 : ret = false;
15263 : }
15264 :
15265 12876 : if (!oarg && narg)
15266 : {
15267 2 : gfc_error ("Too many arguments for procedure %qs with binding label "
15268 : "%qs at %L, originally declared at %L", nsym->name,
15269 2 : nsym->binding_label, &narg->sym->declared_at, oloc);
15270 2 : ret = false;
15271 : }
15272 :
15273 12876 : return ret;
15274 : }
15275 :
15276 :
15277 : /* Verify that any binding labels used in a given namespace do not collide
15278 : with the names or binding labels of any global symbols. Multiple INTERFACE
15279 : for the same procedure are permitted. Abstract interfaces and dummy
15280 : arguments are not checked. */
15281 :
15282 : static void
15283 1954549 : gfc_verify_binding_labels (gfc_symbol *sym)
15284 : {
15285 1954549 : gfc_gsymbol *gsym;
15286 1954549 : const char *module;
15287 :
15288 1954549 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
15289 70678 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
15290 41846 : || sym->attr.abstract || sym->attr.dummy)
15291 : return;
15292 :
15293 : /* Avoid double error reporting. */
15294 41710 : if (sym->error)
15295 : return;
15296 :
15297 : /* TODO: Check the names of reserved external C identifiers here, see
15298 : PR 125251. */
15299 :
15300 : /* According to the Fortran standard, global identifiers are case
15301 : insensitive, which also holds for C identifiers. This was probably done
15302 : for systems which had case-insensitive linkers. Such systems could not
15303 : accommodate the C standards referenced, so this restriction makes little
15304 : sense for modern systems. Therefore, check case-sensitive labels unless
15305 : -pedantic is in force. */
15306 :
15307 41710 : if (pedantic)
15308 4663 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
15309 : else
15310 37047 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
15311 :
15312 41710 : if (sym->module)
15313 : module = sym->module;
15314 13133 : else if (sym->ns && sym->ns->proc_name
15315 13133 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
15316 4591 : module = sym->ns->proc_name->name;
15317 8542 : else if (sym->ns && sym->ns->parent
15318 358 : && sym->ns && sym->ns->parent->proc_name
15319 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15320 272 : module = sym->ns->parent->proc_name->name;
15321 : else
15322 : module = NULL;
15323 :
15324 41710 : if (gsym)
15325 : {
15326 12920 : if (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)
15327 : {
15328 12879 : gfc_symbol *global_sym;
15329 12879 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &global_sym);
15330 :
15331 : /* For when the symtree does not match the symbol name, which can happen
15332 : in modules with PRIVATE. */
15333 :
15334 12879 : if (global_sym == NULL)
15335 1 : gfc_find_symbol_by_name (gsym->sym_name, gsym->ns, &global_sym);
15336 :
15337 12879 : gcc_assert (global_sym);
15338 :
15339 : /* If subroutines and functions are conflated, there is little point
15340 : in continuing checks. */
15341 12879 : if ((sym->attr.function && gsym->type == GSYM_SUBROUTINE)
15342 12879 : || (sym->attr.subroutine && gsym->type == GSYM_FUNCTION))
15343 : {
15344 1 : gfc_global_used (gsym, &sym->declared_at);
15345 1 : sym->binding_label = NULL;
15346 1 : sym->error = 1;
15347 13 : return;
15348 : }
15349 :
15350 7242 : if (gsym->type == GSYM_FUNCTION && sym->attr.function
15351 20120 : && !gfc_compare_types (&sym->ts, &global_sym->ts))
15352 : {
15353 2 : gfc_error ("Return type mismatch of function %qs with binding "
15354 : "label %qs at %L (%s/%s), originally declared at %L",
15355 : sym->name, sym->binding_label,
15356 : &sym->declared_at,
15357 : gfc_typename (&sym->ts),
15358 2 : gfc_typename (&global_sym->ts),
15359 : &gsym->where);
15360 2 : sym->binding_label = NULL;
15361 2 : sym->error = 1;
15362 2 : return;
15363 : }
15364 12876 : if (!compare_c_binding_arglists (global_sym, sym))
15365 : {
15366 10 : sym->binding_label = NULL;
15367 10 : sym->error = 1;
15368 10 : return;
15369 : }
15370 : }
15371 : }
15372 :
15373 12866 : if (!gsym
15374 12907 : || (!gsym->defined
15375 9955 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
15376 : {
15377 28790 : if (!gsym)
15378 28790 : gsym = gfc_get_gsymbol (sym->binding_label, true);
15379 38745 : gsym->where = sym->declared_at;
15380 38745 : gsym->sym_name = sym->name;
15381 38745 : gsym->binding_label = sym->binding_label;
15382 38745 : gsym->ns = sym->ns;
15383 38745 : gsym->mod_name = module;
15384 38745 : if (sym->attr.function)
15385 26322 : gsym->type = GSYM_FUNCTION;
15386 12423 : else if (sym->attr.subroutine)
15387 12283 : gsym->type = GSYM_SUBROUTINE;
15388 : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
15389 38745 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
15390 38745 : return;
15391 : }
15392 :
15393 2952 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
15394 : {
15395 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
15396 : "identifier as entity at %L", sym->name,
15397 : sym->binding_label, &sym->declared_at, &gsym->where);
15398 : /* Clear the binding label to prevent checking multiple times. */
15399 1 : sym->binding_label = NULL;
15400 1 : return;
15401 : }
15402 :
15403 2951 : if (sym->attr.flavor == FL_VARIABLE && module
15404 37 : && (strcmp (module, gsym->mod_name) != 0
15405 35 : || strcmp (sym->name, gsym->sym_name) != 0))
15406 : {
15407 : /* This can only happen if the variable is defined in a module - if it
15408 : isn't the same module, reject it. */
15409 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
15410 : "uses the same global identifier as entity at %L from module %qs",
15411 : sym->name, module, sym->binding_label,
15412 : &sym->declared_at, &gsym->where, gsym->mod_name);
15413 3 : sym->binding_label = NULL;
15414 3 : return;
15415 : }
15416 :
15417 2948 : if ((sym->attr.function || sym->attr.subroutine)
15418 2912 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
15419 2910 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
15420 2527 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
15421 2095 : && (module != gsym->mod_name
15422 2091 : || strcmp (gsym->sym_name, sym->name) != 0
15423 2091 : || (module && strcmp (module, gsym->mod_name) != 0)))
15424 : {
15425 : /* Print an error if the procedure is defined multiple times; we have to
15426 : exclude references to the same procedure via module association or
15427 : multiple checks for the same procedure. */
15428 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
15429 : "global identifier as entity at %L", sym->name,
15430 : sym->binding_label, &sym->declared_at, &gsym->where);
15431 4 : sym->binding_label = NULL;
15432 4 : return;
15433 : }
15434 : }
15435 :
15436 :
15437 : /* Resolve an index expression. */
15438 :
15439 : static bool
15440 269126 : resolve_index_expr (gfc_expr *e)
15441 : {
15442 269126 : if (!gfc_resolve_expr (e))
15443 : return false;
15444 :
15445 269116 : if (!gfc_simplify_expr (e, 0))
15446 : return false;
15447 :
15448 269114 : if (!gfc_specification_expr (e))
15449 : return false;
15450 :
15451 : return true;
15452 : }
15453 :
15454 :
15455 : /* Resolve a charlen structure. */
15456 :
15457 : static bool
15458 104712 : resolve_charlen (gfc_charlen *cl)
15459 : {
15460 104712 : int k;
15461 104712 : bool saved_specification_expr;
15462 :
15463 104712 : if (cl->resolved)
15464 : return true;
15465 :
15466 95826 : cl->resolved = 1;
15467 95826 : saved_specification_expr = specification_expr;
15468 95826 : specification_expr = true;
15469 :
15470 95826 : if (cl->length_from_typespec)
15471 : {
15472 1502 : if (!gfc_resolve_expr (cl->length))
15473 : {
15474 1 : specification_expr = saved_specification_expr;
15475 1 : return false;
15476 : }
15477 :
15478 1501 : if (!gfc_simplify_expr (cl->length, 0))
15479 : {
15480 0 : specification_expr = saved_specification_expr;
15481 0 : return false;
15482 : }
15483 :
15484 : /* cl->length has been resolved. It should have an integer type. */
15485 1501 : if (cl->length
15486 1500 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
15487 : {
15488 4 : gfc_error ("Scalar INTEGER expression expected at %L",
15489 : &cl->length->where);
15490 4 : return false;
15491 : }
15492 : }
15493 : else
15494 : {
15495 94324 : if (!resolve_index_expr (cl->length))
15496 : {
15497 19 : specification_expr = saved_specification_expr;
15498 19 : return false;
15499 : }
15500 : }
15501 :
15502 : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
15503 : a negative value, the length of character entities declared is zero. */
15504 95802 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15505 57507 : && mpz_sgn (cl->length->value.integer) < 0)
15506 0 : gfc_replace_expr (cl->length,
15507 : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
15508 :
15509 : /* Check that the character length is not too large. */
15510 95802 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
15511 95802 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15512 57507 : && cl->length->ts.type == BT_INTEGER
15513 57507 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
15514 : {
15515 4 : gfc_error ("String length at %L is too large", &cl->length->where);
15516 4 : specification_expr = saved_specification_expr;
15517 4 : return false;
15518 : }
15519 :
15520 95798 : specification_expr = saved_specification_expr;
15521 95798 : return true;
15522 : }
15523 :
15524 :
15525 : /* Test for non-constant shape arrays. */
15526 :
15527 : static bool
15528 119936 : is_non_constant_shape_array (gfc_symbol *sym)
15529 : {
15530 119936 : gfc_expr *e;
15531 119936 : int i;
15532 119936 : bool not_constant;
15533 :
15534 119936 : not_constant = false;
15535 119936 : if (sym->as != NULL)
15536 : {
15537 : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
15538 : has not been simplified; parameter array references. Do the
15539 : simplification now. */
15540 157633 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
15541 : {
15542 90924 : if (i == GFC_MAX_DIMENSIONS)
15543 : break;
15544 :
15545 90922 : e = sym->as->lower[i];
15546 90922 : if (e && (!resolve_index_expr(e)
15547 88017 : || !gfc_is_constant_expr (e)))
15548 : not_constant = true;
15549 90922 : e = sym->as->upper[i];
15550 90922 : if (e && (!resolve_index_expr(e)
15551 86757 : || !gfc_is_constant_expr (e)))
15552 : not_constant = true;
15553 : }
15554 : }
15555 119936 : return not_constant;
15556 : }
15557 :
15558 : /* Given a symbol and an initialization expression, add code to initialize
15559 : the symbol to the function entry. */
15560 : static void
15561 2210 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
15562 : {
15563 2210 : gfc_expr *lval;
15564 2210 : gfc_code *init_st;
15565 2210 : gfc_namespace *ns = sym->ns;
15566 :
15567 2210 : if (sym->attr.function && sym->result == sym && IS_PDT (sym))
15568 : {
15569 46 : gfc_free_expr (init);
15570 46 : return;
15571 : }
15572 :
15573 : /* Search for the function namespace if this is a contained
15574 : function without an explicit result. */
15575 2164 : if (sym->attr.function && sym == sym->result
15576 299 : && sym->name != sym->ns->proc_name->name)
15577 : {
15578 298 : ns = ns->contained;
15579 1376 : for (;ns; ns = ns->sibling)
15580 1315 : if (strcmp (ns->proc_name->name, sym->name) == 0)
15581 : break;
15582 : }
15583 :
15584 2164 : if (ns == NULL)
15585 : {
15586 61 : gfc_free_expr (init);
15587 61 : return;
15588 : }
15589 :
15590 : /* Build an l-value expression for the result. */
15591 2103 : lval = gfc_lval_expr_from_sym (sym);
15592 :
15593 : /* Add the code at scope entry. */
15594 2103 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
15595 2103 : init_st->next = ns->code;
15596 2103 : ns->code = init_st;
15597 :
15598 : /* Assign the default initializer to the l-value. */
15599 2103 : init_st->loc = sym->declared_at;
15600 2103 : init_st->expr1 = lval;
15601 2103 : init_st->expr2 = init;
15602 : }
15603 :
15604 :
15605 : /* Whether or not we can generate a default initializer for a symbol. */
15606 :
15607 : static bool
15608 31321 : can_generate_init (gfc_symbol *sym)
15609 : {
15610 31321 : symbol_attribute *a;
15611 31321 : if (!sym)
15612 : return false;
15613 31321 : a = &sym->attr;
15614 :
15615 : /* These symbols should never have a default initialization. */
15616 51638 : return !(
15617 31321 : a->allocatable
15618 31321 : || a->external
15619 30142 : || a->pointer
15620 30142 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
15621 6019 : && (CLASS_DATA (sym)->attr.class_pointer
15622 3983 : || CLASS_DATA (sym)->attr.proc_pointer))
15623 28106 : || a->in_equivalence
15624 27985 : || a->in_common
15625 27938 : || a->data
15626 27760 : || sym->module
15627 23853 : || a->cray_pointee
15628 23791 : || a->cray_pointer
15629 23791 : || sym->assoc
15630 20998 : || (!a->referenced && !a->result)
15631 20317 : || (a->dummy && (a->intent != INTENT_OUT
15632 1129 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
15633 20317 : || (a->function && sym != sym->result)
15634 : );
15635 : }
15636 :
15637 :
15638 : /* Assign the default initializer to a derived type variable or result. */
15639 :
15640 : static void
15641 11959 : apply_default_init (gfc_symbol *sym)
15642 : {
15643 11959 : gfc_expr *init = NULL;
15644 :
15645 11959 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15646 : return;
15647 :
15648 11666 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
15649 10753 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15650 :
15651 11666 : if (init == NULL && sym->ts.type != BT_CLASS)
15652 : return;
15653 :
15654 1828 : build_init_assign (sym, init);
15655 1828 : sym->attr.referenced = 1;
15656 : }
15657 :
15658 :
15659 : /* Build an initializer for a local. Returns null if the symbol should not have
15660 : a default initialization. */
15661 :
15662 : static gfc_expr *
15663 209692 : build_default_init_expr (gfc_symbol *sym)
15664 : {
15665 : /* These symbols should never have a default initialization. */
15666 209692 : if (sym->attr.allocatable
15667 195716 : || sym->attr.external
15668 195716 : || sym->attr.dummy
15669 128292 : || sym->attr.pointer
15670 119964 : || sym->attr.in_equivalence
15671 117588 : || sym->attr.in_common
15672 114486 : || sym->attr.data
15673 112188 : || sym->module
15674 109490 : || sym->attr.cray_pointee
15675 109189 : || sym->attr.cray_pointer
15676 108887 : || sym->assoc)
15677 : return NULL;
15678 :
15679 : /* Get the appropriate init expression. */
15680 103859 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
15681 : }
15682 :
15683 : /* Add an initialization expression to a local variable. */
15684 : static void
15685 209692 : apply_default_init_local (gfc_symbol *sym)
15686 : {
15687 209692 : gfc_expr *init = NULL;
15688 :
15689 : /* The symbol should be a variable or a function return value. */
15690 209692 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15691 209692 : || (sym->attr.function && sym->result != sym))
15692 : return;
15693 :
15694 : /* Try to build the initializer expression. If we can't initialize
15695 : this symbol, then init will be NULL. */
15696 209692 : init = build_default_init_expr (sym);
15697 209692 : if (init == NULL)
15698 : return;
15699 :
15700 : /* For saved variables, we don't want to add an initializer at function
15701 : entry, so we just add a static initializer. Note that automatic variables
15702 : are stack allocated even with -fno-automatic; we have also to exclude
15703 : result variable, which are also nonstatic. */
15704 419 : if (!sym->attr.automatic
15705 419 : && (sym->attr.save || sym->ns->save_all
15706 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15707 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15708 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15709 : {
15710 : /* Don't clobber an existing initializer! */
15711 37 : gcc_assert (sym->value == NULL);
15712 37 : sym->value = init;
15713 37 : return;
15714 : }
15715 :
15716 382 : build_init_assign (sym, init);
15717 : }
15718 :
15719 :
15720 : /* Resolution of common features of flavors variable and procedure. */
15721 :
15722 : static bool
15723 1013131 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15724 : {
15725 1013131 : gfc_array_spec *as;
15726 :
15727 1013131 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15728 20154 : && sym->ts.u.derived && CLASS_DATA (sym))
15729 20149 : as = CLASS_DATA (sym)->as;
15730 : else
15731 992982 : as = sym->as;
15732 :
15733 : /* Constraints on deferred shape variable. */
15734 1013131 : if (as == NULL || as->type != AS_DEFERRED)
15735 : {
15736 988180 : bool pointer, allocatable, dimension;
15737 :
15738 988180 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15739 16804 : && sym->ts.u.derived && CLASS_DATA (sym))
15740 : {
15741 16799 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15742 16799 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15743 16799 : dimension = CLASS_DATA (sym)->attr.dimension;
15744 : }
15745 : else
15746 : {
15747 971381 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15748 971381 : allocatable = sym->attr.allocatable;
15749 971381 : dimension = sym->attr.dimension;
15750 : }
15751 :
15752 988180 : if (allocatable)
15753 : {
15754 8295 : if (dimension
15755 8295 : && as
15756 524 : && as->type != AS_ASSUMED_RANK
15757 5 : && !sym->attr.select_rank_temporary)
15758 : {
15759 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15760 : "shape or assumed rank", sym->name, &sym->declared_at);
15761 3 : return false;
15762 : }
15763 8292 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15764 : "%qs at %L may not be ALLOCATABLE",
15765 : sym->name, &sym->declared_at))
15766 : return false;
15767 : }
15768 :
15769 988176 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15770 : {
15771 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15772 : "assumed rank", sym->name, &sym->declared_at);
15773 4 : sym->error = 1;
15774 4 : return false;
15775 : }
15776 : }
15777 : else
15778 : {
15779 24951 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15780 4885 : && sym->ts.type != BT_CLASS && !sym->assoc)
15781 : {
15782 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15783 : sym->name, &sym->declared_at);
15784 3 : return false;
15785 : }
15786 : }
15787 :
15788 : /* Constraints on polymorphic variables. */
15789 1013120 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15790 : {
15791 : /* F03:C502. */
15792 19462 : if (sym->attr.class_ok
15793 19406 : && sym->ts.u.derived
15794 19401 : && !sym->attr.select_type_temporary
15795 18249 : && !UNLIMITED_POLY (sym)
15796 15571 : && CLASS_DATA (sym)
15797 15571 : && CLASS_DATA (sym)->ts.u.derived
15798 35032 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15799 : {
15800 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15801 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15802 : &sym->declared_at);
15803 5 : return false;
15804 : }
15805 :
15806 : /* F03:C509. */
15807 : /* Assume that use associated symbols were checked in the module ns.
15808 : Class-variables that are associate-names are also something special
15809 : and excepted from the test. */
15810 19457 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15811 54 : && !sym->attr.select_type_temporary
15812 54 : && !sym->attr.select_rank_temporary)
15813 : {
15814 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15815 : "or pointer", sym->name, &sym->declared_at);
15816 54 : return false;
15817 : }
15818 : }
15819 :
15820 : return true;
15821 : }
15822 :
15823 :
15824 : /* Additional checks for symbols with flavor variable and derived
15825 : type. To be called from resolve_fl_variable. */
15826 :
15827 : static bool
15828 84891 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15829 : {
15830 84891 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15831 :
15832 : /* Check to see if a derived type is blocked from being host
15833 : associated by the presence of another class I symbol in the same
15834 : namespace. 14.6.1.3 of the standard and the discussion on
15835 : comp.lang.fortran. */
15836 84891 : if (sym->ts.u.derived
15837 84886 : && sym->ns != sym->ts.u.derived->ns
15838 48533 : && !sym->ts.u.derived->attr.use_assoc
15839 18127 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15840 : {
15841 17138 : gfc_symbol *s;
15842 17138 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15843 17138 : if (s && s->attr.generic)
15844 2 : s = gfc_find_dt_in_generic (s);
15845 17138 : if (s && !gfc_fl_struct (s->attr.flavor))
15846 : {
15847 2 : gfc_error ("The type %qs cannot be host associated at %L "
15848 : "because it is blocked by an incompatible object "
15849 : "of the same name declared at %L",
15850 2 : sym->ts.u.derived->name, &sym->declared_at,
15851 : &s->declared_at);
15852 2 : return false;
15853 : }
15854 : }
15855 :
15856 : /* 4th constraint in section 11.3: "If an object of a type for which
15857 : component-initialization is specified (R429) appears in the
15858 : specification-part of a module and does not have the ALLOCATABLE
15859 : or POINTER attribute, the object shall have the SAVE attribute."
15860 :
15861 : The check for initializers is performed with
15862 : gfc_has_default_initializer because gfc_default_initializer generates
15863 : a hidden default for allocatable components. */
15864 84206 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15865 19301 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15866 435 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15867 21 : && !sym->attr.pointer && !sym->attr.allocatable
15868 21 : && gfc_has_default_initializer (sym->ts.u.derived)
15869 84898 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15870 : "%qs at %L, needed due to the default "
15871 : "initialization", sym->name, &sym->declared_at))
15872 : return false;
15873 :
15874 : /* Assign default initializer. */
15875 84887 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15876 78473 : && (!no_init_flag
15877 61052 : || (sym->attr.intent == INTENT_OUT
15878 3321 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15879 20568 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15880 :
15881 : return true;
15882 : }
15883 :
15884 :
15885 : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15886 : except in the declaration of an entity or component that has the POINTER
15887 : or ALLOCATABLE attribute. */
15888 :
15889 : static bool
15890 1593388 : deferred_requirements (gfc_symbol *sym)
15891 : {
15892 1593388 : if (sym->ts.deferred
15893 8164 : && !(sym->attr.pointer
15894 2496 : || sym->attr.allocatable
15895 127 : || sym->attr.associate_var
15896 7 : || sym->attr.omp_udr_artificial_var))
15897 : {
15898 : /* If a function has a result variable, only check the variable. */
15899 7 : if (sym->result && sym->name != sym->result->name)
15900 : return true;
15901 :
15902 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15903 : "requires either the POINTER or ALLOCATABLE attribute",
15904 : sym->name, &sym->declared_at);
15905 6 : return false;
15906 : }
15907 : return true;
15908 : }
15909 :
15910 :
15911 : /* Resolve symbols with flavor variable. */
15912 :
15913 : static bool
15914 679504 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15915 : {
15916 679504 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15917 : "SAVE attribute");
15918 :
15919 679504 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15920 : return false;
15921 :
15922 : /* Set this flag to check that variables are parameters of all entries.
15923 : This check is effected by the call to gfc_resolve_expr through
15924 : is_non_constant_shape_array. */
15925 679444 : bool saved_specification_expr = specification_expr;
15926 679444 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
15927 679444 : specification_expr = true;
15928 679444 : specification_expr_symbol = sym;
15929 :
15930 679444 : if (sym->ns->proc_name
15931 679349 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15932 674098 : || sym->ns->proc_name->attr.is_main_program)
15933 84565 : && !sym->attr.use_assoc
15934 81191 : && !sym->attr.allocatable
15935 75288 : && !sym->attr.pointer
15936 751001 : && is_non_constant_shape_array (sym))
15937 : {
15938 : /* F08:C541. The shape of an array defined in a main program or module
15939 : * needs to be constant. */
15940 3 : gfc_error ("The module or main program array %qs at %L must "
15941 : "have constant shape", sym->name, &sym->declared_at);
15942 3 : specification_expr = saved_specification_expr;
15943 3 : specification_expr_symbol = saved_specification_expr_symbol;
15944 3 : return false;
15945 : }
15946 :
15947 : /* Constraints on deferred type parameter. */
15948 679441 : if (!deferred_requirements (sym))
15949 : return false;
15950 :
15951 679437 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15952 : {
15953 : /* Make sure that character string variables with assumed length are
15954 : dummy arguments. */
15955 36666 : gfc_expr *e = NULL;
15956 :
15957 36666 : if (sym->ts.u.cl)
15958 36666 : e = sym->ts.u.cl->length;
15959 : else
15960 : return false;
15961 :
15962 36666 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15963 2676 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15964 2 : && !sym->attr.omp_udr_artificial_var)
15965 : {
15966 2 : gfc_error ("Entity with assumed character length at %L must be a "
15967 : "dummy argument or a PARAMETER", &sym->declared_at);
15968 2 : specification_expr = saved_specification_expr;
15969 2 : specification_expr_symbol = saved_specification_expr_symbol;
15970 2 : return false;
15971 : }
15972 :
15973 21234 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15974 : {
15975 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15976 1 : specification_expr = saved_specification_expr;
15977 1 : specification_expr_symbol = saved_specification_expr_symbol;
15978 1 : return false;
15979 : }
15980 :
15981 36663 : if (!gfc_is_constant_expr (e)
15982 36663 : && !(e->expr_type == EXPR_VARIABLE
15983 1436 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
15984 : {
15985 2250 : if (!sym->attr.use_assoc && sym->ns->proc_name
15986 1734 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15987 1733 : || sym->ns->proc_name->attr.is_main_program))
15988 : {
15989 3 : gfc_error ("%qs at %L must have constant character length "
15990 : "in this context", sym->name, &sym->declared_at);
15991 3 : specification_expr = saved_specification_expr;
15992 3 : specification_expr_symbol = saved_specification_expr_symbol;
15993 3 : return false;
15994 : }
15995 2247 : if (sym->attr.in_common)
15996 : {
15997 1 : gfc_error ("COMMON variable %qs at %L must have constant "
15998 : "character length", sym->name, &sym->declared_at);
15999 1 : specification_expr = saved_specification_expr;
16000 1 : specification_expr_symbol = saved_specification_expr_symbol;
16001 1 : return false;
16002 : }
16003 : }
16004 : }
16005 :
16006 679430 : if (sym->value == NULL && sym->attr.referenced
16007 211639 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
16008 209692 : apply_default_init_local (sym); /* Try to apply a default initialization. */
16009 :
16010 : /* Determine if the symbol may not have an initializer. */
16011 679430 : int no_init_flag = 0, automatic_flag = 0;
16012 679430 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
16013 174256 : || sym->attr.intrinsic || sym->attr.result)
16014 : no_init_flag = 1;
16015 141623 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
16016 176853 : && is_non_constant_shape_array (sym))
16017 : {
16018 1355 : no_init_flag = automatic_flag = 1;
16019 :
16020 : /* Also, they must not have the SAVE attribute.
16021 : SAVE_IMPLICIT is checked below. */
16022 1355 : if (sym->as && sym->attr.codimension)
16023 : {
16024 7 : int corank = sym->as->corank;
16025 7 : sym->as->corank = 0;
16026 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
16027 7 : sym->as->corank = corank;
16028 : }
16029 1355 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
16030 : {
16031 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
16032 2 : specification_expr = saved_specification_expr;
16033 2 : specification_expr_symbol = saved_specification_expr_symbol;
16034 2 : return false;
16035 : }
16036 : }
16037 :
16038 : /* Ensure that any initializer is simplified. */
16039 679428 : if (sym->value)
16040 8396 : gfc_simplify_expr (sym->value, 1);
16041 :
16042 : /* Reject illegal initializers. */
16043 679428 : if (!sym->mark && sym->value)
16044 : {
16045 8396 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
16046 67 : && CLASS_DATA (sym)->attr.allocatable))
16047 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
16048 : sym->name, &sym->declared_at);
16049 8395 : else if (sym->attr.external)
16050 0 : gfc_error ("External %qs at %L cannot have an initializer",
16051 : sym->name, &sym->declared_at);
16052 8395 : else if (sym->attr.dummy)
16053 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
16054 : sym->name, &sym->declared_at);
16055 8392 : else if (sym->attr.intrinsic)
16056 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
16057 : sym->name, &sym->declared_at);
16058 8392 : else if (sym->attr.result)
16059 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
16060 : sym->name, &sym->declared_at);
16061 8391 : else if (automatic_flag)
16062 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
16063 : sym->name, &sym->declared_at);
16064 : else
16065 8386 : goto no_init_error;
16066 10 : specification_expr = saved_specification_expr;
16067 10 : specification_expr_symbol = saved_specification_expr_symbol;
16068 10 : return false;
16069 : }
16070 :
16071 671032 : no_init_error:
16072 679418 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
16073 : {
16074 84891 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
16075 84891 : specification_expr = saved_specification_expr;
16076 84891 : specification_expr_symbol = saved_specification_expr_symbol;
16077 84891 : return res;
16078 : }
16079 :
16080 594527 : specification_expr = saved_specification_expr;
16081 594527 : specification_expr_symbol = saved_specification_expr_symbol;
16082 594527 : return true;
16083 : }
16084 :
16085 :
16086 : /* Compare the dummy characteristics of a module procedure interface
16087 : declaration with the corresponding declaration in a submodule. */
16088 : static gfc_formal_arglist *new_formal;
16089 : static char errmsg[200];
16090 :
16091 : static void
16092 1352 : compare_fsyms (gfc_symbol *sym)
16093 : {
16094 1352 : gfc_symbol *fsym;
16095 :
16096 1352 : if (sym == NULL || new_formal == NULL)
16097 : return;
16098 :
16099 1352 : fsym = new_formal->sym;
16100 :
16101 1352 : if (sym == fsym)
16102 : return;
16103 :
16104 1328 : if (strcmp (sym->name, fsym->name) == 0)
16105 : {
16106 523 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
16107 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
16108 : }
16109 : }
16110 :
16111 :
16112 : /* Resolve a procedure. */
16113 :
16114 : static bool
16115 502102 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
16116 : {
16117 502102 : gfc_formal_arglist *arg;
16118 502102 : bool allocatable_or_pointer = false;
16119 :
16120 502102 : if (sym->attr.function
16121 502102 : && !resolve_fl_var_and_proc (sym, mp_flag))
16122 : return false;
16123 :
16124 : /* Constraints on deferred type parameter. */
16125 502092 : if (!deferred_requirements (sym))
16126 : return false;
16127 :
16128 502091 : if (sym->ts.type == BT_CHARACTER)
16129 : {
16130 11985 : gfc_charlen *cl = sym->ts.u.cl;
16131 :
16132 7734 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
16133 13292 : && !resolve_charlen (cl))
16134 : return false;
16135 :
16136 11984 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
16137 10678 : && sym->attr.proc == PROC_ST_FUNCTION)
16138 : {
16139 0 : gfc_error ("Character-valued statement function %qs at %L must "
16140 : "have constant length", sym->name, &sym->declared_at);
16141 0 : return false;
16142 : }
16143 : }
16144 :
16145 : /* Ensure that derived type for are not of a private type. Internal
16146 : module procedures are excluded by 2.2.3.3 - i.e., they are not
16147 : externally accessible and can access all the objects accessible in
16148 : the host. */
16149 115909 : if (!(sym->ns->parent && sym->ns->parent->proc_name
16150 115909 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
16151 591423 : && gfc_check_symbol_access (sym))
16152 : {
16153 468221 : gfc_interface *iface;
16154 :
16155 997003 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
16156 : {
16157 528783 : if (arg->sym
16158 528643 : && arg->sym->ts.type == BT_DERIVED
16159 43741 : && arg->sym->ts.u.derived
16160 43741 : && !arg->sym->ts.u.derived->attr.use_assoc
16161 4351 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16162 528792 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
16163 : "and cannot be a dummy argument"
16164 : " of %qs, which is PUBLIC at %L",
16165 9 : arg->sym->name, sym->name,
16166 : &sym->declared_at))
16167 : {
16168 : /* Stop this message from recurring. */
16169 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16170 1 : return false;
16171 : }
16172 : }
16173 :
16174 : /* PUBLIC interfaces may expose PRIVATE procedures that take types
16175 : PRIVATE to the containing module. */
16176 665401 : for (iface = sym->generic; iface; iface = iface->next)
16177 : {
16178 463699 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
16179 : {
16180 266518 : if (arg->sym
16181 266486 : && arg->sym->ts.type == BT_DERIVED
16182 8033 : && !arg->sym->ts.u.derived->attr.use_assoc
16183 232 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16184 266522 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
16185 : "PUBLIC interface %qs at %L "
16186 : "takes dummy arguments of %qs which "
16187 : "is PRIVATE", iface->sym->name,
16188 4 : sym->name, &iface->sym->declared_at,
16189 4 : gfc_typename(&arg->sym->ts)))
16190 : {
16191 : /* Stop this message from recurring. */
16192 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16193 1 : return false;
16194 : }
16195 : }
16196 : }
16197 : }
16198 :
16199 502088 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
16200 86 : && !sym->attr.proc_pointer)
16201 : {
16202 2 : gfc_error ("Function %qs at %L cannot have an initializer",
16203 : sym->name, &sym->declared_at);
16204 :
16205 : /* Make sure no second error is issued for this. */
16206 2 : sym->value->error = 1;
16207 2 : return false;
16208 : }
16209 :
16210 : /* An external symbol may not have an initializer because it is taken to be
16211 : a procedure. Exception: Procedure Pointers. */
16212 502086 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
16213 : {
16214 0 : gfc_error ("External object %qs at %L may not have an initializer",
16215 : sym->name, &sym->declared_at);
16216 0 : return false;
16217 : }
16218 :
16219 : /* An elemental function is required to return a scalar 12.7.1 */
16220 502086 : if (sym->attr.elemental && sym->attr.function
16221 86584 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16222 2 : && CLASS_DATA (sym)->as)))
16223 : {
16224 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
16225 : "result", sym->name, &sym->declared_at);
16226 : /* Reset so that the error only occurs once. */
16227 3 : sym->attr.elemental = 0;
16228 3 : return false;
16229 : }
16230 :
16231 502083 : if (sym->attr.proc == PROC_ST_FUNCTION
16232 223 : && (sym->attr.allocatable || sym->attr.pointer))
16233 : {
16234 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
16235 : "allocatable attribute", sym->name, &sym->declared_at);
16236 2 : return false;
16237 : }
16238 :
16239 : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
16240 : char-len-param shall not be array-valued, pointer-valued, recursive
16241 : or pure. ....snip... A character value of * may only be used in the
16242 : following ways: (i) Dummy arg of procedure - dummy associates with
16243 : actual length; (ii) To declare a named constant; or (iii) External
16244 : function - but length must be declared in calling scoping unit. */
16245 502081 : if (sym->attr.function
16246 333608 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
16247 6856 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
16248 : {
16249 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
16250 178 : || (sym->attr.recursive) || (sym->attr.pure))
16251 : {
16252 4 : if (sym->as && sym->as->rank)
16253 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16254 : "array-valued", sym->name, &sym->declared_at);
16255 :
16256 4 : if (sym->attr.pointer)
16257 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16258 : "pointer-valued", sym->name, &sym->declared_at);
16259 :
16260 4 : if (sym->attr.pure)
16261 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16262 : "pure", sym->name, &sym->declared_at);
16263 :
16264 4 : if (sym->attr.recursive)
16265 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16266 : "recursive", sym->name, &sym->declared_at);
16267 :
16268 : return false;
16269 : }
16270 :
16271 : /* Appendix B.2 of the standard. Contained functions give an
16272 : error anyway. Deferred character length is an F2003 feature.
16273 : Don't warn on intrinsic conversion functions, which start
16274 : with two underscores. */
16275 176 : if (!sym->attr.contained && !sym->ts.deferred
16276 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
16277 172 : gfc_notify_std (GFC_STD_F95_OBS,
16278 : "CHARACTER(*) function %qs at %L",
16279 : sym->name, &sym->declared_at);
16280 : }
16281 :
16282 : /* F2008, C1218. */
16283 502077 : if (sym->attr.elemental)
16284 : {
16285 89886 : if (sym->attr.proc_pointer)
16286 : {
16287 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
16288 : : sym->name);
16289 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
16290 : name, &sym->declared_at);
16291 7 : return false;
16292 : }
16293 89879 : if (sym->attr.dummy)
16294 : {
16295 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
16296 : sym->name, &sym->declared_at);
16297 3 : return false;
16298 : }
16299 : }
16300 :
16301 : /* F2018, C15100: "The result of an elemental function shall be scalar,
16302 : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
16303 : pointer is tested and caught elsewhere. */
16304 502067 : if (sym->result)
16305 280546 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
16306 280546 : && CLASS_DATA (sym->result) ?
16307 1696 : (CLASS_DATA (sym->result)->attr.allocatable
16308 1696 : || CLASS_DATA (sym->result)->attr.pointer) :
16309 278850 : (sym->result->attr.allocatable
16310 278850 : || sym->result->attr.pointer);
16311 :
16312 502067 : if (sym->attr.elemental && sym->result
16313 86189 : && allocatable_or_pointer)
16314 : {
16315 4 : gfc_error ("Function result variable %qs at %L of elemental "
16316 : "function %qs shall not have an ALLOCATABLE or POINTER "
16317 : "attribute", sym->result->name,
16318 : &sym->result->declared_at, sym->name);
16319 4 : return false;
16320 : }
16321 :
16322 : /* F2018:C1585: "The function result of a pure function shall not be both
16323 : polymorphic and allocatable, or have a polymorphic allocatable ultimate
16324 : component." */
16325 502063 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
16326 : {
16327 2544 : if (sym->ts.type == BT_CLASS
16328 5 : && sym->attr.class_ok
16329 4 : && CLASS_DATA (sym->result)
16330 4 : && CLASS_DATA (sym->result)->attr.allocatable)
16331 : {
16332 4 : gfc_error ("Result variable %qs of pure function at %L is "
16333 : "polymorphic allocatable",
16334 : sym->result->name, &sym->result->declared_at);
16335 4 : return false;
16336 : }
16337 :
16338 2540 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
16339 : {
16340 : gfc_component *c = sym->ts.u.derived->components;
16341 4805 : for (; c; c = c->next)
16342 2574 : if (c->ts.type == BT_CLASS
16343 2 : && CLASS_DATA (c)
16344 2 : && CLASS_DATA (c)->attr.allocatable)
16345 : {
16346 2 : gfc_error ("Result variable %qs of pure function at %L has "
16347 : "polymorphic allocatable component %qs",
16348 : sym->result->name, &sym->result->declared_at,
16349 : c->name);
16350 2 : return false;
16351 : }
16352 : }
16353 : }
16354 :
16355 502057 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
16356 : {
16357 7238 : gfc_formal_arglist *curr_arg;
16358 7238 : int has_non_interop_arg = 0;
16359 :
16360 7238 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
16361 7238 : sym->common_block))
16362 : {
16363 : /* Clear these to prevent looking at them again if there was an
16364 : error. */
16365 2 : sym->attr.is_bind_c = 0;
16366 2 : sym->attr.is_c_interop = 0;
16367 2 : sym->ts.is_c_interop = 0;
16368 : }
16369 : else
16370 : {
16371 : /* So far, no errors have been found. */
16372 : sym->attr.is_c_interop = 1;
16373 : sym->ts.is_c_interop = 1;
16374 : }
16375 :
16376 7238 : curr_arg = gfc_sym_get_dummy_args (sym);
16377 31851 : while (curr_arg != NULL)
16378 : {
16379 : /* Skip implicitly typed dummy args here. */
16380 17375 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
16381 17318 : if (!gfc_verify_c_interop_param (curr_arg->sym))
16382 : /* If something is found to fail, record the fact so we
16383 : can mark the symbol for the procedure as not being
16384 : BIND(C) to try and prevent multiple errors being
16385 : reported. */
16386 17375 : has_non_interop_arg = 1;
16387 :
16388 17375 : curr_arg = curr_arg->next;
16389 : }
16390 :
16391 : /* See if any of the arguments were not interoperable and if so, clear
16392 : the procedure symbol to prevent duplicate error messages. */
16393 7238 : if (has_non_interop_arg != 0)
16394 : {
16395 128 : sym->attr.is_c_interop = 0;
16396 128 : sym->ts.is_c_interop = 0;
16397 128 : sym->attr.is_bind_c = 0;
16398 : }
16399 : }
16400 :
16401 502057 : if (!sym->attr.proc_pointer)
16402 : {
16403 500950 : if (sym->attr.save == SAVE_EXPLICIT)
16404 : {
16405 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
16406 : "in %qs at %L", sym->name, &sym->declared_at);
16407 5 : return false;
16408 : }
16409 500945 : if (sym->attr.intent)
16410 : {
16411 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
16412 : "in %qs at %L", sym->name, &sym->declared_at);
16413 1 : return false;
16414 : }
16415 500944 : if (sym->attr.subroutine && sym->attr.result)
16416 : {
16417 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
16418 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
16419 2 : return false;
16420 : }
16421 500942 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
16422 145010 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
16423 145007 : || sym->attr.contained))
16424 : {
16425 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
16426 : "in %qs at %L", sym->name, &sym->declared_at);
16427 3 : return false;
16428 : }
16429 500939 : if (strcmp ("ppr@", sym->name) == 0)
16430 : {
16431 0 : gfc_error ("Procedure pointer result %qs at %L "
16432 : "is missing the pointer attribute",
16433 0 : sym->ns->proc_name->name, &sym->declared_at);
16434 0 : return false;
16435 : }
16436 : }
16437 :
16438 : /* Assume that a procedure whose body is not known has references
16439 : to external arrays. */
16440 502046 : if (sym->attr.if_source != IFSRC_DECL)
16441 345716 : sym->attr.array_outer_dependency = 1;
16442 :
16443 : /* Compare the characteristics of a module procedure with the
16444 : interface declaration. Ideally this would be done with
16445 : gfc_compare_interfaces but, at present, the formal interface
16446 : cannot be copied to the ts.interface. */
16447 502046 : if (sym->attr.module_procedure
16448 1615 : && sym->attr.if_source == IFSRC_DECL)
16449 : {
16450 659 : gfc_symbol *iface;
16451 659 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
16452 659 : char *module_name;
16453 659 : char *submodule_name;
16454 659 : strcpy (name, sym->ns->proc_name->name);
16455 659 : module_name = strtok (name, ".");
16456 659 : submodule_name = strtok (NULL, ".");
16457 :
16458 659 : iface = sym->tlink;
16459 659 : sym->tlink = NULL;
16460 :
16461 : /* Make sure that the result uses the correct charlen for deferred
16462 : length results. */
16463 659 : if (iface && sym->result
16464 192 : && iface->ts.type == BT_CHARACTER
16465 19 : && iface->ts.deferred)
16466 6 : sym->result->ts.u.cl = iface->ts.u.cl;
16467 :
16468 6 : if (iface == NULL)
16469 196 : goto check_formal;
16470 :
16471 : /* Check the procedure characteristics. */
16472 463 : if (sym->attr.elemental != iface->attr.elemental)
16473 : {
16474 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
16475 : "PROCEDURE at %L and its interface in %s",
16476 : &sym->declared_at, module_name);
16477 10 : return false;
16478 : }
16479 :
16480 462 : if (sym->attr.pure != iface->attr.pure)
16481 : {
16482 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
16483 : "PROCEDURE at %L and its interface in %s",
16484 : &sym->declared_at, module_name);
16485 2 : return false;
16486 : }
16487 :
16488 460 : if (sym->attr.recursive != iface->attr.recursive)
16489 : {
16490 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
16491 : "PROCEDURE at %L and its interface in %s",
16492 : &sym->declared_at, module_name);
16493 2 : return false;
16494 : }
16495 :
16496 : /* Check the result characteristics. */
16497 458 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
16498 : {
16499 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
16500 : "in MODULE %qs and the declaration at %L in "
16501 : "(SUB)MODULE %qs",
16502 : errmsg, module_name, &sym->declared_at,
16503 : submodule_name ? submodule_name : module_name);
16504 5 : return false;
16505 : }
16506 :
16507 453 : check_formal:
16508 : /* Check the characteristics of the formal arguments. */
16509 649 : if (sym->formal && sym->formal_ns)
16510 : {
16511 1260 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
16512 : {
16513 722 : new_formal = arg;
16514 722 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
16515 : }
16516 : }
16517 : }
16518 :
16519 : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
16520 : BIND(C) attribute. */
16521 502036 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
16522 : {
16523 1 : gfc_error ("Interface of %qs at %L must be explicit",
16524 : sym->name, &sym->declared_at);
16525 1 : return false;
16526 : }
16527 :
16528 : return true;
16529 : }
16530 :
16531 :
16532 : /* Resolve a list of finalizer procedures. That is, after they have hopefully
16533 : been defined and we now know their defined arguments, check that they fulfill
16534 : the requirements of the standard for procedures used as finalizers. */
16535 :
16536 : static bool
16537 117320 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
16538 : {
16539 117320 : gfc_finalizer *list, *pdt_finalizers = NULL;
16540 117320 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
16541 117320 : bool result = true;
16542 117320 : bool seen_scalar = false;
16543 117320 : gfc_symbol *vtab;
16544 117320 : gfc_component *c;
16545 117320 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
16546 :
16547 117320 : if (parent)
16548 16526 : gfc_resolve_finalizers (parent, finalizable);
16549 :
16550 : /* Ensure that derived-type components have a their finalizers resolved. */
16551 117320 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
16552 370691 : for (c = derived->components; c; c = c->next)
16553 253371 : if (c->ts.type == BT_DERIVED
16554 70787 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
16555 : {
16556 9108 : bool has_final2 = false;
16557 9108 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
16558 0 : return false; /* Error. */
16559 9108 : has_final = has_final || has_final2;
16560 : }
16561 : /* Return early if not finalizable. */
16562 117320 : if (!has_final)
16563 : {
16564 114575 : if (finalizable)
16565 9124 : *finalizable = false;
16566 : return true;
16567 : }
16568 :
16569 : /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of
16570 : the template. If the finalizers field has the same value, it needs to be
16571 : supplied with finalizers of the same pdt_type. */
16572 2745 : if (derived->attr.pdt_type
16573 54 : && derived->template_sym
16574 24 : && derived->template_sym->f2k_derived
16575 24 : && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers)
16576 2769 : && derived->f2k_derived->finalizers == pdt_finalizers)
16577 : {
16578 24 : gfc_finalizer *tmp = NULL;
16579 24 : derived->f2k_derived->finalizers = NULL;
16580 24 : prev_link = &derived->f2k_derived->finalizers;
16581 84 : for (list = pdt_finalizers; list; list = list->next)
16582 : {
16583 60 : gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym);
16584 60 : if (args->sym
16585 60 : && args->sym->ts.type == BT_DERIVED
16586 60 : && args->sym->ts.u.derived
16587 60 : && !strcmp (args->sym->ts.u.derived->name, derived->name))
16588 : {
16589 36 : tmp = gfc_get_finalizer ();
16590 36 : *tmp = *list;
16591 36 : tmp->next = NULL;
16592 36 : *prev_link = tmp;
16593 36 : prev_link = &(tmp->next);
16594 36 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16595 : }
16596 : }
16597 : }
16598 :
16599 : /* Walk over the list of finalizer-procedures, check them, and if any one
16600 : does not fit in with the standard's definition, print an error and remove
16601 : it from the list. */
16602 2745 : prev_link = &derived->f2k_derived->finalizers;
16603 5638 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
16604 : {
16605 2893 : gfc_formal_arglist *dummy_args;
16606 2893 : gfc_symbol* arg;
16607 2893 : gfc_finalizer* i;
16608 2893 : int my_rank;
16609 :
16610 : /* Skip this finalizer if we already resolved it. */
16611 2893 : if (list->proc_tree)
16612 : {
16613 2324 : if (list->proc_tree->n.sym->formal->sym->as == NULL
16614 602 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
16615 1722 : seen_scalar = true;
16616 2324 : prev_link = &(list->next);
16617 2324 : continue;
16618 : }
16619 :
16620 : /* Check this exists and is a SUBROUTINE. */
16621 569 : if (!list->proc_sym->attr.subroutine)
16622 : {
16623 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
16624 : list->proc_sym->name, &list->where);
16625 3 : goto error;
16626 : }
16627 :
16628 : /* We should have exactly one argument. */
16629 566 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
16630 566 : if (!dummy_args || dummy_args->next)
16631 : {
16632 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
16633 : &list->where);
16634 2 : goto error;
16635 : }
16636 564 : arg = dummy_args->sym;
16637 :
16638 564 : if (!arg)
16639 : {
16640 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16641 1 : &list->proc_sym->declared_at, derived->name);
16642 1 : goto error;
16643 : }
16644 :
16645 563 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
16646 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
16647 : {
16648 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
16649 : "be the only finalizer with the same kind/type "
16650 : "(F2018: C790)", &list->where);
16651 0 : goto error;
16652 : }
16653 :
16654 : /* This argument must be of our type. */
16655 563 : if (!derived->attr.pdt_template
16656 551 : && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived))
16657 : {
16658 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16659 : &arg->declared_at, derived->name);
16660 2 : goto error;
16661 : }
16662 :
16663 : /* It must neither be a pointer nor allocatable nor optional. */
16664 561 : if (arg->attr.pointer)
16665 : {
16666 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
16667 : &arg->declared_at);
16668 1 : goto error;
16669 : }
16670 560 : if (arg->attr.allocatable)
16671 : {
16672 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16673 : " ALLOCATABLE", &arg->declared_at);
16674 1 : goto error;
16675 : }
16676 559 : if (arg->attr.optional)
16677 : {
16678 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
16679 : &arg->declared_at);
16680 1 : goto error;
16681 : }
16682 :
16683 : /* It must not be INTENT(OUT). */
16684 558 : if (arg->attr.intent == INTENT_OUT)
16685 : {
16686 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16687 : " INTENT(OUT)", &arg->declared_at);
16688 1 : goto error;
16689 : }
16690 :
16691 : /* Warn if the procedure is non-scalar and not assumed shape. */
16692 557 : if (warn_surprising && arg->as && arg->as->rank != 0
16693 3 : && arg->as->type != AS_ASSUMED_SHAPE)
16694 2 : gfc_warning (OPT_Wsurprising,
16695 : "Non-scalar FINAL procedure at %L should have assumed"
16696 : " shape argument", &arg->declared_at);
16697 :
16698 : /* Check that it does not match in kind and rank with a FINAL procedure
16699 : defined earlier. To really loop over the *earlier* declarations,
16700 : we need to walk the tail of the list as new ones were pushed at the
16701 : front. */
16702 : /* TODO: Handle kind parameters once they are implemented. */
16703 557 : my_rank = (arg->as ? arg->as->rank : 0);
16704 664 : for (i = list->next; i; i = i->next)
16705 : {
16706 109 : gfc_formal_arglist *dummy_args;
16707 :
16708 : /* Argument list might be empty; that is an error signalled earlier,
16709 : but we nevertheless continued resolving. */
16710 109 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
16711 109 : if (dummy_args && !derived->attr.pdt_template)
16712 : {
16713 107 : gfc_symbol* i_arg = dummy_args->sym;
16714 107 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
16715 107 : if (i_rank == my_rank)
16716 : {
16717 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
16718 : " rank (%d) as %qs",
16719 2 : list->proc_sym->name, &list->where, my_rank,
16720 2 : i->proc_sym->name);
16721 2 : goto error;
16722 : }
16723 : }
16724 : }
16725 :
16726 : /* Is this the/a scalar finalizer procedure? */
16727 555 : if (my_rank == 0)
16728 423 : seen_scalar = true;
16729 :
16730 : /* Find the symtree for this procedure. */
16731 555 : gcc_assert (!list->proc_tree);
16732 555 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16733 :
16734 555 : prev_link = &list->next;
16735 555 : continue;
16736 :
16737 : /* Remove wrong nodes immediately from the list so we don't risk any
16738 : troubles in the future when they might fail later expectations. */
16739 14 : error:
16740 14 : i = list;
16741 14 : *prev_link = list->next;
16742 14 : gfc_free_finalizer (i);
16743 14 : result = false;
16744 555 : }
16745 :
16746 2745 : if (result == false)
16747 : return false;
16748 :
16749 : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16750 : were nodes in the list, must have been for arrays. It is surely a good
16751 : idea to have a scalar version there if there's something to finalize. */
16752 2741 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16753 1 : gfc_warning (OPT_Wsurprising,
16754 : "Only array FINAL procedures declared for derived type %qs"
16755 : " defined at %L, suggest also scalar one unless an assumed"
16756 : " rank finalizer has been declared",
16757 : derived->name, &derived->declared_at);
16758 :
16759 2741 : if (!derived->attr.pdt_template)
16760 : {
16761 2693 : vtab = gfc_find_derived_vtab (derived);
16762 2693 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16763 2693 : if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym)
16764 2693 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16765 : }
16766 :
16767 2741 : if (finalizable)
16768 676 : *finalizable = true;
16769 :
16770 : return true;
16771 : }
16772 :
16773 :
16774 : static gfc_symbol * containing_dt;
16775 :
16776 : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16777 : arguments whose declared types are PDT instances only transmit the PASS arg
16778 : if they match the enclosing derived type. */
16779 :
16780 : static bool
16781 1496 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16782 : {
16783 1496 : gfc_formal_arglist *dummy_args;
16784 1496 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16785 : {
16786 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16787 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16788 126 : dummy_args = dummy_args->next;
16789 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16790 532 : if (dummy_args->sym->ts.type == BT_CLASS
16791 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16792 : containing_dt->name))
16793 356 : return true;
16794 : }
16795 : return false;
16796 : }
16797 :
16798 :
16799 : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16800 :
16801 : static bool
16802 750 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16803 : const char* generic_name, locus where)
16804 : {
16805 750 : gfc_symbol *sym1, *sym2;
16806 750 : const char *pass1, *pass2;
16807 750 : gfc_formal_arglist *dummy_args;
16808 :
16809 750 : gcc_assert (t1->specific && t2->specific);
16810 750 : gcc_assert (!t1->specific->is_generic);
16811 750 : gcc_assert (!t2->specific->is_generic);
16812 750 : gcc_assert (t1->is_operator == t2->is_operator);
16813 :
16814 750 : sym1 = t1->specific->u.specific->n.sym;
16815 750 : sym2 = t2->specific->u.specific->n.sym;
16816 :
16817 750 : if (sym1 == sym2)
16818 : return true;
16819 :
16820 : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16821 750 : if (sym1->attr.subroutine != sym2->attr.subroutine
16822 748 : || sym1->attr.function != sym2->attr.function)
16823 : {
16824 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16825 : " GENERIC %qs at %L",
16826 : sym1->name, sym2->name, generic_name, &where);
16827 2 : return false;
16828 : }
16829 :
16830 : /* Determine PASS arguments. */
16831 748 : if (t1->specific->nopass)
16832 : pass1 = NULL;
16833 697 : else if (t1->specific->pass_arg)
16834 : pass1 = t1->specific->pass_arg;
16835 : else
16836 : {
16837 438 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16838 438 : if (dummy_args)
16839 437 : pass1 = dummy_args->sym->name;
16840 : else
16841 : pass1 = NULL;
16842 : }
16843 748 : if (t2->specific->nopass)
16844 : pass2 = NULL;
16845 696 : else if (t2->specific->pass_arg)
16846 : pass2 = t2->specific->pass_arg;
16847 : else
16848 : {
16849 559 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16850 559 : if (dummy_args)
16851 558 : pass2 = dummy_args->sym->name;
16852 : else
16853 : pass2 = NULL;
16854 : }
16855 :
16856 : /* Care must be taken with pdt types and templates because the declared type
16857 : of the argument that is not 'no_pass' need not be the same as the
16858 : containing derived type. If this is the case, subject the argument to
16859 : the full interface check, even though it cannot be used in the type
16860 : bound context. */
16861 748 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16862 748 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16863 :
16864 748 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16865 748 : pass1 = pass2 = NULL;
16866 :
16867 : /* Compare the interfaces. */
16868 748 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16869 : NULL, 0, pass1, pass2))
16870 : {
16871 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16872 : sym1->name, sym2->name, generic_name, &where);
16873 8 : return false;
16874 : }
16875 :
16876 : return true;
16877 : }
16878 :
16879 :
16880 : /* Worker function for resolving a generic procedure binding; this is used to
16881 : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16882 :
16883 : The difference between those cases is finding possible inherited bindings
16884 : that are overridden, as one has to look for them in tb_sym_root,
16885 : tb_uop_root or tb_op, respectively. Thus the caller must already find
16886 : the super-type and set p->overridden correctly. */
16887 :
16888 : static bool
16889 2421 : resolve_tb_generic_targets (gfc_symbol* super_type,
16890 : gfc_typebound_proc* p, const char* name)
16891 : {
16892 2421 : gfc_tbp_generic* target;
16893 2421 : gfc_symtree* first_target;
16894 2421 : gfc_symtree* inherited;
16895 :
16896 2421 : gcc_assert (p && p->is_generic);
16897 :
16898 : /* Try to find the specific bindings for the symtrees in our target-list. */
16899 2421 : gcc_assert (p->u.generic);
16900 5446 : for (target = p->u.generic; target; target = target->next)
16901 3042 : if (!target->specific)
16902 : {
16903 2627 : gfc_typebound_proc* overridden_tbp;
16904 2627 : gfc_tbp_generic* g;
16905 2627 : const char* target_name;
16906 :
16907 2627 : target_name = target->specific_st->name;
16908 :
16909 : /* Defined for this type directly. */
16910 2627 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16911 : {
16912 2618 : target->specific = target->specific_st->n.tb;
16913 2618 : goto specific_found;
16914 : }
16915 :
16916 : /* Look for an inherited specific binding. */
16917 9 : if (super_type)
16918 : {
16919 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16920 : true, NULL);
16921 :
16922 5 : if (inherited)
16923 : {
16924 5 : gcc_assert (inherited->n.tb);
16925 5 : target->specific = inherited->n.tb;
16926 5 : goto specific_found;
16927 : }
16928 : }
16929 :
16930 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16931 : " at %L", target_name, name, &p->where);
16932 4 : return false;
16933 :
16934 : /* Once we've found the specific binding, check it is not ambiguous with
16935 : other specifics already found or inherited for the same GENERIC. */
16936 2623 : specific_found:
16937 2623 : gcc_assert (target->specific);
16938 :
16939 : /* This must really be a specific binding! */
16940 2623 : if (target->specific->is_generic)
16941 : {
16942 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16943 : " %qs is GENERIC, too", name, &p->where, target_name);
16944 3 : return false;
16945 : }
16946 :
16947 : /* Check those already resolved on this type directly. */
16948 6690 : for (g = p->u.generic; g; g = g->next)
16949 1464 : if (g != target && g->specific
16950 4809 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16951 : return false;
16952 :
16953 : /* Check for ambiguity with inherited specific targets. */
16954 2629 : for (overridden_tbp = p->overridden; overridden_tbp;
16955 16 : overridden_tbp = overridden_tbp->overridden)
16956 19 : if (overridden_tbp->is_generic)
16957 : {
16958 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16959 : {
16960 18 : gcc_assert (g->specific);
16961 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16962 : return false;
16963 : }
16964 : }
16965 : }
16966 :
16967 : /* If we attempt to "overwrite" a specific binding, this is an error. */
16968 2404 : if (p->overridden && !p->overridden->is_generic)
16969 : {
16970 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16971 : " the same name", name, &p->where);
16972 1 : return false;
16973 : }
16974 :
16975 : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16976 : all must have the same attributes here. */
16977 2403 : first_target = p->u.generic->specific->u.specific;
16978 2403 : gcc_assert (first_target);
16979 2403 : p->subroutine = first_target->n.sym->attr.subroutine;
16980 2403 : p->function = first_target->n.sym->attr.function;
16981 :
16982 2403 : return true;
16983 : }
16984 :
16985 :
16986 : /* Resolve a GENERIC procedure binding for a derived type. */
16987 :
16988 : static bool
16989 1249 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
16990 : {
16991 1249 : gfc_symbol* super_type;
16992 :
16993 : /* Find the overridden binding if any. */
16994 1249 : st->n.tb->overridden = NULL;
16995 1249 : super_type = gfc_get_derived_super_type (derived);
16996 1249 : if (super_type)
16997 : {
16998 40 : gfc_symtree* overridden;
16999 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
17000 : true, NULL);
17001 :
17002 40 : if (overridden && overridden->n.tb)
17003 21 : st->n.tb->overridden = overridden->n.tb;
17004 : }
17005 :
17006 : /* Resolve using worker function. */
17007 1249 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
17008 : }
17009 :
17010 :
17011 : /* Retrieve the target-procedure of an operator binding and do some checks in
17012 : common for intrinsic and user-defined type-bound operators. */
17013 :
17014 : static gfc_symbol*
17015 1244 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
17016 : {
17017 1244 : gfc_symbol* target_proc;
17018 :
17019 1244 : gcc_assert (target->specific && !target->specific->is_generic);
17020 1244 : target_proc = target->specific->u.specific->n.sym;
17021 1244 : gcc_assert (target_proc);
17022 :
17023 : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
17024 1244 : if (target->specific->nopass)
17025 : {
17026 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
17027 2 : return NULL;
17028 : }
17029 :
17030 : return target_proc;
17031 : }
17032 :
17033 :
17034 : /* Resolve a type-bound intrinsic operator. */
17035 :
17036 : static bool
17037 1059 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
17038 : gfc_typebound_proc* p)
17039 : {
17040 1059 : gfc_symbol* super_type;
17041 1059 : gfc_tbp_generic* target;
17042 :
17043 : /* If there's already an error here, do nothing (but don't fail again). */
17044 1059 : if (p->error)
17045 : return true;
17046 :
17047 : /* Operators should always be GENERIC bindings. */
17048 1059 : gcc_assert (p->is_generic);
17049 :
17050 : /* Look for an overridden binding. */
17051 1059 : super_type = gfc_get_derived_super_type (derived);
17052 1059 : if (super_type && super_type->f2k_derived)
17053 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
17054 : op, true, NULL);
17055 : else
17056 1058 : p->overridden = NULL;
17057 :
17058 : /* Resolve general GENERIC properties using worker function. */
17059 1059 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
17060 1 : goto error;
17061 :
17062 : /* Check the targets to be procedures of correct interface. */
17063 2163 : for (target = p->u.generic; target; target = target->next)
17064 : {
17065 1130 : gfc_symbol* target_proc;
17066 :
17067 1130 : target_proc = get_checked_tb_operator_target (target, p->where);
17068 1130 : if (!target_proc)
17069 1 : goto error;
17070 :
17071 1129 : if (!gfc_check_operator_interface (target_proc, op, p->where))
17072 3 : goto error;
17073 :
17074 : /* Add target to non-typebound operator list. */
17075 1126 : if (!target->specific->deferred && !derived->attr.use_assoc
17076 397 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
17077 : {
17078 395 : gfc_interface *head, *intr;
17079 :
17080 : /* Preempt 'gfc_check_new_interface' for submodules, where the
17081 : mechanism for handling module procedures winds up resolving
17082 : operator interfaces twice and would otherwise cause an error.
17083 : Likewise, new instances of PDTs can cause the operator inter-
17084 : faces to be resolved multiple times. */
17085 467 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
17086 91 : if (intr->sym == target_proc
17087 21 : && (target_proc->attr.used_in_submodule
17088 4 : || derived->attr.pdt_type
17089 2 : || derived->attr.pdt_template))
17090 : return true;
17091 :
17092 376 : if (!gfc_check_new_interface (derived->ns->op[op],
17093 : target_proc, p->where))
17094 : return false;
17095 374 : head = derived->ns->op[op];
17096 374 : intr = gfc_get_interface ();
17097 374 : intr->sym = target_proc;
17098 374 : intr->where = p->where;
17099 374 : intr->next = head;
17100 374 : derived->ns->op[op] = intr;
17101 : }
17102 : }
17103 :
17104 : return true;
17105 :
17106 5 : error:
17107 5 : p->error = 1;
17108 5 : return false;
17109 : }
17110 :
17111 :
17112 : /* Resolve a type-bound user operator (tree-walker callback). */
17113 :
17114 : static gfc_symbol* resolve_bindings_derived;
17115 : static bool resolve_bindings_result;
17116 :
17117 : static bool check_uop_procedure (gfc_symbol* sym, locus where);
17118 :
17119 : static void
17120 113 : resolve_typebound_user_op (gfc_symtree* stree)
17121 : {
17122 113 : gfc_symbol* super_type;
17123 113 : gfc_tbp_generic* target;
17124 :
17125 113 : gcc_assert (stree && stree->n.tb);
17126 :
17127 113 : if (stree->n.tb->error)
17128 : return;
17129 :
17130 : /* Operators should always be GENERIC bindings. */
17131 113 : gcc_assert (stree->n.tb->is_generic);
17132 :
17133 : /* Find overridden procedure, if any. */
17134 113 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
17135 113 : if (super_type && super_type->f2k_derived)
17136 : {
17137 18 : gfc_symtree* overridden;
17138 18 : overridden = gfc_find_typebound_user_op (super_type, NULL,
17139 : stree->name, true, NULL);
17140 :
17141 18 : if (overridden && overridden->n.tb)
17142 0 : stree->n.tb->overridden = overridden->n.tb;
17143 : }
17144 : else
17145 95 : stree->n.tb->overridden = NULL;
17146 :
17147 : /* Resolve basically using worker function. */
17148 113 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
17149 0 : goto error;
17150 :
17151 : /* Check the targets to be functions of correct interface. */
17152 224 : for (target = stree->n.tb->u.generic; target; target = target->next)
17153 : {
17154 114 : gfc_symbol* target_proc;
17155 :
17156 114 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
17157 114 : if (!target_proc)
17158 1 : goto error;
17159 :
17160 113 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
17161 2 : goto error;
17162 : }
17163 :
17164 : return;
17165 :
17166 3 : error:
17167 3 : resolve_bindings_result = false;
17168 3 : stree->n.tb->error = 1;
17169 : }
17170 :
17171 :
17172 : /* Resolve the type-bound procedures for a derived type. */
17173 :
17174 : static void
17175 10231 : resolve_typebound_procedure (gfc_symtree* stree)
17176 : {
17177 10231 : gfc_symbol* proc;
17178 10231 : locus where;
17179 10231 : gfc_symbol* me_arg;
17180 10231 : gfc_symbol* super_type;
17181 10231 : gfc_component* comp;
17182 :
17183 10231 : gcc_assert (stree);
17184 :
17185 : /* Undefined specific symbol from GENERIC target definition. */
17186 10231 : if (!stree->n.tb)
17187 10149 : return;
17188 :
17189 10225 : if (stree->n.tb->error)
17190 : return;
17191 :
17192 : /* If this is a GENERIC binding, use that routine. */
17193 10209 : if (stree->n.tb->is_generic)
17194 : {
17195 1249 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
17196 17 : goto error;
17197 : return;
17198 : }
17199 :
17200 : /* Get the target-procedure to check it. */
17201 8960 : gcc_assert (!stree->n.tb->is_generic);
17202 8960 : gcc_assert (stree->n.tb->u.specific);
17203 8960 : proc = stree->n.tb->u.specific->n.sym;
17204 8960 : where = stree->n.tb->where;
17205 :
17206 : /* Default access should already be resolved from the parser. */
17207 8960 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
17208 :
17209 8960 : if (stree->n.tb->deferred)
17210 : {
17211 676 : if (!check_proc_interface (proc, &where))
17212 5 : goto error;
17213 : }
17214 : else
17215 : {
17216 : /* If proc has not been resolved at this point, proc->name may
17217 : actually be a USE associated entity. See PR fortran/89647. */
17218 8284 : if (!proc->resolve_symbol_called
17219 5734 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
17220 : {
17221 11 : gfc_symbol *tmp;
17222 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
17223 11 : if (tmp && tmp->attr.use_assoc)
17224 : {
17225 1 : proc->module = tmp->module;
17226 1 : proc->attr.proc = tmp->attr.proc;
17227 1 : proc->attr.function = tmp->attr.function;
17228 1 : proc->attr.subroutine = tmp->attr.subroutine;
17229 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
17230 1 : proc->ts = tmp->ts;
17231 1 : proc->result = tmp->result;
17232 : }
17233 : }
17234 :
17235 : /* Check for F08:C465. */
17236 8284 : if ((!proc->attr.subroutine && !proc->attr.function)
17237 8274 : || (proc->attr.proc != PROC_MODULE
17238 70 : && proc->attr.if_source != IFSRC_IFBODY
17239 7 : && !proc->attr.module_procedure)
17240 8273 : || proc->attr.abstract)
17241 : {
17242 12 : gfc_error ("%qs must be a module procedure or an external "
17243 : "procedure with an explicit interface at %L",
17244 : proc->name, &where);
17245 12 : goto error;
17246 : }
17247 : }
17248 :
17249 8943 : stree->n.tb->subroutine = proc->attr.subroutine;
17250 8943 : stree->n.tb->function = proc->attr.function;
17251 :
17252 : /* Find the super-type of the current derived type. We could do this once and
17253 : store in a global if speed is needed, but as long as not I believe this is
17254 : more readable and clearer. */
17255 8943 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
17256 :
17257 : /* If PASS, resolve and check arguments if not already resolved / loaded
17258 : from a .mod file. */
17259 8943 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
17260 : {
17261 2844 : gfc_formal_arglist *dummy_args;
17262 :
17263 2844 : dummy_args = gfc_sym_get_dummy_args (proc);
17264 2844 : if (stree->n.tb->pass_arg)
17265 : {
17266 468 : gfc_formal_arglist *i;
17267 :
17268 : /* If an explicit passing argument name is given, walk the arg-list
17269 : and look for it. */
17270 :
17271 468 : me_arg = NULL;
17272 468 : stree->n.tb->pass_arg_num = 1;
17273 601 : for (i = dummy_args; i; i = i->next)
17274 : {
17275 599 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
17276 : {
17277 : me_arg = i->sym;
17278 : break;
17279 : }
17280 133 : ++stree->n.tb->pass_arg_num;
17281 : }
17282 :
17283 468 : if (!me_arg)
17284 : {
17285 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
17286 : " argument %qs",
17287 : proc->name, stree->n.tb->pass_arg, &where,
17288 : stree->n.tb->pass_arg);
17289 2 : goto error;
17290 : }
17291 : }
17292 : else
17293 : {
17294 : /* Otherwise, take the first one; there should in fact be at least
17295 : one. */
17296 2376 : stree->n.tb->pass_arg_num = 1;
17297 2376 : if (!dummy_args)
17298 : {
17299 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
17300 : " least one argument", proc->name, &where);
17301 2 : goto error;
17302 : }
17303 2374 : me_arg = dummy_args->sym;
17304 : }
17305 :
17306 : /* Now check that the argument-type matches and the passed-object
17307 : dummy argument is generally fine. */
17308 :
17309 2374 : gcc_assert (me_arg);
17310 :
17311 2840 : if (me_arg->ts.type != BT_CLASS)
17312 : {
17313 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17314 : " at %L", proc->name, &where);
17315 5 : goto error;
17316 : }
17317 :
17318 : /* The derived type is not a PDT template or type. Resolve as usual. */
17319 2835 : if (!resolve_bindings_derived->attr.pdt_template
17320 2826 : && !(containing_dt && containing_dt->attr.pdt_type
17321 60 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
17322 2806 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
17323 : {
17324 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17325 : "the derived-type %qs", me_arg->name, proc->name,
17326 : me_arg->name, &where, resolve_bindings_derived->name);
17327 0 : goto error;
17328 : }
17329 :
17330 2835 : if (resolve_bindings_derived->attr.pdt_template
17331 2844 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
17332 9 : CLASS_DATA (me_arg)->ts.u.derived))
17333 : {
17334 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17335 : "the parametric derived-type %qs", me_arg->name,
17336 : proc->name, me_arg->name, &where,
17337 : resolve_bindings_derived->name);
17338 0 : goto error;
17339 : }
17340 :
17341 2835 : if (((resolve_bindings_derived->attr.pdt_template
17342 9 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
17343 9 : CLASS_DATA (me_arg)->ts.u.derived))
17344 2826 : || resolve_bindings_derived->attr.pdt_type)
17345 69 : && (me_arg->param_list != NULL)
17346 2904 : && (gfc_spec_list_type (me_arg->param_list,
17347 69 : CLASS_DATA(me_arg)->ts.u.derived)
17348 : != SPEC_ASSUMED))
17349 : {
17350 :
17351 : /* Add a check to verify if there are any LEN parameters in the
17352 : first place. If there are LEN parameters, throw this error.
17353 : If there are only KIND parameters, then don't trigger
17354 : this error. */
17355 6 : gfc_component *c;
17356 6 : bool seen_len_param = false;
17357 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
17358 :
17359 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
17360 : {
17361 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
17362 : me_arg_param->name, true, true, NULL);
17363 :
17364 6 : gcc_assert (c != NULL);
17365 :
17366 6 : if (c->attr.pdt_kind)
17367 0 : continue;
17368 :
17369 : /* Getting here implies that there is a pdt_len parameter
17370 : in the list. */
17371 : seen_len_param = true;
17372 : break;
17373 : }
17374 :
17375 6 : if (seen_len_param)
17376 : {
17377 6 : gfc_error ("All LEN type parameters of the passed dummy "
17378 : "argument %qs of %qs at %L must be ASSUMED.",
17379 : me_arg->name, proc->name, &where);
17380 6 : goto error;
17381 : }
17382 : }
17383 :
17384 2829 : gcc_assert (me_arg->ts.type == BT_CLASS);
17385 2829 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
17386 : {
17387 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
17388 : " scalar", proc->name, &where);
17389 1 : goto error;
17390 : }
17391 2828 : if (CLASS_DATA (me_arg)->attr.allocatable)
17392 : {
17393 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17394 : " be ALLOCATABLE", proc->name, &where);
17395 2 : goto error;
17396 : }
17397 2826 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17398 : {
17399 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17400 : " be POINTER", proc->name, &where);
17401 2 : goto error;
17402 : }
17403 : }
17404 :
17405 : /* If we are extending some type, check that we don't override a procedure
17406 : flagged NON_OVERRIDABLE. */
17407 8923 : stree->n.tb->overridden = NULL;
17408 8923 : if (super_type)
17409 : {
17410 1513 : gfc_symtree* overridden;
17411 1513 : overridden = gfc_find_typebound_proc (super_type, NULL,
17412 : stree->name, true, NULL);
17413 :
17414 1513 : if (overridden)
17415 : {
17416 1218 : if (overridden->n.tb)
17417 1218 : stree->n.tb->overridden = overridden->n.tb;
17418 :
17419 1218 : if (!gfc_check_typebound_override (stree, overridden))
17420 26 : goto error;
17421 : }
17422 : }
17423 :
17424 : /* See if there's a name collision with a component directly in this type. */
17425 21297 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
17426 12401 : if (!strcmp (comp->name, stree->name))
17427 : {
17428 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
17429 : " %qs",
17430 : stree->name, &where, resolve_bindings_derived->name);
17431 1 : goto error;
17432 : }
17433 :
17434 : /* Try to find a name collision with an inherited component. */
17435 8896 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
17436 : NULL))
17437 : {
17438 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
17439 : " component of %qs",
17440 : stree->name, &where, resolve_bindings_derived->name);
17441 1 : goto error;
17442 : }
17443 :
17444 8895 : stree->n.tb->error = 0;
17445 8895 : return;
17446 :
17447 82 : error:
17448 82 : resolve_bindings_result = false;
17449 82 : stree->n.tb->error = 1;
17450 : }
17451 :
17452 :
17453 : static bool
17454 89454 : resolve_typebound_procedures (gfc_symbol* derived)
17455 : {
17456 89454 : int op;
17457 89454 : gfc_symbol* super_type;
17458 :
17459 : /* Resolve the super-type first so that inherited bindings (including
17460 : user operators) are fully resolved before we look them up via
17461 : gfc_find_typebound_user_op. This must happen even when 'derived'
17462 : has no direct type-bound bindings of its own. */
17463 89454 : super_type = gfc_get_derived_super_type (derived);
17464 89454 : if (super_type)
17465 13936 : resolve_symbol (super_type);
17466 :
17467 89454 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
17468 : return true;
17469 :
17470 4900 : resolve_bindings_derived = derived;
17471 4900 : resolve_bindings_result = true;
17472 :
17473 4900 : containing_dt = derived; /* Needed for checks of PDTs. */
17474 4900 : if (derived->f2k_derived->tb_sym_root)
17475 4900 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
17476 : &resolve_typebound_procedure);
17477 :
17478 4900 : if (derived->f2k_derived->tb_uop_root)
17479 91 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
17480 : &resolve_typebound_user_op);
17481 4900 : containing_dt = NULL;
17482 :
17483 142100 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
17484 : {
17485 137200 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
17486 137200 : if (p && !resolve_typebound_intrinsic_op (derived,
17487 : (gfc_intrinsic_op)op, p))
17488 7 : resolve_bindings_result = false;
17489 : }
17490 :
17491 4900 : return resolve_bindings_result;
17492 : }
17493 :
17494 :
17495 : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
17496 : to give all identical derived types the same backend_decl. */
17497 : static void
17498 183256 : add_dt_to_dt_list (gfc_symbol *derived)
17499 : {
17500 183256 : if (!derived->dt_next)
17501 : {
17502 85906 : if (gfc_derived_types)
17503 : {
17504 70304 : derived->dt_next = gfc_derived_types->dt_next;
17505 70304 : gfc_derived_types->dt_next = derived;
17506 : }
17507 : else
17508 : {
17509 15602 : derived->dt_next = derived;
17510 : }
17511 85906 : gfc_derived_types = derived;
17512 : }
17513 183256 : }
17514 :
17515 :
17516 : /* Ensure that a derived-type is really not abstract, meaning that every
17517 : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
17518 :
17519 : static bool
17520 7212 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
17521 : {
17522 7212 : if (!st)
17523 : return true;
17524 :
17525 2772 : if (!ensure_not_abstract_walker (sub, st->left))
17526 : return false;
17527 2772 : if (!ensure_not_abstract_walker (sub, st->right))
17528 : return false;
17529 :
17530 2771 : if (st->n.tb && st->n.tb->deferred)
17531 : {
17532 2019 : gfc_symtree* overriding;
17533 2019 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
17534 2019 : if (!overriding)
17535 : return false;
17536 2018 : gcc_assert (overriding->n.tb);
17537 2018 : if (overriding->n.tb->deferred)
17538 : {
17539 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
17540 : " %qs is DEFERRED and not overridden",
17541 : sub->name, &sub->declared_at, st->name);
17542 5 : return false;
17543 : }
17544 : }
17545 :
17546 : return true;
17547 : }
17548 :
17549 : static bool
17550 1520 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
17551 : {
17552 : /* The algorithm used here is to recursively travel up the ancestry of sub
17553 : and for each ancestor-type, check all bindings. If any of them is
17554 : DEFERRED, look it up starting from sub and see if the found (overriding)
17555 : binding is not DEFERRED.
17556 : This is not the most efficient way to do this, but it should be ok and is
17557 : clearer than something sophisticated. */
17558 :
17559 1669 : gcc_assert (ancestor && !sub->attr.abstract);
17560 :
17561 1669 : if (!ancestor->attr.abstract)
17562 : return true;
17563 :
17564 : /* Walk bindings of this ancestor. */
17565 1668 : if (ancestor->f2k_derived)
17566 : {
17567 1668 : bool t;
17568 1668 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
17569 1668 : if (!t)
17570 : return false;
17571 : }
17572 :
17573 : /* Find next ancestor type and recurse on it. */
17574 1662 : ancestor = gfc_get_derived_super_type (ancestor);
17575 1662 : if (ancestor)
17576 : return ensure_not_abstract (sub, ancestor);
17577 :
17578 : return true;
17579 : }
17580 :
17581 :
17582 : /* This check for typebound defined assignments is done recursively
17583 : since the order in which derived types are resolved is not always in
17584 : order of the declarations. */
17585 :
17586 : static void
17587 188544 : check_defined_assignments (gfc_symbol *derived)
17588 : {
17589 188544 : gfc_component *c;
17590 :
17591 634924 : for (c = derived->components; c; c = c->next)
17592 : {
17593 448187 : if (!gfc_bt_struct (c->ts.type)
17594 108196 : || c->attr.pointer
17595 21989 : || c->attr.proc_pointer_comp
17596 21989 : || c->attr.class_pointer
17597 21983 : || c->attr.proc_pointer)
17598 426738 : continue;
17599 :
17600 21449 : if (c->ts.u.derived->attr.defined_assign_comp
17601 21214 : || (c->ts.u.derived->f2k_derived
17602 20632 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
17603 : {
17604 1783 : derived->attr.defined_assign_comp = 1;
17605 1783 : return;
17606 : }
17607 :
17608 19666 : if (c->attr.allocatable)
17609 6956 : continue;
17610 :
17611 12710 : check_defined_assignments (c->ts.u.derived);
17612 12710 : if (c->ts.u.derived->attr.defined_assign_comp)
17613 : {
17614 24 : derived->attr.defined_assign_comp = 1;
17615 24 : return;
17616 : }
17617 : }
17618 : }
17619 :
17620 :
17621 : /* Resolve a single component of a derived type or structure. */
17622 :
17623 : static bool
17624 426085 : resolve_component (gfc_component *c, gfc_symbol *sym)
17625 : {
17626 426085 : gfc_symbol *super_type;
17627 426085 : symbol_attribute *attr;
17628 :
17629 426085 : if (c->attr.artificial)
17630 : return true;
17631 :
17632 : /* Do not allow vtype components to be resolved in nameless namespaces
17633 : such as block data because the procedure pointers will cause ICEs
17634 : and vtables are not needed in these contexts. */
17635 291080 : if (sym->attr.vtype && sym->attr.use_assoc
17636 50375 : && sym->ns->proc_name == NULL)
17637 : return true;
17638 :
17639 : /* F2008, C442. */
17640 291071 : if ((!sym->attr.is_class || c != sym->components)
17641 291071 : && c->attr.codimension
17642 230 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
17643 : {
17644 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
17645 : "deferred shape", c->name, &c->loc);
17646 4 : return false;
17647 : }
17648 :
17649 : /* F2008, C443. */
17650 291067 : if (c->attr.codimension && c->ts.type == BT_DERIVED
17651 85 : && c->ts.u.derived->ts.is_iso_c)
17652 : {
17653 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17654 : "shall not be a coarray", c->name, &c->loc);
17655 1 : return false;
17656 : }
17657 :
17658 : /* F2008, C444. */
17659 291066 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
17660 28 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
17661 26 : || c->attr.allocatable))
17662 : {
17663 3 : gfc_error ("Component %qs at %L with coarray component "
17664 : "shall be a nonpointer, nonallocatable scalar",
17665 : c->name, &c->loc);
17666 3 : return false;
17667 : }
17668 :
17669 : /* F2008, C448. */
17670 291063 : if (c->ts.type == BT_CLASS)
17671 : {
17672 7274 : if (c->attr.class_ok && CLASS_DATA (c))
17673 : {
17674 7266 : attr = &(CLASS_DATA (c)->attr);
17675 :
17676 : /* Fix up contiguous attribute. */
17677 7266 : if (c->attr.contiguous)
17678 11 : attr->contiguous = 1;
17679 : }
17680 : else
17681 : attr = NULL;
17682 : }
17683 : else
17684 283789 : attr = &c->attr;
17685 :
17686 291055 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
17687 : {
17688 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
17689 : "is not an array pointer", c->name, &c->loc);
17690 5 : return false;
17691 : }
17692 :
17693 : /* F2003, 15.2.1 - length has to be one. */
17694 41748 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
17695 291077 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
17696 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
17697 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
17698 : {
17699 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
17700 : c->name, &c->loc);
17701 1 : return false;
17702 : }
17703 :
17704 54467 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
17705 451 : && !sym->attr.pdt_type && !sym->attr.pdt_template
17706 291065 : && !(gfc_get_derived_super_type (sym)
17707 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
17708 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
17709 : {
17710 8 : gfc_actual_arglist *type_spec_list;
17711 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
17712 : &type_spec_list)
17713 : != MATCH_YES)
17714 0 : return false;
17715 8 : gfc_free_actual_arglist (c->param_list);
17716 8 : c->param_list = type_spec_list;
17717 8 : if (!sym->attr.pdt_type)
17718 8 : sym->attr.pdt_comp = 1;
17719 : }
17720 291049 : else if (IS_PDT (c) && !sym->attr.pdt_type)
17721 54 : sym->attr.pdt_comp = 1;
17722 :
17723 291057 : if (c->attr.proc_pointer && c->ts.interface)
17724 : {
17725 14960 : gfc_symbol *ifc = c->ts.interface;
17726 :
17727 14960 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
17728 : {
17729 6 : c->tb->error = 1;
17730 6 : return false;
17731 : }
17732 :
17733 14954 : if (ifc->attr.if_source || ifc->attr.intrinsic)
17734 : {
17735 : /* Resolve interface and copy attributes. */
17736 14905 : if (ifc->formal && !ifc->formal_ns)
17737 2611 : resolve_symbol (ifc);
17738 14905 : if (ifc->attr.intrinsic)
17739 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17740 :
17741 14905 : if (ifc->result)
17742 : {
17743 7783 : c->ts = ifc->result->ts;
17744 7783 : c->attr.allocatable = ifc->result->attr.allocatable;
17745 7783 : c->attr.pointer = ifc->result->attr.pointer;
17746 7783 : c->attr.dimension = ifc->result->attr.dimension;
17747 7783 : c->as = gfc_copy_array_spec (ifc->result->as);
17748 7783 : c->attr.class_ok = ifc->result->attr.class_ok;
17749 : }
17750 : else
17751 : {
17752 7122 : c->ts = ifc->ts;
17753 7122 : c->attr.allocatable = ifc->attr.allocatable;
17754 7122 : c->attr.pointer = ifc->attr.pointer;
17755 7122 : c->attr.dimension = ifc->attr.dimension;
17756 7122 : c->as = gfc_copy_array_spec (ifc->as);
17757 7122 : c->attr.class_ok = ifc->attr.class_ok;
17758 : }
17759 14905 : c->ts.interface = ifc;
17760 14905 : c->attr.function = ifc->attr.function;
17761 14905 : c->attr.subroutine = ifc->attr.subroutine;
17762 :
17763 14905 : c->attr.pure = ifc->attr.pure;
17764 14905 : c->attr.elemental = ifc->attr.elemental;
17765 14905 : c->attr.recursive = ifc->attr.recursive;
17766 14905 : c->attr.always_explicit = ifc->attr.always_explicit;
17767 14905 : c->attr.ext_attr |= ifc->attr.ext_attr;
17768 : /* Copy char length. */
17769 14905 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17770 : {
17771 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17772 454 : if (cl->length && !cl->resolved
17773 601 : && !gfc_resolve_expr (cl->length))
17774 : {
17775 0 : c->tb->error = 1;
17776 0 : return false;
17777 : }
17778 491 : c->ts.u.cl = cl;
17779 : }
17780 : }
17781 : }
17782 276097 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17783 : {
17784 : /* Since PPCs are not implicitly typed, a PPC without an explicit
17785 : interface must be a subroutine. */
17786 116 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17787 : }
17788 :
17789 : /* Procedure pointer components: Check PASS arg. */
17790 291051 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17791 578 : && !sym->attr.vtype)
17792 : {
17793 95 : gfc_symbol* me_arg;
17794 :
17795 95 : if (c->tb->pass_arg)
17796 : {
17797 20 : gfc_formal_arglist* i;
17798 :
17799 : /* If an explicit passing argument name is given, walk the arg-list
17800 : and look for it. */
17801 :
17802 20 : me_arg = NULL;
17803 20 : c->tb->pass_arg_num = 1;
17804 34 : for (i = c->ts.interface->formal; i; i = i->next)
17805 : {
17806 33 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17807 : {
17808 : me_arg = i->sym;
17809 : break;
17810 : }
17811 14 : c->tb->pass_arg_num++;
17812 : }
17813 :
17814 20 : if (!me_arg)
17815 : {
17816 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17817 : "at %L has no argument %qs", c->name,
17818 : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17819 1 : c->tb->error = 1;
17820 1 : return false;
17821 : }
17822 : }
17823 : else
17824 : {
17825 : /* Otherwise, take the first one; there should in fact be at least
17826 : one. */
17827 75 : c->tb->pass_arg_num = 1;
17828 75 : if (!c->ts.interface->formal)
17829 : {
17830 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17831 : "must have at least one argument",
17832 : c->name, &c->loc);
17833 3 : c->tb->error = 1;
17834 3 : return false;
17835 : }
17836 72 : me_arg = c->ts.interface->formal->sym;
17837 : }
17838 :
17839 : /* Now check that the argument-type matches. */
17840 72 : gcc_assert (me_arg);
17841 91 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17842 90 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17843 90 : || (me_arg->ts.type == BT_CLASS
17844 82 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17845 : {
17846 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17847 : " the derived type %qs", me_arg->name, c->name,
17848 : me_arg->name, &c->loc, sym->name);
17849 1 : c->tb->error = 1;
17850 1 : return false;
17851 : }
17852 :
17853 : /* Check for F03:C453. */
17854 90 : if (CLASS_DATA (me_arg)->attr.dimension)
17855 : {
17856 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17857 : "must be scalar", me_arg->name, c->name, me_arg->name,
17858 : &c->loc);
17859 1 : c->tb->error = 1;
17860 1 : return false;
17861 : }
17862 :
17863 89 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17864 : {
17865 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17866 : "may not have the POINTER attribute", me_arg->name,
17867 : c->name, me_arg->name, &c->loc);
17868 1 : c->tb->error = 1;
17869 1 : return false;
17870 : }
17871 :
17872 88 : if (CLASS_DATA (me_arg)->attr.allocatable)
17873 : {
17874 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17875 : "may not be ALLOCATABLE", me_arg->name, c->name,
17876 : me_arg->name, &c->loc);
17877 1 : c->tb->error = 1;
17878 1 : return false;
17879 : }
17880 :
17881 87 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17882 : {
17883 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17884 : " at %L", c->name, &c->loc);
17885 2 : return false;
17886 : }
17887 :
17888 : }
17889 :
17890 : /* Check type-spec if this is not the parent-type component. */
17891 291041 : if (((sym->attr.is_class
17892 12908 : && (!sym->components->ts.u.derived->attr.extension
17893 2412 : || c != CLASS_DATA (sym->components)))
17894 279490 : || (!sym->attr.is_class
17895 278133 : && (!sym->attr.extension || c != sym->components)))
17896 282347 : && !sym->attr.vtype
17897 460916 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17898 : return false;
17899 :
17900 291040 : super_type = gfc_get_derived_super_type (sym);
17901 :
17902 : /* If this type is an extension, set the accessibility of the parent
17903 : component. */
17904 291040 : if (super_type
17905 28299 : && ((sym->attr.is_class
17906 12908 : && c == CLASS_DATA (sym->components))
17907 19340 : || (!sym->attr.is_class && c == sym->components))
17908 16296 : && strcmp (super_type->name, c->name) == 0)
17909 6977 : c->attr.access = super_type->attr.access;
17910 :
17911 : /* If this type is an extension, see if this component has the same name
17912 : as an inherited type-bound procedure. */
17913 28299 : if (super_type && !sym->attr.is_class
17914 15391 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17915 : {
17916 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17917 : " inherited type-bound procedure",
17918 : c->name, sym->name, &c->loc);
17919 1 : return false;
17920 : }
17921 :
17922 291039 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17923 9855 : && !c->ts.deferred)
17924 : {
17925 7572 : if (sym->attr.pdt_template || c->attr.pdt_string)
17926 462 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17927 :
17928 7572 : if (c->ts.u.cl->length == NULL
17929 7566 : || !resolve_charlen(c->ts.u.cl)
17930 15137 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17931 : {
17932 9 : gfc_error ("Character length of component %qs needs to "
17933 : "be a constant specification expression at %L",
17934 : c->name,
17935 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17936 9 : return false;
17937 : }
17938 :
17939 7563 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17940 : {
17941 2 : if (!c->ts.u.cl->length->error)
17942 : {
17943 1 : gfc_error ("Character length expression of component %qs at %L "
17944 : "must be of INTEGER type, found %s",
17945 1 : c->name, &c->ts.u.cl->length->where,
17946 : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17947 1 : c->ts.u.cl->length->error = 1;
17948 : }
17949 : return false;
17950 : }
17951 : }
17952 :
17953 291028 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17954 2319 : && !c->attr.pointer && !c->attr.allocatable)
17955 : {
17956 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17957 : "length must be a POINTER or ALLOCATABLE",
17958 : c->name, sym->name, &c->loc);
17959 1 : return false;
17960 : }
17961 :
17962 : /* Add the hidden deferred length field. */
17963 291027 : if (c->ts.type == BT_CHARACTER
17964 10355 : && (c->ts.deferred || c->attr.pdt_string)
17965 2577 : && !c->attr.function
17966 2541 : && !sym->attr.is_class)
17967 : {
17968 2394 : char name[GFC_MAX_SYMBOL_LEN+9];
17969 2394 : gfc_component *strlen;
17970 2394 : sprintf (name, "_%s_length", c->name);
17971 2394 : strlen = gfc_find_component (sym, name, true, true, NULL);
17972 2394 : if (strlen == NULL)
17973 : {
17974 544 : if (!gfc_add_component (sym, name, &strlen))
17975 0 : return false;
17976 544 : strlen->ts.type = BT_INTEGER;
17977 544 : strlen->ts.kind = gfc_charlen_int_kind;
17978 544 : strlen->attr.access = ACCESS_PRIVATE;
17979 544 : strlen->attr.artificial = 1;
17980 : }
17981 : }
17982 :
17983 291027 : if (c->ts.type == BT_DERIVED
17984 54677 : && sym->component_access != ACCESS_PRIVATE
17985 53657 : && gfc_check_symbol_access (sym)
17986 105278 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
17987 52580 : && !c->ts.u.derived->attr.use_assoc
17988 28248 : && !gfc_check_symbol_access (c->ts.u.derived)
17989 291224 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
17990 : "PRIVATE type and cannot be a component of "
17991 : "%qs, which is PUBLIC at %L", c->name,
17992 : sym->name, &sym->declared_at))
17993 : return false;
17994 :
17995 291026 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
17996 : {
17997 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
17998 : "type %s", c->name, &c->loc, sym->name);
17999 2 : return false;
18000 : }
18001 :
18002 291024 : if (sym->attr.sequence)
18003 : {
18004 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
18005 : {
18006 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
18007 : "not have the SEQUENCE attribute",
18008 : c->ts.u.derived->name, &sym->declared_at);
18009 0 : return false;
18010 : }
18011 : }
18012 :
18013 291024 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
18014 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
18015 291024 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
18016 7608 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
18017 0 : CLASS_DATA (c)->ts.u.derived
18018 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
18019 :
18020 : /* If an allocatable component derived type is of the same type as
18021 : the enclosing derived type, we need a vtable generating so that
18022 : the __deallocate procedure is created. */
18023 291024 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
18024 62295 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
18025 495 : gfc_find_vtab (&c->ts);
18026 :
18027 : /* Ensure that all the derived type components are put on the
18028 : derived type list; even in formal namespaces, where derived type
18029 : pointer components might not have been declared. */
18030 291024 : if (c->ts.type == BT_DERIVED
18031 54676 : && c->ts.u.derived
18032 54676 : && c->ts.u.derived->components
18033 51348 : && c->attr.pointer
18034 34735 : && sym != c->ts.u.derived)
18035 4421 : add_dt_to_dt_list (c->ts.u.derived);
18036 :
18037 291024 : if (c->as && c->as->type != AS_DEFERRED
18038 6818 : && (c->attr.pointer || c->attr.allocatable))
18039 : return false;
18040 :
18041 291010 : if (!gfc_resolve_array_spec (c->as,
18042 291010 : !(c->attr.pointer || c->attr.proc_pointer
18043 237432 : || c->attr.allocatable)))
18044 : return false;
18045 :
18046 110615 : if (c->initializer && !sym->attr.vtype
18047 34498 : && !c->attr.pdt_kind && !c->attr.pdt_len
18048 321572 : && !gfc_check_assign_symbol (sym, c, c->initializer))
18049 : return false;
18050 :
18051 : return true;
18052 : }
18053 :
18054 :
18055 : /* Be nice about the locus for a structure expression - show the locus of the
18056 : first non-null sub-expression if we can. */
18057 :
18058 : static locus *
18059 4 : cons_where (gfc_expr *struct_expr)
18060 : {
18061 4 : gfc_constructor *cons;
18062 :
18063 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
18064 :
18065 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
18066 12 : for (; cons; cons = gfc_constructor_next (cons))
18067 : {
18068 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
18069 4 : return &cons->expr->where;
18070 : }
18071 :
18072 0 : return &struct_expr->where;
18073 : }
18074 :
18075 : /* Resolve the components of a structure type. Much less work than derived
18076 : types. */
18077 :
18078 : static bool
18079 913 : resolve_fl_struct (gfc_symbol *sym)
18080 : {
18081 913 : gfc_component *c;
18082 913 : gfc_expr *init = NULL;
18083 913 : bool success;
18084 :
18085 : /* Make sure UNIONs do not have overlapping initializers. */
18086 913 : if (sym->attr.flavor == FL_UNION)
18087 : {
18088 498 : for (c = sym->components; c; c = c->next)
18089 : {
18090 331 : if (init && c->initializer)
18091 : {
18092 2 : gfc_error ("Conflicting initializers in union at %L and %L",
18093 : cons_where (init), cons_where (c->initializer));
18094 2 : gfc_free_expr (c->initializer);
18095 2 : c->initializer = NULL;
18096 : }
18097 : if (init == NULL)
18098 291 : init = c->initializer;
18099 : }
18100 : }
18101 :
18102 913 : success = true;
18103 2830 : for (c = sym->components; c; c = c->next)
18104 1917 : if (!resolve_component (c, sym))
18105 0 : success = false;
18106 :
18107 913 : if (!success)
18108 : return false;
18109 :
18110 913 : if (sym->components)
18111 862 : add_dt_to_dt_list (sym);
18112 :
18113 : return true;
18114 : }
18115 :
18116 : /* Figure if the derived type is using itself directly in one of its components
18117 : or through referencing other derived types. The information is required to
18118 : generate the __deallocate and __final type bound procedures to ensure
18119 : freeing larger hierarchies of derived types with allocatable objects. */
18120 :
18121 : static void
18122 142569 : resolve_cyclic_derived_type (gfc_symbol *derived)
18123 : {
18124 142569 : hash_set<gfc_symbol *> seen, to_examin;
18125 142569 : gfc_component *c;
18126 142569 : seen.add (derived);
18127 142569 : to_examin.add (derived);
18128 478387 : while (!to_examin.is_empty ())
18129 : {
18130 195537 : gfc_symbol *cand = *to_examin.begin ();
18131 195537 : to_examin.remove (cand);
18132 528920 : for (c = cand->components; c; c = c->next)
18133 335671 : if (c->ts.type == BT_DERIVED)
18134 : {
18135 74065 : if (c->ts.u.derived == derived)
18136 : {
18137 1216 : derived->attr.recursive = 1;
18138 2288 : return;
18139 : }
18140 72849 : else if (!seen.contains (c->ts.u.derived))
18141 : {
18142 48327 : seen.add (c->ts.u.derived);
18143 48327 : to_examin.add (c->ts.u.derived);
18144 : }
18145 : }
18146 261606 : else if (c->ts.type == BT_CLASS)
18147 : {
18148 9876 : if (!c->attr.class_ok)
18149 7 : continue;
18150 9869 : if (CLASS_DATA (c)->ts.u.derived == derived)
18151 : {
18152 1072 : derived->attr.recursive = 1;
18153 1072 : return;
18154 : }
18155 8797 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
18156 : {
18157 4948 : seen.add (CLASS_DATA (c)->ts.u.derived);
18158 4948 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
18159 : }
18160 : }
18161 : }
18162 142569 : }
18163 :
18164 : /* Resolve the components of a derived type. This does not have to wait until
18165 : resolution stage, but can be done as soon as the dt declaration has been
18166 : parsed. */
18167 :
18168 : static bool
18169 175930 : resolve_fl_derived0 (gfc_symbol *sym)
18170 : {
18171 175930 : gfc_symbol* super_type;
18172 175930 : gfc_component *c;
18173 175930 : gfc_formal_arglist *f;
18174 175930 : bool success;
18175 :
18176 175930 : if (sym->attr.unlimited_polymorphic)
18177 : return true;
18178 :
18179 175930 : super_type = gfc_get_derived_super_type (sym);
18180 :
18181 : /* F2008, C432. */
18182 175930 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
18183 : {
18184 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
18185 : "parent type %qs shall also have one", sym->name,
18186 : &sym->declared_at, super_type->name);
18187 2 : return false;
18188 : }
18189 :
18190 : /* Ensure the extended type gets resolved before we do. */
18191 18372 : if (super_type && !resolve_fl_derived0 (super_type))
18192 : return false;
18193 :
18194 : /* An ABSTRACT type must be extensible. */
18195 175922 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
18196 : {
18197 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
18198 : sym->name, &sym->declared_at);
18199 2 : return false;
18200 : }
18201 :
18202 : /* Resolving components below, may create vtabs for which the cyclic type
18203 : information needs to be present. */
18204 175920 : if (!sym->attr.vtype)
18205 142569 : resolve_cyclic_derived_type (sym);
18206 :
18207 175920 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
18208 : : sym->components;
18209 :
18210 175920 : success = true;
18211 600088 : for ( ; c != NULL; c = c->next)
18212 424168 : if (!resolve_component (c, sym))
18213 96 : success = false;
18214 :
18215 175920 : if (!success)
18216 : return false;
18217 :
18218 : /* Now add the caf token field, where needed. */
18219 175834 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
18220 1045 : && !sym->attr.vtype)
18221 : {
18222 2313 : for (c = sym->components; c; c = c->next)
18223 1477 : if (!c->attr.dimension && !c->attr.codimension
18224 809 : && (c->attr.allocatable || c->attr.pointer))
18225 : {
18226 146 : char name[GFC_MAX_SYMBOL_LEN+9];
18227 146 : gfc_component *token;
18228 146 : sprintf (name, "_caf_%s", c->name);
18229 146 : token = gfc_find_component (sym, name, true, true, NULL);
18230 146 : if (token == NULL)
18231 : {
18232 82 : if (!gfc_add_component (sym, name, &token))
18233 0 : return false;
18234 82 : token->ts.type = BT_VOID;
18235 82 : token->ts.kind = gfc_default_integer_kind;
18236 82 : token->attr.access = ACCESS_PRIVATE;
18237 82 : token->attr.artificial = 1;
18238 82 : token->attr.caf_token = 1;
18239 : }
18240 146 : c->caf_token = token;
18241 : }
18242 : }
18243 :
18244 175834 : check_defined_assignments (sym);
18245 :
18246 175834 : if (!sym->attr.defined_assign_comp && super_type)
18247 17365 : sym->attr.defined_assign_comp
18248 17365 : = super_type->attr.defined_assign_comp;
18249 :
18250 : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
18251 : all DEFERRED bindings are overridden. */
18252 18365 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
18253 1523 : && !sym->attr.is_class
18254 3303 : && !ensure_not_abstract (sym, super_type))
18255 : return false;
18256 :
18257 : /* Check that there is a component for every PDT parameter. */
18258 175828 : if (sym->attr.pdt_template)
18259 : {
18260 3606 : for (f = sym->formal; f; f = f->next)
18261 : {
18262 2188 : if (!f->sym)
18263 1 : continue;
18264 2187 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
18265 2187 : if (c == NULL)
18266 : {
18267 9 : gfc_error ("Parameterized type %qs does not have a component "
18268 : "corresponding to parameter %qs at %L", sym->name,
18269 9 : f->sym->name, &sym->declared_at);
18270 9 : break;
18271 : }
18272 : }
18273 : }
18274 :
18275 : /* Add derived type to the derived type list. */
18276 175828 : add_dt_to_dt_list (sym);
18277 :
18278 175828 : return true;
18279 : }
18280 :
18281 : /* The following procedure does the full resolution of a derived type,
18282 : including resolution of all type-bound procedures (if present). In contrast
18283 : to 'resolve_fl_derived0' this can only be done after the module has been
18284 : parsed completely. */
18285 :
18286 : static bool
18287 91703 : resolve_fl_derived (gfc_symbol *sym)
18288 : {
18289 91703 : gfc_symbol *gen_dt = NULL;
18290 :
18291 91703 : if (sym->attr.unlimited_polymorphic)
18292 : return true;
18293 :
18294 91703 : if (!sym->attr.is_class)
18295 78524 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
18296 58750 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
18297 2315 : && (!gen_dt->generic->sym->attr.use_assoc
18298 2166 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
18299 91885 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
18300 : "%qs at %L being the same name as derived "
18301 : "type at %L", sym->name,
18302 : gen_dt->generic->sym == sym
18303 11 : ? gen_dt->generic->next->sym->name
18304 : : gen_dt->generic->sym->name,
18305 : gen_dt->generic->sym == sym
18306 11 : ? &gen_dt->generic->next->sym->declared_at
18307 : : &gen_dt->generic->sym->declared_at,
18308 : &sym->declared_at))
18309 : return false;
18310 :
18311 91699 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
18312 : {
18313 13 : gfc_error ("Derived type %qs at %L has not been declared",
18314 : sym->name, &sym->declared_at);
18315 13 : return false;
18316 : }
18317 :
18318 : /* Resolve the finalizer procedures. */
18319 91686 : if (!gfc_resolve_finalizers (sym, NULL))
18320 : return false;
18321 :
18322 91683 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
18323 : {
18324 : /* Fix up incomplete CLASS symbols. */
18325 13179 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
18326 13179 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18327 :
18328 13179 : if (data->ts.u.derived->attr.pdt_template)
18329 : {
18330 0 : match m;
18331 0 : m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
18332 : &data->param_list);
18333 0 : if (m != MATCH_YES
18334 0 : || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
18335 : {
18336 0 : gfc_error ("Failed to build PDT class component at %L",
18337 : &sym->declared_at);
18338 0 : return false;
18339 : }
18340 0 : data = gfc_find_component (sym, "_data", true, true, NULL);
18341 0 : vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18342 : }
18343 :
18344 : /* Nothing more to do for unlimited polymorphic entities. */
18345 13179 : if (data->ts.u.derived->attr.unlimited_polymorphic)
18346 : {
18347 2145 : add_dt_to_dt_list (sym);
18348 2145 : return true;
18349 : }
18350 11034 : else if (vptr->ts.u.derived == NULL)
18351 : {
18352 6542 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
18353 6542 : gcc_assert (vtab);
18354 6542 : vptr->ts.u.derived = vtab->ts.u.derived;
18355 6542 : if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
18356 : return false;
18357 : }
18358 : }
18359 :
18360 89538 : if (!resolve_fl_derived0 (sym))
18361 : return false;
18362 :
18363 : /* Resolve the type-bound procedures. */
18364 89454 : if (!resolve_typebound_procedures (sym))
18365 : return false;
18366 :
18367 : /* Generate module vtables subject to their accessibility and their not
18368 : being vtables or pdt templates. If this is not done class declarations
18369 : in external procedures wind up with their own version and so SELECT TYPE
18370 : fails because the vptrs do not have the same address. */
18371 89413 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
18372 89352 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
18373 66931 : || (sym->attr.recursive && sym->attr.alloc_comp))
18374 22587 : && sym->attr.access != ACCESS_PRIVATE
18375 22554 : && !(sym->attr.vtype || sym->attr.pdt_template))
18376 : {
18377 20154 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
18378 20154 : gfc_set_sym_referenced (vtab);
18379 : }
18380 :
18381 : return true;
18382 : }
18383 :
18384 :
18385 : static bool
18386 875 : resolve_fl_namelist (gfc_symbol *sym)
18387 : {
18388 875 : gfc_namelist *nl;
18389 875 : gfc_symbol *nlsym;
18390 :
18391 3070 : for (nl = sym->namelist; nl; nl = nl->next)
18392 : {
18393 : /* Check again, the check in match only works if NAMELIST comes
18394 : after the decl. */
18395 2200 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
18396 : {
18397 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
18398 : "allowed", nl->sym->name, sym->name, &sym->declared_at);
18399 1 : return false;
18400 : }
18401 :
18402 678 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
18403 2207 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18404 : "with assumed shape in namelist %qs at %L",
18405 : nl->sym->name, sym->name, &sym->declared_at))
18406 : return false;
18407 :
18408 2198 : if (is_non_constant_shape_array (nl->sym)
18409 2248 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18410 : "with nonconstant shape in namelist %qs at %L",
18411 50 : nl->sym->name, sym->name, &sym->declared_at))
18412 : return false;
18413 :
18414 2197 : if (nl->sym->ts.type == BT_CHARACTER
18415 605 : && (nl->sym->ts.u.cl->length == NULL
18416 566 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
18417 2279 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
18418 : "nonconstant character length in "
18419 82 : "namelist %qs at %L", nl->sym->name,
18420 : sym->name, &sym->declared_at))
18421 : return false;
18422 :
18423 : }
18424 :
18425 : /* Reject PRIVATE objects in a PUBLIC namelist. */
18426 870 : if (gfc_check_symbol_access (sym))
18427 : {
18428 3051 : for (nl = sym->namelist; nl; nl = nl->next)
18429 : {
18430 2194 : if (!nl->sym->attr.use_assoc
18431 4092 : && !is_sym_host_assoc (nl->sym, sym->ns)
18432 4218 : && !gfc_check_symbol_access (nl->sym))
18433 : {
18434 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
18435 : "cannot be member of PUBLIC namelist %qs at %L",
18436 2 : nl->sym->name, sym->name, &sym->declared_at);
18437 2 : return false;
18438 : }
18439 :
18440 2192 : if (nl->sym->ts.type == BT_DERIVED
18441 472 : && (nl->sym->ts.u.derived->attr.alloc_comp
18442 470 : || nl->sym->ts.u.derived->attr.pointer_comp))
18443 : {
18444 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
18445 : "namelist %qs at %L with ALLOCATABLE "
18446 : "or POINTER components", nl->sym->name,
18447 : sym->name, &sym->declared_at))
18448 : return false;
18449 : return true;
18450 : }
18451 :
18452 : /* Types with private components that came here by USE-association. */
18453 2187 : if (nl->sym->ts.type == BT_DERIVED
18454 2187 : && derived_inaccessible (nl->sym->ts.u.derived))
18455 : {
18456 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
18457 : "components and cannot be member of namelist %qs at %L",
18458 : nl->sym->name, sym->name, &sym->declared_at);
18459 6 : return false;
18460 : }
18461 :
18462 : /* Types with private components that are defined in the same module. */
18463 2181 : if (nl->sym->ts.type == BT_DERIVED
18464 922 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
18465 2465 : && nl->sym->ts.u.derived->attr.private_comp)
18466 : {
18467 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
18468 : "cannot be a member of PUBLIC namelist %qs at %L",
18469 : nl->sym->name, sym->name, &sym->declared_at);
18470 0 : return false;
18471 : }
18472 : }
18473 : }
18474 :
18475 :
18476 : /* 14.1.2 A module or internal procedure represent local entities
18477 : of the same type as a namelist member and so are not allowed. */
18478 3035 : for (nl = sym->namelist; nl; nl = nl->next)
18479 : {
18480 2181 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
18481 1616 : continue;
18482 :
18483 565 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
18484 7 : if ((nl->sym == sym->ns->proc_name)
18485 1 : ||
18486 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
18487 6 : continue;
18488 :
18489 559 : nlsym = NULL;
18490 559 : if (nl->sym->name)
18491 559 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
18492 559 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
18493 : {
18494 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
18495 : "attribute in %qs at %L", nlsym->name,
18496 : &sym->declared_at);
18497 3 : return false;
18498 : }
18499 : }
18500 :
18501 : return true;
18502 : }
18503 :
18504 :
18505 : static bool
18506 411872 : resolve_fl_parameter (gfc_symbol *sym)
18507 : {
18508 : /* A parameter array's shape needs to be constant. */
18509 411872 : if (sym->as != NULL
18510 411872 : && (sym->as->type == AS_DEFERRED
18511 6369 : || is_non_constant_shape_array (sym)))
18512 : {
18513 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
18514 : "or of deferred shape", sym->name, &sym->declared_at);
18515 17 : return false;
18516 : }
18517 :
18518 : /* Constraints on deferred type parameter. */
18519 411855 : if (!deferred_requirements (sym))
18520 : return false;
18521 :
18522 : /* Make sure a parameter that has been implicitly typed still
18523 : matches the implicit type, since PARAMETER statements can precede
18524 : IMPLICIT statements. */
18525 411854 : if (sym->attr.implicit_type
18526 412567 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
18527 713 : sym->ns)))
18528 : {
18529 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
18530 : "later IMPLICIT type", sym->name, &sym->declared_at);
18531 0 : return false;
18532 : }
18533 :
18534 : /* Make sure the types of derived parameters are consistent. This
18535 : type checking is deferred until resolution because the type may
18536 : refer to a derived type from the host. */
18537 411854 : if (sym->ts.type == BT_DERIVED
18538 411854 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
18539 : {
18540 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
18541 0 : &sym->value->where);
18542 0 : return false;
18543 : }
18544 :
18545 : /* F03:C509,C514. */
18546 411854 : if (sym->ts.type == BT_CLASS)
18547 : {
18548 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
18549 : sym->name, &sym->declared_at);
18550 0 : return false;
18551 : }
18552 :
18553 : /* Some programmers can have a typo when using an implied-do loop to
18554 : initialize an array constant. For example,
18555 : INTEGER I,J
18556 : INTEGER, PARAMETER :: A(3) = [(I, I = 1, 3)] ! OK
18557 : INTEGER, PARAMETER :: B(3) = [(A(J), I = 1, 3)] ! Not OK, J undefined
18558 : This check catches the typo. */
18559 411854 : if (sym->attr.dimension
18560 6362 : && sym->value && sym->value->expr_type == EXPR_ARRAY
18561 418210 : && !gfc_is_constant_expr (sym->value))
18562 : {
18563 : /* PR fortran/117070 argues a nonconstant proc pointer can appear in
18564 : the array constructor of a parameter. This seems inconsistent with
18565 : the concept of a parameter. TODO: Needs an interpretation. */
18566 20 : if (sym->value->ts.type == BT_DERIVED
18567 18 : && sym->value->ts.u.derived
18568 18 : && sym->value->ts.u.derived->attr.proc_pointer_comp)
18569 : return true;
18570 2 : gfc_error ("Expecting constant expression near %L", &sym->value->where);
18571 2 : return false;
18572 : }
18573 :
18574 : return true;
18575 : }
18576 :
18577 :
18578 : /* Called by resolve_symbol to check PDTs. */
18579 :
18580 : static void
18581 1576 : resolve_pdt (gfc_symbol* sym)
18582 : {
18583 1576 : gfc_symbol *derived = NULL;
18584 1576 : gfc_actual_arglist *param;
18585 1576 : gfc_component *c;
18586 1576 : bool const_len_exprs = true;
18587 1576 : bool assumed_len_exprs = false;
18588 1576 : symbol_attribute *attr;
18589 :
18590 1576 : if (sym->ts.type == BT_DERIVED)
18591 : {
18592 1337 : derived = sym->ts.u.derived;
18593 1337 : attr = &(sym->attr);
18594 : }
18595 239 : else if (sym->ts.type == BT_CLASS)
18596 : {
18597 239 : derived = CLASS_DATA (sym)->ts.u.derived;
18598 239 : attr = &(CLASS_DATA (sym)->attr);
18599 : }
18600 : else
18601 0 : gcc_unreachable ();
18602 :
18603 1576 : gcc_assert (derived->attr.pdt_type);
18604 :
18605 3825 : for (param = sym->param_list; param; param = param->next)
18606 : {
18607 2249 : c = gfc_find_component (derived, param->name, false, true, NULL);
18608 2249 : gcc_assert (c);
18609 2249 : if (c->attr.pdt_kind)
18610 1276 : continue;
18611 :
18612 692 : if (param->expr && !gfc_is_constant_expr (param->expr)
18613 1099 : && c->attr.pdt_len)
18614 : const_len_exprs = false;
18615 847 : else if (param->spec_type == SPEC_ASSUMED)
18616 303 : assumed_len_exprs = true;
18617 :
18618 973 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
18619 18 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
18620 16 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
18621 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
18622 : "parameter %qs and requires either the POINTER "
18623 : "or ALLOCATABLE attribute",
18624 : sym->name, &sym->declared_at,
18625 : param->name);
18626 :
18627 : }
18628 :
18629 1576 : if (!const_len_exprs
18630 120 : && (sym->ns->proc_name->attr.is_main_program
18631 119 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18632 118 : || sym->attr.save != SAVE_NONE))
18633 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
18634 : "SAVE attribute or be a variable declared in the "
18635 : "main program, a module or a submodule(F08/C513)",
18636 : sym->name, &sym->declared_at);
18637 :
18638 1576 : if (assumed_len_exprs && !(sym->attr.dummy
18639 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
18640 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
18641 : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
18642 : sym->name, &sym->declared_at);
18643 1576 : }
18644 :
18645 :
18646 : /* Resolve the symbol's array spec. */
18647 :
18648 : static bool
18649 1787710 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
18650 : {
18651 1787710 : gfc_namespace *orig_current_ns = gfc_current_ns;
18652 1787710 : gfc_current_ns = gfc_get_spec_ns (sym);
18653 :
18654 1787710 : bool saved_specification_expr = specification_expr;
18655 1787710 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
18656 1787710 : specification_expr = true;
18657 1787710 : specification_expr_symbol = sym;
18658 :
18659 1787710 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
18660 :
18661 1787710 : specification_expr = saved_specification_expr;
18662 1787710 : specification_expr_symbol = saved_specification_expr_symbol;
18663 1787710 : gfc_current_ns = orig_current_ns;
18664 :
18665 1787710 : return result;
18666 : }
18667 :
18668 :
18669 : /* Do anything necessary to resolve a symbol. Right now, we just
18670 : assume that an otherwise unknown symbol is a variable. This sort
18671 : of thing commonly happens for symbols in module. */
18672 :
18673 : static void
18674 1951053 : resolve_symbol (gfc_symbol *sym)
18675 : {
18676 1951053 : int check_constant, mp_flag;
18677 1951053 : gfc_symtree *symtree;
18678 1951053 : gfc_symtree *this_symtree;
18679 1951053 : gfc_namespace *ns;
18680 1951053 : gfc_component *c;
18681 1951053 : symbol_attribute class_attr;
18682 1951053 : gfc_array_spec *as;
18683 1951053 : bool declared_has_coarray_comp = false;
18684 :
18685 1951053 : if (sym->resolve_symbol_called >= 1)
18686 194846 : return;
18687 1861065 : sym->resolve_symbol_called = 1;
18688 :
18689 : /* No symbol will ever have union type; only components can be unions.
18690 : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
18691 : (just like derived type declaration symbols have flavor FL_DERIVED). */
18692 1861065 : gcc_assert (sym->ts.type != BT_UNION);
18693 :
18694 : /* Coarrayed polymorphic objects with allocatable or pointer components are
18695 : yet unsupported for -fcoarray=lib. */
18696 1861065 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
18697 116 : && sym->ts.u.derived && CLASS_DATA (sym)
18698 116 : && CLASS_DATA (sym)->attr.codimension
18699 98 : && CLASS_DATA (sym)->ts.u.derived
18700 97 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
18701 94 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
18702 : {
18703 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
18704 : "type coarrays at %L are unsupported", &sym->declared_at);
18705 6 : return;
18706 : }
18707 :
18708 1861059 : if (sym->attr.artificial)
18709 : return;
18710 :
18711 1758999 : if (sym->attr.unlimited_polymorphic)
18712 : return;
18713 :
18714 1757460 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
18715 : {
18716 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
18717 : "the OpenMP DEPEND clause", &sym->declared_at);
18718 4 : return;
18719 : }
18720 :
18721 1757456 : if (sym->attr.flavor == FL_UNKNOWN
18722 1735942 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
18723 465407 : && !sym->attr.generic && !sym->attr.external
18724 184552 : && sym->attr.if_source == IFSRC_UNKNOWN
18725 83280 : && sym->ts.type == BT_UNKNOWN))
18726 : {
18727 : /* A symbol in a common block might not have been resolved yet properly.
18728 : Do not try to find an interface with the same name. */
18729 96167 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
18730 21510 : && !sym->attr.generic && !sym->attr.external
18731 21459 : && sym->attr.in_common)
18732 2595 : goto skip_interfaces;
18733 :
18734 : /* If we find that a flavorless symbol is an interface in one of the
18735 : parent namespaces, find its symtree in this namespace, free the
18736 : symbol and set the symtree to point to the interface symbol. */
18737 134016 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
18738 : {
18739 41154 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
18740 41154 : if (symtree && (symtree->n.sym->generic ||
18741 785 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
18742 683 : && sym->ns->construct_entities)))
18743 : {
18744 718 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
18745 : sym->name);
18746 718 : if (this_symtree->n.sym == sym)
18747 : {
18748 710 : symtree->n.sym->refs++;
18749 710 : gfc_release_symbol (sym);
18750 710 : this_symtree->n.sym = symtree->n.sym;
18751 710 : return;
18752 : }
18753 : }
18754 : }
18755 :
18756 92862 : skip_interfaces:
18757 : /* Otherwise give it a flavor according to such attributes as
18758 : it has. */
18759 95457 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
18760 21329 : && sym->attr.intrinsic == 0)
18761 21325 : sym->attr.flavor = FL_VARIABLE;
18762 74132 : else if (sym->attr.flavor == FL_UNKNOWN)
18763 : {
18764 55 : sym->attr.flavor = FL_PROCEDURE;
18765 55 : if (sym->attr.dimension)
18766 0 : sym->attr.function = 1;
18767 : }
18768 : }
18769 :
18770 1756746 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
18771 2384 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
18772 :
18773 1530 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
18774 1758276 : && !resolve_procedure_interface (sym))
18775 : return;
18776 :
18777 1756735 : if (sym->attr.is_protected && !sym->attr.proc_pointer
18778 130 : && (sym->attr.procedure || sym->attr.external))
18779 : {
18780 0 : if (sym->attr.external)
18781 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18782 : "at %L", &sym->declared_at);
18783 : else
18784 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18785 : "at %L", &sym->declared_at);
18786 :
18787 : return;
18788 : }
18789 :
18790 : /* Ensure that variables of derived or class type having a finalizer are
18791 : marked used even when the variable is not used anything else in the scope.
18792 : This fixes PR118730. */
18793 679632 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18794 469380 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18795 1807475 : && gfc_may_be_finalized (sym->ts))
18796 8880 : gfc_set_sym_referenced (sym);
18797 :
18798 1756735 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18799 : return;
18800 :
18801 1756590 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18802 1756590 : && !resolve_fl_struct (sym))
18803 : return;
18804 :
18805 : /* Symbols that are module procedures with results (functions) have
18806 : the types and array specification copied for type checking in
18807 : procedures that call them, as well as for saving to a module
18808 : file. These symbols can't stand the scrutiny that their results
18809 : can. */
18810 1756590 : mp_flag = (sym->result != NULL && sym->result != sym);
18811 :
18812 : /* Make sure that the intrinsic is consistent with its internal
18813 : representation. This needs to be done before assigning a default
18814 : type to avoid spurious warnings. */
18815 1720825 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18816 1793872 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18817 : return;
18818 :
18819 : /* Resolve associate names. */
18820 1756554 : if (sym->assoc)
18821 7123 : resolve_assoc_var (sym, true);
18822 :
18823 : /* Assign default type to symbols that need one and don't have one. */
18824 1756554 : if (sym->ts.type == BT_UNKNOWN)
18825 : {
18826 422065 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18827 : {
18828 11847 : gfc_set_default_type (sym, 1, NULL);
18829 : }
18830 :
18831 274248 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18832 65805 : && !sym->attr.function && !sym->attr.subroutine
18833 423738 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18834 622 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18835 :
18836 422065 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18837 : {
18838 : /* The specific case of an external procedure should emit an error
18839 : in the case that there is no implicit type. */
18840 105775 : if (!mp_flag)
18841 : {
18842 99552 : if (!sym->attr.mixed_entry_master)
18843 99444 : gfc_set_default_type (sym, sym->attr.external, NULL);
18844 : }
18845 : else
18846 : {
18847 : /* Result may be in another namespace. */
18848 6223 : resolve_symbol (sym->result);
18849 :
18850 6223 : if (!sym->result->attr.proc_pointer)
18851 : {
18852 6043 : sym->ts = sym->result->ts;
18853 6043 : sym->as = gfc_copy_array_spec (sym->result->as);
18854 6043 : sym->attr.dimension = sym->result->attr.dimension;
18855 6043 : sym->attr.codimension = sym->result->attr.codimension;
18856 6043 : sym->attr.pointer = sym->result->attr.pointer;
18857 6043 : sym->attr.allocatable = sym->result->attr.allocatable;
18858 6043 : sym->attr.contiguous = sym->result->attr.contiguous;
18859 : }
18860 : }
18861 : }
18862 : }
18863 1334489 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18864 31500 : resolve_symbol_array_spec (sym->result, false);
18865 :
18866 : /* For a CLASS-valued function with a result variable, affirm that it has
18867 : been resolved also when looking at the symbol 'sym'. */
18868 453565 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18869 745 : sym->attr.class_ok = sym->result->attr.class_ok;
18870 :
18871 1756554 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18872 20159 : && CLASS_DATA (sym))
18873 : {
18874 20159 : as = CLASS_DATA (sym)->as;
18875 20159 : class_attr = CLASS_DATA (sym)->attr;
18876 20159 : class_attr.pointer = class_attr.class_pointer;
18877 20159 : declared_has_coarray_comp = CLASS_DATA (sym)->ts.u.derived
18878 20159 : && CLASS_DATA (sym)->ts.u.derived->attr.coarray_comp;
18879 : }
18880 : else
18881 : {
18882 1736395 : class_attr = sym->attr;
18883 1736395 : as = sym->as;
18884 : }
18885 :
18886 : /* F2008, C530. */
18887 1756554 : if (sym->attr.contiguous
18888 8546 : && !sym->attr.associate_var
18889 8545 : && (!class_attr.dimension
18890 8542 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18891 140 : && !class_attr.pointer)))
18892 : {
18893 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18894 : "array pointer or an assumed-shape or assumed-rank array",
18895 : sym->name, &sym->declared_at);
18896 7 : return;
18897 : }
18898 :
18899 : /* Assumed size arrays and assumed shape arrays must be dummy
18900 : arguments. Array-spec's of implied-shape should have been resolved to
18901 : AS_EXPLICIT already. */
18902 :
18903 1748145 : if (as)
18904 : {
18905 : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18906 : specification expression. */
18907 152674 : if (as->type == AS_IMPLIED_SHAPE)
18908 : {
18909 : int i;
18910 1 : for (i=0; i<as->rank; i++)
18911 : {
18912 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18913 : {
18914 1 : gfc_error ("Bad specification for assumed size array at %L",
18915 : &as->lower[i]->where);
18916 1 : return;
18917 : }
18918 : }
18919 0 : gcc_unreachable();
18920 : }
18921 :
18922 152673 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18923 117543 : || as->type == AS_ASSUMED_SHAPE)
18924 47508 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18925 8 : && !sym->attr.associate_var)
18926 : {
18927 7 : if (as->type == AS_ASSUMED_SIZE)
18928 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18929 : &sym->declared_at);
18930 : else
18931 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18932 : &sym->declared_at);
18933 : return;
18934 : }
18935 : /* TS 29113, C535a. */
18936 152666 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18937 60 : && !sym->attr.select_type_temporary
18938 60 : && !(cs_base && cs_base->current
18939 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18940 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18941 0 : && cs_base->current->op == EXEC_BLOCK))))
18942 : {
18943 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18944 : &sym->declared_at);
18945 18 : return;
18946 : }
18947 152648 : if (as->type == AS_ASSUMED_RANK
18948 27383 : && (sym->attr.codimension || sym->attr.value))
18949 : {
18950 5 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18951 : "CODIMENSION attribute", &sym->declared_at);
18952 5 : return;
18953 : }
18954 :
18955 : /* F2008, C557 (F2018, C862; F2023, C867). Assumed-shape and
18956 : explicit-shape array dummies may have the VALUE attribute, but
18957 : assumed-size arrays may not. */
18958 152643 : if (as->type == AS_ASSUMED_SIZE && sym->attr.value)
18959 : {
18960 1 : gfc_error ("Assumed-size array %qs at %L may not have the VALUE "
18961 : "attribute", sym->name, &sym->declared_at);
18962 1 : return;
18963 : }
18964 152642 : else if (sym->attr.value && sym->attr.dummy
18965 144 : && (as->type == AS_EXPLICIT || as->type == AS_ASSUMED_SHAPE))
18966 : {
18967 144 : if (!gfc_notify_std (GFC_STD_F2008, "Array dummy argument %qs at "
18968 : "%L with VALUE attribute", sym->name,
18969 : &sym->declared_at))
18970 : return;
18971 :
18972 : /* F2023, 18.3.6 (4): only a scalar VALUE dummy is interoperable
18973 : with a formal parameter of the C prototype. */
18974 143 : if (sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
18975 : {
18976 2 : gfc_error ("Array dummy argument %qs at %L with VALUE attribute "
18977 : "not allowed in BIND(C) procedure %qs", sym->name,
18978 : &sym->declared_at, sym->ns->proc_name->name);
18979 2 : return;
18980 : }
18981 :
18982 141 : if (sym->ts.type == BT_CLASS)
18983 : {
18984 1 : gfc_error ("Sorry, polymorphic array dummy argument %qs at %L "
18985 : "with VALUE attribute is not yet implemented",
18986 : sym->name, &sym->declared_at);
18987 1 : return;
18988 : }
18989 : }
18990 : }
18991 :
18992 : /* Make sure symbols with known intent or optional are really dummy
18993 : variable. Because of ENTRY statement, this has to be deferred
18994 : until resolution time. */
18995 :
18996 1756511 : if (!sym->attr.dummy
18997 1262560 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
18998 : {
18999 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
19000 2 : return;
19001 : }
19002 :
19003 1756509 : if (sym->attr.value && !sym->attr.dummy)
19004 : {
19005 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
19006 : "it is not a dummy argument", sym->name, &sym->declared_at);
19007 2 : return;
19008 : }
19009 :
19010 1756507 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
19011 : {
19012 695 : gfc_charlen *cl = sym->ts.u.cl;
19013 695 : if (!cl)
19014 : {
19015 0 : gfc_error ("Character dummy variable %qs at %L with VALUE "
19016 : "attribute must have a length specification",
19017 : sym->name, &sym->declared_at);
19018 0 : return;
19019 : }
19020 :
19021 : /* C interoperable character dummies must have length one. */
19022 695 : if (sym->ts.is_c_interop
19023 382 : && (!cl->length
19024 381 : || cl->length->expr_type != EXPR_CONSTANT
19025 381 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
19026 : {
19027 2 : gfc_error ("C interoperable character dummy variable %qs at %L "
19028 : "with VALUE attribute must have length one",
19029 : sym->name, &sym->declared_at);
19030 2 : return;
19031 : }
19032 :
19033 : /* Assumed-length character dummy with VALUE, valid since F2008. */
19034 693 : if (!cl->length
19035 693 : && !gfc_notify_std (GFC_STD_F2008, "Assumed-length character "
19036 : "dummy variable %qs at %L with VALUE attribute",
19037 : sym->name, &sym->declared_at))
19038 : return;
19039 :
19040 : /* Likewise for a specified but non-constant length. */
19041 643 : if (cl->length && cl->length->expr_type != EXPR_CONSTANT
19042 715 : && !gfc_notify_std (GFC_STD_F2008, "Character dummy variable "
19043 : "%qs at %L with VALUE attribute and "
19044 : "non-constant length",
19045 24 : sym->name, &sym->declared_at))
19046 : return;
19047 : }
19048 :
19049 1756503 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
19050 126614 : && sym->ts.u.derived->attr.generic)
19051 : {
19052 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
19053 20 : if (!sym->ts.u.derived)
19054 : {
19055 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
19056 : "which has not been defined", sym->name,
19057 : &sym->declared_at, sym->ts.u.derived->name);
19058 0 : sym->ts.type = BT_UNKNOWN;
19059 0 : return;
19060 : }
19061 : }
19062 :
19063 : /* Use the same constraints as TYPE(*), except for the type check
19064 : and that only scalars and assumed-size arrays are permitted. */
19065 1756503 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
19066 : {
19067 14556 : if (!sym->attr.dummy)
19068 : {
19069 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
19070 : "a dummy argument", sym->name, &sym->declared_at);
19071 1 : return;
19072 : }
19073 :
19074 14555 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
19075 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
19076 0 : && sym->ts.type != BT_COMPLEX)
19077 : {
19078 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
19079 : "of type TYPE(*) or of an numeric intrinsic type",
19080 : sym->name, &sym->declared_at);
19081 0 : return;
19082 : }
19083 :
19084 14555 : if (sym->attr.allocatable || sym->attr.codimension
19085 14553 : || sym->attr.pointer || sym->attr.value)
19086 : {
19087 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
19088 : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
19089 : "attribute", sym->name, &sym->declared_at);
19090 4 : return;
19091 : }
19092 :
19093 14551 : if (sym->attr.intent == INTENT_OUT)
19094 : {
19095 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
19096 : "have the INTENT(OUT) attribute",
19097 : sym->name, &sym->declared_at);
19098 0 : return;
19099 : }
19100 14551 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
19101 : {
19102 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
19103 : "either be a scalar or an assumed-size array",
19104 : sym->name, &sym->declared_at);
19105 1 : return;
19106 : }
19107 :
19108 : /* Set the type to TYPE(*) and add a dimension(*) to ensure
19109 : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
19110 : packing. */
19111 14550 : sym->ts.type = BT_ASSUMED;
19112 14550 : sym->as = gfc_get_array_spec ();
19113 14550 : sym->as->type = AS_ASSUMED_SIZE;
19114 14550 : sym->as->rank = 1;
19115 14550 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
19116 : }
19117 1741947 : else if (sym->ts.type == BT_ASSUMED)
19118 : {
19119 : /* TS 29113, C407a. */
19120 12350 : if (!sym->attr.dummy)
19121 : {
19122 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
19123 : "for dummy variables", sym->name, &sym->declared_at);
19124 7 : return;
19125 : }
19126 12343 : if (sym->attr.allocatable || sym->attr.codimension
19127 12339 : || sym->attr.pointer || sym->attr.value)
19128 : {
19129 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
19130 : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
19131 : sym->name, &sym->declared_at);
19132 8 : return;
19133 : }
19134 12335 : if (sym->attr.intent == INTENT_OUT)
19135 : {
19136 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
19137 : "INTENT(OUT) attribute",
19138 : sym->name, &sym->declared_at);
19139 2 : return;
19140 : }
19141 12333 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
19142 : {
19143 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
19144 : "explicit-shape array", sym->name, &sym->declared_at);
19145 3 : return;
19146 : }
19147 : }
19148 :
19149 : /* If the symbol is marked as bind(c), that it is declared at module level
19150 : scope and verify its type and kind. Do not do the latter for symbols
19151 : that are implicitly typed because that is handled in
19152 : gfc_set_default_type. Handle dummy arguments and procedure definitions
19153 : separately. Also, anything that is use associated is not handled here
19154 : but instead is handled in the module it is declared in. Finally, derived
19155 : type definitions are allowed to be BIND(C) since that only implies that
19156 : they're interoperable, and they are checked fully for interoperability
19157 : when a variable is declared of that type. */
19158 1756477 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
19159 7814 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
19160 568 : && sym->attr.flavor != FL_DERIVED)
19161 : {
19162 168 : bool t = true;
19163 :
19164 : /* First, make sure the variable is declared at the
19165 : module-level scope (J3/04-007, Section 15.3). */
19166 168 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
19167 7 : && !sym->attr.in_common)
19168 : {
19169 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
19170 : "is neither a COMMON block nor declared at the "
19171 : "module level scope", sym->name, &(sym->declared_at));
19172 6 : t = false;
19173 : }
19174 162 : else if (sym->ts.type == BT_CHARACTER
19175 162 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
19176 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
19177 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
19178 : {
19179 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
19180 1 : sym->name, &sym->declared_at);
19181 1 : t = false;
19182 : }
19183 161 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
19184 : {
19185 1 : t = verify_com_block_vars_c_interop (sym->common_head);
19186 : }
19187 160 : else if (sym->attr.implicit_type == 0)
19188 : {
19189 : /* If type() declaration, we need to verify that the components
19190 : of the given type are all C interoperable, etc. */
19191 158 : if (sym->ts.type == BT_DERIVED &&
19192 24 : sym->ts.u.derived->attr.is_c_interop != 1)
19193 : {
19194 : /* Make sure the user marked the derived type as BIND(C). If
19195 : not, call the verify routine. This could print an error
19196 : for the derived type more than once if multiple variables
19197 : of that type are declared. */
19198 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
19199 1 : verify_bind_c_derived_type (sym->ts.u.derived);
19200 158 : t = false;
19201 : }
19202 :
19203 : /* Verify the variable itself as C interoperable if it
19204 : is BIND(C). It is not possible for this to succeed if
19205 : the verify_bind_c_derived_type failed, so don't have to handle
19206 : any error returned by verify_bind_c_derived_type. */
19207 158 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
19208 158 : sym->common_block);
19209 : }
19210 :
19211 166 : if (!t)
19212 : {
19213 : /* clear the is_bind_c flag to prevent reporting errors more than
19214 : once if something failed. */
19215 10 : sym->attr.is_bind_c = 0;
19216 10 : return;
19217 : }
19218 : }
19219 :
19220 : /* If a derived type symbol has reached this point, without its
19221 : type being declared, we have an error. Notice that most
19222 : conditions that produce undefined derived types have already
19223 : been dealt with. However, the likes of:
19224 : implicit type(t) (t) ..... call foo (t) will get us here if
19225 : the type is not declared in the scope of the implicit
19226 : statement. Change the type to BT_UNKNOWN, both because it is so
19227 : and to prevent an ICE. */
19228 1756467 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
19229 126612 : && sym->ts.u.derived->components == NULL
19230 1177 : && !sym->ts.u.derived->attr.zero_comp)
19231 : {
19232 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
19233 : "which has not been defined", sym->name,
19234 : &sym->declared_at, sym->ts.u.derived->name);
19235 3 : sym->ts.type = BT_UNKNOWN;
19236 3 : return;
19237 : }
19238 :
19239 : /* Make sure that the derived type has been resolved and that the
19240 : derived type is visible in the symbol's namespace, if it is a
19241 : module function and is not PRIVATE. */
19242 1756464 : if (sym->ts.type == BT_DERIVED
19243 133771 : && sym->ts.u.derived->attr.use_assoc
19244 115682 : && sym->ns->proc_name
19245 115674 : && sym->ns->proc_name->attr.flavor == FL_MODULE
19246 1762437 : && !resolve_fl_derived (sym->ts.u.derived))
19247 : return;
19248 :
19249 : /* Unless the derived-type declaration is use associated, Fortran 95
19250 : does not allow public entries of private derived types.
19251 : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
19252 : 161 in 95-006r3. */
19253 1756464 : if (sym->ts.type == BT_DERIVED
19254 133771 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
19255 8141 : && !sym->ts.u.derived->attr.use_assoc
19256 2168 : && gfc_check_symbol_access (sym)
19257 1955 : && !gfc_check_symbol_access (sym->ts.u.derived)
19258 1756478 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
19259 : "derived type %qs",
19260 14 : (sym->attr.flavor == FL_PARAMETER)
19261 : ? "parameter" : "variable",
19262 : sym->name, &sym->declared_at,
19263 14 : sym->ts.u.derived->name))
19264 : return;
19265 :
19266 : /* F2008, C1302. */
19267 1756457 : if (sym->ts.type == BT_DERIVED
19268 133764 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19269 180 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
19270 133733 : || sym->ts.u.derived->attr.lock_comp)
19271 44 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19272 : {
19273 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
19274 : "type LOCK_TYPE must be a coarray", sym->name,
19275 : &sym->declared_at);
19276 4 : return;
19277 : }
19278 :
19279 : /* TS18508, C702/C703. */
19280 1756453 : if (sym->ts.type == BT_DERIVED
19281 133760 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19282 179 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
19283 133743 : || sym->ts.u.derived->attr.event_comp)
19284 17 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19285 : {
19286 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
19287 : "type EVENT_TYPE must be a coarray", sym->name,
19288 : &sym->declared_at);
19289 1 : return;
19290 : }
19291 :
19292 : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
19293 : default initialization is defined (5.1.2.4.4). */
19294 1756452 : if (sym->ts.type == BT_DERIVED
19295 133759 : && sym->attr.dummy
19296 45890 : && sym->attr.intent == INTENT_OUT
19297 2357 : && sym->as
19298 382 : && sym->as->type == AS_ASSUMED_SIZE)
19299 : {
19300 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
19301 : {
19302 1 : if (c->initializer)
19303 : {
19304 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
19305 : "ASSUMED SIZE and so cannot have a default initializer",
19306 : sym->name, &sym->declared_at);
19307 1 : return;
19308 : }
19309 : }
19310 : }
19311 :
19312 : /* F2008, C542. */
19313 1756451 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19314 45889 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
19315 : {
19316 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
19317 : "INTENT(OUT)", sym->name, &sym->declared_at);
19318 0 : return;
19319 : }
19320 :
19321 : /* TS18508. */
19322 1756451 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19323 45889 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
19324 : {
19325 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
19326 : "INTENT(OUT)", sym->name, &sym->declared_at);
19327 0 : return;
19328 : }
19329 :
19330 : /* F2008, C525. */
19331 1756451 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19332 1756338 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19333 20161 : && sym->ts.u.derived && CLASS_DATA (sym)
19334 20156 : && CLASS_DATA (sym)->attr.coarray_comp))
19335 1756338 : || class_attr.codimension)
19336 1857 : && (sym->attr.result || sym->result == sym))
19337 : {
19338 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
19339 : "a coarray component", sym->name, &sym->declared_at);
19340 8 : return;
19341 : }
19342 :
19343 : /* F2008, C524. */
19344 1756443 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
19345 429 : && sym->ts.u.derived->ts.is_iso_c)
19346 : {
19347 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
19348 : "shall not be a coarray", sym->name, &sym->declared_at);
19349 3 : return;
19350 : }
19351 :
19352 : /* F2008, C525. */
19353 1756440 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19354 1756330 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19355 20160 : && sym->ts.u.derived && CLASS_DATA (sym)
19356 20155 : && CLASS_DATA (sym)->attr.coarray_comp))
19357 110 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
19358 106 : || class_attr.allocatable))
19359 : {
19360 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
19361 : "nonpointer, nonallocatable scalar, which is not a coarray",
19362 : sym->name, &sym->declared_at);
19363 4 : return;
19364 : }
19365 :
19366 : /* F2008, C526. The function-result case was handled above. */
19367 1756436 : if (class_attr.codimension
19368 1736 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
19369 364 : || sym->attr.select_type_temporary
19370 288 : || sym->attr.associate_var
19371 270 : || (sym->ns->save_all && !sym->attr.automatic)
19372 270 : || sym->ns->proc_name->attr.flavor == FL_MODULE
19373 270 : || sym->ns->proc_name->attr.is_main_program
19374 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
19375 : {
19376 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
19377 : "nor a dummy argument", sym->name, &sym->declared_at);
19378 4 : return;
19379 : }
19380 : /* F2008, C528. */
19381 1756432 : else if (class_attr.codimension && !sym->attr.select_type_temporary
19382 1656 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
19383 : {
19384 7 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
19385 : "deferred shape without allocatable", sym->name,
19386 : &sym->declared_at);
19387 7 : return;
19388 : }
19389 1756425 : else if (class_attr.codimension && class_attr.allocatable && as
19390 642 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
19391 : {
19392 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
19393 : "deferred shape", sym->name, &sym->declared_at);
19394 9 : return;
19395 : }
19396 :
19397 : /* F2008, C541. */
19398 1756416 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19399 1756310 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19400 20155 : && declared_has_coarray_comp))
19401 1756303 : || (class_attr.codimension && class_attr.allocatable))
19402 746 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
19403 : {
19404 4 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
19405 : "allocatable coarray or have coarray components",
19406 : sym->name, &sym->declared_at);
19407 4 : return;
19408 : }
19409 :
19410 1756412 : if (class_attr.codimension && sym->attr.dummy
19411 469 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
19412 : {
19413 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
19414 : "procedure %qs", sym->name, &sym->declared_at,
19415 : sym->ns->proc_name->name);
19416 2 : return;
19417 : }
19418 :
19419 1756410 : if (sym->ts.type == BT_LOGICAL
19420 114582 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
19421 114579 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
19422 32780 : && sym->ns->proc_name->attr.is_bind_c)))
19423 : {
19424 : int i;
19425 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
19426 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
19427 : break;
19428 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
19429 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
19430 : "%L with non-C_Bool kind in BIND(C) procedure "
19431 : "%qs", sym->name, &sym->declared_at,
19432 13 : sym->ns->proc_name->name))
19433 : return;
19434 167 : else if (!gfc_logical_kinds[i].c_bool
19435 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
19436 : "%qs at %L with non-C_Bool kind in "
19437 : "BIND(C) procedure %qs", sym->name,
19438 : &sym->declared_at,
19439 15 : sym->attr.function ? sym->name
19440 13 : : sym->ns->proc_name->name))
19441 : return;
19442 : }
19443 :
19444 1756407 : switch (sym->attr.flavor)
19445 : {
19446 679504 : case FL_VARIABLE:
19447 679504 : if (!resolve_fl_variable (sym, mp_flag))
19448 : return;
19449 : break;
19450 :
19451 502103 : case FL_PROCEDURE:
19452 502103 : if (sym->formal && !sym->formal_ns)
19453 : {
19454 : /* Check that none of the arguments are a namelist. */
19455 : gfc_formal_arglist *formal = sym->formal;
19456 :
19457 108040 : for (; formal; formal = formal->next)
19458 73163 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
19459 : {
19460 1 : gfc_error ("Namelist %qs cannot be an argument to "
19461 : "subroutine or function at %L",
19462 : formal->sym->name, &sym->declared_at);
19463 1 : return;
19464 : }
19465 : }
19466 :
19467 502102 : if (!resolve_fl_procedure (sym, mp_flag))
19468 : return;
19469 : break;
19470 :
19471 875 : case FL_NAMELIST:
19472 875 : if (!resolve_fl_namelist (sym))
19473 : return;
19474 : break;
19475 :
19476 411872 : case FL_PARAMETER:
19477 411872 : if (!resolve_fl_parameter (sym))
19478 : return;
19479 : break;
19480 :
19481 : default:
19482 : break;
19483 : }
19484 :
19485 : /* Resolve array specifier. Check as well some constraints
19486 : on COMMON blocks. */
19487 :
19488 1756210 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
19489 :
19490 1756210 : resolve_symbol_array_spec (sym, check_constant);
19491 :
19492 : /* Resolve formal namespaces. */
19493 1756210 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
19494 279573 : && !sym->attr.contained && !sym->attr.intrinsic)
19495 249807 : gfc_resolve (sym->formal_ns);
19496 :
19497 : /* Make sure the formal namespace is present. */
19498 1756210 : if (sym->formal && !sym->formal_ns)
19499 : {
19500 : gfc_formal_arglist *formal = sym->formal;
19501 35418 : while (formal && !formal->sym)
19502 11 : formal = formal->next;
19503 :
19504 35407 : if (formal)
19505 : {
19506 35396 : sym->formal_ns = formal->sym->ns;
19507 35396 : if (sym->formal_ns && sym->ns != formal->sym->ns)
19508 26932 : sym->formal_ns->refs++;
19509 : }
19510 : }
19511 :
19512 : /* Check threadprivate restrictions. */
19513 1756210 : if ((sym->attr.threadprivate || sym->attr.omp_groupprivate)
19514 387 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
19515 33 : && !(sym->ns->save_all && !sym->attr.automatic)
19516 32 : && sym->module == NULL
19517 17 : && (sym->ns->proc_name == NULL
19518 17 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19519 4 : && !sym->ns->proc_name->attr.is_main_program)))
19520 : {
19521 2 : if (sym->attr.threadprivate)
19522 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
19523 : else
19524 1 : gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE "
19525 : "attribute", sym->name, &sym->declared_at);
19526 : }
19527 :
19528 1756210 : if (sym->attr.omp_groupprivate && sym->value)
19529 2 : gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an "
19530 : "initializer", sym->name, &sym->declared_at);
19531 :
19532 : /* Check omp declare target restrictions. */
19533 1756210 : if ((sym->attr.omp_declare_target
19534 1754786 : || sym->attr.omp_declare_target_link
19535 1754737 : || sym->attr.omp_declare_target_local)
19536 1521 : && !sym->attr.omp_groupprivate /* already warned. */
19537 1471 : && sym->attr.flavor == FL_VARIABLE
19538 628 : && !sym->attr.save
19539 206 : && !(sym->ns->save_all && !sym->attr.automatic)
19540 206 : && (!sym->attr.in_common
19541 192 : && sym->module == NULL
19542 102 : && (sym->ns->proc_name == NULL
19543 102 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19544 12 : && !sym->ns->proc_name->attr.is_main_program))))
19545 4 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
19546 : sym->name, &sym->declared_at);
19547 :
19548 : /* If we have come this far we can apply default-initializers, as
19549 : described in 14.7.5, to those variables that have not already
19550 : been assigned one. */
19551 1756210 : if (sym->ts.type == BT_DERIVED
19552 133729 : && !sym->value
19553 108319 : && !sym->attr.allocatable
19554 105261 : && !sym->attr.alloc_comp)
19555 : {
19556 105190 : symbol_attribute *a = &sym->attr;
19557 :
19558 105190 : if ((!a->save && !a->dummy && !a->pointer
19559 57895 : && !a->in_common && !a->use_assoc
19560 10803 : && a->referenced
19561 8508 : && !((a->function || a->result)
19562 1711 : && (!a->dimension
19563 160 : || sym->ts.u.derived->attr.alloc_comp
19564 95 : || sym->ts.u.derived->attr.pointer_comp))
19565 6878 : && !(a->function && sym != sym->result))
19566 98332 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
19567 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
19568 8287 : apply_default_init (sym);
19569 96903 : else if (a->function && !a->pointer && !a->allocatable
19570 21060 : && !a->use_assoc && !a->used_in_submodule && sym->result)
19571 : /* Default initialization for function results. */
19572 2759 : apply_default_init (sym->result);
19573 94144 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
19574 12040 : && (sym->ts.u.derived->attr.alloc_comp
19575 11475 : || sym->ts.u.derived->attr.pointer_comp))
19576 : /* Mark the result symbol to be referenced, when it has allocatable
19577 : components. */
19578 624 : sym->result->attr.referenced = 1;
19579 : }
19580 :
19581 1756210 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
19582 19642 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
19583 1322 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
19584 1247 : && !CLASS_DATA (sym)->attr.class_pointer
19585 1221 : && !CLASS_DATA (sym)->attr.allocatable)
19586 913 : apply_default_init (sym);
19587 :
19588 : /* If this symbol has a type-spec, check it. */
19589 1756210 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
19590 664944 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
19591 1424835 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
19592 : return;
19593 :
19594 1756207 : if (sym->param_list)
19595 1576 : resolve_pdt (sym);
19596 : }
19597 :
19598 :
19599 4151 : void gfc_resolve_symbol (gfc_symbol *sym)
19600 : {
19601 4151 : resolve_symbol (sym);
19602 4151 : return;
19603 : }
19604 :
19605 :
19606 : /************* Resolve DATA statements *************/
19607 :
19608 : static struct
19609 : {
19610 : gfc_data_value *vnode;
19611 : mpz_t left;
19612 : }
19613 : values;
19614 :
19615 :
19616 : /* Advance the values structure to point to the next value in the data list. */
19617 :
19618 : static bool
19619 10892 : next_data_value (void)
19620 : {
19621 16660 : while (mpz_cmp_ui (values.left, 0) == 0)
19622 : {
19623 :
19624 8198 : if (values.vnode->next == NULL)
19625 : return false;
19626 :
19627 5768 : values.vnode = values.vnode->next;
19628 5768 : mpz_set (values.left, values.vnode->repeat);
19629 : }
19630 :
19631 : return true;
19632 : }
19633 :
19634 :
19635 : static bool
19636 3557 : check_data_variable (gfc_data_variable *var, locus *where)
19637 : {
19638 3557 : gfc_expr *e;
19639 3557 : mpz_t size;
19640 3557 : mpz_t offset;
19641 3557 : bool t;
19642 3557 : ar_type mark = AR_UNKNOWN;
19643 3557 : int i;
19644 3557 : mpz_t section_index[GFC_MAX_DIMENSIONS];
19645 3557 : int vector_offset[GFC_MAX_DIMENSIONS];
19646 3557 : gfc_ref *ref;
19647 3557 : gfc_array_ref *ar;
19648 3557 : gfc_symbol *sym;
19649 3557 : int has_pointer;
19650 :
19651 3557 : if (!gfc_resolve_expr (var->expr))
19652 : return false;
19653 :
19654 3557 : ar = NULL;
19655 3557 : e = var->expr;
19656 :
19657 3557 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
19658 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
19659 0 : e = e->value.function.actual->expr;
19660 :
19661 3557 : if (e->expr_type != EXPR_VARIABLE)
19662 : {
19663 0 : gfc_error ("Expecting definable entity near %L", where);
19664 0 : return false;
19665 : }
19666 :
19667 3557 : sym = e->symtree->n.sym;
19668 :
19669 3557 : if (sym->ns->is_block_data && !sym->attr.in_common)
19670 : {
19671 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
19672 : sym->name, &sym->declared_at);
19673 2 : return false;
19674 : }
19675 :
19676 3555 : if (e->ref == NULL && sym->as)
19677 : {
19678 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
19679 : " declaration", sym->name, where);
19680 1 : return false;
19681 : }
19682 :
19683 3554 : if (gfc_is_coindexed (e))
19684 : {
19685 7 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
19686 : where);
19687 7 : return false;
19688 : }
19689 :
19690 3547 : has_pointer = sym->attr.pointer;
19691 :
19692 5988 : for (ref = e->ref; ref; ref = ref->next)
19693 : {
19694 2445 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
19695 : has_pointer = 1;
19696 :
19697 2419 : if (has_pointer)
19698 : {
19699 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
19700 : {
19701 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
19702 : "be a full array", sym->name, where);
19703 1 : return false;
19704 : }
19705 :
19706 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
19707 : {
19708 1 : gfc_error ("DATA object near %L has the pointer attribute "
19709 : "and the corresponding DATA value is not a valid "
19710 : "initial-data-target", where);
19711 1 : return false;
19712 : }
19713 : }
19714 :
19715 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
19716 : {
19717 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
19718 : "attribute", ref->u.c.component->name, &e->where);
19719 1 : return false;
19720 : }
19721 :
19722 : /* Reject substrings of strings of non-constant length. */
19723 2442 : if (ref->type == REF_SUBSTRING
19724 73 : && ref->u.ss.length
19725 73 : && ref->u.ss.length->length
19726 2515 : && !gfc_is_constant_expr (ref->u.ss.length->length))
19727 1 : goto bad_charlen;
19728 : }
19729 :
19730 : /* Reject strings with deferred length or non-constant length. */
19731 3543 : if (e->ts.type == BT_CHARACTER
19732 3543 : && (e->ts.deferred
19733 374 : || (e->ts.u.cl->length
19734 323 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
19735 5 : goto bad_charlen;
19736 :
19737 3538 : mpz_init_set_si (offset, 0);
19738 :
19739 3538 : if (e->rank == 0 || has_pointer)
19740 : {
19741 2691 : mpz_init_set_ui (size, 1);
19742 2691 : ref = NULL;
19743 : }
19744 : else
19745 : {
19746 847 : ref = e->ref;
19747 :
19748 : /* Find the array section reference. */
19749 1030 : for (ref = e->ref; ref; ref = ref->next)
19750 : {
19751 1030 : if (ref->type != REF_ARRAY)
19752 92 : continue;
19753 938 : if (ref->u.ar.type == AR_ELEMENT)
19754 91 : continue;
19755 : break;
19756 : }
19757 847 : gcc_assert (ref);
19758 :
19759 : /* Set marks according to the reference pattern. */
19760 847 : switch (ref->u.ar.type)
19761 : {
19762 : case AR_FULL:
19763 : mark = AR_FULL;
19764 : break;
19765 :
19766 151 : case AR_SECTION:
19767 151 : ar = &ref->u.ar;
19768 : /* Get the start position of array section. */
19769 151 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
19770 151 : mark = AR_SECTION;
19771 151 : break;
19772 :
19773 0 : default:
19774 0 : gcc_unreachable ();
19775 : }
19776 :
19777 847 : if (!gfc_array_size (e, &size))
19778 : {
19779 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
19780 : where);
19781 1 : mpz_clear (offset);
19782 1 : return false;
19783 : }
19784 : }
19785 :
19786 3537 : t = true;
19787 :
19788 11937 : while (mpz_cmp_ui (size, 0) > 0)
19789 : {
19790 8463 : if (!next_data_value ())
19791 : {
19792 1 : gfc_error ("DATA statement at %L has more variables than values",
19793 : where);
19794 1 : t = false;
19795 1 : break;
19796 : }
19797 :
19798 8462 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
19799 8462 : if (!t)
19800 : break;
19801 :
19802 : /* If we have more than one element left in the repeat count,
19803 : and we have more than one element left in the target variable,
19804 : then create a range assignment. */
19805 : /* FIXME: Only done for full arrays for now, since array sections
19806 : seem tricky. */
19807 8443 : if (mark == AR_FULL && ref && ref->next == NULL
19808 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
19809 : {
19810 137 : mpz_t range;
19811 :
19812 137 : if (mpz_cmp (size, values.left) >= 0)
19813 : {
19814 126 : mpz_init_set (range, values.left);
19815 126 : mpz_sub (size, size, values.left);
19816 126 : mpz_set_ui (values.left, 0);
19817 : }
19818 : else
19819 : {
19820 11 : mpz_init_set (range, size);
19821 11 : mpz_sub (values.left, values.left, size);
19822 11 : mpz_set_ui (size, 0);
19823 : }
19824 :
19825 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19826 : offset, &range);
19827 :
19828 137 : mpz_add (offset, offset, range);
19829 137 : mpz_clear (range);
19830 :
19831 137 : if (!t)
19832 : break;
19833 129 : }
19834 :
19835 : /* Assign initial value to symbol. */
19836 : else
19837 : {
19838 8306 : mpz_sub_ui (values.left, values.left, 1);
19839 8306 : mpz_sub_ui (size, size, 1);
19840 :
19841 8306 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19842 : offset, NULL);
19843 8306 : if (!t)
19844 : break;
19845 :
19846 8271 : if (mark == AR_FULL)
19847 5259 : mpz_add_ui (offset, offset, 1);
19848 :
19849 : /* Modify the array section indexes and recalculate the offset
19850 : for next element. */
19851 3012 : else if (mark == AR_SECTION)
19852 366 : gfc_advance_section (section_index, ar, &offset, vector_offset);
19853 : }
19854 : }
19855 :
19856 3537 : if (mark == AR_SECTION)
19857 : {
19858 344 : for (i = 0; i < ar->dimen; i++)
19859 194 : mpz_clear (section_index[i]);
19860 : }
19861 :
19862 3537 : mpz_clear (size);
19863 3537 : mpz_clear (offset);
19864 :
19865 3537 : return t;
19866 :
19867 6 : bad_charlen:
19868 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19869 : &e->where);
19870 6 : return false;
19871 : }
19872 :
19873 :
19874 : static bool traverse_data_var (gfc_data_variable *, locus *);
19875 :
19876 : /* Iterate over a list of elements in a DATA statement. */
19877 :
19878 : static bool
19879 237 : traverse_data_list (gfc_data_variable *var, locus *where)
19880 : {
19881 237 : mpz_t trip;
19882 237 : iterator_stack frame;
19883 237 : gfc_expr *e, *start, *end, *step;
19884 237 : bool retval = true;
19885 :
19886 237 : mpz_init (frame.value);
19887 237 : mpz_init (trip);
19888 :
19889 237 : start = gfc_copy_expr (var->iter.start);
19890 237 : end = gfc_copy_expr (var->iter.end);
19891 237 : step = gfc_copy_expr (var->iter.step);
19892 :
19893 237 : if (!gfc_simplify_expr (start, 1)
19894 237 : || start->expr_type != EXPR_CONSTANT)
19895 : {
19896 0 : gfc_error ("start of implied-do loop at %L could not be "
19897 : "simplified to a constant value", &start->where);
19898 0 : retval = false;
19899 0 : goto cleanup;
19900 : }
19901 237 : if (!gfc_simplify_expr (end, 1)
19902 237 : || end->expr_type != EXPR_CONSTANT)
19903 : {
19904 0 : gfc_error ("end of implied-do loop at %L could not be "
19905 : "simplified to a constant value", &end->where);
19906 0 : retval = false;
19907 0 : goto cleanup;
19908 : }
19909 237 : if (!gfc_simplify_expr (step, 1)
19910 237 : || step->expr_type != EXPR_CONSTANT)
19911 : {
19912 0 : gfc_error ("step of implied-do loop at %L could not be "
19913 : "simplified to a constant value", &step->where);
19914 0 : retval = false;
19915 0 : goto cleanup;
19916 : }
19917 237 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19918 : {
19919 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19920 : &step->where);
19921 1 : retval = false;
19922 1 : goto cleanup;
19923 : }
19924 :
19925 236 : mpz_set (trip, end->value.integer);
19926 236 : mpz_sub (trip, trip, start->value.integer);
19927 236 : mpz_add (trip, trip, step->value.integer);
19928 :
19929 236 : mpz_div (trip, trip, step->value.integer);
19930 :
19931 236 : mpz_set (frame.value, start->value.integer);
19932 :
19933 236 : frame.prev = iter_stack;
19934 236 : frame.variable = var->iter.var->symtree;
19935 236 : iter_stack = &frame;
19936 :
19937 1127 : while (mpz_cmp_ui (trip, 0) > 0)
19938 : {
19939 905 : if (!traverse_data_var (var->list, where))
19940 : {
19941 14 : retval = false;
19942 14 : goto cleanup;
19943 : }
19944 :
19945 891 : e = gfc_copy_expr (var->expr);
19946 891 : if (!gfc_simplify_expr (e, 1))
19947 : {
19948 0 : gfc_free_expr (e);
19949 0 : retval = false;
19950 0 : goto cleanup;
19951 : }
19952 :
19953 891 : mpz_add (frame.value, frame.value, step->value.integer);
19954 :
19955 891 : mpz_sub_ui (trip, trip, 1);
19956 : }
19957 :
19958 222 : cleanup:
19959 237 : mpz_clear (frame.value);
19960 237 : mpz_clear (trip);
19961 :
19962 237 : gfc_free_expr (start);
19963 237 : gfc_free_expr (end);
19964 237 : gfc_free_expr (step);
19965 :
19966 237 : iter_stack = frame.prev;
19967 237 : return retval;
19968 : }
19969 :
19970 :
19971 : /* Type resolve variables in the variable list of a DATA statement. */
19972 :
19973 : static bool
19974 3418 : traverse_data_var (gfc_data_variable *var, locus *where)
19975 : {
19976 3418 : bool t;
19977 :
19978 7114 : for (; var; var = var->next)
19979 : {
19980 3794 : if (var->expr == NULL)
19981 237 : t = traverse_data_list (var, where);
19982 : else
19983 3557 : t = check_data_variable (var, where);
19984 :
19985 3794 : if (!t)
19986 : return false;
19987 : }
19988 :
19989 : return true;
19990 : }
19991 :
19992 :
19993 : /* Resolve the expressions and iterators associated with a data statement.
19994 : This is separate from the assignment checking because data lists should
19995 : only be resolved once. */
19996 :
19997 : static bool
19998 2668 : resolve_data_variables (gfc_data_variable *d)
19999 : {
20000 5707 : for (; d; d = d->next)
20001 : {
20002 3044 : if (d->list == NULL)
20003 : {
20004 2891 : if (!gfc_resolve_expr (d->expr))
20005 : return false;
20006 : }
20007 : else
20008 : {
20009 153 : if (!gfc_resolve_iterator (&d->iter, false, true))
20010 : return false;
20011 :
20012 150 : if (!resolve_data_variables (d->list))
20013 : return false;
20014 : }
20015 : }
20016 :
20017 : return true;
20018 : }
20019 :
20020 :
20021 : /* Resolve a single DATA statement. We implement this by storing a pointer to
20022 : the value list into static variables, and then recursively traversing the
20023 : variables list, expanding iterators and such. */
20024 :
20025 : static void
20026 2518 : resolve_data (gfc_data *d)
20027 : {
20028 :
20029 2518 : if (!resolve_data_variables (d->var))
20030 : return;
20031 :
20032 2513 : values.vnode = d->value;
20033 2513 : if (d->value == NULL)
20034 0 : mpz_set_ui (values.left, 0);
20035 : else
20036 2513 : mpz_set (values.left, d->value->repeat);
20037 :
20038 2513 : if (!traverse_data_var (d->var, &d->where))
20039 : return;
20040 :
20041 : /* At this point, we better not have any values left. */
20042 :
20043 2429 : if (next_data_value ())
20044 0 : gfc_error ("DATA statement at %L has more values than variables",
20045 : &d->where);
20046 : }
20047 :
20048 :
20049 : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
20050 : accessed by host or use association, is a dummy argument to a pure function,
20051 : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
20052 : is storage associated with any such variable, shall not be used in the
20053 : following contexts: (clients of this function). */
20054 :
20055 : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
20056 : procedure. Returns zero if assignment is OK, nonzero if there is a
20057 : problem. */
20058 : bool
20059 57368 : gfc_impure_variable (gfc_symbol *sym)
20060 : {
20061 57368 : gfc_symbol *proc;
20062 57368 : gfc_namespace *ns;
20063 :
20064 57368 : if (sym->attr.use_assoc || sym->attr.in_common)
20065 : return 1;
20066 :
20067 : /* The namespace of a module procedure interface holds the arguments and
20068 : symbols, and so the symbol namespace can be different to that of the
20069 : procedure. */
20070 56738 : if (sym->ns != gfc_current_ns
20071 6075 : && gfc_current_ns->proc_name->abr_modproc_decl
20072 48 : && sym->ns->proc_name->attr.function
20073 12 : && sym->attr.result
20074 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
20075 : return 0;
20076 :
20077 : /* Check if the symbol's ns is inside the pure procedure. */
20078 61510 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20079 : {
20080 61226 : if (ns == sym->ns)
20081 : break;
20082 6394 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
20083 5264 : && !(sym->attr.function || sym->attr.result))
20084 : return 1;
20085 : }
20086 :
20087 55116 : proc = sym->ns->proc_name;
20088 55116 : if (sym->attr.dummy
20089 6081 : && !sym->attr.value
20090 5959 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
20091 5753 : || proc->attr.function))
20092 700 : return 1;
20093 :
20094 : /* TODO: Sort out what can be storage associated, if anything, and include
20095 : it here. In principle equivalences should be scanned but it does not
20096 : seem to be possible to storage associate an impure variable this way. */
20097 : return 0;
20098 : }
20099 :
20100 :
20101 : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
20102 : current namespace is inside a pure procedure. */
20103 :
20104 : bool
20105 2392621 : gfc_pure (gfc_symbol *sym)
20106 : {
20107 2392621 : symbol_attribute attr;
20108 2392621 : gfc_namespace *ns;
20109 :
20110 2392621 : if (sym == NULL)
20111 : {
20112 : /* Check if the current namespace or one of its parents
20113 : belongs to a pure procedure. */
20114 3230927 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20115 : {
20116 1909247 : sym = ns->proc_name;
20117 1909247 : if (sym == NULL)
20118 : return 0;
20119 1908106 : attr = sym->attr;
20120 1908106 : if (attr.flavor == FL_PROCEDURE && attr.pure)
20121 : return 1;
20122 : }
20123 : return 0;
20124 : }
20125 :
20126 1062214 : attr = sym->attr;
20127 :
20128 1062214 : return attr.flavor == FL_PROCEDURE && attr.pure;
20129 : }
20130 :
20131 :
20132 : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
20133 : checks if the current namespace is implicitly pure. Note that this
20134 : function returns false for a PURE procedure. */
20135 :
20136 : bool
20137 734757 : gfc_implicit_pure (gfc_symbol *sym)
20138 : {
20139 734757 : gfc_namespace *ns;
20140 :
20141 734757 : if (sym == NULL)
20142 : {
20143 : /* Check if the current procedure is implicit_pure. Walk up
20144 : the procedure list until we find a procedure. */
20145 1012951 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20146 : {
20147 722785 : sym = ns->proc_name;
20148 722785 : if (sym == NULL)
20149 : return 0;
20150 :
20151 722712 : if (sym->attr.flavor == FL_PROCEDURE)
20152 : break;
20153 : }
20154 : }
20155 :
20156 444515 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
20157 762856 : && !sym->attr.pure;
20158 : }
20159 :
20160 :
20161 : void
20162 431962 : gfc_unset_implicit_pure (gfc_symbol *sym)
20163 : {
20164 431962 : gfc_namespace *ns;
20165 :
20166 431962 : if (sym == NULL)
20167 : {
20168 : /* Check if the current procedure is implicit_pure. Walk up
20169 : the procedure list until we find a procedure. */
20170 706150 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20171 : {
20172 436888 : sym = ns->proc_name;
20173 436888 : if (sym == NULL)
20174 : return;
20175 :
20176 436055 : if (sym->attr.flavor == FL_PROCEDURE)
20177 : break;
20178 : }
20179 : }
20180 :
20181 431129 : if (sym->attr.flavor == FL_PROCEDURE)
20182 153348 : sym->attr.implicit_pure = 0;
20183 : else
20184 277781 : sym->attr.pure = 0;
20185 : }
20186 :
20187 :
20188 : /* Test whether the current procedure is elemental or not. */
20189 :
20190 : bool
20191 1432859 : gfc_elemental (gfc_symbol *sym)
20192 : {
20193 1432859 : symbol_attribute attr;
20194 :
20195 1432859 : if (sym == NULL)
20196 0 : sym = gfc_current_ns->proc_name;
20197 0 : if (sym == NULL)
20198 : return 0;
20199 1432859 : attr = sym->attr;
20200 :
20201 1432859 : return attr.flavor == FL_PROCEDURE && attr.elemental;
20202 : }
20203 :
20204 :
20205 : /* Warn about unused labels. */
20206 :
20207 : static void
20208 4843 : warn_unused_fortran_label (gfc_st_label *label)
20209 : {
20210 4869 : if (label == NULL)
20211 : return;
20212 :
20213 27 : warn_unused_fortran_label (label->left);
20214 :
20215 27 : if (label->defined == ST_LABEL_UNKNOWN)
20216 : return;
20217 :
20218 26 : switch (label->referenced)
20219 : {
20220 2 : case ST_LABEL_UNKNOWN:
20221 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
20222 : label->value, &label->where);
20223 2 : break;
20224 :
20225 1 : case ST_LABEL_BAD_TARGET:
20226 1 : gfc_warning (OPT_Wunused_label,
20227 : "Label %d at %L defined but cannot be used",
20228 : label->value, &label->where);
20229 1 : break;
20230 :
20231 : default:
20232 : break;
20233 : }
20234 :
20235 26 : warn_unused_fortran_label (label->right);
20236 : }
20237 :
20238 :
20239 : /* Returns the sequence type of a symbol or sequence. */
20240 :
20241 : static seq_type
20242 1076 : sequence_type (gfc_typespec ts)
20243 : {
20244 1076 : seq_type result;
20245 1076 : gfc_component *c;
20246 :
20247 1076 : switch (ts.type)
20248 : {
20249 49 : case BT_DERIVED:
20250 :
20251 49 : if (ts.u.derived->components == NULL)
20252 : return SEQ_NONDEFAULT;
20253 :
20254 49 : result = sequence_type (ts.u.derived->components->ts);
20255 103 : for (c = ts.u.derived->components->next; c; c = c->next)
20256 67 : if (sequence_type (c->ts) != result)
20257 : return SEQ_MIXED;
20258 :
20259 : return result;
20260 :
20261 129 : case BT_CHARACTER:
20262 129 : if (ts.kind != gfc_default_character_kind)
20263 0 : return SEQ_NONDEFAULT;
20264 :
20265 : return SEQ_CHARACTER;
20266 :
20267 240 : case BT_INTEGER:
20268 240 : if (ts.kind != gfc_default_integer_kind)
20269 25 : return SEQ_NONDEFAULT;
20270 :
20271 : return SEQ_NUMERIC;
20272 :
20273 559 : case BT_REAL:
20274 559 : if (!(ts.kind == gfc_default_real_kind
20275 269 : || ts.kind == gfc_default_double_kind))
20276 0 : return SEQ_NONDEFAULT;
20277 :
20278 : return SEQ_NUMERIC;
20279 :
20280 81 : case BT_COMPLEX:
20281 81 : if (ts.kind != gfc_default_complex_kind)
20282 48 : return SEQ_NONDEFAULT;
20283 :
20284 : return SEQ_NUMERIC;
20285 :
20286 17 : case BT_LOGICAL:
20287 17 : if (ts.kind != gfc_default_logical_kind)
20288 0 : return SEQ_NONDEFAULT;
20289 :
20290 : return SEQ_NUMERIC;
20291 :
20292 : default:
20293 : return SEQ_NONDEFAULT;
20294 : }
20295 : }
20296 :
20297 :
20298 : /* Resolve derived type EQUIVALENCE object. */
20299 :
20300 : static bool
20301 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
20302 : {
20303 80 : gfc_component *c = derived->components;
20304 :
20305 80 : if (!derived)
20306 : return true;
20307 :
20308 : /* Shall not be an object of nonsequence derived type. */
20309 80 : if (!derived->attr.sequence)
20310 : {
20311 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
20312 : "attribute to be an EQUIVALENCE object", sym->name,
20313 : &e->where);
20314 0 : return false;
20315 : }
20316 :
20317 : /* Shall not have allocatable components. */
20318 80 : if (derived->attr.alloc_comp)
20319 : {
20320 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
20321 : "components to be an EQUIVALENCE object",sym->name,
20322 : &e->where);
20323 1 : return false;
20324 : }
20325 :
20326 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
20327 : {
20328 1 : gfc_error ("Derived type variable %qs at %L with default "
20329 : "initialization cannot be in EQUIVALENCE with a variable "
20330 : "in COMMON", sym->name, &e->where);
20331 1 : return false;
20332 : }
20333 :
20334 245 : for (; c ; c = c->next)
20335 : {
20336 167 : if (gfc_bt_struct (c->ts.type)
20337 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
20338 : return false;
20339 :
20340 : /* Shall not be an object of sequence derived type containing a pointer
20341 : in the structure. */
20342 167 : if (c->attr.pointer)
20343 : {
20344 0 : gfc_error ("Derived type variable %qs at %L with pointer "
20345 : "component(s) cannot be an EQUIVALENCE object",
20346 : sym->name, &e->where);
20347 0 : return false;
20348 : }
20349 : }
20350 : return true;
20351 : }
20352 :
20353 :
20354 : /* Resolve equivalence object.
20355 : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
20356 : an allocatable array, an object of nonsequence derived type, an object of
20357 : sequence derived type containing a pointer at any level of component
20358 : selection, an automatic object, a function name, an entry name, a result
20359 : name, a named constant, a structure component, or a subobject of any of
20360 : the preceding objects. A substring shall not have length zero. A
20361 : derived type shall not have components with default initialization nor
20362 : shall two objects of an equivalence group be initialized.
20363 : Either all or none of the objects shall have an protected attribute.
20364 : The simple constraints are done in symbol.cc(check_conflict) and the rest
20365 : are implemented here. */
20366 :
20367 : static void
20368 1565 : resolve_equivalence (gfc_equiv *eq)
20369 : {
20370 1565 : gfc_symbol *sym;
20371 1565 : gfc_symbol *first_sym;
20372 1565 : gfc_expr *e;
20373 1565 : gfc_ref *r;
20374 1565 : locus *last_where = NULL;
20375 1565 : seq_type eq_type, last_eq_type;
20376 1565 : gfc_typespec *last_ts;
20377 1565 : int object, cnt_protected;
20378 1565 : const char *msg;
20379 :
20380 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
20381 :
20382 1565 : first_sym = eq->expr->symtree->n.sym;
20383 :
20384 1565 : cnt_protected = 0;
20385 :
20386 4727 : for (object = 1; eq; eq = eq->eq, object++)
20387 : {
20388 3171 : e = eq->expr;
20389 :
20390 3171 : e->ts = e->symtree->n.sym->ts;
20391 : /* match_varspec might not know yet if it is seeing
20392 : array reference or substring reference, as it doesn't
20393 : know the types. */
20394 3171 : if (e->ref && e->ref->type == REF_ARRAY)
20395 : {
20396 2152 : gfc_ref *ref = e->ref;
20397 2152 : sym = e->symtree->n.sym;
20398 :
20399 2152 : if (sym->attr.dimension)
20400 : {
20401 1855 : ref->u.ar.as = sym->as;
20402 1855 : ref = ref->next;
20403 : }
20404 :
20405 : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
20406 2152 : if (e->ts.type == BT_CHARACTER
20407 592 : && ref
20408 371 : && ref->type == REF_ARRAY
20409 371 : && ref->u.ar.dimen == 1
20410 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
20411 371 : && ref->u.ar.stride[0] == NULL)
20412 : {
20413 370 : gfc_expr *start = ref->u.ar.start[0];
20414 370 : gfc_expr *end = ref->u.ar.end[0];
20415 370 : void *mem = NULL;
20416 :
20417 : /* Optimize away the (:) reference. */
20418 370 : if (start == NULL && end == NULL)
20419 : {
20420 9 : if (e->ref == ref)
20421 0 : e->ref = ref->next;
20422 : else
20423 9 : e->ref->next = ref->next;
20424 : mem = ref;
20425 : }
20426 : else
20427 : {
20428 361 : ref->type = REF_SUBSTRING;
20429 361 : if (start == NULL)
20430 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
20431 : NULL, 1);
20432 361 : ref->u.ss.start = start;
20433 361 : if (end == NULL && e->ts.u.cl)
20434 27 : end = gfc_copy_expr (e->ts.u.cl->length);
20435 361 : ref->u.ss.end = end;
20436 361 : ref->u.ss.length = e->ts.u.cl;
20437 361 : e->ts.u.cl = NULL;
20438 : }
20439 370 : ref = ref->next;
20440 370 : free (mem);
20441 : }
20442 :
20443 : /* Any further ref is an error. */
20444 1930 : if (ref)
20445 : {
20446 1 : gcc_assert (ref->type == REF_ARRAY);
20447 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
20448 : &ref->u.ar.where);
20449 1 : continue;
20450 : }
20451 : }
20452 :
20453 3170 : if (!gfc_resolve_expr (e))
20454 2 : continue;
20455 :
20456 3168 : sym = e->symtree->n.sym;
20457 :
20458 3168 : if (sym->attr.is_protected)
20459 2 : cnt_protected++;
20460 3168 : if (cnt_protected > 0 && cnt_protected != object)
20461 : {
20462 2 : gfc_error ("Either all or none of the objects in the "
20463 : "EQUIVALENCE set at %L shall have the "
20464 : "PROTECTED attribute",
20465 : &e->where);
20466 2 : break;
20467 : }
20468 :
20469 : /* Shall not equivalence common block variables in a PURE procedure. */
20470 3166 : if (sym->ns->proc_name
20471 3150 : && sym->ns->proc_name->attr.pure
20472 7 : && sym->attr.in_common)
20473 : {
20474 : /* Need to check for symbols that may have entered the pure
20475 : procedure via a USE statement. */
20476 7 : bool saw_sym = false;
20477 7 : if (sym->ns->use_stmts)
20478 : {
20479 6 : gfc_use_rename *r;
20480 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
20481 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
20482 : }
20483 : else
20484 : saw_sym = true;
20485 :
20486 6 : if (saw_sym)
20487 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
20488 : "EQUIVALENCE object in the pure procedure %qs",
20489 : sym->name, &e->where, sym->ns->proc_name->name);
20490 : break;
20491 : }
20492 :
20493 : /* Shall not be a named constant. */
20494 3159 : if (e->expr_type == EXPR_CONSTANT)
20495 : {
20496 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
20497 : "object", sym->name, &e->where);
20498 0 : continue;
20499 : }
20500 :
20501 3161 : if (e->ts.type == BT_DERIVED
20502 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
20503 2 : continue;
20504 :
20505 : /* Check that the types correspond correctly:
20506 : Note 5.28:
20507 : A numeric sequence structure may be equivalenced to another sequence
20508 : structure, an object of default integer type, default real type, double
20509 : precision real type, default logical type such that components of the
20510 : structure ultimately only become associated to objects of the same
20511 : kind. A character sequence structure may be equivalenced to an object
20512 : of default character kind or another character sequence structure.
20513 : Other objects may be equivalenced only to objects of the same type and
20514 : kind parameters. */
20515 :
20516 : /* Identical types are unconditionally OK. */
20517 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
20518 2677 : goto identical_types;
20519 :
20520 480 : last_eq_type = sequence_type (*last_ts);
20521 480 : eq_type = sequence_type (sym->ts);
20522 :
20523 : /* Since the pair of objects is not of the same type, mixed or
20524 : non-default sequences can be rejected. */
20525 :
20526 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
20527 : "statement at %L with different type objects");
20528 481 : if ((object ==2
20529 480 : && last_eq_type == SEQ_MIXED
20530 7 : && last_where
20531 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20532 486 : || (eq_type == SEQ_MIXED
20533 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20534 1 : continue;
20535 :
20536 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
20537 : "statement at %L with objects of different type");
20538 483 : if ((object ==2
20539 479 : && last_eq_type == SEQ_NONDEFAULT
20540 50 : && last_where
20541 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20542 525 : || (eq_type == SEQ_NONDEFAULT
20543 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20544 4 : continue;
20545 :
20546 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
20547 : "EQUIVALENCE statement at %L");
20548 479 : if (last_eq_type == SEQ_CHARACTER
20549 475 : && eq_type != SEQ_CHARACTER
20550 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20551 4 : continue;
20552 :
20553 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
20554 : "EQUIVALENCE statement at %L");
20555 473 : if (last_eq_type == SEQ_NUMERIC
20556 471 : && eq_type != SEQ_NUMERIC
20557 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20558 2 : continue;
20559 :
20560 3146 : identical_types:
20561 :
20562 3146 : last_ts =&sym->ts;
20563 3146 : last_where = &e->where;
20564 :
20565 3146 : if (!e->ref)
20566 1003 : continue;
20567 :
20568 : /* Shall not be an automatic array. */
20569 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
20570 : {
20571 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
20572 : "an EQUIVALENCE object", sym->name, &e->where);
20573 3 : continue;
20574 : }
20575 :
20576 2140 : r = e->ref;
20577 4326 : while (r)
20578 : {
20579 : /* Shall not be a structure component. */
20580 2187 : if (r->type == REF_COMPONENT)
20581 : {
20582 0 : gfc_error ("Structure component %qs at %L cannot be an "
20583 : "EQUIVALENCE object",
20584 0 : r->u.c.component->name, &e->where);
20585 0 : break;
20586 : }
20587 :
20588 : /* A substring shall not have length zero. */
20589 2187 : if (r->type == REF_SUBSTRING)
20590 : {
20591 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
20592 : {
20593 1 : gfc_error ("Substring at %L has length zero",
20594 : &r->u.ss.start->where);
20595 1 : break;
20596 : }
20597 : }
20598 2186 : r = r->next;
20599 : }
20600 : }
20601 1565 : }
20602 :
20603 :
20604 : /* Function called by resolve_fntype to flag other symbols used in the
20605 : length type parameter specification of function results. */
20606 :
20607 : static bool
20608 4237 : flag_fn_result_spec (gfc_expr *expr,
20609 : gfc_symbol *sym,
20610 : int *f ATTRIBUTE_UNUSED)
20611 : {
20612 4237 : gfc_namespace *ns;
20613 4237 : gfc_symbol *s;
20614 :
20615 4237 : if (expr->expr_type == EXPR_VARIABLE)
20616 : {
20617 1384 : s = expr->symtree->n.sym;
20618 2171 : for (ns = s->ns; ns; ns = ns->parent)
20619 2171 : if (!ns->parent)
20620 : break;
20621 :
20622 1384 : if (sym == s)
20623 : {
20624 1 : gfc_error ("Self reference in character length expression "
20625 : "for %qs at %L", sym->name, &expr->where);
20626 1 : return true;
20627 : }
20628 :
20629 1383 : if (!s->fn_result_spec
20630 1383 : && s->attr.flavor == FL_PARAMETER)
20631 : {
20632 : /* Function contained in a module.... */
20633 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
20634 : {
20635 32 : gfc_symtree *st;
20636 32 : s->fn_result_spec = 1;
20637 : /* Make sure that this symbol is translated as a module
20638 : variable. */
20639 32 : st = gfc_get_unique_symtree (ns);
20640 32 : st->n.sym = s;
20641 32 : s->refs++;
20642 32 : }
20643 : /* ... which is use associated and called. */
20644 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
20645 0 : ||
20646 : /* External function matched with an interface. */
20647 0 : (s->ns->proc_name
20648 0 : && ((s->ns == ns
20649 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
20650 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
20651 0 : && s->ns->proc_name->attr.function))
20652 31 : s->fn_result_spec = 1;
20653 : }
20654 : }
20655 : return false;
20656 : }
20657 :
20658 :
20659 : /* Resolve function and ENTRY types, issue diagnostics if needed. */
20660 :
20661 : static void
20662 362782 : resolve_fntype (gfc_namespace *ns)
20663 : {
20664 362782 : gfc_entry_list *el;
20665 362782 : gfc_symbol *sym;
20666 :
20667 362782 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
20668 : return;
20669 :
20670 : /* If there are any entries, ns->proc_name is the entry master
20671 : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
20672 189585 : if (ns->entries)
20673 596 : sym = ns->entries->sym;
20674 : else
20675 : sym = ns->proc_name;
20676 189585 : if (sym->result == sym
20677 153891 : && sym->ts.type == BT_UNKNOWN
20678 6 : && !gfc_set_default_type (sym, 0, NULL)
20679 189589 : && !sym->attr.untyped)
20680 : {
20681 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
20682 : sym->name, &sym->declared_at);
20683 3 : sym->attr.untyped = 1;
20684 : }
20685 :
20686 14040 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
20687 1868 : && !sym->attr.contained
20688 299 : && !gfc_check_symbol_access (sym->ts.u.derived)
20689 189585 : && gfc_check_symbol_access (sym))
20690 : {
20691 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
20692 : "%L of PRIVATE type %qs", sym->name,
20693 0 : &sym->declared_at, sym->ts.u.derived->name);
20694 : }
20695 :
20696 189585 : if (ns->entries)
20697 1253 : for (el = ns->entries->next; el; el = el->next)
20698 : {
20699 657 : if (el->sym->result == el->sym
20700 445 : && el->sym->ts.type == BT_UNKNOWN
20701 2 : && !gfc_set_default_type (el->sym, 0, NULL)
20702 659 : && !el->sym->attr.untyped)
20703 : {
20704 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
20705 : el->sym->name, &el->sym->declared_at);
20706 2 : el->sym->attr.untyped = 1;
20707 : }
20708 : }
20709 :
20710 189585 : if (sym->ts.type == BT_CHARACTER
20711 7086 : && sym->ts.u.cl->length
20712 1883 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
20713 1878 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
20714 : }
20715 :
20716 :
20717 : /* 12.3.2.1.1 Defined operators. */
20718 :
20719 : static bool
20720 508 : check_uop_procedure (gfc_symbol *sym, locus where)
20721 : {
20722 508 : gfc_formal_arglist *formal;
20723 :
20724 508 : if (!sym->attr.function)
20725 : {
20726 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
20727 : sym->name, &where);
20728 4 : return false;
20729 : }
20730 :
20731 504 : if (sym->ts.type == BT_CHARACTER
20732 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
20733 2 : && !(sym->result && ((sym->result->ts.u.cl
20734 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
20735 : {
20736 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
20737 : "character length", sym->name, &where);
20738 2 : return false;
20739 : }
20740 :
20741 502 : formal = gfc_sym_get_dummy_args (sym);
20742 502 : if (!formal || !formal->sym)
20743 : {
20744 1 : gfc_error ("User operator procedure %qs at %L must have at least "
20745 : "one argument", sym->name, &where);
20746 1 : return false;
20747 : }
20748 :
20749 501 : if (formal->sym->attr.intent != INTENT_IN)
20750 : {
20751 0 : gfc_error ("First argument of operator interface at %L must be "
20752 : "INTENT(IN)", &where);
20753 0 : return false;
20754 : }
20755 :
20756 501 : if (formal->sym->attr.optional)
20757 : {
20758 0 : gfc_error ("First argument of operator interface at %L cannot be "
20759 : "optional", &where);
20760 0 : return false;
20761 : }
20762 :
20763 501 : formal = formal->next;
20764 501 : if (!formal || !formal->sym)
20765 : return true;
20766 :
20767 297 : if (formal->sym->attr.intent != INTENT_IN)
20768 : {
20769 0 : gfc_error ("Second argument of operator interface at %L must be "
20770 : "INTENT(IN)", &where);
20771 0 : return false;
20772 : }
20773 :
20774 297 : if (formal->sym->attr.optional)
20775 : {
20776 1 : gfc_error ("Second argument of operator interface at %L cannot be "
20777 : "optional", &where);
20778 1 : return false;
20779 : }
20780 :
20781 296 : if (formal->next)
20782 : {
20783 2 : gfc_error ("Operator interface at %L must have, at most, two "
20784 : "arguments", &where);
20785 2 : return false;
20786 : }
20787 :
20788 : return true;
20789 : }
20790 :
20791 : static void
20792 363588 : gfc_resolve_uops (gfc_symtree *symtree)
20793 : {
20794 363588 : gfc_interface *itr;
20795 :
20796 363588 : if (symtree == NULL)
20797 : return;
20798 :
20799 403 : gfc_resolve_uops (symtree->left);
20800 403 : gfc_resolve_uops (symtree->right);
20801 :
20802 798 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
20803 395 : check_uop_procedure (itr->sym, itr->sym->declared_at);
20804 : }
20805 :
20806 : /* Mark all lhs in assignment statement as used. It is better to put this into
20807 : its own function rather than into the different switch cases in
20808 : gfc_resolve_code. */
20809 :
20810 : static void
20811 701678 : mark_lhs_assignments_set (gfc_code *code)
20812 : {
20813 :
20814 1857463 : for (; code; code = code->next)
20815 : {
20816 1155785 : gfc_expr *lvalue = code->expr1, *rvalue = code->expr2;
20817 :
20818 1155785 : if (lvalue == NULL || lvalue->symtree == NULL || rvalue == NULL)
20819 854578 : continue;
20820 :
20821 301207 : switch (code->op)
20822 : {
20823 289429 : case EXEC_ASSIGN:
20824 289429 : if (gfc_is_reallocatable_lhs (lvalue) && lvalue->rank == rvalue->rank)
20825 8539 : gfc_lvalue_allocated_at (lvalue->symtree->n.sym, &lvalue->where);
20826 :
20827 299722 : gcc_fallthrough();
20828 299722 : case EXEC_POINTER_ASSIGN:
20829 299722 : gfc_expr_set_at (lvalue, &rvalue->where, VALUE_VARDEF);
20830 : default:
20831 : break;
20832 : }
20833 : }
20834 701678 : }
20835 :
20836 : /* Examine all of the expressions associated with a program unit,
20837 : assign types to all intermediate expressions, make sure that all
20838 : assignments are to compatible types and figure out which names
20839 : refer to which functions or subroutines. It doesn't check code
20840 : block, which is handled by gfc_resolve_code. */
20841 :
20842 : static void
20843 365392 : resolve_types (gfc_namespace *ns)
20844 : {
20845 365392 : gfc_namespace *n;
20846 365392 : gfc_charlen *cl;
20847 365392 : gfc_data *d;
20848 365392 : gfc_equiv *eq;
20849 365392 : gfc_namespace* old_ns = gfc_current_ns;
20850 365392 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
20851 :
20852 365392 : if (ns->types_resolved)
20853 : return;
20854 :
20855 : /* Check that all IMPLICIT types are ok. */
20856 362783 : if (!ns->seen_implicit_none)
20857 : {
20858 : unsigned letter;
20859 9135397 : for (letter = 0; letter != GFC_LETTERS; ++letter)
20860 8797049 : if (ns->set_flag[letter]
20861 8797049 : && !resolve_typespec_used (&ns->default_type[letter],
20862 : &ns->implicit_loc[letter], NULL))
20863 : return;
20864 : }
20865 :
20866 362782 : gfc_current_ns = ns;
20867 :
20868 362782 : resolve_entries (ns);
20869 :
20870 362782 : resolve_common_vars (&ns->blank_common, false);
20871 362782 : resolve_common_blocks (ns->common_root);
20872 :
20873 362782 : resolve_contained_functions (ns);
20874 :
20875 362782 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
20876 310978 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
20877 206403 : gfc_resolve_formal_arglist (ns->proc_name);
20878 :
20879 362782 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
20880 :
20881 458621 : for (cl = ns->cl_list; cl; cl = cl->next)
20882 95839 : resolve_charlen (cl);
20883 :
20884 362782 : gfc_traverse_ns (ns, resolve_symbol);
20885 :
20886 362782 : resolve_fntype (ns);
20887 :
20888 412651 : for (n = ns->contained; n; n = n->sibling)
20889 : {
20890 : /* Exclude final wrappers with the test for the artificial attribute. */
20891 49869 : if (gfc_pure (ns->proc_name)
20892 5 : && !gfc_pure (n->proc_name)
20893 49869 : && !n->proc_name->attr.artificial)
20894 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20895 : "also be PURE", n->proc_name->name,
20896 : &n->proc_name->declared_at);
20897 :
20898 49869 : resolve_types (n);
20899 : }
20900 :
20901 362782 : forall_flag = 0;
20902 362782 : gfc_do_concurrent_flag = 0;
20903 362782 : gfc_check_interfaces (ns);
20904 :
20905 362782 : gfc_traverse_ns (ns, resolve_values);
20906 :
20907 362782 : if (ns->save_all || (!flag_automatic && !recursive))
20908 315 : gfc_save_all (ns);
20909 :
20910 362782 : iter_stack = NULL;
20911 365300 : for (d = ns->data; d; d = d->next)
20912 2518 : resolve_data (d);
20913 :
20914 362782 : iter_stack = NULL;
20915 362782 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20916 :
20917 362782 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20918 :
20919 364347 : for (eq = ns->equiv; eq; eq = eq->next)
20920 1565 : resolve_equivalence (eq);
20921 :
20922 : /* Warn about unused labels. */
20923 362782 : if (warn_unused_label)
20924 4816 : warn_unused_fortran_label (ns->st_labels);
20925 :
20926 362782 : gfc_resolve_uops (ns->uop_root);
20927 :
20928 362782 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20929 :
20930 362782 : gfc_resolve_omp_declare (ns);
20931 :
20932 362782 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20933 :
20934 362782 : gfc_resolve_omp_udms (ns->omp_udm_root);
20935 :
20936 362782 : ns->types_resolved = 1;
20937 :
20938 362782 : gfc_current_ns = old_ns;
20939 : }
20940 :
20941 :
20942 : /* Call gfc_resolve_code recursively. */
20943 :
20944 : static void
20945 365454 : resolve_codes (gfc_namespace *ns)
20946 : {
20947 365454 : gfc_namespace *n;
20948 365454 : bitmap_obstack old_obstack;
20949 :
20950 365454 : if (ns->resolved == 1)
20951 14769 : return;
20952 :
20953 400616 : for (n = ns->contained; n; n = n->sibling)
20954 49931 : resolve_codes (n);
20955 :
20956 350685 : gfc_current_ns = ns;
20957 :
20958 : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20959 350685 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20960 337962 : cs_base = NULL;
20961 :
20962 : /* Set to an out of range value. */
20963 350685 : current_entry_id = -1;
20964 :
20965 350685 : old_obstack = labels_obstack;
20966 350685 : bitmap_obstack_initialize (&labels_obstack);
20967 :
20968 350685 : gfc_resolve_oacc_declare (ns);
20969 350685 : gfc_resolve_oacc_routines (ns);
20970 350685 : gfc_resolve_omp_local_vars (ns);
20971 350685 : if (ns->omp_allocate)
20972 62 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20973 350685 : gfc_resolve_code (ns->code, ns);
20974 :
20975 350684 : bitmap_obstack_release (&labels_obstack);
20976 350684 : labels_obstack = old_obstack;
20977 : }
20978 :
20979 : /* Return true if the value of a variable can be considered used, either
20980 : through the value_used flag or because it is a suitable dummy argument. */
20981 :
20982 : static bool
20983 453 : var_value_is_used (gfc_symbol *sym)
20984 : {
20985 453 : if (sym->attr.value_used != VALUE_UNUSED)
20986 : return true;
20987 :
20988 107 : if (!sym->attr.dummy)
20989 : return false;
20990 :
20991 90 : if (sym->attr.value)
20992 : return false;
20993 :
20994 90 : switch (sym->attr.intent)
20995 : {
20996 : case INTENT_UNKNOWN:
20997 : case INTENT_INOUT:
20998 : case INTENT_OUT:
20999 : return true;
21000 :
21001 : case INTENT_IN:
21002 : default:
21003 : return false;
21004 : }
21005 : }
21006 :
21007 : /* Similar, see if the variable could have gotten its value from somewhere. */
21008 :
21009 : static bool
21010 2381 : var_value_is_set (gfc_symbol *sym)
21011 : {
21012 2381 : if (sym->attr.value_set != VALUE_UNSET)
21013 : return true;
21014 :
21015 1684 : if (sym->value)
21016 : return true;
21017 :
21018 1669 : if (sym->ts.type == BT_DERIVED
21019 1669 : && gfc_has_default_initializer (sym->ts.u.derived))
21020 : return true;
21021 :
21022 1669 : if (!sym->attr.dummy)
21023 : return false;
21024 :
21025 1624 : if (sym->attr.value)
21026 : return true;
21027 :
21028 1591 : if (sym->attr.intent == INTENT_OUT)
21029 3 : return false;
21030 :
21031 : return true;
21032 : }
21033 :
21034 : /* Callback function to catch set but never used variables. */
21035 :
21036 : static void
21037 34278 : find_unused_vs_set (gfc_symbol *sym)
21038 : {
21039 34278 : symbol_attribute *attr = &sym->attr;
21040 :
21041 34278 : if (attr->flavor != FL_VARIABLE)
21042 : return;
21043 :
21044 : /* Do not warn about anything too far out of the ordinary. This might be
21045 : tightened later. */
21046 8605 : if (attr->in_common || attr->in_equivalence || attr->artificial
21047 8199 : || attr->cray_pointer || attr->cray_pointee || attr->associate_var
21048 8196 : || attr->target || attr->fe_temp || attr->omp_declare_target
21049 8193 : || attr->omp_declare_target_link || attr->omp_declare_target_local
21050 8184 : || attr->omp_declare_target_indirect || attr->oacc_declare_create
21051 8184 : || attr->oacc_declare_copyin || attr->oacc_declare_deviceptr
21052 8184 : || attr->oacc_declare_device_resident || attr->oacc_declare_link
21053 8184 : || attr->result || attr->warning_emitted || attr->use_assoc
21054 5645 : || attr->volatile_ || attr->asynchronous || !attr->referenced)
21055 : return;
21056 :
21057 2449 : if (attr->host_assoc && attr->access != ACCESS_PRIVATE)
21058 : return;
21059 :
21060 : /* There is no allocation in sight, but the variable is used anyway. This
21061 : might be hidden behind PRESENT, but issue a warning nonetheless. If
21062 : people complain, we might want to make this to an extra option to be
21063 : included with -Wextra. */
21064 :
21065 2383 : if (warn_undefined_vars && attr->allocatable && !attr->allocated
21066 2435 : && var_value_is_used (sym))
21067 : {
21068 3 : if (attr->dummy && attr->intent == INTENT_OUT)
21069 : {
21070 0 : gfc_warning (OPT_Wundefined_vars, "Unallocated INTENT(OUT) variable "
21071 : "%qs referenced at %L", sym->name, &sym->other_loc);
21072 0 : attr->warning_emitted = 1;
21073 0 : return;
21074 : }
21075 :
21076 3 : if (!attr->dummy)
21077 : {
21078 2 : gfc_warning (OPT_Wundefined_vars, "Unallocated variable %qs "
21079 : "referenced at %L", sym->name, &sym->other_loc);
21080 2 : attr->warning_emitted = 1;
21081 2 : return;
21082 : }
21083 : }
21084 :
21085 2424 : if (warn_undefined_vars && !var_value_is_set (sym))
21086 : {
21087 : /* Warn about variables which have been allocated and used, but never
21088 : set. */
21089 48 : if (attr->allocated && sym->attr.value_used > VALUE_MAYBE_USED)
21090 : {
21091 3 : switch (sym->attr.value_used)
21092 : {
21093 1 : case VALUE_INTENT_IN:
21094 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
21095 : "undefined to INTENT(IN) argument at %L", sym->name,
21096 : &sym->other_loc);
21097 1 : break;
21098 :
21099 1 : case VALUE_VALUE_ARG:
21100 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
21101 : "undefined to VALUE argument at %L", sym->name,
21102 : &sym->other_loc);
21103 1 : break;
21104 1 : case VALUE_USED:
21105 1 : gfc_warning (OPT_Wundefined_vars, "Allocated undefined variable "
21106 : "%qs used at %L", sym->name, &sym->other_loc);
21107 1 : break;
21108 0 : default:
21109 0 : gfc_internal_error ("Wrong value_set");
21110 3 : break;
21111 : }
21112 3 : attr->warning_emitted = 1;
21113 3 : return;
21114 : }
21115 :
21116 : /* Similar, when undefined variables are passed to INTENT(IN), VALUE
21117 : arguments or are used in general. */
21118 :
21119 45 : if (attr->value_used == VALUE_INTENT_IN)
21120 : {
21121 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
21122 : "to INTENT(IN) argument at %L", sym->name, &sym->other_loc);
21123 1 : attr->warning_emitted = 1;
21124 1 : return;
21125 : }
21126 44 : else if (attr->value_used == VALUE_VALUE_ARG)
21127 : {
21128 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
21129 : "to VALUE argument at %L", sym->name, &sym->other_loc);
21130 1 : attr->warning_emitted = 1;
21131 1 : return;
21132 : }
21133 43 : else if (attr->value_used == VALUE_USED)
21134 : {
21135 9 : if (attr->dummy && attr->intent == INTENT_OUT)
21136 1 : gfc_warning (OPT_Wundefined_vars, "Undefined INTENT(OUT) variable %qs "
21137 : "used at %L", sym->name, &sym->other_loc);
21138 : else
21139 8 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs used at "
21140 : "%L", sym->name, &sym->other_loc);
21141 :
21142 9 : attr->warning_emitted = 1;
21143 9 : return;
21144 : }
21145 :
21146 : /* PR 28004 - warn about INTENT(OUT) variables that are never set. If
21147 : the variable or a component are allocatable, do not warn since this is
21148 : a frequent shortcut for deallocation. */
21149 :
21150 34 : if (sym->attr.dummy && sym->attr.intent == INTENT_OUT
21151 2 : && !(attr->allocatable || attr->alloc_comp))
21152 : {
21153 0 : gfc_warning (OPT_Wundefined_vars, "INTENT(OUT) variable %qs "
21154 : "declared at %L is not assigned a value", sym->name,
21155 : &sym->declared_at);
21156 0 : attr->warning_emitted = 1;
21157 0 : return;
21158 : }
21159 : }
21160 :
21161 : /* Warn for unused but defined variables. */
21162 :
21163 2410 : if (warn_unused_but_set_variable)
21164 : {
21165 2302 : if (attr->value_set == VALUE_VARDEF && !var_value_is_used (sym))
21166 : {
21167 7 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs defined at "
21168 : "%L but never used", sym->name, &sym->other_loc);
21169 7 : attr->warning_emitted = 1;
21170 7 : return;
21171 : }
21172 2295 : if (attr->allocatable && !var_value_is_used (sym))
21173 : {
21174 2 : if (attr->allocated == ALLOCATED_ALLOCATE_STMT)
21175 : {
21176 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs "
21177 : "allocated at %L but never used", sym->name,
21178 : &sym->extra_loc);
21179 1 : attr->warning_emitted = 1;
21180 1 : return;
21181 : }
21182 1 : else if (attr->allocated == ALLOCATED_ARG)
21183 : {
21184 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs maybe "
21185 : "allocated as argument at %L but never used",
21186 : sym->name, &sym->extra_loc);
21187 1 : attr->warning_emitted = 1;
21188 1 : return;
21189 : }
21190 : }
21191 : }
21192 :
21193 : /* -Wunused-intent-out and -Wunused-read are enabled with -Wextra, so
21194 : check for these conditions at the end. If one of the warnings
21195 : with -Wall triggered, we do not want to issue a different warrning
21196 : for the same variable if the user supplies -Wall -Wextra instead
21197 : of only -Wall. */
21198 :
21199 39 : if (warn_unused_intent_out && attr->value_set == VALUE_INTENT_OUT
21200 2406 : && !var_value_is_used (sym))
21201 : {
21202 1 : gfc_warning (OPT_Wunused_intent_out, "Variable %qs passed to "
21203 : "INTENT(OUT) argument at %L but value never used",
21204 : sym->name, &sym->other_loc);
21205 1 : attr->warning_emitted = 1;
21206 1 : return;
21207 : }
21208 :
21209 2400 : if (warn_unused_read && attr->value_set == VALUE_READ && !var_value_is_used (sym))
21210 : {
21211 1 : gfc_warning (OPT_Wunused_read, "Variable %qs read at %L but never "
21212 : "used", sym->name, &sym->other_loc);
21213 1 : attr->warning_emitted = 1;
21214 1 : return;
21215 : }
21216 : }
21217 :
21218 : /* Run warn_unused_vs_set over a namespace recursively. */
21219 :
21220 : static void
21221 4845 : warn_unused_vs_set (gfc_namespace *ns)
21222 : {
21223 4845 : gfc_traverse_ns (ns, find_unused_vs_set);
21224 :
21225 5368 : for (gfc_namespace *n = ns->contained; n; n = n->sibling)
21226 523 : warn_unused_vs_set (n);
21227 4845 : }
21228 :
21229 : /* This function is called after a complete program unit has been compiled.
21230 : Its purpose is to examine all of the expressions associated with a program
21231 : unit, assign types to all intermediate expressions, make sure that all
21232 : assignments are to compatible types and figure out which names refer to
21233 : which functions or subroutines. */
21234 :
21235 : void
21236 320448 : gfc_resolve (gfc_namespace *ns, gfc_association_list *a)
21237 : {
21238 320448 : gfc_namespace *old_ns;
21239 320448 : code_stack *old_cs_base;
21240 320448 : struct gfc_omp_saved_state old_omp_state;
21241 :
21242 320448 : if (ns->resolved)
21243 4925 : return;
21244 :
21245 315523 : ns->resolved = -1;
21246 315523 : old_ns = gfc_current_ns;
21247 315523 : old_cs_base = cs_base;
21248 :
21249 : /* As gfc_resolve can be called during resolution of an OpenMP construct
21250 : body, we should clear any state associated to it, so that say NS's
21251 : DO loops are not interpreted as OpenMP loops. */
21252 315523 : if (!ns->construct_entities)
21253 302800 : gfc_omp_save_and_clear_state (&old_omp_state);
21254 :
21255 315523 : resolve_types (ns);
21256 315523 : component_assignment_level = 0;
21257 315523 : resolve_codes (ns);
21258 315522 : mark_assoc_used (a);
21259 :
21260 315522 : if (warn_unused_but_set_variable || warn_unused_intent_out
21261 311258 : || warn_unused_read || warn_undefined_vars)
21262 : {
21263 4346 : int error_count;
21264 4346 : gfc_get_errors (NULL, &error_count);
21265 4346 : if (error_count == 0)
21266 4322 : warn_unused_vs_set (ns);
21267 : }
21268 :
21269 315522 : if (ns->omp_assumes)
21270 16 : gfc_resolve_omp_assumptions (ns->omp_assumes);
21271 :
21272 315522 : gfc_current_ns = old_ns;
21273 315522 : cs_base = old_cs_base;
21274 315522 : ns->resolved = 1;
21275 :
21276 315522 : gfc_run_passes (ns);
21277 :
21278 315522 : if (!ns->construct_entities)
21279 302799 : gfc_omp_restore_state (&old_omp_state);
21280 : }
|
