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 :
86 : /* The id of the last entry seen. */
87 : static int current_entry_id;
88 :
89 : /* We use bitmaps to determine if a branch target is valid. */
90 : static bitmap_obstack labels_obstack;
91 :
92 : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 : static bool inquiry_argument = false;
94 :
95 :
96 : /* Is the symbol host associated? */
97 : static bool
98 51937 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
99 : {
100 56424 : for (ns = ns->parent; ns; ns = ns->parent)
101 : {
102 4738 : if (sym->ns == ns)
103 : return true;
104 : }
105 :
106 : return false;
107 : }
108 :
109 : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
110 : an ABSTRACT derived-type. If where is not NULL, an error message with that
111 : locus is printed, optionally using name. */
112 :
113 : static bool
114 1510498 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
115 : {
116 1510498 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
117 : {
118 5 : if (where)
119 : {
120 5 : if (name)
121 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
122 : name, where, ts->u.derived->name);
123 : else
124 1 : gfc_error ("ABSTRACT type %qs used at %L",
125 : ts->u.derived->name, where);
126 : }
127 :
128 5 : return false;
129 : }
130 :
131 : return true;
132 : }
133 :
134 :
135 : static bool
136 5530 : check_proc_interface (gfc_symbol *ifc, locus *where)
137 : {
138 : /* Several checks for F08:C1216. */
139 5530 : if (ifc->attr.procedure)
140 : {
141 2 : gfc_error ("Interface %qs at %L is declared "
142 : "in a later PROCEDURE statement", ifc->name, where);
143 2 : return false;
144 : }
145 5528 : if (ifc->generic)
146 : {
147 : /* For generic interfaces, check if there is
148 : a specific procedure with the same name. */
149 : gfc_interface *gen = ifc->generic;
150 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
151 5 : gen = gen->next;
152 7 : if (!gen)
153 : {
154 4 : gfc_error ("Interface %qs at %L may not be generic",
155 : ifc->name, where);
156 4 : return false;
157 : }
158 : }
159 5524 : if (ifc->attr.proc == PROC_ST_FUNCTION)
160 : {
161 4 : gfc_error ("Interface %qs at %L may not be a statement function",
162 : ifc->name, where);
163 4 : return false;
164 : }
165 5520 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
166 5520 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
167 17 : ifc->attr.intrinsic = 1;
168 5520 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
169 : {
170 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
171 : "PROCEDURE statement at %L", ifc->name, where);
172 3 : return false;
173 : }
174 5517 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
175 : {
176 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
177 7 : return false;
178 : }
179 : return true;
180 : }
181 :
182 :
183 : static void resolve_symbol (gfc_symbol *sym);
184 :
185 :
186 : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
187 :
188 : static bool
189 2015 : resolve_procedure_interface (gfc_symbol *sym)
190 : {
191 2015 : gfc_symbol *ifc = sym->ts.interface;
192 :
193 2015 : if (!ifc)
194 : return true;
195 :
196 1859 : if (ifc == sym)
197 : {
198 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
199 : sym->name, &sym->declared_at);
200 2 : return false;
201 : }
202 1857 : if (!check_proc_interface (ifc, &sym->declared_at))
203 : return false;
204 :
205 1848 : if (ifc->attr.if_source || ifc->attr.intrinsic)
206 : {
207 : /* Resolve interface and copy attributes. */
208 1569 : resolve_symbol (ifc);
209 1569 : if (ifc->attr.intrinsic)
210 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
211 :
212 1569 : if (ifc->result)
213 : {
214 682 : sym->ts = ifc->result->ts;
215 682 : sym->attr.allocatable = ifc->result->attr.allocatable;
216 682 : sym->attr.pointer = ifc->result->attr.pointer;
217 682 : sym->attr.dimension = ifc->result->attr.dimension;
218 682 : sym->attr.class_ok = ifc->result->attr.class_ok;
219 682 : sym->as = gfc_copy_array_spec (ifc->result->as);
220 682 : sym->result = sym;
221 : }
222 : else
223 : {
224 887 : sym->ts = ifc->ts;
225 887 : sym->attr.allocatable = ifc->attr.allocatable;
226 887 : sym->attr.pointer = ifc->attr.pointer;
227 887 : sym->attr.dimension = ifc->attr.dimension;
228 887 : sym->attr.class_ok = ifc->attr.class_ok;
229 887 : sym->as = gfc_copy_array_spec (ifc->as);
230 : }
231 1569 : sym->ts.interface = ifc;
232 1569 : sym->attr.function = ifc->attr.function;
233 1569 : sym->attr.subroutine = ifc->attr.subroutine;
234 :
235 1569 : sym->attr.pure = ifc->attr.pure;
236 1569 : sym->attr.elemental = ifc->attr.elemental;
237 1569 : sym->attr.contiguous = ifc->attr.contiguous;
238 1569 : sym->attr.recursive = ifc->attr.recursive;
239 1569 : sym->attr.always_explicit = ifc->attr.always_explicit;
240 1569 : sym->attr.ext_attr |= ifc->attr.ext_attr;
241 1569 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
242 : /* Copy char length. */
243 1569 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
244 : {
245 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
246 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
247 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
248 : return false;
249 : }
250 : }
251 :
252 : return true;
253 : }
254 :
255 :
256 : /* Resolve types of formal argument lists. These have to be done early so that
257 : the formal argument lists of module procedures can be copied to the
258 : containing module before the individual procedures are resolved
259 : individually. We also resolve argument lists of procedures in interface
260 : blocks because they are self-contained scoping units.
261 :
262 : Since a dummy argument cannot be a non-dummy procedure, the only
263 : resort left for untyped names are the IMPLICIT types. */
264 :
265 : void
266 518318 : gfc_resolve_formal_arglist (gfc_symbol *proc)
267 : {
268 518318 : gfc_formal_arglist *f;
269 518318 : gfc_symbol *sym;
270 518318 : bool saved_specification_expr;
271 518318 : int i;
272 :
273 518318 : if (proc->result != NULL)
274 322742 : sym = proc->result;
275 : else
276 : sym = proc;
277 :
278 518318 : if (gfc_elemental (proc)
279 356256 : || sym->attr.pointer || sym->attr.allocatable
280 862535 : || (sym->as && sym->as->rank != 0))
281 : {
282 176413 : proc->attr.always_explicit = 1;
283 176413 : sym->attr.always_explicit = 1;
284 : }
285 :
286 518318 : gfc_namespace *orig_current_ns = gfc_current_ns;
287 518318 : gfc_current_ns = gfc_get_procedure_ns (proc);
288 :
289 1341019 : for (f = proc->formal; f; f = f->next)
290 : {
291 822703 : gfc_array_spec *as;
292 :
293 822703 : sym = f->sym;
294 :
295 822703 : if (sym == NULL)
296 : {
297 : /* Alternate return placeholder. */
298 171 : if (gfc_elemental (proc))
299 1 : gfc_error ("Alternate return specifier in elemental subroutine "
300 : "%qs at %L is not allowed", proc->name,
301 : &proc->declared_at);
302 171 : if (proc->attr.function)
303 1 : gfc_error ("Alternate return specifier in function "
304 : "%qs at %L is not allowed", proc->name,
305 : &proc->declared_at);
306 171 : continue;
307 : }
308 :
309 563 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310 823095 : && !resolve_procedure_interface (sym))
311 : break;
312 :
313 822532 : if (strcmp (proc->name, sym->name) == 0)
314 : {
315 2 : gfc_error ("Self-referential argument "
316 : "%qs at %L is not allowed", sym->name,
317 : &proc->declared_at);
318 2 : break;
319 : }
320 :
321 822530 : if (sym->attr.if_source != IFSRC_UNKNOWN)
322 831 : gfc_resolve_formal_arglist (sym);
323 :
324 822530 : if (sym->attr.subroutine || sym->attr.external)
325 : {
326 835 : if (sym->attr.flavor == FL_UNKNOWN)
327 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328 : }
329 : else
330 : {
331 821695 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 3663 : && (!sym->attr.function || sym->result == sym))
333 3625 : gfc_set_default_type (sym, 1, sym->ns);
334 : }
335 :
336 822530 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 836162 : ? CLASS_DATA (sym)->as : sym->as;
338 :
339 822530 : saved_specification_expr = specification_expr;
340 822530 : specification_expr = true;
341 822530 : gfc_resolve_array_spec (as, 0);
342 822530 : specification_expr = saved_specification_expr;
343 :
344 : /* We can't tell if an array with dimension (:) is assumed or deferred
345 : shape until we know if it has the pointer or allocatable attributes.
346 : */
347 822530 : if (as && as->rank > 0 && as->type == AS_DEFERRED
348 12162 : && ((sym->ts.type != BT_CLASS
349 11066 : && !(sym->attr.pointer || sym->attr.allocatable))
350 5302 : || (sym->ts.type == BT_CLASS
351 1096 : && !(CLASS_DATA (sym)->attr.class_pointer
352 896 : || CLASS_DATA (sym)->attr.allocatable)))
353 7341 : && sym->attr.flavor != FL_PROCEDURE)
354 : {
355 7340 : as->type = AS_ASSUMED_SHAPE;
356 17041 : for (i = 0; i < as->rank; i++)
357 9701 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
358 : }
359 :
360 127826 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361 114316 : || (as && as->type == AS_ASSUMED_RANK)
362 771658 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363 761569 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 11519 : && (CLASS_DATA (sym)->attr.class_pointer
365 11036 : || CLASS_DATA (sym)->attr.allocatable
366 10138 : || CLASS_DATA (sym)->attr.target))
367 760188 : || sym->attr.optional)
368 : {
369 77504 : proc->attr.always_explicit = 1;
370 77504 : if (proc->result)
371 36071 : proc->result->attr.always_explicit = 1;
372 : }
373 :
374 : /* If the flavor is unknown at this point, it has to be a variable.
375 : A procedure specification would have already set the type. */
376 :
377 822530 : if (sym->attr.flavor == FL_UNKNOWN)
378 50282 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379 :
380 822530 : if (gfc_pure (proc))
381 : {
382 326947 : if (sym->attr.flavor == FL_PROCEDURE)
383 : {
384 : /* F08:C1279. */
385 29 : if (!gfc_pure (sym))
386 : {
387 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 : "also be PURE", sym->name, &sym->declared_at);
389 1 : continue;
390 : }
391 : }
392 326918 : else if (!sym->attr.pointer)
393 : {
394 326904 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 : {
396 111 : if (sym->attr.value)
397 110 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398 : " of pure function %qs at %L with VALUE "
399 : "attribute but without INTENT(IN)",
400 : sym->name, proc->name, &sym->declared_at);
401 : else
402 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
403 : "be INTENT(IN) or VALUE", sym->name, proc->name,
404 : &sym->declared_at);
405 : }
406 :
407 326904 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 : {
409 159 : if (sym->attr.value)
410 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411 : " of pure subroutine %qs at %L with VALUE "
412 : "attribute but without INTENT", sym->name,
413 : proc->name, &sym->declared_at);
414 : else
415 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 : "must have its INTENT specified or have the "
417 : "VALUE attribute", sym->name, proc->name,
418 : &sym->declared_at);
419 : }
420 : }
421 :
422 : /* F08:C1278a. */
423 326946 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 : {
425 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 : " may not be polymorphic", sym->name, proc->name,
427 : &sym->declared_at);
428 1 : continue;
429 : }
430 : }
431 :
432 822528 : if (proc->attr.implicit_pure)
433 : {
434 24628 : if (sym->attr.flavor == FL_PROCEDURE)
435 : {
436 301 : if (!gfc_pure (sym))
437 281 : proc->attr.implicit_pure = 0;
438 : }
439 24327 : else if (!sym->attr.pointer)
440 : {
441 23547 : if (proc->attr.function && sym->attr.intent != INTENT_IN
442 2727 : && !sym->value)
443 2727 : proc->attr.implicit_pure = 0;
444 :
445 23547 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 4169 : && !sym->value)
447 4169 : proc->attr.implicit_pure = 0;
448 : }
449 : }
450 :
451 822528 : if (gfc_elemental (proc))
452 : {
453 : /* F08:C1289. */
454 301458 : if (sym->attr.codimension
455 301457 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456 905 : && CLASS_DATA (sym)->attr.codimension))
457 : {
458 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 : "procedure", sym->name, &sym->declared_at);
460 3 : continue;
461 : }
462 :
463 301455 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464 903 : && CLASS_DATA (sym)->as))
465 : {
466 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
467 : "be scalar", sym->name, &sym->declared_at);
468 2 : continue;
469 : }
470 :
471 301453 : if (sym->attr.allocatable
472 301452 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473 902 : && CLASS_DATA (sym)->attr.allocatable))
474 : {
475 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 : "have the ALLOCATABLE attribute", sym->name,
477 : &sym->declared_at);
478 2 : continue;
479 : }
480 :
481 301451 : if (sym->attr.pointer
482 301450 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483 901 : && CLASS_DATA (sym)->attr.class_pointer))
484 : {
485 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 : "have the POINTER attribute", sym->name,
487 : &sym->declared_at);
488 2 : continue;
489 : }
490 :
491 301449 : if (sym->attr.flavor == FL_PROCEDURE)
492 : {
493 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
494 : "procedure %qs at %L", sym->name, proc->name,
495 : &sym->declared_at);
496 2 : continue;
497 : }
498 :
499 : /* Fortran 2008 Corrigendum 1, C1290a. */
500 301447 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501 : {
502 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 : "have its INTENT specified or have the VALUE "
504 : "attribute", sym->name, proc->name,
505 : &sym->declared_at);
506 2 : continue;
507 : }
508 : }
509 :
510 : /* Each dummy shall be specified to be scalar. */
511 822515 : if (proc->attr.proc == PROC_ST_FUNCTION)
512 : {
513 307 : if (sym->as != NULL)
514 : {
515 : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 : shall be specified, explicitly or implicitly, to be scalar. */
517 1 : gfc_error ("Argument %qs of statement function %qs at %L "
518 : "must be scalar", sym->name, proc->name,
519 : &proc->declared_at);
520 1 : continue;
521 : }
522 :
523 306 : if (sym->ts.type == BT_CHARACTER)
524 : {
525 48 : gfc_charlen *cl = sym->ts.u.cl;
526 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 : {
528 0 : gfc_error ("Character-valued argument %qs of statement "
529 : "function at %L must have constant length",
530 : sym->name, &sym->declared_at);
531 0 : continue;
532 : }
533 : }
534 : }
535 : }
536 518318 : if (sym)
537 518226 : sym->formal_resolved = 1;
538 518318 : gfc_current_ns = orig_current_ns;
539 518318 : }
540 :
541 :
542 : /* Work function called when searching for symbols that have argument lists
543 : associated with them. */
544 :
545 : static void
546 1812396 : find_arglists (gfc_symbol *sym)
547 : {
548 1812396 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
549 328236 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
550 : return;
551 :
552 326201 : gfc_resolve_formal_arglist (sym);
553 : }
554 :
555 :
556 : /* Given a namespace, resolve all formal argument lists within the namespace.
557 : */
558 :
559 : static void
560 342255 : resolve_formal_arglists (gfc_namespace *ns)
561 : {
562 0 : if (ns == NULL)
563 : return;
564 :
565 342255 : gfc_traverse_ns (ns, find_arglists);
566 : }
567 :
568 :
569 : static void
570 36801 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
571 : {
572 36801 : bool t;
573 :
574 36801 : if (sym && sym->attr.flavor == FL_PROCEDURE
575 36801 : && sym->ns->parent
576 1070 : && sym->ns->parent->proc_name
577 1070 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
578 1 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
579 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
580 : "encompassing procedure", sym->name, &sym->declared_at);
581 :
582 : /* If this namespace is not a function or an entry master function,
583 : ignore it. */
584 36801 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
585 10825 : || sym->attr.entry_master)
586 26165 : return;
587 :
588 10636 : if (!sym->result)
589 : return;
590 :
591 : /* Try to find out of what the return type is. */
592 10636 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
593 : {
594 57 : t = gfc_set_default_type (sym->result, 0, ns);
595 :
596 57 : if (!t && !sym->result->attr.untyped)
597 : {
598 19 : if (sym->result == sym)
599 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
600 : sym->name, &sym->declared_at);
601 18 : else if (!sym->result->attr.proc_pointer)
602 0 : gfc_error ("Result %qs of contained function %qs at %L has "
603 : "no IMPLICIT type", sym->result->name, sym->name,
604 : &sym->result->declared_at);
605 19 : sym->result->attr.untyped = 1;
606 : }
607 : }
608 :
609 : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
610 : type, lists the only ways a character length value of * can be used:
611 : dummy arguments of procedures, named constants, function results and
612 : in allocate statements if the allocate_object is an assumed length dummy
613 : in external functions. Internal function results and results of module
614 : procedures are not on this list, ergo, not permitted. */
615 :
616 10636 : if (sym->result->ts.type == BT_CHARACTER)
617 : {
618 1187 : gfc_charlen *cl = sym->result->ts.u.cl;
619 1187 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
620 : {
621 : /* See if this is a module-procedure and adapt error message
622 : accordingly. */
623 4 : bool module_proc;
624 4 : gcc_assert (ns->parent && ns->parent->proc_name);
625 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
626 :
627 7 : gfc_error (module_proc
628 : ? G_("Character-valued module procedure %qs at %L"
629 : " must not be assumed length")
630 : : G_("Character-valued internal function %qs at %L"
631 : " must not be assumed length"),
632 : sym->name, &sym->declared_at);
633 : }
634 : }
635 : }
636 :
637 :
638 : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
639 : introduce duplicates. */
640 :
641 : static void
642 1424 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
643 : {
644 1424 : gfc_formal_arglist *f, *new_arglist;
645 1424 : gfc_symbol *new_sym;
646 :
647 2569 : for (; new_args != NULL; new_args = new_args->next)
648 : {
649 1145 : new_sym = new_args->sym;
650 : /* See if this arg is already in the formal argument list. */
651 2169 : for (f = proc->formal; f; f = f->next)
652 : {
653 1472 : if (new_sym == f->sym)
654 : break;
655 : }
656 :
657 1145 : if (f)
658 448 : continue;
659 :
660 : /* Add a new argument. Argument order is not important. */
661 697 : new_arglist = gfc_get_formal_arglist ();
662 697 : new_arglist->sym = new_sym;
663 697 : new_arglist->next = proc->formal;
664 697 : proc->formal = new_arglist;
665 : }
666 1424 : }
667 :
668 :
669 : /* Flag the arguments that are not present in all entries. */
670 :
671 : static void
672 1424 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
673 : {
674 1424 : gfc_formal_arglist *f, *head;
675 1424 : head = new_args;
676 :
677 3002 : for (f = proc->formal; f; f = f->next)
678 : {
679 1578 : if (f->sym == NULL)
680 36 : continue;
681 :
682 2708 : for (new_args = head; new_args; new_args = new_args->next)
683 : {
684 2266 : if (new_args->sym == f->sym)
685 : break;
686 : }
687 :
688 1542 : if (new_args)
689 1100 : continue;
690 :
691 442 : f->sym->attr.not_always_present = 1;
692 : }
693 1424 : }
694 :
695 :
696 : /* Resolve alternate entry points. If a symbol has multiple entry points we
697 : create a new master symbol for the main routine, and turn the existing
698 : symbol into an entry point. */
699 :
700 : static void
701 378549 : resolve_entries (gfc_namespace *ns)
702 : {
703 378549 : gfc_namespace *old_ns;
704 378549 : gfc_code *c;
705 378549 : gfc_symbol *proc;
706 378549 : gfc_entry_list *el;
707 : /* Provide sufficient space to hold "master.%d.%s". */
708 378549 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
709 378549 : static int master_count = 0;
710 :
711 378549 : if (ns->proc_name == NULL)
712 377879 : return;
713 :
714 : /* No need to do anything if this procedure doesn't have alternate entry
715 : points. */
716 378500 : if (!ns->entries)
717 : return;
718 :
719 : /* We may already have resolved alternate entry points. */
720 921 : if (ns->proc_name->attr.entry_master)
721 : return;
722 :
723 : /* If this isn't a procedure something has gone horribly wrong. */
724 670 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
725 :
726 : /* Remember the current namespace. */
727 670 : old_ns = gfc_current_ns;
728 :
729 670 : gfc_current_ns = ns;
730 :
731 : /* Add the main entry point to the list of entry points. */
732 670 : el = gfc_get_entry_list ();
733 670 : el->sym = ns->proc_name;
734 670 : el->id = 0;
735 670 : el->next = ns->entries;
736 670 : ns->entries = el;
737 670 : ns->proc_name->attr.entry = 1;
738 :
739 : /* If it is a module function, it needs to be in the right namespace
740 : so that gfc_get_fake_result_decl can gather up the results. The
741 : need for this arose in get_proc_name, where these beasts were
742 : left in their own namespace, to keep prior references linked to
743 : the entry declaration.*/
744 670 : if (ns->proc_name->attr.function
745 566 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
746 189 : el->sym->ns = ns;
747 :
748 : /* Do the same for entries where the master is not a module
749 : procedure. These are retained in the module namespace because
750 : of the module procedure declaration. */
751 1424 : for (el = el->next; el; el = el->next)
752 754 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
753 0 : && el->sym->attr.mod_proc)
754 0 : el->sym->ns = ns;
755 670 : el = ns->entries;
756 :
757 : /* Add an entry statement for it. */
758 670 : c = gfc_get_code (EXEC_ENTRY);
759 670 : c->ext.entry = el;
760 670 : c->next = ns->code;
761 670 : ns->code = c;
762 :
763 : /* Create a new symbol for the master function. */
764 : /* Give the internal function a unique name (within this file).
765 : Also include the function name so the user has some hope of figuring
766 : out what is going on. */
767 670 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
768 670 : master_count++, ns->proc_name->name);
769 670 : gfc_get_ha_symbol (name, &proc);
770 670 : gcc_assert (proc != NULL);
771 :
772 670 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
773 670 : if (ns->proc_name->attr.subroutine)
774 104 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
775 : else
776 : {
777 566 : gfc_symbol *sym;
778 566 : gfc_typespec *ts, *fts;
779 566 : gfc_array_spec *as, *fas;
780 566 : gfc_add_function (&proc->attr, proc->name, NULL);
781 566 : proc->result = proc;
782 566 : fas = ns->entries->sym->as;
783 566 : fas = fas ? fas : ns->entries->sym->result->as;
784 566 : fts = &ns->entries->sym->result->ts;
785 566 : if (fts->type == BT_UNKNOWN)
786 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
787 1060 : for (el = ns->entries->next; el; el = el->next)
788 : {
789 605 : ts = &el->sym->result->ts;
790 605 : as = el->sym->as;
791 605 : as = as ? as : el->sym->result->as;
792 605 : if (ts->type == BT_UNKNOWN)
793 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
794 :
795 605 : if (! gfc_compare_types (ts, fts)
796 497 : || (el->sym->result->attr.dimension
797 497 : != ns->entries->sym->result->attr.dimension)
798 605 : || (el->sym->result->attr.pointer
799 497 : != ns->entries->sym->result->attr.pointer))
800 : break;
801 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
802 559 : && gfc_compare_array_spec (as, fas) == 0)
803 5 : gfc_error ("Function %s at %L has entries with mismatched "
804 : "array specifications", ns->entries->sym->name,
805 5 : &ns->entries->sym->declared_at);
806 : /* The characteristics need to match and thus both need to have
807 : the same string length, i.e. both len=*, or both len=4.
808 : Having both len=<variable> is also possible, but difficult to
809 : check at compile time. */
810 492 : else if (ts->type == BT_CHARACTER
811 89 : && (el->sym->result->attr.allocatable
812 89 : != ns->entries->sym->result->attr.allocatable))
813 : {
814 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
815 : "characteristics", ns->entries->sym->name,
816 : &ns->entries->sym->declared_at, el->sym->name);
817 3 : goto cleanup;
818 : }
819 489 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
820 86 : && (((ts->u.cl->length && !fts->u.cl->length)
821 85 : ||(!ts->u.cl->length && fts->u.cl->length))
822 66 : || (ts->u.cl->length
823 29 : && ts->u.cl->length->expr_type
824 29 : != fts->u.cl->length->expr_type)
825 66 : || (ts->u.cl->length
826 29 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
827 28 : && mpz_cmp (ts->u.cl->length->value.integer,
828 28 : fts->u.cl->length->value.integer) != 0)))
829 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
830 : "entries returning variables of different "
831 : "string lengths", ns->entries->sym->name,
832 21 : &ns->entries->sym->declared_at);
833 468 : else if (el->sym->result->attr.allocatable
834 468 : != ns->entries->sym->result->attr.allocatable)
835 : break;
836 : }
837 :
838 563 : if (el == NULL)
839 : {
840 455 : sym = ns->entries->sym->result;
841 : /* All result types the same. */
842 455 : proc->ts = *fts;
843 455 : if (sym->attr.dimension)
844 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
845 455 : if (sym->attr.pointer)
846 78 : gfc_add_pointer (&proc->attr, NULL);
847 455 : if (sym->attr.allocatable)
848 24 : gfc_add_allocatable (&proc->attr, NULL);
849 : }
850 : else
851 : {
852 : /* Otherwise the result will be passed through a union by
853 : reference. */
854 108 : proc->attr.mixed_entry_master = 1;
855 346 : for (el = ns->entries; el; el = el->next)
856 : {
857 238 : sym = el->sym->result;
858 238 : if (sym->attr.dimension)
859 : {
860 1 : if (el == ns->entries)
861 0 : gfc_error ("FUNCTION result %s cannot be an array in "
862 : "FUNCTION %s at %L", sym->name,
863 0 : ns->entries->sym->name, &sym->declared_at);
864 : else
865 1 : gfc_error ("ENTRY result %s cannot be an array in "
866 : "FUNCTION %s at %L", sym->name,
867 1 : ns->entries->sym->name, &sym->declared_at);
868 : }
869 237 : else if (sym->attr.pointer)
870 : {
871 1 : if (el == ns->entries)
872 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
873 : "FUNCTION %s at %L", sym->name,
874 1 : ns->entries->sym->name, &sym->declared_at);
875 : else
876 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
877 : "FUNCTION %s at %L", sym->name,
878 0 : ns->entries->sym->name, &sym->declared_at);
879 : }
880 236 : else if (sym->attr.allocatable)
881 : {
882 0 : if (el == ns->entries)
883 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
884 : "FUNCTION %s at %L", sym->name,
885 0 : ns->entries->sym->name, &sym->declared_at);
886 : else
887 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
888 : "FUNCTION %s at %L", sym->name,
889 0 : ns->entries->sym->name, &sym->declared_at);
890 : }
891 : else
892 : {
893 236 : ts = &sym->ts;
894 236 : if (ts->type == BT_UNKNOWN)
895 9 : ts = gfc_get_default_type (sym->name, NULL);
896 236 : switch (ts->type)
897 : {
898 85 : case BT_INTEGER:
899 85 : if (ts->kind == gfc_default_integer_kind)
900 : sym = NULL;
901 : break;
902 100 : case BT_REAL:
903 100 : if (ts->kind == gfc_default_real_kind
904 18 : || ts->kind == gfc_default_double_kind)
905 : sym = NULL;
906 : break;
907 20 : case BT_COMPLEX:
908 20 : if (ts->kind == gfc_default_complex_kind)
909 : sym = NULL;
910 : break;
911 28 : case BT_LOGICAL:
912 28 : if (ts->kind == gfc_default_logical_kind)
913 : sym = NULL;
914 : break;
915 : case BT_UNKNOWN:
916 : /* We will issue error elsewhere. */
917 : sym = NULL;
918 : break;
919 : default:
920 : break;
921 : }
922 3 : if (sym)
923 : {
924 3 : if (el == ns->entries)
925 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
926 : "in FUNCTION %s at %L", sym->name,
927 1 : gfc_typename (ts), ns->entries->sym->name,
928 : &sym->declared_at);
929 : else
930 2 : gfc_error ("ENTRY result %s cannot be of type %s "
931 : "in FUNCTION %s at %L", sym->name,
932 2 : gfc_typename (ts), ns->entries->sym->name,
933 : &sym->declared_at);
934 : }
935 : }
936 : }
937 : }
938 : }
939 :
940 108 : cleanup:
941 670 : proc->attr.access = ACCESS_PRIVATE;
942 670 : proc->attr.entry_master = 1;
943 :
944 : /* Merge all the entry point arguments. */
945 2094 : for (el = ns->entries; el; el = el->next)
946 1424 : merge_argument_lists (proc, el->sym->formal);
947 :
948 : /* Check the master formal arguments for any that are not
949 : present in all entry points. */
950 2094 : for (el = ns->entries; el; el = el->next)
951 1424 : check_argument_lists (proc, el->sym->formal);
952 :
953 : /* Use the master function for the function body. */
954 670 : ns->proc_name = proc;
955 :
956 : /* Finalize the new symbols. */
957 670 : gfc_commit_symbols ();
958 :
959 : /* Restore the original namespace. */
960 670 : gfc_current_ns = old_ns;
961 : }
962 :
963 :
964 : /* Forward declaration. */
965 : static bool is_non_constant_shape_array (gfc_symbol *sym);
966 :
967 :
968 : /* Resolve common variables. */
969 : static void
970 344232 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
971 : {
972 344232 : gfc_symbol *csym = common_block->head;
973 344232 : gfc_gsymbol *gsym;
974 :
975 350283 : for (; csym; csym = csym->common_next)
976 : {
977 6051 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
978 6051 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
979 : {
980 3 : if (csym->common_block)
981 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
982 : "COMMON block at %L", gsym->name,
983 : &gsym->where, &csym->common_block->where);
984 : else
985 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
986 : "COMMON block", gsym->name, &gsym->where);
987 : }
988 :
989 : /* gfc_add_in_common may have been called before, but the reported errors
990 : have been ignored to continue parsing.
991 : We do the checks again here, unless the symbol is USE associated. */
992 6051 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
993 : {
994 5778 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
995 5778 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
996 : &common_block->where);
997 : }
998 :
999 6051 : if (csym->value || csym->attr.data)
1000 : {
1001 149 : if (!csym->ns->is_block_data)
1002 33 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1003 : "but only in BLOCK DATA initialization is "
1004 : "allowed", csym->name, &csym->declared_at);
1005 116 : else if (!named_common)
1006 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1007 : "in a blank COMMON but initialization is only "
1008 : "allowed in named common blocks", csym->name,
1009 : &csym->declared_at);
1010 : }
1011 :
1012 6051 : if (UNLIMITED_POLY (csym))
1013 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1014 : "[F2008:C5100]", csym->name, &csym->declared_at);
1015 :
1016 6051 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1017 : {
1018 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1019 : "COMMON at %L", csym->name, &csym->declared_at,
1020 : &common_block->where);
1021 : /* Avoid confusing follow-on error. */
1022 1 : csym->error = 1;
1023 : }
1024 :
1025 6051 : if (csym->ts.type != BT_DERIVED)
1026 6004 : continue;
1027 :
1028 47 : if (!(csym->ts.u.derived->attr.sequence
1029 3 : || csym->ts.u.derived->attr.is_bind_c))
1030 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1031 : "has neither the SEQUENCE nor the BIND(C) "
1032 : "attribute", csym->name, &csym->declared_at);
1033 47 : if (csym->ts.u.derived->attr.alloc_comp)
1034 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1035 : "has an ultimate component that is "
1036 : "allocatable", csym->name, &csym->declared_at);
1037 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1038 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1039 : "may not have default initializer", csym->name,
1040 : &csym->declared_at);
1041 :
1042 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1043 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1044 : }
1045 344232 : }
1046 :
1047 : /* Resolve common blocks. */
1048 : static void
1049 342785 : resolve_common_blocks (gfc_symtree *common_root)
1050 : {
1051 342785 : gfc_symbol *sym = NULL;
1052 342785 : gfc_gsymbol * gsym;
1053 :
1054 342785 : if (common_root == NULL)
1055 342663 : return;
1056 :
1057 1977 : if (common_root->left)
1058 246 : resolve_common_blocks (common_root->left);
1059 1977 : if (common_root->right)
1060 284 : resolve_common_blocks (common_root->right);
1061 :
1062 1977 : resolve_common_vars (common_root->n.common, true);
1063 :
1064 : /* The common name is a global name - in Fortran 2003 also if it has a
1065 : C binding name, since Fortran 2008 only the C binding name is a global
1066 : identifier. */
1067 1977 : if (!common_root->n.common->binding_label
1068 1977 : || gfc_notification_std (GFC_STD_F2008))
1069 : {
1070 3810 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1071 1905 : common_root->n.common->name);
1072 :
1073 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1074 14 : && gsym->type == GSYM_COMMON
1075 1918 : && ((common_root->n.common->binding_label
1076 6 : && (!gsym->binding_label
1077 0 : || strcmp (common_root->n.common->binding_label,
1078 : gsym->binding_label) != 0))
1079 7 : || (!common_root->n.common->binding_label
1080 7 : && gsym->binding_label)))
1081 : {
1082 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1083 : "identifier and must thus have the same binding name "
1084 : "as the same-named COMMON block at %L: %s vs %s",
1085 6 : common_root->n.common->name, &common_root->n.common->where,
1086 : &gsym->where,
1087 : common_root->n.common->binding_label
1088 : ? common_root->n.common->binding_label : "(blank)",
1089 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1090 6 : return;
1091 : }
1092 :
1093 1899 : if (gsym && gsym->type != GSYM_COMMON
1094 1 : && !common_root->n.common->binding_label)
1095 : {
1096 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1097 : "as entity at %L",
1098 0 : common_root->n.common->name, &common_root->n.common->where,
1099 : &gsym->where);
1100 0 : return;
1101 : }
1102 814 : if (gsym && gsym->type != GSYM_COMMON)
1103 : {
1104 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1105 : "%L sharing the identifier with global non-COMMON-block "
1106 1 : "entity at %L", common_root->n.common->name,
1107 1 : &common_root->n.common->where, &gsym->where);
1108 1 : return;
1109 : }
1110 1085 : if (!gsym)
1111 : {
1112 1085 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1113 1085 : gsym->type = GSYM_COMMON;
1114 1085 : gsym->where = common_root->n.common->where;
1115 1085 : gsym->defined = 1;
1116 : }
1117 1898 : gsym->used = 1;
1118 : }
1119 :
1120 1970 : if (common_root->n.common->binding_label)
1121 : {
1122 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1123 : common_root->n.common->binding_label);
1124 76 : if (gsym && gsym->type != GSYM_COMMON)
1125 : {
1126 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1127 : "global identifier as entity at %L",
1128 : &common_root->n.common->where,
1129 1 : common_root->n.common->binding_label, &gsym->where);
1130 1 : return;
1131 : }
1132 57 : if (!gsym)
1133 : {
1134 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1135 57 : gsym->type = GSYM_COMMON;
1136 57 : gsym->where = common_root->n.common->where;
1137 57 : gsym->defined = 1;
1138 : }
1139 75 : gsym->used = 1;
1140 : }
1141 :
1142 1969 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1143 1969 : if (sym == NULL)
1144 : return;
1145 :
1146 122 : if (sym->attr.flavor == FL_PARAMETER)
1147 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1148 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1149 :
1150 122 : if (sym->attr.external)
1151 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1152 1 : sym->name, &common_root->n.common->where);
1153 :
1154 122 : if (sym->attr.intrinsic)
1155 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1156 2 : sym->name, &common_root->n.common->where);
1157 120 : else if (sym->attr.result
1158 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1159 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1160 : "that is also a function result", sym->name,
1161 1 : &common_root->n.common->where);
1162 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1163 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1164 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1165 : "that is also a global procedure", sym->name,
1166 3 : &common_root->n.common->where);
1167 : }
1168 :
1169 :
1170 : /* Resolve contained function types. Because contained functions can call one
1171 : another, they have to be worked out before any of the contained procedures
1172 : can be resolved.
1173 :
1174 : The good news is that if a function doesn't already have a type, the only
1175 : way it can get one is through an IMPLICIT type or a RESULT variable, because
1176 : by definition contained functions are contained namespace they're contained
1177 : in, not in a sibling or parent namespace. */
1178 :
1179 : static void
1180 342255 : resolve_contained_functions (gfc_namespace *ns)
1181 : {
1182 342255 : gfc_namespace *child;
1183 342255 : gfc_entry_list *el;
1184 :
1185 342255 : resolve_formal_arglists (ns);
1186 :
1187 378549 : for (child = ns->contained; child; child = child->sibling)
1188 : {
1189 : /* Resolve alternate entry points first. */
1190 36294 : resolve_entries (child);
1191 :
1192 : /* Then check function return types. */
1193 36294 : resolve_contained_fntype (child->proc_name, child);
1194 36801 : for (el = child->entries; el; el = el->next)
1195 507 : resolve_contained_fntype (el->sym, child);
1196 : }
1197 342255 : }
1198 :
1199 :
1200 :
1201 : /* A Parameterized Derived Type constructor must contain values for
1202 : the PDT KIND parameters or they must have a default initializer.
1203 : Go through the constructor picking out the KIND expressions,
1204 : storing them in 'param_list' and then call gfc_get_pdt_instance
1205 : to obtain the PDT instance. */
1206 :
1207 : static gfc_actual_arglist *param_list, *param_tail, *param;
1208 :
1209 : static bool
1210 296 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1211 : {
1212 296 : param = gfc_get_actual_arglist ();
1213 296 : if (!param_list)
1214 240 : param_list = param_tail = param;
1215 : else
1216 : {
1217 56 : param_tail->next = param;
1218 56 : param_tail = param_tail->next;
1219 : }
1220 :
1221 296 : param_tail->name = c->name;
1222 296 : if (expr)
1223 296 : param_tail->expr = gfc_copy_expr (expr);
1224 0 : else if (c->initializer)
1225 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1226 : else
1227 : {
1228 0 : param_tail->spec_type = SPEC_ASSUMED;
1229 0 : if (c->attr.pdt_kind)
1230 : {
1231 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1232 : "at %C has no value", param->name);
1233 0 : return false;
1234 : }
1235 : }
1236 :
1237 : return true;
1238 : }
1239 :
1240 : static bool
1241 276 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1242 : gfc_symbol *derived)
1243 : {
1244 276 : gfc_constructor *cons = NULL;
1245 276 : gfc_component *comp;
1246 276 : bool t = true;
1247 :
1248 276 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1249 240 : cons = gfc_constructor_first (expr->value.constructor);
1250 36 : else if (constr)
1251 36 : cons = *constr;
1252 276 : gcc_assert (cons);
1253 :
1254 276 : comp = derived->components;
1255 :
1256 844 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1257 : {
1258 568 : if (cons->expr
1259 568 : && cons->expr->expr_type == EXPR_STRUCTURE
1260 0 : && comp->ts.type == BT_DERIVED)
1261 : {
1262 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1263 0 : if (!t)
1264 : return t;
1265 : }
1266 568 : else if (comp->ts.type == BT_DERIVED)
1267 : {
1268 36 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1269 36 : if (!t)
1270 : return t;
1271 : }
1272 532 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1273 296 : && derived->attr.pdt_template)
1274 : {
1275 296 : t = get_pdt_spec_expr (comp, cons->expr);
1276 296 : if (!t)
1277 : return t;
1278 : }
1279 : }
1280 : return t;
1281 : }
1282 :
1283 :
1284 : static bool resolve_fl_derived0 (gfc_symbol *sym);
1285 : static bool resolve_fl_struct (gfc_symbol *sym);
1286 :
1287 :
1288 : /* Resolve all of the elements of a structure constructor and make sure that
1289 : the types are correct. The 'init' flag indicates that the given
1290 : constructor is an initializer. */
1291 :
1292 : static bool
1293 62398 : resolve_structure_cons (gfc_expr *expr, int init)
1294 : {
1295 62398 : gfc_constructor *cons;
1296 62398 : gfc_component *comp;
1297 62398 : bool t;
1298 62398 : symbol_attribute a;
1299 :
1300 62398 : t = true;
1301 :
1302 62398 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1303 : {
1304 59555 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1305 59405 : resolve_fl_derived0 (expr->ts.u.derived);
1306 : else
1307 150 : resolve_fl_struct (expr->ts.u.derived);
1308 :
1309 : /* If this is a Parameterized Derived Type template, find the
1310 : instance corresponding to the PDT kind parameters. */
1311 59555 : if (expr->ts.u.derived->attr.pdt_template)
1312 : {
1313 240 : param_list = NULL;
1314 240 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1315 240 : if (!t)
1316 : return t;
1317 240 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1318 :
1319 240 : expr->param_list = gfc_copy_actual_arglist (param_list);
1320 :
1321 240 : if (param_list)
1322 240 : gfc_free_actual_arglist (param_list);
1323 :
1324 240 : if (!expr->ts.u.derived->attr.pdt_type)
1325 : return false;
1326 : }
1327 : }
1328 :
1329 : /* A constructor may have references if it is the result of substituting a
1330 : parameter variable. In this case we just pull out the component we
1331 : want. */
1332 62398 : if (expr->ref)
1333 160 : comp = expr->ref->u.c.sym->components;
1334 62238 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1335 : || expr->ts.type == BT_UNION)
1336 62236 : && expr->ts.u.derived)
1337 62236 : comp = expr->ts.u.derived->components;
1338 : else
1339 : return false;
1340 :
1341 62396 : cons = gfc_constructor_first (expr->value.constructor);
1342 :
1343 207499 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1344 : {
1345 145105 : int rank;
1346 :
1347 145105 : if (!cons->expr)
1348 9671 : continue;
1349 :
1350 : /* Unions use an EXPR_NULL contrived expression to tell the translation
1351 : phase to generate an initializer of the appropriate length.
1352 : Ignore it here. */
1353 135434 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1354 15 : continue;
1355 :
1356 135419 : if (!gfc_resolve_expr (cons->expr))
1357 : {
1358 0 : t = false;
1359 0 : continue;
1360 : }
1361 :
1362 135419 : rank = comp->as ? comp->as->rank : 0;
1363 135419 : if (comp->ts.type == BT_CLASS
1364 1763 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1365 1762 : && CLASS_DATA (comp)->as)
1366 519 : rank = CLASS_DATA (comp)->as->rank;
1367 :
1368 135419 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1369 228 : gfc_find_vtab (&cons->expr->ts);
1370 :
1371 135419 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1372 474 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1373 : {
1374 4 : gfc_error ("The rank of the element in the structure "
1375 : "constructor at %L does not match that of the "
1376 : "component (%d/%d)", &cons->expr->where,
1377 : cons->expr->rank, rank);
1378 4 : t = false;
1379 : }
1380 :
1381 : /* If we don't have the right type, try to convert it. */
1382 :
1383 236838 : if (!comp->attr.proc_pointer &&
1384 101419 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1385 : {
1386 12344 : if (strcmp (comp->name, "_extends") == 0)
1387 : {
1388 : /* Can afford to be brutal with the _extends initializer.
1389 : The derived type can get lost because it is PRIVATE
1390 : but it is not usage constrained by the standard. */
1391 9004 : cons->expr->ts = comp->ts;
1392 : }
1393 3340 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1394 : {
1395 2 : gfc_error ("The element in the structure constructor at %L, "
1396 : "for pointer component %qs, is %s but should be %s",
1397 2 : &cons->expr->where, comp->name,
1398 2 : gfc_basic_typename (cons->expr->ts.type),
1399 : gfc_basic_typename (comp->ts.type));
1400 2 : t = false;
1401 : }
1402 3338 : else if (!UNLIMITED_POLY (comp))
1403 : {
1404 3275 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1405 3275 : if (t)
1406 135419 : t = t2;
1407 : }
1408 : }
1409 :
1410 : /* For strings, the length of the constructor should be the same as
1411 : the one of the structure, ensure this if the lengths are known at
1412 : compile time and when we are dealing with PARAMETER or structure
1413 : constructors. */
1414 135419 : if (cons->expr->ts.type == BT_CHARACTER
1415 3877 : && comp->ts.type == BT_CHARACTER
1416 3851 : && comp->ts.u.cl && comp->ts.u.cl->length
1417 2486 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1418 2451 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1419 926 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1420 926 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1421 926 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1422 926 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1423 926 : comp->ts.u.cl->length->value.integer) != 0)
1424 : {
1425 11 : if (comp->attr.pointer)
1426 : {
1427 3 : HOST_WIDE_INT la, lb;
1428 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1429 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1430 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1431 : "component %qs in constructor at %L",
1432 3 : la, lb, comp->name, &cons->expr->where);
1433 3 : t = false;
1434 : }
1435 :
1436 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1437 4 : && cons->expr->rank != 0
1438 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1439 : {
1440 : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1441 : to make use of the gfc_resolve_character_array_constructor
1442 : machinery. The expression is later simplified away to
1443 : an array of string literals. */
1444 1 : gfc_expr *para = cons->expr;
1445 1 : cons->expr = gfc_get_expr ();
1446 1 : cons->expr->ts = para->ts;
1447 1 : cons->expr->where = para->where;
1448 1 : cons->expr->expr_type = EXPR_ARRAY;
1449 1 : cons->expr->rank = para->rank;
1450 1 : cons->expr->corank = para->corank;
1451 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1452 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1453 1 : para, &cons->expr->where);
1454 : }
1455 :
1456 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1457 : {
1458 : /* Rely on the cleanup of the namespace to deal correctly with
1459 : the old charlen. (There was a block here that attempted to
1460 : remove the charlen but broke the chain in so doing.) */
1461 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1462 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1463 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1464 5 : gfc_resolve_character_array_constructor (cons->expr);
1465 : }
1466 : }
1467 :
1468 135419 : if (cons->expr->expr_type == EXPR_NULL
1469 40542 : && !(comp->attr.pointer || comp->attr.allocatable
1470 20219 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1471 1112 : || (comp->ts.type == BT_CLASS
1472 1110 : && (CLASS_DATA (comp)->attr.class_pointer
1473 893 : || CLASS_DATA (comp)->attr.allocatable))))
1474 : {
1475 2 : t = false;
1476 2 : gfc_error ("The NULL in the structure constructor at %L is "
1477 : "being applied to component %qs, which is neither "
1478 : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1479 : comp->name);
1480 : }
1481 :
1482 135419 : if (comp->attr.proc_pointer && comp->ts.interface)
1483 : {
1484 : /* Check procedure pointer interface. */
1485 15213 : gfc_symbol *s2 = NULL;
1486 15213 : gfc_component *c2;
1487 15213 : const char *name;
1488 15213 : char err[200];
1489 :
1490 15213 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1491 15213 : if (c2)
1492 : {
1493 12 : s2 = c2->ts.interface;
1494 12 : name = c2->name;
1495 : }
1496 15201 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1497 : {
1498 0 : s2 = cons->expr->symtree->n.sym->result;
1499 0 : name = cons->expr->symtree->n.sym->result->name;
1500 : }
1501 15201 : else if (cons->expr->expr_type != EXPR_NULL)
1502 : {
1503 14788 : s2 = cons->expr->symtree->n.sym;
1504 14788 : name = cons->expr->symtree->n.sym->name;
1505 : }
1506 :
1507 14800 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1508 : err, sizeof (err), NULL, NULL))
1509 : {
1510 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1511 : "component %qs in structure constructor at %L:"
1512 2 : " %s", comp->name, &cons->expr->where, err);
1513 2 : return false;
1514 : }
1515 : }
1516 :
1517 : /* Validate shape, except for dynamic or PDT arrays. */
1518 135417 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1519 2227 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1520 1508 : && !comp->attr.pdt_array)
1521 : {
1522 1261 : mpz_t len;
1523 1261 : mpz_init (len);
1524 2615 : for (int n = 0; n < rank; n++)
1525 : {
1526 1359 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1527 1354 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1528 : {
1529 5 : gfc_error ("Bad array spec of component %qs referenced in "
1530 : "structure constructor at %L",
1531 5 : comp->name, &cons->expr->where);
1532 5 : t = false;
1533 5 : break;
1534 1354 : };
1535 1354 : if (cons->expr->shape == NULL)
1536 12 : continue;
1537 1342 : mpz_set_ui (len, 1);
1538 1342 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1539 1342 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1540 1342 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1541 : {
1542 9 : gfc_error ("The shape of component %qs in the structure "
1543 : "constructor at %L differs from the shape of the "
1544 : "declared component for dimension %d (%ld/%ld)",
1545 : comp->name, &cons->expr->where, n+1,
1546 : mpz_get_si (cons->expr->shape[n]),
1547 : mpz_get_si (len));
1548 9 : t = false;
1549 : }
1550 : }
1551 1261 : mpz_clear (len);
1552 : }
1553 :
1554 135417 : if (!comp->attr.pointer || comp->attr.proc_pointer
1555 21737 : || cons->expr->expr_type == EXPR_NULL)
1556 125437 : continue;
1557 :
1558 9980 : a = gfc_expr_attr (cons->expr);
1559 :
1560 9980 : if (!a.pointer && !a.target)
1561 : {
1562 1 : t = false;
1563 1 : gfc_error ("The element in the structure constructor at %L, "
1564 : "for pointer component %qs should be a POINTER or "
1565 1 : "a TARGET", &cons->expr->where, comp->name);
1566 : }
1567 :
1568 9980 : if (init)
1569 : {
1570 : /* F08:C461. Additional checks for pointer initialization. */
1571 9912 : if (a.allocatable)
1572 : {
1573 0 : t = false;
1574 0 : gfc_error ("Pointer initialization target at %L "
1575 0 : "must not be ALLOCATABLE", &cons->expr->where);
1576 : }
1577 9912 : if (!a.save)
1578 : {
1579 0 : t = false;
1580 0 : gfc_error ("Pointer initialization target at %L "
1581 0 : "must have the SAVE attribute", &cons->expr->where);
1582 : }
1583 : }
1584 :
1585 : /* F2023:C770: A designator that is an initial-data-target shall ...
1586 : not have a vector subscript. */
1587 9980 : if (comp->attr.pointer && (a.pointer || a.target)
1588 19959 : && gfc_has_vector_index (cons->expr))
1589 : {
1590 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1591 1 : &cons->expr->where);
1592 1 : t = false;
1593 : }
1594 :
1595 : /* F2003, C1272 (3). */
1596 9980 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1597 9980 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1598 9944 : || gfc_is_coindexed (cons->expr));
1599 33 : if (impure && gfc_pure (NULL))
1600 : {
1601 1 : t = false;
1602 1 : gfc_error ("Invalid expression in the structure constructor for "
1603 : "pointer component %qs at %L in PURE procedure",
1604 1 : comp->name, &cons->expr->where);
1605 : }
1606 :
1607 9980 : if (impure)
1608 33 : gfc_unset_implicit_pure (NULL);
1609 : }
1610 :
1611 : return t;
1612 : }
1613 :
1614 :
1615 : /****************** Expression name resolution ******************/
1616 :
1617 : /* Returns 0 if a symbol was not declared with a type or
1618 : attribute declaration statement, nonzero otherwise. */
1619 :
1620 : static bool
1621 739812 : was_declared (gfc_symbol *sym)
1622 : {
1623 739812 : symbol_attribute a;
1624 :
1625 739812 : a = sym->attr;
1626 :
1627 739812 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1628 : return 1;
1629 :
1630 627255 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1631 618759 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1632 618757 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1633 618703 : || a.asynchronous || a.codimension || a.subroutine)
1634 94055 : return 1;
1635 :
1636 : return 0;
1637 : }
1638 :
1639 :
1640 : /* Determine if a symbol is generic or not. */
1641 :
1642 : static int
1643 410720 : generic_sym (gfc_symbol *sym)
1644 : {
1645 410720 : gfc_symbol *s;
1646 :
1647 410720 : if (sym->attr.generic ||
1648 381594 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1649 30189 : return 1;
1650 :
1651 380531 : if (was_declared (sym) || sym->ns->parent == NULL)
1652 : return 0;
1653 :
1654 76826 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1655 :
1656 76826 : if (s != NULL)
1657 : {
1658 133 : if (s == sym)
1659 : return 0;
1660 : else
1661 132 : return generic_sym (s);
1662 : }
1663 :
1664 : return 0;
1665 : }
1666 :
1667 :
1668 : /* Determine if a symbol is specific or not. */
1669 :
1670 : static int
1671 380443 : specific_sym (gfc_symbol *sym)
1672 : {
1673 380443 : gfc_symbol *s;
1674 :
1675 380443 : if (sym->attr.if_source == IFSRC_IFBODY
1676 369328 : || sym->attr.proc == PROC_MODULE
1677 : || sym->attr.proc == PROC_INTERNAL
1678 : || sym->attr.proc == PROC_ST_FUNCTION
1679 293697 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1680 673409 : || sym->attr.external)
1681 89862 : return 1;
1682 :
1683 290581 : if (was_declared (sym) || sym->ns->parent == NULL)
1684 : return 0;
1685 :
1686 76724 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1687 :
1688 76724 : return (s == NULL) ? 0 : specific_sym (s);
1689 : }
1690 :
1691 :
1692 : /* Figure out if the procedure is specific, generic or unknown. */
1693 :
1694 : enum proc_type
1695 : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1696 :
1697 : static proc_type
1698 410442 : procedure_kind (gfc_symbol *sym)
1699 : {
1700 410442 : if (generic_sym (sym))
1701 : return PTYPE_GENERIC;
1702 :
1703 380396 : if (specific_sym (sym))
1704 89862 : return PTYPE_SPECIFIC;
1705 :
1706 : return PTYPE_UNKNOWN;
1707 : }
1708 :
1709 : /* Check references to assumed size arrays. The flag need_full_assumed_size
1710 : is nonzero when matching actual arguments. */
1711 :
1712 : static int need_full_assumed_size = 0;
1713 :
1714 : static bool
1715 1414614 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1716 : {
1717 1414614 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1718 : return false;
1719 :
1720 : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1721 : What should it be? */
1722 3788 : if (e->ref
1723 3786 : && e->ref->u.ar.as
1724 3785 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1725 3290 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1726 3290 : && (e->ref->u.ar.type == AR_FULL))
1727 : {
1728 25 : gfc_error ("The upper bound in the last dimension must "
1729 : "appear in the reference to the assumed size "
1730 : "array %qs at %L", sym->name, &e->where);
1731 25 : return true;
1732 : }
1733 : return false;
1734 : }
1735 :
1736 :
1737 : /* Look for bad assumed size array references in argument expressions
1738 : of elemental and array valued intrinsic procedures. Since this is
1739 : called from procedure resolution functions, it only recurses at
1740 : operators. */
1741 :
1742 : static bool
1743 227196 : resolve_assumed_size_actual (gfc_expr *e)
1744 : {
1745 227196 : if (e == NULL)
1746 : return false;
1747 :
1748 226701 : switch (e->expr_type)
1749 : {
1750 109415 : case EXPR_VARIABLE:
1751 109415 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1752 : return true;
1753 : break;
1754 :
1755 47981 : case EXPR_OP:
1756 47981 : if (resolve_assumed_size_actual (e->value.op.op1)
1757 47981 : || resolve_assumed_size_actual (e->value.op.op2))
1758 0 : return true;
1759 : break;
1760 :
1761 : default:
1762 : break;
1763 : }
1764 : return false;
1765 : }
1766 :
1767 :
1768 : /* Check a generic procedure, passed as an actual argument, to see if
1769 : there is a matching specific name. If none, it is an error, and if
1770 : more than one, the reference is ambiguous. */
1771 : static int
1772 8 : count_specific_procs (gfc_expr *e)
1773 : {
1774 8 : int n;
1775 8 : gfc_interface *p;
1776 8 : gfc_symbol *sym;
1777 :
1778 8 : n = 0;
1779 8 : sym = e->symtree->n.sym;
1780 :
1781 22 : for (p = sym->generic; p; p = p->next)
1782 14 : if (strcmp (sym->name, p->sym->name) == 0)
1783 : {
1784 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1785 : sym->name);
1786 8 : n++;
1787 : }
1788 :
1789 8 : if (n > 1)
1790 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1791 : &e->where);
1792 :
1793 8 : if (n == 0)
1794 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1795 : "argument at %L", sym->name, &e->where);
1796 :
1797 8 : return n;
1798 : }
1799 :
1800 :
1801 : /* See if a call to sym could possibly be a not allowed RECURSION because of
1802 : a missing RECURSIVE declaration. This means that either sym is the current
1803 : context itself, or sym is the parent of a contained procedure calling its
1804 : non-RECURSIVE containing procedure.
1805 : This also works if sym is an ENTRY. */
1806 :
1807 : static bool
1808 150361 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1809 : {
1810 150361 : gfc_symbol* proc_sym;
1811 150361 : gfc_symbol* context_proc;
1812 150361 : gfc_namespace* real_context;
1813 :
1814 150361 : if (sym->attr.flavor == FL_PROGRAM
1815 : || gfc_fl_struct (sym->attr.flavor))
1816 : return false;
1817 :
1818 : /* If we've got an ENTRY, find real procedure. */
1819 150360 : if (sym->attr.entry && sym->ns->entries)
1820 45 : proc_sym = sym->ns->entries->sym;
1821 : else
1822 : proc_sym = sym;
1823 :
1824 : /* If sym is RECURSIVE, all is well of course. */
1825 150360 : if (proc_sym->attr.recursive || flag_recursive)
1826 : return false;
1827 :
1828 : /* Find the context procedure's "real" symbol if it has entries.
1829 : We look for a procedure symbol, so recurse on the parents if we don't
1830 : find one (like in case of a BLOCK construct). */
1831 1838 : for (real_context = context; ; real_context = real_context->parent)
1832 : {
1833 : /* We should find something, eventually! */
1834 127454 : gcc_assert (real_context);
1835 :
1836 127454 : context_proc = (real_context->entries ? real_context->entries->sym
1837 : : real_context->proc_name);
1838 :
1839 : /* In some special cases, there may not be a proc_name, like for this
1840 : invalid code:
1841 : real(bad_kind()) function foo () ...
1842 : when checking the call to bad_kind ().
1843 : In these cases, we simply return here and assume that the
1844 : call is ok. */
1845 127454 : if (!context_proc)
1846 : return false;
1847 :
1848 127190 : if (context_proc->attr.flavor != FL_LABEL)
1849 : break;
1850 : }
1851 :
1852 : /* A call from sym's body to itself is recursion, of course. */
1853 125352 : if (context_proc == proc_sym)
1854 : return true;
1855 :
1856 : /* The same is true if context is a contained procedure and sym the
1857 : containing one. */
1858 125337 : if (context_proc->attr.contained)
1859 : {
1860 20695 : gfc_symbol* parent_proc;
1861 :
1862 20695 : gcc_assert (context->parent);
1863 20695 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1864 : : context->parent->proc_name);
1865 :
1866 20695 : if (parent_proc == proc_sym)
1867 9 : return true;
1868 : }
1869 :
1870 : return false;
1871 : }
1872 :
1873 :
1874 : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1875 : its typespec and formal argument list. */
1876 :
1877 : bool
1878 42199 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1879 : {
1880 42199 : gfc_intrinsic_sym* isym = NULL;
1881 42199 : const char* symstd;
1882 :
1883 42199 : if (sym->resolve_symbol_called >= 2)
1884 : return true;
1885 :
1886 32472 : sym->resolve_symbol_called = 2;
1887 :
1888 : /* Already resolved. */
1889 32472 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1890 : return true;
1891 :
1892 : /* We already know this one is an intrinsic, so we don't call
1893 : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1894 : gfc_find_subroutine directly to check whether it is a function or
1895 : subroutine. */
1896 :
1897 24665 : if (sym->intmod_sym_id && sym->attr.subroutine)
1898 : {
1899 8868 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1900 8868 : isym = gfc_intrinsic_subroutine_by_id (id);
1901 8868 : }
1902 15797 : else if (sym->intmod_sym_id)
1903 : {
1904 12147 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1905 12147 : isym = gfc_intrinsic_function_by_id (id);
1906 : }
1907 3650 : else if (!sym->attr.subroutine)
1908 3563 : isym = gfc_find_function (sym->name);
1909 :
1910 24578 : if (isym && !sym->attr.subroutine)
1911 : {
1912 15665 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1913 24 : && !sym->attr.implicit_type)
1914 10 : gfc_warning (OPT_Wsurprising,
1915 : "Type specified for intrinsic function %qs at %L is"
1916 : " ignored", sym->name, &sym->declared_at);
1917 :
1918 19788 : if (!sym->attr.function &&
1919 4123 : !gfc_add_function(&sym->attr, sym->name, loc))
1920 : return false;
1921 :
1922 15665 : sym->ts = isym->ts;
1923 : }
1924 9000 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1925 : {
1926 8997 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1927 : {
1928 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1929 : " specifier", sym->name, &sym->declared_at);
1930 1 : return false;
1931 : }
1932 :
1933 9037 : if (!sym->attr.subroutine &&
1934 41 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1935 : return false;
1936 : }
1937 : else
1938 : {
1939 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1940 : &sym->declared_at);
1941 3 : return false;
1942 : }
1943 :
1944 24660 : gfc_copy_formal_args_intr (sym, isym, NULL);
1945 :
1946 24660 : sym->attr.pure = isym->pure;
1947 24660 : sym->attr.elemental = isym->elemental;
1948 :
1949 : /* Check it is actually available in the standard settings. */
1950 24660 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1951 : {
1952 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1953 : "available in the current standard settings but %s. Use "
1954 : "an appropriate %<-std=*%> option or enable "
1955 : "%<-fall-intrinsics%> in order to use it.",
1956 : sym->name, &sym->declared_at, symstd);
1957 31 : return false;
1958 : }
1959 :
1960 : return true;
1961 : }
1962 :
1963 :
1964 : /* Resolve a procedure expression, like passing it to a called procedure or as
1965 : RHS for a procedure pointer assignment. */
1966 :
1967 : static bool
1968 1318123 : resolve_procedure_expression (gfc_expr* expr)
1969 : {
1970 1318123 : gfc_symbol* sym;
1971 :
1972 1318123 : if (expr->expr_type != EXPR_VARIABLE)
1973 : return true;
1974 1318106 : gcc_assert (expr->symtree);
1975 :
1976 1318106 : sym = expr->symtree->n.sym;
1977 :
1978 1318106 : if (sym->attr.intrinsic)
1979 1346 : gfc_resolve_intrinsic (sym, &expr->where);
1980 :
1981 1318106 : if (sym->attr.flavor != FL_PROCEDURE
1982 31210 : || (sym->attr.function && sym->result == sym))
1983 : return true;
1984 :
1985 : /* A non-RECURSIVE procedure that is used as procedure expression within its
1986 : own body is in danger of being called recursively. */
1987 16896 : if (is_illegal_recursion (sym, gfc_current_ns))
1988 : {
1989 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
1990 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
1991 : " possibly calling itself recursively in procedure %qs. "
1992 : " Declare it RECURSIVE or use %<-frecursive%>",
1993 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
1994 : else
1995 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1996 : " itself recursively. Declare it RECURSIVE or use"
1997 : " %<-frecursive%>", sym->name, &expr->where);
1998 : }
1999 :
2000 : return true;
2001 : }
2002 :
2003 :
2004 : /* Check that name is not a derived type. */
2005 :
2006 : static bool
2007 3231 : is_dt_name (const char *name)
2008 : {
2009 3231 : gfc_symbol *dt_list, *dt_first;
2010 :
2011 3231 : dt_list = dt_first = gfc_derived_types;
2012 5666 : for (; dt_list; dt_list = dt_list->dt_next)
2013 : {
2014 3547 : if (strcmp(dt_list->name, name) == 0)
2015 : return true;
2016 3544 : if (dt_first == dt_list->dt_next)
2017 : break;
2018 : }
2019 : return false;
2020 : }
2021 :
2022 :
2023 : /* Resolve an actual argument list. Most of the time, this is just
2024 : resolving the expressions in the list.
2025 : The exception is that we sometimes have to decide whether arguments
2026 : that look like procedure arguments are really simple variable
2027 : references. */
2028 :
2029 : static bool
2030 424527 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2031 : bool no_formal_args)
2032 : {
2033 424527 : gfc_symbol *sym = NULL;
2034 424527 : gfc_symtree *parent_st;
2035 424527 : gfc_expr *e;
2036 424527 : gfc_component *comp;
2037 424527 : int save_need_full_assumed_size;
2038 424527 : bool return_value = false;
2039 424527 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2040 :
2041 424527 : actual_arg = true;
2042 424527 : first_actual_arg = true;
2043 :
2044 1090468 : for (; arg; arg = arg->next)
2045 : {
2046 666042 : e = arg->expr;
2047 666042 : if (e == NULL)
2048 : {
2049 : /* Check the label is a valid branching target. */
2050 2412 : if (arg->label)
2051 : {
2052 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2053 : {
2054 0 : gfc_error ("Label %d referenced at %L is never defined",
2055 : arg->label->value, &arg->label->where);
2056 0 : goto cleanup;
2057 : }
2058 : }
2059 2412 : first_actual_arg = false;
2060 2412 : continue;
2061 : }
2062 :
2063 663630 : if (e->expr_type == EXPR_VARIABLE
2064 292371 : && e->symtree->n.sym->attr.generic
2065 8 : && no_formal_args
2066 663635 : && count_specific_procs (e) != 1)
2067 2 : goto cleanup;
2068 :
2069 663628 : if (e->ts.type != BT_PROCEDURE)
2070 : {
2071 591697 : save_need_full_assumed_size = need_full_assumed_size;
2072 591697 : if (e->expr_type != EXPR_VARIABLE)
2073 371259 : need_full_assumed_size = 0;
2074 591697 : if (!gfc_resolve_expr (e))
2075 60 : goto cleanup;
2076 591637 : need_full_assumed_size = save_need_full_assumed_size;
2077 591637 : goto argument_list;
2078 : }
2079 :
2080 : /* See if the expression node should really be a variable reference. */
2081 :
2082 71931 : sym = e->symtree->n.sym;
2083 :
2084 71931 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2085 : {
2086 3 : gfc_error ("Derived type %qs is used as an actual "
2087 : "argument at %L", sym->name, &e->where);
2088 3 : goto cleanup;
2089 : }
2090 :
2091 71928 : if (sym->attr.flavor == FL_PROCEDURE
2092 68700 : || sym->attr.intrinsic
2093 68700 : || sym->attr.external)
2094 : {
2095 3228 : int actual_ok;
2096 :
2097 : /* If a procedure is not already determined to be something else
2098 : check if it is intrinsic. */
2099 3228 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2100 1254 : sym->attr.intrinsic = 1;
2101 :
2102 3228 : if (sym->attr.proc == PROC_ST_FUNCTION)
2103 : {
2104 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2105 : "actual argument", sym->name, &e->where);
2106 : }
2107 :
2108 6456 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2109 3228 : sym->attr.subroutine);
2110 3228 : if (sym->attr.intrinsic && actual_ok == 0)
2111 : {
2112 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2113 : "actual argument", sym->name, &e->where);
2114 : }
2115 :
2116 3228 : if (sym->attr.contained && !sym->attr.use_assoc
2117 414 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2118 : {
2119 226 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2120 : " used as actual argument at %L",
2121 : sym->name, &e->where))
2122 3 : goto cleanup;
2123 : }
2124 :
2125 3225 : if (sym->attr.elemental && !sym->attr.intrinsic)
2126 : {
2127 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2128 : "allowed as an actual argument at %L", sym->name,
2129 : &e->where);
2130 : }
2131 :
2132 : /* Check if a generic interface has a specific procedure
2133 : with the same name before emitting an error. */
2134 3225 : if (sym->attr.generic && count_specific_procs (e) != 1)
2135 0 : goto cleanup;
2136 :
2137 : /* Just in case a specific was found for the expression. */
2138 3225 : sym = e->symtree->n.sym;
2139 :
2140 : /* If the symbol is the function that names the current (or
2141 : parent) scope, then we really have a variable reference. */
2142 :
2143 3225 : if (gfc_is_function_return_value (sym, sym->ns))
2144 0 : goto got_variable;
2145 :
2146 : /* If all else fails, see if we have a specific intrinsic. */
2147 3225 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2148 : {
2149 0 : gfc_intrinsic_sym *isym;
2150 :
2151 0 : isym = gfc_find_function (sym->name);
2152 0 : if (isym == NULL || !isym->specific)
2153 : {
2154 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2155 : "for the reference %qs at %L", sym->name,
2156 : &e->where);
2157 0 : goto cleanup;
2158 : }
2159 0 : sym->ts = isym->ts;
2160 0 : sym->attr.intrinsic = 1;
2161 0 : sym->attr.function = 1;
2162 : }
2163 :
2164 3225 : if (!gfc_resolve_expr (e))
2165 0 : goto cleanup;
2166 3225 : goto argument_list;
2167 : }
2168 :
2169 : /* See if the name is a module procedure in a parent unit. */
2170 :
2171 68700 : if (was_declared (sym) || sym->ns->parent == NULL)
2172 68607 : goto got_variable;
2173 :
2174 93 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2175 : {
2176 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2177 0 : goto cleanup;
2178 : }
2179 :
2180 93 : if (parent_st == NULL)
2181 93 : goto got_variable;
2182 :
2183 0 : sym = parent_st->n.sym;
2184 0 : e->symtree = parent_st; /* Point to the right thing. */
2185 :
2186 0 : if (sym->attr.flavor == FL_PROCEDURE
2187 0 : || sym->attr.intrinsic
2188 0 : || sym->attr.external)
2189 : {
2190 0 : if (!gfc_resolve_expr (e))
2191 0 : goto cleanup;
2192 0 : goto argument_list;
2193 : }
2194 :
2195 0 : got_variable:
2196 68700 : e->expr_type = EXPR_VARIABLE;
2197 68700 : e->ts = sym->ts;
2198 68700 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2199 35625 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2200 3816 : && CLASS_DATA (sym)->as))
2201 : {
2202 38579 : gfc_array_spec *as
2203 35827 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2204 35827 : e->rank = as->rank;
2205 35827 : e->corank = as->corank;
2206 35827 : e->ref = gfc_get_ref ();
2207 35827 : e->ref->type = REF_ARRAY;
2208 35827 : e->ref->u.ar.type = AR_FULL;
2209 35827 : e->ref->u.ar.as = as;
2210 : }
2211 :
2212 : /* These symbols are set untyped by calls to gfc_set_default_type
2213 : with 'error_flag' = false. Reset the untyped attribute so that
2214 : the error will be generated in gfc_resolve_expr. */
2215 68700 : if (e->expr_type == EXPR_VARIABLE
2216 68700 : && sym->ts.type == BT_UNKNOWN
2217 36 : && sym->attr.untyped)
2218 5 : sym->attr.untyped = 0;
2219 :
2220 : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2221 : primary.cc (match_actual_arg). If above code determines that it
2222 : is a variable instead, it needs to be resolved as it was not
2223 : done at the beginning of this function. */
2224 68700 : save_need_full_assumed_size = need_full_assumed_size;
2225 68700 : if (e->expr_type != EXPR_VARIABLE)
2226 0 : need_full_assumed_size = 0;
2227 68700 : if (!gfc_resolve_expr (e))
2228 22 : goto cleanup;
2229 68678 : need_full_assumed_size = save_need_full_assumed_size;
2230 :
2231 663540 : argument_list:
2232 : /* Check argument list functions %VAL, %LOC and %REF. There is
2233 : nothing to do for %REF. */
2234 663540 : if (arg->name && arg->name[0] == '%')
2235 : {
2236 42 : if (strcmp ("%VAL", arg->name) == 0)
2237 : {
2238 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2239 : {
2240 2 : gfc_error ("By-value argument at %L is not of numeric "
2241 : "type", &e->where);
2242 2 : goto cleanup;
2243 : }
2244 :
2245 26 : if (e->rank)
2246 : {
2247 1 : gfc_error ("By-value argument at %L cannot be an array or "
2248 : "an array section", &e->where);
2249 1 : goto cleanup;
2250 : }
2251 :
2252 : /* Intrinsics are still PROC_UNKNOWN here. However,
2253 : since same file external procedures are not resolvable
2254 : in gfortran, it is a good deal easier to leave them to
2255 : intrinsic.cc. */
2256 25 : if (ptype != PROC_UNKNOWN
2257 25 : && ptype != PROC_DUMMY
2258 9 : && ptype != PROC_EXTERNAL
2259 9 : && ptype != PROC_MODULE)
2260 : {
2261 3 : gfc_error ("By-value argument at %L is not allowed "
2262 : "in this context", &e->where);
2263 3 : goto cleanup;
2264 : }
2265 : }
2266 :
2267 : /* Statement functions have already been excluded above. */
2268 14 : else if (strcmp ("%LOC", arg->name) == 0
2269 8 : && e->ts.type == BT_PROCEDURE)
2270 : {
2271 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2272 : {
2273 0 : gfc_error ("Passing internal procedure at %L by location "
2274 : "not allowed", &e->where);
2275 0 : goto cleanup;
2276 : }
2277 : }
2278 : }
2279 :
2280 663534 : comp = gfc_get_proc_ptr_comp(e);
2281 663534 : if (e->expr_type == EXPR_VARIABLE
2282 290993 : && comp && comp->attr.elemental)
2283 : {
2284 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2285 : "allowed as an actual argument at %L", comp->name,
2286 : &e->where);
2287 : }
2288 :
2289 : /* Fortran 2008, C1237. */
2290 290993 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2291 663979 : && gfc_has_ultimate_pointer (e))
2292 : {
2293 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2294 : "component", &e->where);
2295 3 : goto cleanup;
2296 : }
2297 :
2298 663531 : if (e->expr_type == EXPR_VARIABLE
2299 290990 : && e->ts.type == BT_PROCEDURE
2300 3225 : && no_formal_args
2301 1505 : && sym->attr.flavor == FL_PROCEDURE
2302 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2303 142 : && !sym->attr.external
2304 2 : && !sym->attr.intrinsic
2305 2 : && !sym->attr.artificial
2306 2 : && !sym->ts.interface)
2307 : {
2308 : /* Emit a warning for -std=legacy and an error otherwise. */
2309 2 : if (gfc_option.warn_std == 0)
2310 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2311 : "does neither have an explicit interface nor the "
2312 : "EXTERNAL attribute", sym->name, &e->where);
2313 : else
2314 : {
2315 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2316 : "does neither have an explicit interface nor the "
2317 : "EXTERNAL attribute", sym->name, &e->where);
2318 2 : goto cleanup;
2319 : }
2320 : }
2321 :
2322 663529 : first_actual_arg = false;
2323 : }
2324 :
2325 : return_value = true;
2326 :
2327 424527 : cleanup:
2328 424527 : actual_arg = actual_arg_sav;
2329 424527 : first_actual_arg = first_actual_arg_sav;
2330 :
2331 424527 : return return_value;
2332 : }
2333 :
2334 :
2335 : /* Do the checks of the actual argument list that are specific to elemental
2336 : procedures. If called with c == NULL, we have a function, otherwise if
2337 : expr == NULL, we have a subroutine. */
2338 :
2339 : static bool
2340 322847 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2341 : {
2342 322847 : gfc_actual_arglist *arg0;
2343 322847 : gfc_actual_arglist *arg;
2344 322847 : gfc_symbol *esym = NULL;
2345 322847 : gfc_intrinsic_sym *isym = NULL;
2346 322847 : gfc_expr *e = NULL;
2347 322847 : gfc_intrinsic_arg *iformal = NULL;
2348 322847 : gfc_formal_arglist *eformal = NULL;
2349 322847 : bool formal_optional = false;
2350 322847 : bool set_by_optional = false;
2351 322847 : int i;
2352 322847 : int rank = 0;
2353 :
2354 : /* Is this an elemental procedure? */
2355 322847 : if (expr && expr->value.function.actual != NULL)
2356 : {
2357 234293 : if (expr->value.function.esym != NULL
2358 43706 : && expr->value.function.esym->attr.elemental)
2359 : {
2360 : arg0 = expr->value.function.actual;
2361 : esym = expr->value.function.esym;
2362 : }
2363 218003 : else if (expr->value.function.isym != NULL
2364 189533 : && expr->value.function.isym->elemental)
2365 : {
2366 : arg0 = expr->value.function.actual;
2367 : isym = expr->value.function.isym;
2368 : }
2369 : else
2370 : return true;
2371 : }
2372 88554 : else if (c && c->ext.actual != NULL)
2373 : {
2374 70170 : arg0 = c->ext.actual;
2375 :
2376 70170 : if (c->resolved_sym)
2377 : esym = c->resolved_sym;
2378 : else
2379 313 : esym = c->symtree->n.sym;
2380 70170 : gcc_assert (esym);
2381 :
2382 70170 : if (!esym->attr.elemental)
2383 : return true;
2384 : }
2385 : else
2386 : return true;
2387 :
2388 : /* The rank of an elemental is the rank of its array argument(s). */
2389 173455 : for (arg = arg0; arg; arg = arg->next)
2390 : {
2391 112377 : if (arg->expr != NULL && arg->expr->rank != 0)
2392 : {
2393 10458 : rank = arg->expr->rank;
2394 10458 : if (arg->expr->expr_type == EXPR_VARIABLE
2395 5250 : && arg->expr->symtree->n.sym->attr.optional)
2396 10458 : set_by_optional = true;
2397 :
2398 : /* Function specific; set the result rank and shape. */
2399 10458 : if (expr)
2400 : {
2401 8272 : expr->rank = rank;
2402 8272 : expr->corank = arg->expr->corank;
2403 8272 : if (!expr->shape && arg->expr->shape)
2404 : {
2405 3932 : expr->shape = gfc_get_shape (rank);
2406 8659 : for (i = 0; i < rank; i++)
2407 4727 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2408 : }
2409 : }
2410 : break;
2411 : }
2412 : }
2413 :
2414 : /* If it is an array, it shall not be supplied as an actual argument
2415 : to an elemental procedure unless an array of the same rank is supplied
2416 : as an actual argument corresponding to a nonoptional dummy argument of
2417 : that elemental procedure(12.4.1.5). */
2418 71536 : formal_optional = false;
2419 71536 : if (isym)
2420 49255 : iformal = isym->formal;
2421 : else
2422 22281 : eformal = esym->formal;
2423 :
2424 189213 : for (arg = arg0; arg; arg = arg->next)
2425 : {
2426 117677 : if (eformal)
2427 : {
2428 39955 : if (eformal->sym && eformal->sym->attr.optional)
2429 39955 : formal_optional = true;
2430 39955 : eformal = eformal->next;
2431 : }
2432 77722 : else if (isym && iformal)
2433 : {
2434 67499 : if (iformal->optional)
2435 13411 : formal_optional = true;
2436 67499 : iformal = iformal->next;
2437 : }
2438 10223 : else if (isym)
2439 10215 : formal_optional = true;
2440 :
2441 117677 : if (pedantic && arg->expr != NULL
2442 68473 : && arg->expr->expr_type == EXPR_VARIABLE
2443 32212 : && arg->expr->symtree->n.sym->attr.optional
2444 572 : && formal_optional
2445 479 : && arg->expr->rank
2446 153 : && (set_by_optional || arg->expr->rank != rank)
2447 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2448 : {
2449 114 : bool t = false;
2450 : gfc_actual_arglist *a;
2451 :
2452 : /* Scan the argument list for a non-optional argument with the
2453 : same rank as arg. */
2454 114 : for (a = arg0; a; a = a->next)
2455 87 : if (a != arg
2456 45 : && a->expr->rank == arg->expr->rank
2457 39 : && (a->expr->expr_type != EXPR_VARIABLE
2458 37 : || (a->expr->expr_type == EXPR_VARIABLE
2459 37 : && !a->expr->symtree->n.sym->attr.optional)))
2460 : {
2461 : t = true;
2462 : break;
2463 : }
2464 :
2465 42 : if (!t)
2466 27 : gfc_warning (OPT_Wpedantic,
2467 : "%qs at %L is an array and OPTIONAL; If it is not "
2468 : "present, then it cannot be the actual argument of "
2469 : "an ELEMENTAL procedure unless there is a non-optional"
2470 : " argument with the same rank "
2471 : "(Fortran 2018, 15.5.2.12)",
2472 : arg->expr->symtree->n.sym->name, &arg->expr->where);
2473 : }
2474 : }
2475 :
2476 189202 : for (arg = arg0; arg; arg = arg->next)
2477 : {
2478 117675 : if (arg->expr == NULL || arg->expr->rank == 0)
2479 104545 : continue;
2480 :
2481 : /* Being elemental, the last upper bound of an assumed size array
2482 : argument must be present. */
2483 13130 : if (resolve_assumed_size_actual (arg->expr))
2484 : return false;
2485 :
2486 : /* Elemental procedure's array actual arguments must conform. */
2487 13127 : if (e != NULL)
2488 : {
2489 2672 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2490 : return false;
2491 : }
2492 : else
2493 10455 : e = arg->expr;
2494 : }
2495 :
2496 : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2497 : is an array, the intent inout/out variable needs to be also an array. */
2498 71527 : if (rank > 0 && esym && expr == NULL)
2499 6673 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2500 4493 : arg = arg->next, eformal = eformal->next)
2501 4495 : if (eformal->sym
2502 4494 : && (eformal->sym->attr.intent == INTENT_OUT
2503 3412 : || eformal->sym->attr.intent == INTENT_INOUT)
2504 1494 : && arg->expr && arg->expr->rank == 0)
2505 : {
2506 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2507 : "ELEMENTAL subroutine %qs is a scalar, but another "
2508 : "actual argument is an array", &arg->expr->where,
2509 : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2510 : : "INOUT", eformal->sym->name, esym->name);
2511 2 : return false;
2512 : }
2513 : return true;
2514 : }
2515 :
2516 :
2517 : /* This function does the checking of references to global procedures
2518 : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2519 : 77 and 95 standards. It checks for a gsymbol for the name, making
2520 : one if it does not already exist. If it already exists, then the
2521 : reference being resolved must correspond to the type of gsymbol.
2522 : Otherwise, the new symbol is equipped with the attributes of the
2523 : reference. The corresponding code that is called in creating
2524 : global entities is parse.cc.
2525 :
2526 : In addition, for all but -std=legacy, the gsymbols are used to
2527 : check the interfaces of external procedures from the same file.
2528 : The namespace of the gsymbol is resolved and then, once this is
2529 : done the interface is checked. */
2530 :
2531 :
2532 : static bool
2533 14861 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2534 : {
2535 14861 : if (!gsym_ns->proc_name->attr.recursive)
2536 : return true;
2537 :
2538 151 : if (sym->ns == gsym_ns)
2539 : return false;
2540 :
2541 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2542 0 : return false;
2543 :
2544 : return true;
2545 : }
2546 :
2547 : static bool
2548 14861 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2549 : {
2550 14861 : if (gsym_ns->entries)
2551 : {
2552 : gfc_entry_list *entry = gsym_ns->entries;
2553 :
2554 3234 : for (; entry; entry = entry->next)
2555 : {
2556 2281 : if (strcmp (sym->name, entry->sym->name) == 0)
2557 : {
2558 946 : if (strcmp (gsym_ns->proc_name->name,
2559 946 : sym->ns->proc_name->name) == 0)
2560 : return false;
2561 :
2562 946 : if (sym->ns->parent
2563 0 : && strcmp (gsym_ns->proc_name->name,
2564 0 : sym->ns->parent->proc_name->name) == 0)
2565 : return false;
2566 : }
2567 : }
2568 : }
2569 : return true;
2570 : }
2571 :
2572 :
2573 : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2574 :
2575 : bool
2576 15697 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2577 : {
2578 15697 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2579 :
2580 58774 : for ( ; arg; arg = arg->next)
2581 : {
2582 27752 : if (!arg->sym)
2583 157 : continue;
2584 :
2585 27595 : if (arg->sym->attr.allocatable) /* (2a) */
2586 : {
2587 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2588 0 : return true;
2589 : }
2590 27595 : else if (arg->sym->attr.asynchronous)
2591 : {
2592 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2593 0 : return true;
2594 : }
2595 27595 : else if (arg->sym->attr.optional)
2596 : {
2597 75 : strncpy (errmsg, _("optional argument"), err_len);
2598 75 : return true;
2599 : }
2600 27520 : else if (arg->sym->attr.pointer)
2601 : {
2602 12 : strncpy (errmsg, _("pointer argument"), err_len);
2603 12 : return true;
2604 : }
2605 27508 : else if (arg->sym->attr.target)
2606 : {
2607 72 : strncpy (errmsg, _("target argument"), err_len);
2608 72 : return true;
2609 : }
2610 27436 : else if (arg->sym->attr.value)
2611 : {
2612 0 : strncpy (errmsg, _("value argument"), err_len);
2613 0 : return true;
2614 : }
2615 27436 : else if (arg->sym->attr.volatile_)
2616 : {
2617 1 : strncpy (errmsg, _("volatile argument"), err_len);
2618 1 : return true;
2619 : }
2620 27435 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2621 : {
2622 45 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2623 45 : return true;
2624 : }
2625 27390 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2626 : {
2627 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2628 1 : return true;
2629 : }
2630 27389 : else if (arg->sym->attr.codimension) /* (2c) */
2631 : {
2632 1 : strncpy (errmsg, _("coarray argument"), err_len);
2633 1 : return true;
2634 : }
2635 27388 : else if (false) /* (2d) TODO: parametrized derived type */
2636 : {
2637 : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2638 : return true;
2639 : }
2640 27388 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2641 : {
2642 164 : strncpy (errmsg, _("polymorphic argument"), err_len);
2643 164 : return true;
2644 : }
2645 27224 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2646 : {
2647 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2648 0 : return true;
2649 : }
2650 27224 : else if (arg->sym->ts.type == BT_ASSUMED)
2651 : {
2652 : /* As assumed-type is unlimited polymorphic (cf. above).
2653 : See also TS 29113, Note 6.1. */
2654 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2655 1 : return true;
2656 : }
2657 : }
2658 :
2659 15325 : if (sym->attr.function)
2660 : {
2661 3457 : gfc_symbol *res = sym->result ? sym->result : sym;
2662 :
2663 3457 : if (res->attr.dimension) /* (3a) */
2664 : {
2665 93 : strncpy (errmsg, _("array result"), err_len);
2666 93 : return true;
2667 : }
2668 3364 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2669 : {
2670 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2671 38 : return true;
2672 : }
2673 3326 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2674 347 : && res->ts.u.cl->length
2675 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2676 : {
2677 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2678 12 : return true;
2679 : }
2680 : }
2681 :
2682 15182 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2683 : {
2684 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2685 7 : return true;
2686 : }
2687 15175 : else if (sym->attr.is_bind_c) /* (5) */
2688 : {
2689 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2690 0 : return true;
2691 : }
2692 :
2693 : return false;
2694 : }
2695 :
2696 :
2697 : static void
2698 29246 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2699 : {
2700 29246 : gfc_gsymbol * gsym;
2701 29246 : gfc_namespace *ns;
2702 29246 : enum gfc_symbol_type type;
2703 29246 : char reason[200];
2704 :
2705 29246 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2706 :
2707 29246 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2708 29246 : sym->binding_label != NULL);
2709 :
2710 29246 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2711 10 : gfc_global_used (gsym, where);
2712 :
2713 29246 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2714 9141 : || sym->attr.if_source == IFSRC_IFBODY)
2715 24894 : && gsym->type != GSYM_UNKNOWN
2716 22733 : && !gsym->binding_label
2717 20470 : && gsym->ns
2718 14861 : && gsym->ns->proc_name
2719 14861 : && not_in_recursive (sym, gsym->ns)
2720 44107 : && not_entry_self_reference (sym, gsym->ns))
2721 : {
2722 14861 : gfc_symbol *def_sym;
2723 14861 : def_sym = gsym->ns->proc_name;
2724 :
2725 14861 : if (gsym->ns->resolved != -1)
2726 : {
2727 :
2728 : /* Resolve the gsymbol namespace if needed. */
2729 14840 : if (!gsym->ns->resolved)
2730 : {
2731 2767 : gfc_symbol *old_dt_list;
2732 :
2733 : /* Stash away derived types so that the backend_decls
2734 : do not get mixed up. */
2735 2767 : old_dt_list = gfc_derived_types;
2736 2767 : gfc_derived_types = NULL;
2737 :
2738 2767 : gfc_resolve (gsym->ns);
2739 :
2740 : /* Store the new derived types with the global namespace. */
2741 2767 : if (gfc_derived_types)
2742 306 : gsym->ns->derived_types = gfc_derived_types;
2743 :
2744 : /* Restore the derived types of this namespace. */
2745 2767 : gfc_derived_types = old_dt_list;
2746 : }
2747 :
2748 : /* Make sure that translation for the gsymbol occurs before
2749 : the procedure currently being resolved. */
2750 14840 : ns = gfc_global_ns_list;
2751 25181 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2752 : {
2753 16827 : if (ns->sibling == gsym->ns)
2754 : {
2755 6486 : ns->sibling = gsym->ns->sibling;
2756 6486 : gsym->ns->sibling = gfc_global_ns_list;
2757 6486 : gfc_global_ns_list = gsym->ns;
2758 6486 : break;
2759 : }
2760 : }
2761 :
2762 : /* This can happen if a binding name has been specified. */
2763 14840 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2764 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2765 :
2766 14840 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2767 : {
2768 953 : gfc_entry_list *entry;
2769 1659 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2770 1659 : if (strcmp (entry->sym->name, sym->name) == 0)
2771 : {
2772 953 : def_sym = entry->sym;
2773 953 : break;
2774 : }
2775 : }
2776 : }
2777 :
2778 14861 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2779 : {
2780 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2781 : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2782 6 : gfc_typename (&def_sym->ts));
2783 28 : goto done;
2784 : }
2785 :
2786 14855 : if (sym->attr.if_source == IFSRC_UNKNOWN
2787 14855 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2788 : {
2789 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2790 : sym->name, &sym->declared_at, reason);
2791 8 : goto done;
2792 : }
2793 :
2794 14847 : bool bad_result_characteristics;
2795 14847 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2796 : reason, sizeof(reason), NULL, NULL,
2797 : &bad_result_characteristics))
2798 : {
2799 : /* Turn erros into warnings with -std=gnu and -std=legacy,
2800 : unless a function returns a wrong type, which can lead
2801 : to all kinds of ICEs and wrong code. */
2802 :
2803 14 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2804 2 : && !bad_result_characteristics)
2805 2 : gfc_errors_to_warnings (true);
2806 :
2807 14 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2808 : sym->name, &sym->declared_at, reason);
2809 14 : sym->error = 1;
2810 14 : gfc_errors_to_warnings (false);
2811 14 : goto done;
2812 : }
2813 : }
2814 :
2815 29246 : done:
2816 :
2817 29246 : if (gsym->type == GSYM_UNKNOWN)
2818 : {
2819 3920 : gsym->type = type;
2820 3920 : gsym->where = *where;
2821 : }
2822 :
2823 29246 : gsym->used = 1;
2824 29246 : }
2825 :
2826 :
2827 : /************* Function resolution *************/
2828 :
2829 : /* Resolve a function call known to be generic.
2830 : Section 14.1.2.4.1. */
2831 :
2832 : static match
2833 27404 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2834 : {
2835 27404 : gfc_symbol *s;
2836 :
2837 27404 : if (sym->attr.generic)
2838 : {
2839 26299 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2840 26299 : if (s != NULL)
2841 : {
2842 19774 : expr->value.function.name = s->name;
2843 19774 : expr->value.function.esym = s;
2844 :
2845 19774 : if (s->ts.type != BT_UNKNOWN)
2846 19757 : expr->ts = s->ts;
2847 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2848 15 : expr->ts = s->result->ts;
2849 :
2850 19774 : if (s->as != NULL)
2851 : {
2852 55 : expr->rank = s->as->rank;
2853 55 : expr->corank = s->as->corank;
2854 : }
2855 19719 : else if (s->result != NULL && s->result->as != NULL)
2856 : {
2857 0 : expr->rank = s->result->as->rank;
2858 0 : expr->corank = s->result->as->corank;
2859 : }
2860 :
2861 19774 : gfc_set_sym_referenced (expr->value.function.esym);
2862 :
2863 19774 : return MATCH_YES;
2864 : }
2865 :
2866 : /* TODO: Need to search for elemental references in generic
2867 : interface. */
2868 : }
2869 :
2870 7630 : if (sym->attr.intrinsic)
2871 1062 : return gfc_intrinsic_func_interface (expr, 0);
2872 :
2873 : return MATCH_NO;
2874 : }
2875 :
2876 :
2877 : static bool
2878 27263 : resolve_generic_f (gfc_expr *expr)
2879 : {
2880 27263 : gfc_symbol *sym;
2881 27263 : match m;
2882 27263 : gfc_interface *intr = NULL;
2883 :
2884 27263 : sym = expr->symtree->n.sym;
2885 :
2886 27404 : for (;;)
2887 : {
2888 27404 : m = resolve_generic_f0 (expr, sym);
2889 27404 : if (m == MATCH_YES)
2890 : return true;
2891 6570 : else if (m == MATCH_ERROR)
2892 : return false;
2893 :
2894 6570 : generic:
2895 6573 : if (!intr)
2896 6544 : for (intr = sym->generic; intr; intr = intr->next)
2897 6460 : if (gfc_fl_struct (intr->sym->attr.flavor))
2898 : break;
2899 :
2900 6573 : if (sym->ns->parent == NULL)
2901 : break;
2902 283 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2903 :
2904 283 : if (sym == NULL)
2905 : break;
2906 144 : if (!generic_sym (sym))
2907 3 : goto generic;
2908 : }
2909 :
2910 : /* Last ditch attempt. See if the reference is to an intrinsic
2911 : that possesses a matching interface. 14.1.2.4 */
2912 6429 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2913 : {
2914 5 : if (gfc_init_expr_flag)
2915 1 : gfc_error ("Function %qs in initialization expression at %L "
2916 : "must be an intrinsic function",
2917 1 : expr->symtree->n.sym->name, &expr->where);
2918 : else
2919 4 : gfc_error ("There is no specific function for the generic %qs "
2920 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2921 5 : return false;
2922 : }
2923 :
2924 6424 : if (intr)
2925 : {
2926 6389 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2927 : NULL, false))
2928 : return false;
2929 6362 : if (!gfc_use_derived (expr->ts.u.derived))
2930 : return false;
2931 6362 : return resolve_structure_cons (expr, 0);
2932 : }
2933 :
2934 35 : m = gfc_intrinsic_func_interface (expr, 0);
2935 35 : if (m == MATCH_YES)
2936 : return true;
2937 :
2938 3 : if (m == MATCH_NO)
2939 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2940 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2941 : &expr->where);
2942 :
2943 : return false;
2944 : }
2945 :
2946 :
2947 : /* Resolve a function call known to be specific. */
2948 :
2949 : static match
2950 27848 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2951 : {
2952 27848 : match m;
2953 :
2954 27848 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2955 : {
2956 7961 : if (sym->attr.dummy)
2957 : {
2958 276 : sym->attr.proc = PROC_DUMMY;
2959 276 : goto found;
2960 : }
2961 :
2962 7685 : sym->attr.proc = PROC_EXTERNAL;
2963 7685 : goto found;
2964 : }
2965 :
2966 19887 : if (sym->attr.proc == PROC_MODULE
2967 : || sym->attr.proc == PROC_ST_FUNCTION
2968 : || sym->attr.proc == PROC_INTERNAL)
2969 19149 : goto found;
2970 :
2971 738 : if (sym->attr.intrinsic)
2972 : {
2973 731 : m = gfc_intrinsic_func_interface (expr, 1);
2974 731 : if (m == MATCH_YES)
2975 : return MATCH_YES;
2976 0 : if (m == MATCH_NO)
2977 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2978 : "with an intrinsic", sym->name, &expr->where);
2979 :
2980 0 : return MATCH_ERROR;
2981 : }
2982 :
2983 : return MATCH_NO;
2984 :
2985 27110 : found:
2986 27110 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2987 :
2988 27110 : if (sym->result)
2989 27110 : expr->ts = sym->result->ts;
2990 : else
2991 0 : expr->ts = sym->ts;
2992 27110 : expr->value.function.name = sym->name;
2993 27110 : expr->value.function.esym = sym;
2994 : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2995 : error(s). */
2996 27110 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2997 : return MATCH_ERROR;
2998 27109 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2999 : {
3000 322 : expr->rank = CLASS_DATA (sym)->as->rank;
3001 322 : expr->corank = CLASS_DATA (sym)->as->corank;
3002 : }
3003 26787 : else if (sym->as != NULL)
3004 : {
3005 2305 : expr->rank = sym->as->rank;
3006 2305 : expr->corank = sym->as->corank;
3007 : }
3008 :
3009 : return MATCH_YES;
3010 : }
3011 :
3012 :
3013 : static bool
3014 27841 : resolve_specific_f (gfc_expr *expr)
3015 : {
3016 27841 : gfc_symbol *sym;
3017 27841 : match m;
3018 :
3019 27841 : sym = expr->symtree->n.sym;
3020 :
3021 27848 : for (;;)
3022 : {
3023 27848 : m = resolve_specific_f0 (sym, expr);
3024 27848 : if (m == MATCH_YES)
3025 : return true;
3026 8 : if (m == MATCH_ERROR)
3027 : return false;
3028 :
3029 7 : if (sym->ns->parent == NULL)
3030 : break;
3031 :
3032 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3033 :
3034 7 : if (sym == NULL)
3035 : break;
3036 : }
3037 :
3038 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3039 0 : expr->symtree->n.sym->name, &expr->where);
3040 :
3041 0 : return true;
3042 : }
3043 :
3044 : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3045 : candidates in CANDIDATES_LEN. */
3046 :
3047 : static void
3048 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3049 : char **&candidates,
3050 : size_t &candidates_len)
3051 : {
3052 388 : gfc_symtree *p;
3053 :
3054 388 : if (sym == NULL)
3055 : return;
3056 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3057 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3058 51 : vec_push (candidates, candidates_len, sym->name);
3059 :
3060 388 : p = sym->left;
3061 388 : if (p)
3062 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3063 :
3064 388 : p = sym->right;
3065 388 : if (p)
3066 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3067 : }
3068 :
3069 :
3070 : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3071 :
3072 : const char*
3073 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3074 : {
3075 57 : char **candidates = NULL;
3076 57 : size_t candidates_len = 0;
3077 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3078 57 : return gfc_closest_fuzzy_match (fn, candidates);
3079 : }
3080 :
3081 :
3082 : /* Resolve a procedure call not known to be generic nor specific. */
3083 :
3084 : static bool
3085 274799 : resolve_unknown_f (gfc_expr *expr)
3086 : {
3087 274799 : gfc_symbol *sym;
3088 274799 : gfc_typespec *ts;
3089 :
3090 274799 : sym = expr->symtree->n.sym;
3091 :
3092 274799 : if (sym->attr.dummy)
3093 : {
3094 289 : sym->attr.proc = PROC_DUMMY;
3095 289 : expr->value.function.name = sym->name;
3096 289 : goto set_type;
3097 : }
3098 :
3099 : /* See if we have an intrinsic function reference. */
3100 :
3101 274510 : if (gfc_is_intrinsic (sym, 0, expr->where))
3102 : {
3103 272255 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3104 : return true;
3105 : return false;
3106 : }
3107 :
3108 : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3109 : /* Intrinsics were handled above, only non-intrinsics left here. */
3110 2255 : if (sym->attr.flavor == FL_PROCEDURE
3111 2252 : && sym->attr.implicit_type
3112 371 : && sym->ns
3113 371 : && sym->ns->has_implicit_none_export)
3114 : {
3115 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3116 : "for symbol %qs at %L", sym->name, &sym->declared_at);
3117 3 : sym->error = 1;
3118 3 : return false;
3119 : }
3120 :
3121 : /* The reference is to an external name. */
3122 :
3123 2252 : sym->attr.proc = PROC_EXTERNAL;
3124 2252 : expr->value.function.name = sym->name;
3125 2252 : expr->value.function.esym = expr->symtree->n.sym;
3126 :
3127 2252 : if (sym->as != NULL)
3128 : {
3129 1 : expr->rank = sym->as->rank;
3130 1 : expr->corank = sym->as->corank;
3131 : }
3132 :
3133 : /* Type of the expression is either the type of the symbol or the
3134 : default type of the symbol. */
3135 :
3136 2251 : set_type:
3137 2541 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3138 :
3139 2541 : if (sym->ts.type != BT_UNKNOWN)
3140 2490 : expr->ts = sym->ts;
3141 : else
3142 : {
3143 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3144 :
3145 51 : if (ts->type == BT_UNKNOWN)
3146 : {
3147 41 : const char *guessed
3148 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3149 41 : if (guessed)
3150 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3151 : "; did you mean %qs?",
3152 : sym->name, &expr->where, guessed);
3153 : else
3154 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3155 : sym->name, &expr->where);
3156 41 : return false;
3157 : }
3158 : else
3159 10 : expr->ts = *ts;
3160 : }
3161 :
3162 : return true;
3163 : }
3164 :
3165 :
3166 : /* Return true, if the symbol is an external procedure. */
3167 : static bool
3168 846462 : is_external_proc (gfc_symbol *sym)
3169 : {
3170 844771 : if (!sym->attr.dummy && !sym->attr.contained
3171 737817 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3172 160635 : && sym->attr.proc != PROC_ST_FUNCTION
3173 160040 : && !sym->attr.proc_pointer
3174 158930 : && !sym->attr.use_assoc
3175 904985 : && sym->name)
3176 : return true;
3177 :
3178 : return false;
3179 : }
3180 :
3181 :
3182 : /* Figure out if a function reference is pure or not. Also set the name
3183 : of the function for a potential error message. Return nonzero if the
3184 : function is PURE, zero if not. */
3185 : static bool
3186 : pure_stmt_function (gfc_expr *, gfc_symbol *);
3187 :
3188 : bool
3189 254465 : gfc_pure_function (gfc_expr *e, const char **name)
3190 : {
3191 254465 : bool pure;
3192 254465 : gfc_component *comp;
3193 :
3194 254465 : *name = NULL;
3195 :
3196 254465 : if (e->symtree != NULL
3197 254111 : && e->symtree->n.sym != NULL
3198 254111 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3199 305 : return pure_stmt_function (e, e->symtree->n.sym);
3200 :
3201 254160 : comp = gfc_get_proc_ptr_comp (e);
3202 254160 : if (comp)
3203 : {
3204 465 : pure = gfc_pure (comp->ts.interface);
3205 465 : *name = comp->name;
3206 : }
3207 253695 : else if (e->value.function.esym)
3208 : {
3209 52411 : pure = gfc_pure (e->value.function.esym);
3210 52411 : *name = e->value.function.esym->name;
3211 : }
3212 201284 : else if (e->value.function.isym)
3213 : {
3214 400430 : pure = e->value.function.isym->pure
3215 200215 : || e->value.function.isym->elemental;
3216 200215 : *name = e->value.function.isym->name;
3217 : }
3218 1069 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3219 : {
3220 : /* The function has been resolved, but esym is not yet set.
3221 : This can happen with functions as dummy argument. */
3222 287 : pure = e->symtree->n.sym->attr.pure;
3223 287 : *name = e->symtree->n.sym->name;
3224 : }
3225 : else
3226 : {
3227 : /* Implicit functions are not pure. */
3228 782 : pure = 0;
3229 782 : *name = e->value.function.name;
3230 : }
3231 :
3232 : return pure;
3233 : }
3234 :
3235 :
3236 : /* Check if the expression is a reference to an implicitly pure function. */
3237 :
3238 : bool
3239 37822 : gfc_implicit_pure_function (gfc_expr *e)
3240 : {
3241 37822 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3242 37822 : if (comp)
3243 449 : return gfc_implicit_pure (comp->ts.interface);
3244 37373 : else if (e->value.function.esym)
3245 31970 : return gfc_implicit_pure (e->value.function.esym);
3246 : else
3247 : return 0;
3248 : }
3249 :
3250 :
3251 : static bool
3252 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3253 : int *f ATTRIBUTE_UNUSED)
3254 : {
3255 981 : const char *name;
3256 :
3257 : /* Don't bother recursing into other statement functions
3258 : since they will be checked individually for purity. */
3259 981 : if (e->expr_type != EXPR_FUNCTION
3260 343 : || !e->symtree
3261 343 : || e->symtree->n.sym == sym
3262 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3263 : return false;
3264 :
3265 19 : return gfc_pure_function (e, &name) ? false : true;
3266 : }
3267 :
3268 :
3269 : static bool
3270 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3271 : {
3272 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3273 : }
3274 :
3275 :
3276 : /* Check if an impure function is allowed in the current context. */
3277 :
3278 242646 : static bool check_pure_function (gfc_expr *e)
3279 : {
3280 242646 : const char *name = NULL;
3281 242646 : code_stack *stack;
3282 242646 : bool saw_block = false;
3283 :
3284 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3285 : gfc_do_concurrent_flag = 0 when the check for an impure function
3286 : occurs. Check the stack to see if the source code has a nested
3287 : BLOCK construct. */
3288 :
3289 561524 : for (stack = cs_base; stack; stack = stack->prev)
3290 : {
3291 318880 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3292 : {
3293 7195 : saw_block = true;
3294 7195 : continue;
3295 : }
3296 :
3297 5221 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3298 : {
3299 10 : bool is_pure;
3300 318878 : is_pure = (e->value.function.isym
3301 9 : && (e->value.function.isym->pure
3302 1 : || e->value.function.isym->elemental))
3303 11 : || (e->value.function.esym
3304 1 : && (e->value.function.esym->attr.pure
3305 1 : || e->value.function.esym->attr.elemental));
3306 2 : if (!is_pure)
3307 : {
3308 2 : gfc_error ("Reference to impure function at %L inside a "
3309 : "DO CONCURRENT", &e->where);
3310 2 : return false;
3311 : }
3312 : }
3313 : }
3314 :
3315 242644 : if (!gfc_pure_function (e, &name) && name)
3316 : {
3317 36553 : if (forall_flag)
3318 : {
3319 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3320 : "FORALL %s", name, &e->where,
3321 : forall_flag == 2 ? "mask" : "block");
3322 4 : return false;
3323 : }
3324 36549 : else if (gfc_do_concurrent_flag)
3325 : {
3326 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3327 : "DO CONCURRENT %s", name, &e->where,
3328 : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3329 2 : return false;
3330 : }
3331 36547 : else if (gfc_pure (NULL))
3332 : {
3333 5 : gfc_error ("Reference to impure function %qs at %L "
3334 : "within a PURE procedure", name, &e->where);
3335 5 : return false;
3336 : }
3337 36542 : if (!gfc_implicit_pure_function (e))
3338 30152 : gfc_unset_implicit_pure (NULL);
3339 : }
3340 : return true;
3341 : }
3342 :
3343 :
3344 : /* Update current procedure's array_outer_dependency flag, considering
3345 : a call to procedure SYM. */
3346 :
3347 : static void
3348 131489 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3349 : {
3350 : /* Check to see if this is a sibling function that has not yet
3351 : been resolved. */
3352 131489 : gfc_namespace *sibling = gfc_current_ns->sibling;
3353 247996 : for (; sibling; sibling = sibling->sibling)
3354 : {
3355 123310 : if (sibling->proc_name == sym)
3356 : {
3357 6803 : gfc_resolve (sibling);
3358 6803 : break;
3359 : }
3360 : }
3361 :
3362 : /* If SYM has references to outer arrays, so has the procedure calling
3363 : SYM. If SYM is a procedure pointer, we can assume the worst. */
3364 131489 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3365 67749 : && gfc_current_ns->proc_name)
3366 67705 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3367 131489 : }
3368 :
3369 :
3370 : /* Resolve a function call, which means resolving the arguments, then figuring
3371 : out which entity the name refers to. */
3372 :
3373 : static bool
3374 343044 : resolve_function (gfc_expr *expr)
3375 : {
3376 343044 : gfc_actual_arglist *arg;
3377 343044 : gfc_symbol *sym;
3378 343044 : bool t;
3379 343044 : int temp;
3380 343044 : procedure_type p = PROC_INTRINSIC;
3381 343044 : bool no_formal_args;
3382 :
3383 343044 : sym = NULL;
3384 343044 : if (expr->symtree)
3385 342690 : sym = expr->symtree->n.sym;
3386 :
3387 : /* If this is a procedure pointer component, it has already been resolved. */
3388 343044 : if (gfc_is_proc_ptr_comp (expr))
3389 : return true;
3390 :
3391 : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3392 : another caf_get. */
3393 342646 : if (sym && sym->attr.intrinsic
3394 8454 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3395 8454 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3396 : return true;
3397 :
3398 342646 : if (expr->ref)
3399 : {
3400 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3401 : &expr->where);
3402 1 : return false;
3403 : }
3404 :
3405 342291 : if (sym && sym->attr.intrinsic
3406 351099 : && !gfc_resolve_intrinsic (sym, &expr->where))
3407 : return false;
3408 :
3409 342645 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3410 : {
3411 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3412 4 : return false;
3413 : }
3414 :
3415 : /* If this is a deferred TBP with an abstract interface (which may
3416 : of course be referenced), expr->value.function.esym will be set. */
3417 342287 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3418 : {
3419 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3420 : sym->name, &expr->where);
3421 1 : return false;
3422 : }
3423 :
3424 : /* If this is a deferred TBP with an abstract interface, its result
3425 : cannot be an assumed length character (F2003: C418). */
3426 342286 : if (sym && sym->attr.abstract && sym->attr.function
3427 192 : && sym->result->ts.u.cl
3428 158 : && sym->result->ts.u.cl->length == NULL
3429 2 : && !sym->result->ts.deferred)
3430 : {
3431 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3432 : "character length result (F2008: C418)", sym->name,
3433 : &sym->declared_at);
3434 1 : return false;
3435 : }
3436 :
3437 : /* Switch off assumed size checking and do this again for certain kinds
3438 : of procedure, once the procedure itself is resolved. */
3439 342639 : need_full_assumed_size++;
3440 :
3441 342639 : if (expr->symtree && expr->symtree->n.sym)
3442 342285 : p = expr->symtree->n.sym->attr.proc;
3443 :
3444 342639 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3445 1093 : inquiry_argument = true;
3446 342285 : no_formal_args = sym && is_external_proc (sym)
3447 356339 : && gfc_sym_get_dummy_args (sym) == NULL;
3448 :
3449 342639 : if (!resolve_actual_arglist (expr->value.function.actual,
3450 : p, no_formal_args))
3451 : {
3452 67 : inquiry_argument = false;
3453 67 : return false;
3454 : }
3455 :
3456 342572 : inquiry_argument = false;
3457 :
3458 : /* Resume assumed_size checking. */
3459 342572 : need_full_assumed_size--;
3460 :
3461 : /* If the procedure is external, check for usage. */
3462 342572 : if (sym && is_external_proc (sym))
3463 13680 : resolve_global_procedure (sym, &expr->where, 0);
3464 :
3465 342572 : if (sym && sym->ts.type == BT_CHARACTER
3466 3242 : && sym->ts.u.cl
3467 3182 : && sym->ts.u.cl->length == NULL
3468 670 : && !sym->attr.dummy
3469 663 : && !sym->ts.deferred
3470 2 : && expr->value.function.esym == NULL
3471 2 : && !sym->attr.contained)
3472 : {
3473 : /* Internal procedures are taken care of in resolve_contained_fntype. */
3474 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3475 : "be used at %L since it is not a dummy argument",
3476 : sym->name, &expr->where);
3477 1 : return false;
3478 : }
3479 :
3480 : /* Add and check formal interface when -fc-prototypes-external is in
3481 : force, see comment in resolve_call(). */
3482 :
3483 342571 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3484 18 : && sym->attr.external)
3485 : {
3486 18 : if (sym->formal)
3487 : {
3488 6 : bool conflict;
3489 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3490 : sym->formal, 0, 0, 0, NULL);
3491 6 : if (conflict)
3492 : {
3493 6 : sym->ext_dummy_arglist_mismatch = 1;
3494 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3495 : "Different argument lists in external dummy "
3496 : "function %s at %L and %L", sym->name,
3497 : &expr->where, &sym->formal_at);
3498 : }
3499 : }
3500 12 : else if (!sym->formal_resolved)
3501 : {
3502 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3503 6 : sym->formal_at = expr->where;
3504 : }
3505 : }
3506 : /* See if function is already resolved. */
3507 :
3508 342571 : if (expr->value.function.name != NULL
3509 330689 : || expr->value.function.isym != NULL)
3510 : {
3511 12668 : if (expr->ts.type == BT_UNKNOWN)
3512 3 : expr->ts = sym->ts;
3513 : t = true;
3514 : }
3515 : else
3516 : {
3517 : /* Apply the rules of section 14.1.2. */
3518 :
3519 329903 : switch (procedure_kind (sym))
3520 : {
3521 27263 : case PTYPE_GENERIC:
3522 27263 : t = resolve_generic_f (expr);
3523 27263 : break;
3524 :
3525 27841 : case PTYPE_SPECIFIC:
3526 27841 : t = resolve_specific_f (expr);
3527 27841 : break;
3528 :
3529 274799 : case PTYPE_UNKNOWN:
3530 274799 : t = resolve_unknown_f (expr);
3531 274799 : break;
3532 :
3533 : default:
3534 : gfc_internal_error ("resolve_function(): bad function type");
3535 : }
3536 : }
3537 :
3538 : /* If the expression is still a function (it might have simplified),
3539 : then we check to see if we are calling an elemental function. */
3540 :
3541 342571 : if (expr->expr_type != EXPR_FUNCTION)
3542 : return t;
3543 :
3544 : /* Walk the argument list looking for invalid BOZ. */
3545 735213 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3546 493009 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3547 : {
3548 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3549 : "actual argument in a function reference",
3550 : &arg->expr->where);
3551 5 : return false;
3552 : }
3553 :
3554 242204 : temp = need_full_assumed_size;
3555 242204 : need_full_assumed_size = 0;
3556 :
3557 242204 : if (!resolve_elemental_actual (expr, NULL))
3558 : return false;
3559 :
3560 242201 : if (omp_workshare_flag
3561 32 : && expr->value.function.esym
3562 242206 : && ! gfc_elemental (expr->value.function.esym))
3563 : {
3564 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3565 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3566 : &expr->where);
3567 4 : t = false;
3568 : }
3569 :
3570 : #define GENERIC_ID expr->value.function.isym->id
3571 242197 : else if (expr->value.function.actual != NULL
3572 234290 : && expr->value.function.isym != NULL
3573 189532 : && GENERIC_ID != GFC_ISYM_LBOUND
3574 : && GENERIC_ID != GFC_ISYM_LCOBOUND
3575 : && GENERIC_ID != GFC_ISYM_UCOBOUND
3576 : && GENERIC_ID != GFC_ISYM_LEN
3577 : && GENERIC_ID != GFC_ISYM_LOC
3578 : && GENERIC_ID != GFC_ISYM_C_LOC
3579 : && GENERIC_ID != GFC_ISYM_PRESENT)
3580 : {
3581 : /* Array intrinsics must also have the last upper bound of an
3582 : assumed size array argument. UBOUND and SIZE have to be
3583 : excluded from the check if the second argument is anything
3584 : than a constant. */
3585 :
3586 533777 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3587 : {
3588 369945 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3589 45245 : && arg == expr->value.function.actual
3590 16685 : && arg->next != NULL && arg->next->expr)
3591 : {
3592 8236 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3593 : break;
3594 :
3595 8012 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3596 : break;
3597 :
3598 8012 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3599 8012 : < arg->expr->rank)
3600 : break;
3601 : }
3602 :
3603 367542 : if (arg->expr != NULL
3604 245217 : && arg->expr->rank > 0
3605 485646 : && resolve_assumed_size_actual (arg->expr))
3606 : return false;
3607 : }
3608 : }
3609 : #undef GENERIC_ID
3610 :
3611 242198 : need_full_assumed_size = temp;
3612 :
3613 242198 : if (!check_pure_function(expr))
3614 12 : t = false;
3615 :
3616 : /* Functions without the RECURSIVE attribution are not allowed to
3617 : * call themselves. */
3618 242198 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3619 : {
3620 51176 : gfc_symbol *esym;
3621 51176 : esym = expr->value.function.esym;
3622 :
3623 51176 : if (is_illegal_recursion (esym, gfc_current_ns))
3624 : {
3625 5 : if (esym->attr.entry && esym->ns->entries)
3626 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3627 : " function %qs is not RECURSIVE",
3628 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3629 : else
3630 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3631 : " is not RECURSIVE", esym->name, &expr->where);
3632 :
3633 : t = false;
3634 : }
3635 : }
3636 :
3637 : /* Character lengths of use associated functions may contains references to
3638 : symbols not referenced from the current program unit otherwise. Make sure
3639 : those symbols are marked as referenced. */
3640 :
3641 242198 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3642 3380 : && expr->value.function.esym->attr.use_assoc)
3643 : {
3644 1238 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3645 : }
3646 :
3647 : /* Make sure that the expression has a typespec that works. */
3648 242198 : if (expr->ts.type == BT_UNKNOWN)
3649 : {
3650 921 : if (expr->symtree->n.sym->result
3651 912 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3652 560 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3653 560 : expr->ts = expr->symtree->n.sym->result->ts;
3654 : }
3655 :
3656 : /* These derived types with an incomplete namespace, arising from use
3657 : association, cause gfc_get_derived_vtab to segfault. If the function
3658 : namespace does not suffice, something is badly wrong. */
3659 242198 : if (expr->ts.type == BT_DERIVED
3660 9242 : && !expr->ts.u.derived->ns->proc_name)
3661 : {
3662 3 : gfc_symbol *der;
3663 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3664 3 : if (der)
3665 : {
3666 3 : expr->ts.u.derived->refs--;
3667 3 : expr->ts.u.derived = der;
3668 3 : der->refs++;
3669 : }
3670 : else
3671 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3672 : }
3673 :
3674 242198 : if (!expr->ref && !expr->value.function.isym)
3675 : {
3676 52545 : if (expr->value.function.esym)
3677 51476 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3678 : else
3679 1069 : update_current_proc_array_outer_dependency (sym);
3680 : }
3681 189653 : else if (expr->ref)
3682 : /* typebound procedure: Assume the worst. */
3683 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3684 :
3685 242198 : if (expr->value.function.esym
3686 51476 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3687 26 : gfc_warning (OPT_Wdeprecated_declarations,
3688 : "Using function %qs at %L is deprecated",
3689 : sym->name, &expr->where);
3690 :
3691 : /* Check an external function supplied as a dummy argument has an external
3692 : attribute when a program unit uses 'implicit none (external)'. */
3693 242198 : if (expr->expr_type == EXPR_FUNCTION
3694 242198 : && expr->symtree
3695 241844 : && expr->symtree->n.sym->attr.dummy
3696 564 : && expr->symtree->n.sym->ns->has_implicit_none_export
3697 242199 : && !gfc_is_intrinsic(expr->symtree->n.sym, 0, expr->where))
3698 : {
3699 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
3700 : sym->name, &expr->where);
3701 1 : return false;
3702 : }
3703 :
3704 : return t;
3705 : }
3706 :
3707 :
3708 : /************* Subroutine resolution *************/
3709 :
3710 : static bool
3711 76468 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3712 : {
3713 76468 : code_stack *stack;
3714 76468 : bool saw_block = false;
3715 :
3716 76468 : if (gfc_pure (sym))
3717 : return true;
3718 :
3719 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3720 : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3721 : occurs. Walk up the stack to see if the source code has a nested
3722 : construct. */
3723 :
3724 158160 : for (stack = cs_base; stack; stack = stack->prev)
3725 : {
3726 87121 : if (stack->current->op == EXEC_BLOCK)
3727 : {
3728 1896 : saw_block = true;
3729 1896 : continue;
3730 : }
3731 :
3732 85225 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3733 : {
3734 :
3735 2 : bool is_pure = true;
3736 87121 : is_pure = sym->attr.pure || sym->attr.elemental;
3737 :
3738 2 : if (!is_pure)
3739 : {
3740 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3741 : "is not PURE", loc);
3742 2 : return false;
3743 : }
3744 : }
3745 : }
3746 :
3747 71039 : if (forall_flag)
3748 : {
3749 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3750 : name, loc);
3751 0 : return false;
3752 : }
3753 71039 : else if (gfc_do_concurrent_flag)
3754 : {
3755 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3756 : "PURE", name, loc);
3757 6 : return false;
3758 : }
3759 71033 : else if (gfc_pure (NULL))
3760 : {
3761 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3762 4 : return false;
3763 : }
3764 :
3765 71029 : gfc_unset_implicit_pure (NULL);
3766 71029 : return true;
3767 : }
3768 :
3769 :
3770 : static match
3771 2785 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3772 : {
3773 2785 : gfc_symbol *s;
3774 :
3775 2785 : if (sym->attr.generic)
3776 : {
3777 2784 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3778 2784 : if (s != NULL)
3779 : {
3780 2775 : c->resolved_sym = s;
3781 2775 : if (!pure_subroutine (s, s->name, &c->loc))
3782 : return MATCH_ERROR;
3783 2775 : return MATCH_YES;
3784 : }
3785 :
3786 : /* TODO: Need to search for elemental references in generic interface. */
3787 : }
3788 :
3789 10 : if (sym->attr.intrinsic)
3790 1 : return gfc_intrinsic_sub_interface (c, 0);
3791 :
3792 : return MATCH_NO;
3793 : }
3794 :
3795 :
3796 : static bool
3797 2783 : resolve_generic_s (gfc_code *c)
3798 : {
3799 2783 : gfc_symbol *sym;
3800 2783 : match m;
3801 :
3802 2783 : sym = c->symtree->n.sym;
3803 :
3804 2785 : for (;;)
3805 : {
3806 2785 : m = resolve_generic_s0 (c, sym);
3807 2785 : if (m == MATCH_YES)
3808 : return true;
3809 9 : else if (m == MATCH_ERROR)
3810 : return false;
3811 :
3812 9 : generic:
3813 9 : if (sym->ns->parent == NULL)
3814 : break;
3815 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3816 :
3817 3 : if (sym == NULL)
3818 : break;
3819 2 : if (!generic_sym (sym))
3820 0 : goto generic;
3821 : }
3822 :
3823 : /* Last ditch attempt. See if the reference is to an intrinsic
3824 : that possesses a matching interface. 14.1.2.4 */
3825 7 : sym = c->symtree->n.sym;
3826 :
3827 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3828 : {
3829 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3830 : sym->name, &c->loc);
3831 4 : return false;
3832 : }
3833 :
3834 3 : m = gfc_intrinsic_sub_interface (c, 0);
3835 3 : if (m == MATCH_YES)
3836 : return true;
3837 1 : if (m == MATCH_NO)
3838 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3839 : "intrinsic subroutine interface", sym->name, &c->loc);
3840 :
3841 : return false;
3842 : }
3843 :
3844 :
3845 : /* Resolve a subroutine call known to be specific. */
3846 :
3847 : static match
3848 62021 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3849 : {
3850 62021 : match m;
3851 :
3852 62021 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3853 : {
3854 5625 : if (sym->attr.dummy)
3855 : {
3856 257 : sym->attr.proc = PROC_DUMMY;
3857 257 : goto found;
3858 : }
3859 :
3860 5368 : sym->attr.proc = PROC_EXTERNAL;
3861 5368 : goto found;
3862 : }
3863 :
3864 56396 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3865 56396 : goto found;
3866 :
3867 0 : if (sym->attr.intrinsic)
3868 : {
3869 0 : m = gfc_intrinsic_sub_interface (c, 1);
3870 0 : if (m == MATCH_YES)
3871 : return MATCH_YES;
3872 0 : if (m == MATCH_NO)
3873 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3874 : "with an intrinsic", sym->name, &c->loc);
3875 :
3876 0 : return MATCH_ERROR;
3877 : }
3878 :
3879 : return MATCH_NO;
3880 :
3881 62021 : found:
3882 62021 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3883 :
3884 62021 : c->resolved_sym = sym;
3885 62021 : if (!pure_subroutine (sym, sym->name, &c->loc))
3886 : return MATCH_ERROR;
3887 :
3888 : return MATCH_YES;
3889 : }
3890 :
3891 :
3892 : static bool
3893 62021 : resolve_specific_s (gfc_code *c)
3894 : {
3895 62021 : gfc_symbol *sym;
3896 62021 : match m;
3897 :
3898 62021 : sym = c->symtree->n.sym;
3899 :
3900 62021 : for (;;)
3901 : {
3902 62021 : m = resolve_specific_s0 (c, sym);
3903 62021 : if (m == MATCH_YES)
3904 : return true;
3905 7 : if (m == MATCH_ERROR)
3906 : return false;
3907 :
3908 0 : if (sym->ns->parent == NULL)
3909 : break;
3910 :
3911 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3912 :
3913 0 : if (sym == NULL)
3914 : break;
3915 : }
3916 :
3917 0 : sym = c->symtree->n.sym;
3918 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3919 : sym->name, &c->loc);
3920 :
3921 0 : return false;
3922 : }
3923 :
3924 :
3925 : /* Resolve a subroutine call not known to be generic nor specific. */
3926 :
3927 : static bool
3928 15735 : resolve_unknown_s (gfc_code *c)
3929 : {
3930 15735 : gfc_symbol *sym;
3931 :
3932 15735 : sym = c->symtree->n.sym;
3933 :
3934 15735 : if (sym->attr.dummy)
3935 : {
3936 20 : sym->attr.proc = PROC_DUMMY;
3937 20 : goto found;
3938 : }
3939 :
3940 : /* See if we have an intrinsic function reference. */
3941 :
3942 15715 : if (gfc_is_intrinsic (sym, 1, c->loc))
3943 : {
3944 4186 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3945 : return true;
3946 309 : return false;
3947 : }
3948 :
3949 : /* The reference is to an external name. */
3950 :
3951 11529 : found:
3952 11549 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3953 :
3954 11549 : c->resolved_sym = sym;
3955 :
3956 11549 : return pure_subroutine (sym, sym->name, &c->loc);
3957 : }
3958 :
3959 :
3960 :
3961 : static bool
3962 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3963 : gfc_code *c, gfc_namespace *ns)
3964 : {
3965 805 : locus *here;
3966 :
3967 : /* If the type has been imported then its vtype functions are OK. */
3968 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
3969 : return true;
3970 :
3971 : if (e)
3972 791 : here = &e->where;
3973 : else
3974 7 : here = &c->loc;
3975 :
3976 798 : if (s && !s->import_only)
3977 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
3978 :
3979 798 : if (ns->import_state == IMPORT_ONLY
3980 75 : && sym->ns != ns
3981 58 : && (!s || !s->import_only))
3982 : {
3983 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
3984 : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
3985 21 : return false;
3986 : }
3987 777 : else if (ns->import_state == IMPORT_NONE
3988 27 : && sym->ns != ns)
3989 : {
3990 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
3991 : "has IMPORT, NONE", sym->name, here);
3992 12 : return false;
3993 : }
3994 : return true;
3995 : }
3996 :
3997 :
3998 : static bool
3999 6919 : check_import_status (gfc_expr *e)
4000 : {
4001 6919 : gfc_symtree *st;
4002 6919 : gfc_ref *ref;
4003 6919 : gfc_symbol *sym, *der;
4004 6919 : gfc_namespace *ns = gfc_current_ns;
4005 :
4006 6919 : switch (e->expr_type)
4007 : {
4008 727 : case EXPR_VARIABLE:
4009 727 : case EXPR_FUNCTION:
4010 727 : case EXPR_SUBSTRING:
4011 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
4012 :
4013 : /* Check the symbol itself. */
4014 727 : if (sym
4015 727 : && !(ns->proc_name
4016 : && (sym == ns->proc_name))
4017 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4018 : return false;
4019 :
4020 : /* Check the declared derived type. */
4021 717 : if (sym->ts.type == BT_DERIVED)
4022 : {
4023 16 : der = sym->ts.u.derived;
4024 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4025 :
4026 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4027 : return false;
4028 : }
4029 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4030 : {
4031 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4032 : : sym->ts.u.derived;
4033 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4034 :
4035 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4036 : return false;
4037 : }
4038 :
4039 : /* Check the declared derived types of component references. */
4040 724 : for (ref = e->ref; ref; ref = ref->next)
4041 20 : if (ref->type == REF_COMPONENT)
4042 : {
4043 19 : gfc_component *c = ref->u.c.component;
4044 19 : if (c->ts.type == BT_DERIVED)
4045 : {
4046 7 : der = c->ts.u.derived;
4047 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4048 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4049 : return false;
4050 : }
4051 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4052 : {
4053 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4054 : : c->ts.u.derived;
4055 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4056 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4057 : return false;
4058 : }
4059 : }
4060 :
4061 : break;
4062 :
4063 8 : case EXPR_ARRAY:
4064 8 : case EXPR_STRUCTURE:
4065 : /* Check the declared derived type. */
4066 8 : if (e->ts.type == BT_DERIVED)
4067 : {
4068 8 : der = e->ts.u.derived;
4069 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4070 :
4071 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4072 : return false;
4073 : }
4074 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4075 : {
4076 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4077 : : e->ts.u.derived;
4078 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4079 :
4080 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4081 : return false;
4082 : }
4083 :
4084 : break;
4085 :
4086 : /* Either not applicable or resolved away
4087 : case EXPR_OP:
4088 : case EXPR_UNKNOWN:
4089 : case EXPR_CONSTANT:
4090 : case EXPR_NULL:
4091 : case EXPR_COMPCALL:
4092 : case EXPR_PPC: */
4093 :
4094 : default:
4095 : break;
4096 : }
4097 :
4098 : return true;
4099 : }
4100 :
4101 :
4102 : /* Resolve a subroutine call. Although it was tempting to use the same code
4103 : for functions, subroutines and functions are stored differently and this
4104 : makes things awkward. */
4105 :
4106 :
4107 : static bool
4108 80684 : resolve_call (gfc_code *c)
4109 : {
4110 80684 : bool t;
4111 80684 : procedure_type ptype = PROC_INTRINSIC;
4112 80684 : gfc_symbol *csym, *sym;
4113 80684 : bool no_formal_args;
4114 :
4115 80684 : csym = c->symtree ? c->symtree->n.sym : NULL;
4116 :
4117 80684 : if (csym && csym->ts.type != BT_UNKNOWN)
4118 : {
4119 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4120 : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4121 4 : return false;
4122 : }
4123 :
4124 80680 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4125 : {
4126 16790 : gfc_symtree *st;
4127 16790 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4128 16790 : sym = st ? st->n.sym : NULL;
4129 16790 : if (sym && csym != sym
4130 3 : && sym->ns == gfc_current_ns
4131 3 : && sym->attr.flavor == FL_PROCEDURE
4132 3 : && sym->attr.contained)
4133 : {
4134 3 : sym->refs++;
4135 3 : if (csym->attr.generic)
4136 2 : c->symtree->n.sym = sym;
4137 : else
4138 1 : c->symtree = st;
4139 3 : csym = c->symtree->n.sym;
4140 : }
4141 : }
4142 :
4143 : /* If this ia a deferred TBP, c->expr1 will be set. */
4144 80680 : if (!c->expr1 && csym)
4145 : {
4146 78989 : if (csym->attr.abstract)
4147 : {
4148 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4149 : csym->name, &c->loc);
4150 1 : return false;
4151 : }
4152 :
4153 : /* Subroutines without the RECURSIVE attribution are not allowed to
4154 : call themselves. */
4155 78988 : if (is_illegal_recursion (csym, gfc_current_ns))
4156 : {
4157 4 : if (csym->attr.entry && csym->ns->entries)
4158 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4159 : "as subroutine %qs is not RECURSIVE",
4160 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4161 : else
4162 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4163 : "as it is not RECURSIVE", csym->name, &c->loc);
4164 :
4165 80679 : t = false;
4166 : }
4167 : }
4168 :
4169 : /* Switch off assumed size checking and do this again for certain kinds
4170 : of procedure, once the procedure itself is resolved. */
4171 80679 : need_full_assumed_size++;
4172 :
4173 80679 : if (csym)
4174 80679 : ptype = csym->attr.proc;
4175 :
4176 80679 : no_formal_args = csym && is_external_proc (csym)
4177 15572 : && gfc_sym_get_dummy_args (csym) == NULL;
4178 80679 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4179 : return false;
4180 :
4181 : /* Resume assumed_size checking. */
4182 80645 : need_full_assumed_size--;
4183 :
4184 : /* If 'implicit none (external)' and the symbol is a dummy argument,
4185 : check for an 'external' attribute. */
4186 80645 : if (csym->ns->has_implicit_none_export
4187 4422 : && csym->attr.external == 0 && csym->attr.dummy == 1)
4188 : {
4189 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
4190 : csym->name, &c->loc);
4191 1 : return false;
4192 : }
4193 :
4194 : /* If external, check for usage. */
4195 80644 : if (csym && is_external_proc (csym))
4196 15566 : resolve_global_procedure (csym, &c->loc, 1);
4197 :
4198 : /* If we have an external dummy argument, we want to write out its arguments
4199 : with -fc-prototypes-external. Code like
4200 :
4201 : subroutine foo(a,n)
4202 : external a
4203 : if (n == 1) call a(1)
4204 : if (n == 2) call a(2,3)
4205 : end subroutine foo
4206 :
4207 : is actually legal Fortran, but it is not possible to generate a C23-
4208 : compliant prototype for this, so we just record the fact here and
4209 : handle that during -fc-prototypes-external processing. */
4210 :
4211 80644 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4212 14 : && csym->attr.external)
4213 : {
4214 14 : if (csym->formal)
4215 : {
4216 6 : bool conflict;
4217 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4218 : 0, 0, 0, NULL);
4219 6 : if (conflict)
4220 : {
4221 6 : csym->ext_dummy_arglist_mismatch = 1;
4222 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4223 : "Different argument lists in external dummy "
4224 : "subroutine %s at %L and %L", csym->name,
4225 : &c->loc, &csym->formal_at);
4226 : }
4227 : }
4228 8 : else if (!csym->formal_resolved)
4229 : {
4230 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4231 7 : csym->formal_at = c->loc;
4232 : }
4233 : }
4234 :
4235 80644 : t = true;
4236 80644 : if (c->resolved_sym == NULL)
4237 : {
4238 80539 : c->resolved_isym = NULL;
4239 80539 : switch (procedure_kind (csym))
4240 : {
4241 2783 : case PTYPE_GENERIC:
4242 2783 : t = resolve_generic_s (c);
4243 2783 : break;
4244 :
4245 62021 : case PTYPE_SPECIFIC:
4246 62021 : t = resolve_specific_s (c);
4247 62021 : break;
4248 :
4249 15735 : case PTYPE_UNKNOWN:
4250 15735 : t = resolve_unknown_s (c);
4251 15735 : break;
4252 :
4253 : default:
4254 : gfc_internal_error ("resolve_subroutine(): bad function type");
4255 : }
4256 : }
4257 :
4258 : /* Some checks of elemental subroutine actual arguments. */
4259 80643 : if (!resolve_elemental_actual (NULL, c))
4260 : return false;
4261 :
4262 80635 : if (!c->expr1)
4263 78944 : update_current_proc_array_outer_dependency (csym);
4264 : else
4265 : /* Typebound procedure: Assume the worst. */
4266 1691 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4267 :
4268 80635 : if (c->resolved_sym
4269 80322 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4270 34 : gfc_warning (OPT_Wdeprecated_declarations,
4271 : "Using subroutine %qs at %L is deprecated",
4272 : c->resolved_sym->name, &c->loc);
4273 :
4274 80635 : csym = c->resolved_sym ? c->resolved_sym : csym;
4275 80635 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4276 2 : && csym != gfc_current_ns->proc_name)
4277 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4278 :
4279 : return t;
4280 : }
4281 :
4282 :
4283 : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4284 : op1->shape and op2->shape are non-NULL return true if their shapes
4285 : match. If both op1->shape and op2->shape are non-NULL return false
4286 : if their shapes do not match. If either op1->shape or op2->shape is
4287 : NULL, return true. */
4288 :
4289 : static bool
4290 32204 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4291 : {
4292 32204 : bool t;
4293 32204 : int i;
4294 :
4295 32204 : t = true;
4296 :
4297 32204 : if (op1->shape != NULL && op2->shape != NULL)
4298 : {
4299 42814 : for (i = 0; i < op1->rank; i++)
4300 : {
4301 22844 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4302 : {
4303 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4304 : &op1->where, &op2->where);
4305 3 : t = false;
4306 3 : break;
4307 : }
4308 : }
4309 : }
4310 :
4311 32204 : return t;
4312 : }
4313 :
4314 : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4315 : For example A .AND. B becomes IAND(A, B). */
4316 : static gfc_expr *
4317 668 : logical_to_bitwise (gfc_expr *e)
4318 : {
4319 668 : gfc_expr *tmp, *op1, *op2;
4320 668 : gfc_isym_id isym;
4321 668 : gfc_actual_arglist *args = NULL;
4322 :
4323 668 : gcc_assert (e->expr_type == EXPR_OP);
4324 :
4325 668 : isym = GFC_ISYM_NONE;
4326 668 : op1 = e->value.op.op1;
4327 668 : op2 = e->value.op.op2;
4328 :
4329 668 : switch (e->value.op.op)
4330 : {
4331 : case INTRINSIC_NOT:
4332 : isym = GFC_ISYM_NOT;
4333 : break;
4334 126 : case INTRINSIC_AND:
4335 126 : isym = GFC_ISYM_IAND;
4336 126 : break;
4337 127 : case INTRINSIC_OR:
4338 127 : isym = GFC_ISYM_IOR;
4339 127 : break;
4340 270 : case INTRINSIC_NEQV:
4341 270 : isym = GFC_ISYM_IEOR;
4342 270 : break;
4343 126 : case INTRINSIC_EQV:
4344 : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4345 : Change the old expression to NEQV, which will get replaced by IEOR,
4346 : and wrap it in NOT. */
4347 126 : tmp = gfc_copy_expr (e);
4348 126 : tmp->value.op.op = INTRINSIC_NEQV;
4349 126 : tmp = logical_to_bitwise (tmp);
4350 126 : isym = GFC_ISYM_NOT;
4351 126 : op1 = tmp;
4352 126 : op2 = NULL;
4353 126 : break;
4354 0 : default:
4355 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4356 : }
4357 :
4358 : /* Inherit the original operation's operands as arguments. */
4359 668 : args = gfc_get_actual_arglist ();
4360 668 : args->expr = op1;
4361 668 : if (op2)
4362 : {
4363 523 : args->next = gfc_get_actual_arglist ();
4364 523 : args->next->expr = op2;
4365 : }
4366 :
4367 : /* Convert the expression to a function call. */
4368 668 : e->expr_type = EXPR_FUNCTION;
4369 668 : e->value.function.actual = args;
4370 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4371 668 : e->value.function.name = e->value.function.isym->name;
4372 668 : e->value.function.esym = NULL;
4373 :
4374 : /* Make up a pre-resolved function call symtree if we need to. */
4375 668 : if (!e->symtree || !e->symtree->n.sym)
4376 : {
4377 668 : gfc_symbol *sym;
4378 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4379 668 : sym = e->symtree->n.sym;
4380 668 : sym->result = sym;
4381 668 : sym->attr.flavor = FL_PROCEDURE;
4382 668 : sym->attr.function = 1;
4383 668 : sym->attr.elemental = 1;
4384 668 : sym->attr.pure = 1;
4385 668 : sym->attr.referenced = 1;
4386 668 : gfc_intrinsic_symbol (sym);
4387 668 : gfc_commit_symbol (sym);
4388 : }
4389 :
4390 668 : args->name = e->value.function.isym->formal->name;
4391 668 : if (e->value.function.isym->formal->next)
4392 523 : args->next->name = e->value.function.isym->formal->next->name;
4393 :
4394 668 : return e;
4395 : }
4396 :
4397 : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4398 : candidates in CANDIDATES_LEN. */
4399 : static void
4400 57 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4401 : char **&candidates,
4402 : size_t &candidates_len)
4403 : {
4404 59 : gfc_symtree *p;
4405 :
4406 59 : if (uop == NULL)
4407 : return;
4408 :
4409 : /* Not sure how to properly filter here. Use all for a start.
4410 : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4411 : these as i suppose they don't make terribly sense. */
4412 :
4413 59 : if (uop->n.uop->op != NULL)
4414 2 : vec_push (candidates, candidates_len, uop->name);
4415 :
4416 59 : p = uop->left;
4417 59 : if (p)
4418 0 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4419 :
4420 59 : p = uop->right;
4421 59 : if (p)
4422 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4423 : }
4424 :
4425 : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4426 :
4427 : static const char*
4428 57 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4429 : {
4430 57 : char **candidates = NULL;
4431 57 : size_t candidates_len = 0;
4432 57 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4433 57 : return gfc_closest_fuzzy_match (op, candidates);
4434 : }
4435 :
4436 :
4437 : /* Callback finding an impure function as an operand to an .and. or
4438 : .or. expression. Remember the last function warned about to
4439 : avoid double warnings when recursing. */
4440 :
4441 : static int
4442 192821 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4443 : void *data)
4444 : {
4445 192821 : gfc_expr *f = *e;
4446 192821 : const char *name;
4447 192821 : static gfc_expr *last = NULL;
4448 192821 : bool *found = (bool *) data;
4449 :
4450 192821 : if (f->expr_type == EXPR_FUNCTION)
4451 : {
4452 11790 : *found = 1;
4453 11790 : if (f != last && !gfc_pure_function (f, &name)
4454 13065 : && !gfc_implicit_pure_function (f))
4455 : {
4456 1136 : if (name)
4457 1136 : gfc_warning (OPT_Wfunction_elimination,
4458 : "Impure function %qs at %L might not be evaluated",
4459 : name, &f->where);
4460 : else
4461 0 : gfc_warning (OPT_Wfunction_elimination,
4462 : "Impure function at %L might not be evaluated",
4463 : &f->where);
4464 : }
4465 11790 : last = f;
4466 : }
4467 :
4468 192821 : return 0;
4469 : }
4470 :
4471 : /* Return true if TYPE is character based, false otherwise. */
4472 :
4473 : static int
4474 1373 : is_character_based (bt type)
4475 : {
4476 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4477 : }
4478 :
4479 :
4480 : /* If expression is a hollerith, convert it to character and issue a warning
4481 : for the conversion. */
4482 :
4483 : static void
4484 408 : convert_hollerith_to_character (gfc_expr *e)
4485 : {
4486 408 : if (e->ts.type == BT_HOLLERITH)
4487 : {
4488 108 : gfc_typespec t;
4489 108 : gfc_clear_ts (&t);
4490 108 : t.type = BT_CHARACTER;
4491 108 : t.kind = e->ts.kind;
4492 108 : gfc_convert_type_warn (e, &t, 2, 1);
4493 : }
4494 408 : }
4495 :
4496 : /* Convert to numeric and issue a warning for the conversion. */
4497 :
4498 : static void
4499 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4500 : {
4501 240 : gfc_typespec t;
4502 240 : gfc_clear_ts (&t);
4503 240 : t.type = b->ts.type;
4504 240 : t.kind = b->ts.kind;
4505 240 : gfc_convert_type_warn (a, &t, 2, 1);
4506 240 : }
4507 :
4508 : /* Resolve an operator expression node. This can involve replacing the
4509 : operation with a user defined function call. CHECK_INTERFACES is a
4510 : helper macro. */
4511 :
4512 : #define CHECK_INTERFACES \
4513 : { \
4514 : match m = gfc_extend_expr (e); \
4515 : if (m == MATCH_YES) \
4516 : return true; \
4517 : if (m == MATCH_ERROR) \
4518 : return false; \
4519 : }
4520 :
4521 : static bool
4522 530368 : resolve_operator (gfc_expr *e)
4523 : {
4524 530368 : gfc_expr *op1, *op2;
4525 : /* One error uses 3 names; additional space for wording (also via gettext). */
4526 530368 : bool t = true;
4527 :
4528 : /* Reduce stacked parentheses to single pair */
4529 530368 : while (e->expr_type == EXPR_OP
4530 530526 : && e->value.op.op == INTRINSIC_PARENTHESES
4531 23399 : && e->value.op.op1->expr_type == EXPR_OP
4532 547345 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4533 : {
4534 158 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4535 158 : gfc_replace_expr (e, tmp);
4536 : }
4537 :
4538 : /* Resolve all subnodes-- give them types. */
4539 :
4540 530368 : switch (e->value.op.op)
4541 : {
4542 478585 : default:
4543 478585 : if (!gfc_resolve_expr (e->value.op.op2))
4544 530368 : t = false;
4545 :
4546 : /* Fall through. */
4547 :
4548 530368 : case INTRINSIC_NOT:
4549 530368 : case INTRINSIC_UPLUS:
4550 530368 : case INTRINSIC_UMINUS:
4551 530368 : case INTRINSIC_PARENTHESES:
4552 530368 : if (!gfc_resolve_expr (e->value.op.op1))
4553 : return false;
4554 530207 : if (e->value.op.op1
4555 530198 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4556 : {
4557 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4558 0 : "unary operator %qs", &e->value.op.op1->where,
4559 : gfc_op2string (e->value.op.op));
4560 0 : return false;
4561 : }
4562 530207 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4563 6 : && e->value.op.op == INTRINSIC_UMINUS)
4564 : {
4565 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4566 : &e->value.op.op1->where);
4567 2 : return false;
4568 : }
4569 530205 : break;
4570 : }
4571 :
4572 : /* Typecheck the new node. */
4573 :
4574 530205 : op1 = e->value.op.op1;
4575 530205 : op2 = e->value.op.op2;
4576 530205 : if (op1 == NULL && op2 == NULL)
4577 : return false;
4578 : /* Error out if op2 did not resolve. We already diagnosed op1. */
4579 530196 : if (t == false)
4580 : return false;
4581 :
4582 : /* op1 and op2 cannot both be BOZ. */
4583 530130 : if (op1 && op1->ts.type == BT_BOZ
4584 0 : && op2 && op2->ts.type == BT_BOZ)
4585 : {
4586 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4587 0 : "binary operator %qs", &op1->where, &op2->where,
4588 : gfc_op2string (e->value.op.op));
4589 0 : return false;
4590 : }
4591 :
4592 530130 : if ((op1 && op1->expr_type == EXPR_NULL)
4593 530128 : || (op2 && op2->expr_type == EXPR_NULL))
4594 : {
4595 3 : CHECK_INTERFACES
4596 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4597 3 : return false;
4598 : }
4599 :
4600 530127 : switch (e->value.op.op)
4601 : {
4602 8103 : case INTRINSIC_UPLUS:
4603 8103 : case INTRINSIC_UMINUS:
4604 8103 : if (op1->ts.type == BT_INTEGER
4605 : || op1->ts.type == BT_REAL
4606 : || op1->ts.type == BT_COMPLEX
4607 : || op1->ts.type == BT_UNSIGNED)
4608 : {
4609 8034 : e->ts = op1->ts;
4610 8034 : break;
4611 : }
4612 :
4613 69 : CHECK_INTERFACES
4614 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4615 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4616 43 : return false;
4617 :
4618 154901 : case INTRINSIC_POWER:
4619 154901 : case INTRINSIC_PLUS:
4620 154901 : case INTRINSIC_MINUS:
4621 154901 : case INTRINSIC_TIMES:
4622 154901 : case INTRINSIC_DIVIDE:
4623 :
4624 : /* UNSIGNED cannot appear in a mixed expression without explicit
4625 : conversion. */
4626 154901 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4627 : {
4628 3 : CHECK_INTERFACES
4629 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4630 : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4631 : gfc_typename (op1), gfc_typename (op2));
4632 3 : return false;
4633 : }
4634 :
4635 154898 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4636 : {
4637 : /* Do not perform conversions if operands are not conformable as
4638 : required for the binary intrinsic operators (F2018:10.1.5).
4639 : Defer to a possibly overloading user-defined operator. */
4640 154444 : if (!gfc_op_rank_conformable (op1, op2))
4641 : {
4642 36 : CHECK_INTERFACES
4643 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4644 0 : &op1->where, &op2->where);
4645 0 : return false;
4646 : }
4647 :
4648 154408 : gfc_type_convert_binary (e, 1);
4649 154408 : break;
4650 : }
4651 :
4652 454 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4653 : {
4654 225 : CHECK_INTERFACES
4655 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4656 : "numeric operator %qs at %L",
4657 : gfc_op2string (e->value.op.op), &e->where);
4658 2 : return false;
4659 : }
4660 : else
4661 : {
4662 229 : CHECK_INTERFACES
4663 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4664 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4665 : gfc_typename (op2));
4666 3 : return false;
4667 : }
4668 :
4669 2267 : case INTRINSIC_CONCAT:
4670 2267 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4671 2242 : && op1->ts.kind == op2->ts.kind)
4672 : {
4673 2233 : e->ts.type = BT_CHARACTER;
4674 2233 : e->ts.kind = op1->ts.kind;
4675 2233 : break;
4676 : }
4677 :
4678 34 : CHECK_INTERFACES
4679 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4680 : &e->where, gfc_typename (op1), gfc_typename (op2));
4681 10 : return false;
4682 :
4683 69515 : case INTRINSIC_AND:
4684 69515 : case INTRINSIC_OR:
4685 69515 : case INTRINSIC_EQV:
4686 69515 : case INTRINSIC_NEQV:
4687 69515 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4688 : {
4689 68964 : e->ts.type = BT_LOGICAL;
4690 68964 : e->ts.kind = gfc_kind_max (op1, op2);
4691 68964 : if (op1->ts.kind < e->ts.kind)
4692 140 : gfc_convert_type (op1, &e->ts, 2);
4693 68824 : else if (op2->ts.kind < e->ts.kind)
4694 117 : gfc_convert_type (op2, &e->ts, 2);
4695 :
4696 68964 : if (flag_frontend_optimize &&
4697 57936 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4698 : {
4699 : /* Warn about short-circuiting
4700 : with impure function as second operand. */
4701 51935 : bool op2_f = false;
4702 51935 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4703 : }
4704 : break;
4705 : }
4706 :
4707 : /* Logical ops on integers become bitwise ops with -fdec. */
4708 551 : else if (flag_dec
4709 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4710 : {
4711 523 : e->ts.type = BT_INTEGER;
4712 523 : e->ts.kind = gfc_kind_max (op1, op2);
4713 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4714 289 : gfc_convert_type (op1, &e->ts, 1);
4715 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4716 144 : gfc_convert_type (op2, &e->ts, 1);
4717 523 : e = logical_to_bitwise (e);
4718 523 : goto simplify_op;
4719 : }
4720 :
4721 28 : CHECK_INTERFACES
4722 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4723 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4724 : gfc_typename (op2));
4725 16 : return false;
4726 :
4727 20423 : case INTRINSIC_NOT:
4728 : /* Logical ops on integers become bitwise ops with -fdec. */
4729 20423 : if (flag_dec && op1->ts.type == BT_INTEGER)
4730 : {
4731 19 : e->ts.type = BT_INTEGER;
4732 19 : e->ts.kind = op1->ts.kind;
4733 19 : e = logical_to_bitwise (e);
4734 19 : goto simplify_op;
4735 : }
4736 :
4737 20404 : if (op1->ts.type == BT_LOGICAL)
4738 : {
4739 20398 : e->ts.type = BT_LOGICAL;
4740 20398 : e->ts.kind = op1->ts.kind;
4741 20398 : break;
4742 : }
4743 :
4744 6 : CHECK_INTERFACES
4745 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4746 : gfc_typename (op1));
4747 3 : return false;
4748 :
4749 21275 : case INTRINSIC_GT:
4750 21275 : case INTRINSIC_GT_OS:
4751 21275 : case INTRINSIC_GE:
4752 21275 : case INTRINSIC_GE_OS:
4753 21275 : case INTRINSIC_LT:
4754 21275 : case INTRINSIC_LT_OS:
4755 21275 : case INTRINSIC_LE:
4756 21275 : case INTRINSIC_LE_OS:
4757 21275 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4758 : {
4759 18 : CHECK_INTERFACES
4760 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4761 0 : return false;
4762 : }
4763 :
4764 : /* Fall through. */
4765 :
4766 251416 : case INTRINSIC_EQ:
4767 251416 : case INTRINSIC_EQ_OS:
4768 251416 : case INTRINSIC_NE:
4769 251416 : case INTRINSIC_NE_OS:
4770 :
4771 251416 : if (flag_dec
4772 1038 : && is_character_based (op1->ts.type)
4773 251751 : && is_character_based (op2->ts.type))
4774 : {
4775 204 : convert_hollerith_to_character (op1);
4776 204 : convert_hollerith_to_character (op2);
4777 : }
4778 :
4779 251416 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4780 37730 : && op1->ts.kind == op2->ts.kind)
4781 : {
4782 37693 : e->ts.type = BT_LOGICAL;
4783 37693 : e->ts.kind = gfc_default_logical_kind;
4784 37693 : break;
4785 : }
4786 :
4787 : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4788 213723 : if (op1->ts.type == BT_BOZ)
4789 : {
4790 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4791 : "as an operand of a relational operator"),
4792 : &op1->where))
4793 : return false;
4794 :
4795 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4796 : return false;
4797 :
4798 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4799 : return false;
4800 : }
4801 :
4802 : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4803 213723 : if (op2->ts.type == BT_BOZ)
4804 : {
4805 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4806 : " as an operand of a relational operator"),
4807 : &op2->where))
4808 : return false;
4809 :
4810 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4811 : return false;
4812 :
4813 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4814 : return false;
4815 : }
4816 213723 : if (flag_dec
4817 213723 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4818 120 : convert_to_numeric (op1, op2);
4819 :
4820 213723 : if (flag_dec
4821 213723 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4822 120 : convert_to_numeric (op2, op1);
4823 :
4824 213723 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4825 : {
4826 : /* Do not perform conversions if operands are not conformable as
4827 : required for the binary intrinsic operators (F2018:10.1.5).
4828 : Defer to a possibly overloading user-defined operator. */
4829 212594 : if (!gfc_op_rank_conformable (op1, op2))
4830 : {
4831 70 : CHECK_INTERFACES
4832 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4833 0 : &op1->where, &op2->where);
4834 0 : return false;
4835 : }
4836 :
4837 212524 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4838 : {
4839 1 : CHECK_INTERFACES
4840 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4841 1 : "%s and %s", &op1->where, &op2->where,
4842 : gfc_typename (op1), gfc_typename (op2));
4843 1 : return false;
4844 : }
4845 :
4846 212523 : gfc_type_convert_binary (e, 1);
4847 :
4848 212523 : e->ts.type = BT_LOGICAL;
4849 212523 : e->ts.kind = gfc_default_logical_kind;
4850 :
4851 212523 : if (warn_compare_reals)
4852 : {
4853 69 : gfc_intrinsic_op op = e->value.op.op;
4854 :
4855 : /* Type conversion has made sure that the types of op1 and op2
4856 : agree, so it is only necessary to check the first one. */
4857 69 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4858 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4859 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4860 : {
4861 13 : const char *msg;
4862 :
4863 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4864 : msg = G_("Equality comparison for %s at %L");
4865 : else
4866 6 : msg = G_("Inequality comparison for %s at %L");
4867 :
4868 13 : gfc_warning (OPT_Wcompare_reals, msg,
4869 : gfc_typename (op1), &op1->where);
4870 : }
4871 : }
4872 :
4873 : break;
4874 : }
4875 :
4876 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4877 : {
4878 2 : CHECK_INTERFACES
4879 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4880 : &e->where,
4881 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4882 : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4883 2 : }
4884 : else
4885 : {
4886 1127 : CHECK_INTERFACES
4887 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4888 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4889 : gfc_typename (op2));
4890 : }
4891 :
4892 : return false;
4893 :
4894 282 : case INTRINSIC_USER:
4895 282 : if (e->value.op.uop->op == NULL)
4896 : {
4897 57 : const char *name = e->value.op.uop->name;
4898 57 : const char *guessed;
4899 57 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4900 57 : CHECK_INTERFACES
4901 5 : if (guessed)
4902 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4903 : "%qs?", name, &e->where, guessed);
4904 : else
4905 4 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4906 : }
4907 225 : else if (op2 == NULL)
4908 : {
4909 48 : CHECK_INTERFACES
4910 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4911 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4912 : }
4913 : else
4914 : {
4915 177 : e->value.op.uop->op->sym->attr.referenced = 1;
4916 177 : CHECK_INTERFACES
4917 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
4918 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
4919 : gfc_typename (op2));
4920 : }
4921 :
4922 : return false;
4923 :
4924 23202 : case INTRINSIC_PARENTHESES:
4925 23202 : e->ts = op1->ts;
4926 23202 : if (e->ts.type == BT_CHARACTER)
4927 321 : e->ts.u.cl = op1->ts.u.cl;
4928 : break;
4929 :
4930 0 : default:
4931 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
4932 : }
4933 :
4934 : /* Deal with arrayness of an operand through an operator. */
4935 :
4936 527455 : switch (e->value.op.op)
4937 : {
4938 475821 : case INTRINSIC_PLUS:
4939 475821 : case INTRINSIC_MINUS:
4940 475821 : case INTRINSIC_TIMES:
4941 475821 : case INTRINSIC_DIVIDE:
4942 475821 : case INTRINSIC_POWER:
4943 475821 : case INTRINSIC_CONCAT:
4944 475821 : case INTRINSIC_AND:
4945 475821 : case INTRINSIC_OR:
4946 475821 : case INTRINSIC_EQV:
4947 475821 : case INTRINSIC_NEQV:
4948 475821 : case INTRINSIC_EQ:
4949 475821 : case INTRINSIC_EQ_OS:
4950 475821 : case INTRINSIC_NE:
4951 475821 : case INTRINSIC_NE_OS:
4952 475821 : case INTRINSIC_GT:
4953 475821 : case INTRINSIC_GT_OS:
4954 475821 : case INTRINSIC_GE:
4955 475821 : case INTRINSIC_GE_OS:
4956 475821 : case INTRINSIC_LT:
4957 475821 : case INTRINSIC_LT_OS:
4958 475821 : case INTRINSIC_LE:
4959 475821 : case INTRINSIC_LE_OS:
4960 :
4961 475821 : if (op1->rank == 0 && op2->rank == 0)
4962 424242 : e->rank = 0;
4963 :
4964 475821 : if (op1->rank == 0 && op2->rank != 0)
4965 : {
4966 2505 : e->rank = op2->rank;
4967 :
4968 2505 : if (e->shape == NULL)
4969 2475 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
4970 : }
4971 :
4972 475821 : if (op1->rank != 0 && op2->rank == 0)
4973 : {
4974 16809 : e->rank = op1->rank;
4975 :
4976 16809 : if (e->shape == NULL)
4977 16791 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4978 : }
4979 :
4980 475821 : if (op1->rank != 0 && op2->rank != 0)
4981 : {
4982 32265 : if (op1->rank == op2->rank)
4983 : {
4984 32265 : e->rank = op1->rank;
4985 32265 : if (e->shape == NULL)
4986 : {
4987 32204 : t = compare_shapes (op1, op2);
4988 32204 : if (!t)
4989 3 : e->shape = NULL;
4990 : else
4991 32201 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4992 : }
4993 : }
4994 : else
4995 : {
4996 : /* Allow higher level expressions to work. */
4997 0 : e->rank = 0;
4998 :
4999 : /* Try user-defined operators, and otherwise throw an error. */
5000 0 : CHECK_INTERFACES
5001 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
5002 0 : &op1->where, &op2->where);
5003 0 : return false;
5004 : }
5005 : }
5006 : break;
5007 :
5008 51634 : case INTRINSIC_PARENTHESES:
5009 51634 : case INTRINSIC_NOT:
5010 51634 : case INTRINSIC_UPLUS:
5011 51634 : case INTRINSIC_UMINUS:
5012 : /* Simply copy arrayness attribute */
5013 51634 : e->rank = op1->rank;
5014 51634 : e->corank = op1->corank;
5015 :
5016 51634 : if (e->shape == NULL)
5017 51628 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5018 :
5019 : break;
5020 :
5021 : default:
5022 : break;
5023 : }
5024 :
5025 527997 : simplify_op:
5026 :
5027 : /* Attempt to simplify the expression. */
5028 3 : if (t)
5029 : {
5030 527994 : t = gfc_simplify_expr (e, 0);
5031 : /* Some calls do not succeed in simplification and return false
5032 : even though there is no error; e.g. variable references to
5033 : PARAMETER arrays. */
5034 527994 : if (!gfc_is_constant_expr (e))
5035 482328 : t = true;
5036 : }
5037 : return t;
5038 : }
5039 :
5040 : static bool
5041 150 : resolve_conditional (gfc_expr *expr)
5042 : {
5043 150 : gfc_expr *condition, *true_expr, *false_expr;
5044 :
5045 150 : condition = expr->value.conditional.condition;
5046 150 : true_expr = expr->value.conditional.true_expr;
5047 150 : false_expr = expr->value.conditional.false_expr;
5048 :
5049 300 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5050 300 : || !gfc_resolve_expr (false_expr))
5051 0 : return false;
5052 :
5053 150 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5054 : {
5055 2 : gfc_error (
5056 : "Condition in conditional expression must be a scalar logical at %L",
5057 : &condition->where);
5058 2 : return false;
5059 : }
5060 :
5061 148 : if (true_expr->ts.type != false_expr->ts.type)
5062 : {
5063 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5064 : "must have the same declared type",
5065 : &true_expr->where, &false_expr->where);
5066 1 : return false;
5067 : }
5068 :
5069 147 : if (true_expr->ts.kind != false_expr->ts.kind)
5070 : {
5071 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5072 : "must have the same kind parameter",
5073 : &true_expr->where, &false_expr->where);
5074 1 : return false;
5075 : }
5076 :
5077 146 : if (true_expr->rank != false_expr->rank)
5078 : {
5079 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5080 : "must have the same rank",
5081 : &true_expr->where, &false_expr->where);
5082 1 : return false;
5083 : }
5084 :
5085 : /* TODO: support more data types for conditional expressions */
5086 145 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5087 145 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5088 55 : && true_expr->ts.type != BT_CHARACTER)
5089 : {
5090 1 : gfc_error (
5091 : "Sorry, only integer, logical, real, complex and character types are "
5092 : "currently supported for conditional expressions at %L",
5093 : &expr->where);
5094 1 : return false;
5095 : }
5096 :
5097 : /* TODO: support arrays in conditional expressions */
5098 144 : if (true_expr->rank > 0)
5099 : {
5100 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5101 : "expressions at %L",
5102 : &expr->where);
5103 1 : return false;
5104 : }
5105 :
5106 143 : expr->ts = true_expr->ts;
5107 143 : expr->rank = true_expr->rank;
5108 143 : return true;
5109 : }
5110 :
5111 : /************** Array resolution subroutines **************/
5112 :
5113 : enum compare_result
5114 : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5115 :
5116 : /* Compare two integer expressions. */
5117 :
5118 : static compare_result
5119 462875 : compare_bound (gfc_expr *a, gfc_expr *b)
5120 : {
5121 462875 : int i;
5122 :
5123 462875 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5124 303610 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5125 : return CMP_UNKNOWN;
5126 :
5127 : /* If either of the types isn't INTEGER, we must have
5128 : raised an error earlier. */
5129 :
5130 209597 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5131 : return CMP_UNKNOWN;
5132 :
5133 209593 : i = mpz_cmp (a->value.integer, b->value.integer);
5134 :
5135 209593 : if (i < 0)
5136 : return CMP_LT;
5137 98863 : if (i > 0)
5138 39239 : return CMP_GT;
5139 : return CMP_EQ;
5140 : }
5141 :
5142 :
5143 : /* Compare an integer expression with an integer. */
5144 :
5145 : static compare_result
5146 73685 : compare_bound_int (gfc_expr *a, int b)
5147 : {
5148 73685 : int i;
5149 :
5150 73685 : if (a == NULL
5151 31482 : || a->expr_type != EXPR_CONSTANT
5152 28534 : || a->ts.type != BT_INTEGER)
5153 : return CMP_UNKNOWN;
5154 :
5155 28534 : i = mpz_cmp_si (a->value.integer, b);
5156 :
5157 28534 : if (i < 0)
5158 : return CMP_LT;
5159 24492 : if (i > 0)
5160 21413 : return CMP_GT;
5161 : return CMP_EQ;
5162 : }
5163 :
5164 :
5165 : /* Compare an integer expression with a mpz_t. */
5166 :
5167 : static compare_result
5168 68396 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5169 : {
5170 68396 : int i;
5171 :
5172 68396 : if (a == NULL
5173 55742 : || a->expr_type != EXPR_CONSTANT
5174 53620 : || a->ts.type != BT_INTEGER)
5175 : return CMP_UNKNOWN;
5176 :
5177 53617 : i = mpz_cmp (a->value.integer, b);
5178 :
5179 53617 : if (i < 0)
5180 : return CMP_LT;
5181 24429 : if (i > 0)
5182 10366 : return CMP_GT;
5183 : return CMP_EQ;
5184 : }
5185 :
5186 :
5187 : /* Compute the last value of a sequence given by a triplet.
5188 : Return 0 if it wasn't able to compute the last value, or if the
5189 : sequence if empty, and 1 otherwise. */
5190 :
5191 : static int
5192 51485 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5193 : gfc_expr *stride, mpz_t last)
5194 : {
5195 51485 : mpz_t rem;
5196 :
5197 51485 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5198 36436 : || end == NULL || end->expr_type != EXPR_CONSTANT
5199 31841 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5200 : return 0;
5201 :
5202 31522 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5203 31521 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5204 : return 0;
5205 :
5206 6496 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5207 : {
5208 25151 : if (compare_bound (start, end) == CMP_GT)
5209 : return 0;
5210 23762 : mpz_set (last, end->value.integer);
5211 23762 : return 1;
5212 : }
5213 :
5214 6370 : if (compare_bound_int (stride, 0) == CMP_GT)
5215 : {
5216 : /* Stride is positive */
5217 5149 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5218 : return 0;
5219 : }
5220 : else
5221 : {
5222 : /* Stride is negative */
5223 1221 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5224 : return 0;
5225 : }
5226 :
5227 6350 : mpz_init (rem);
5228 6350 : mpz_sub (rem, end->value.integer, start->value.integer);
5229 6350 : mpz_tdiv_r (rem, rem, stride->value.integer);
5230 6350 : mpz_sub (last, end->value.integer, rem);
5231 6350 : mpz_clear (rem);
5232 :
5233 6350 : return 1;
5234 : }
5235 :
5236 :
5237 : /* Compare a single dimension of an array reference to the array
5238 : specification. */
5239 :
5240 : static bool
5241 214723 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5242 : {
5243 214723 : mpz_t last_value;
5244 :
5245 214723 : if (ar->dimen_type[i] == DIMEN_STAR)
5246 : {
5247 495 : gcc_assert (ar->stride[i] == NULL);
5248 : /* This implies [*] as [*:] and [*:3] are not possible. */
5249 495 : if (ar->start[i] == NULL)
5250 : {
5251 403 : gcc_assert (ar->end[i] == NULL);
5252 : return true;
5253 : }
5254 : }
5255 :
5256 : /* Given start, end and stride values, calculate the minimum and
5257 : maximum referenced indexes. */
5258 :
5259 214320 : switch (ar->dimen_type[i])
5260 : {
5261 : case DIMEN_VECTOR:
5262 : case DIMEN_THIS_IMAGE:
5263 : break;
5264 :
5265 154915 : case DIMEN_STAR:
5266 154915 : case DIMEN_ELEMENT:
5267 154915 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5268 : {
5269 2 : if (i < as->rank)
5270 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5271 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5272 2 : mpz_get_si (ar->start[i]->value.integer),
5273 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5274 : else
5275 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5276 : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5277 0 : mpz_get_si (ar->start[i]->value.integer),
5278 0 : mpz_get_si (as->lower[i]->value.integer),
5279 0 : i + 1 - as->rank);
5280 2 : return true;
5281 : }
5282 154913 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5283 : {
5284 39 : if (i < as->rank)
5285 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5286 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5287 39 : mpz_get_si (ar->start[i]->value.integer),
5288 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5289 : else
5290 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5291 : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5292 0 : mpz_get_si (ar->start[i]->value.integer),
5293 0 : mpz_get_si (as->upper[i]->value.integer),
5294 0 : i + 1 - as->rank);
5295 39 : return true;
5296 : }
5297 :
5298 : break;
5299 :
5300 51530 : case DIMEN_RANGE:
5301 51530 : {
5302 : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5303 : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5304 :
5305 51530 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5306 51530 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5307 :
5308 : /* Check for zero stride, which is not allowed. */
5309 51530 : if (comp_stride_zero == CMP_EQ)
5310 : {
5311 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5312 1 : return false;
5313 : }
5314 :
5315 : /* if start == end || (stride > 0 && start < end)
5316 : || (stride < 0 && start > end),
5317 : then the array section contains at least one element. In this
5318 : case, there is an out-of-bounds access if
5319 : (start < lower || start > upper). */
5320 51529 : if (comp_start_end == CMP_EQ
5321 50767 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5322 48122 : && comp_start_end == CMP_LT)
5323 22572 : || (comp_stride_zero == CMP_LT
5324 22572 : && comp_start_end == CMP_GT))
5325 : {
5326 30158 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5327 : {
5328 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5329 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5330 27 : mpz_get_si (AR_START->value.integer),
5331 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5332 27 : return true;
5333 : }
5334 30131 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5335 : {
5336 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5337 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5338 17 : mpz_get_si (AR_START->value.integer),
5339 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5340 17 : return true;
5341 : }
5342 : }
5343 :
5344 : /* If we can compute the highest index of the array section,
5345 : then it also has to be between lower and upper. */
5346 51485 : mpz_init (last_value);
5347 51485 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5348 : last_value))
5349 : {
5350 30112 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5351 : {
5352 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5353 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5354 : mpz_get_si (last_value),
5355 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5356 3 : mpz_clear (last_value);
5357 3 : return true;
5358 : }
5359 30109 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5360 : {
5361 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5362 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5363 : mpz_get_si (last_value),
5364 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5365 7 : mpz_clear (last_value);
5366 7 : return true;
5367 : }
5368 : }
5369 51475 : mpz_clear (last_value);
5370 :
5371 : #undef AR_START
5372 : #undef AR_END
5373 : }
5374 51475 : break;
5375 :
5376 0 : default:
5377 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5378 : }
5379 :
5380 : return true;
5381 : }
5382 :
5383 :
5384 : /* Compare an array reference with an array specification. */
5385 :
5386 : static bool
5387 422300 : compare_spec_to_ref (gfc_array_ref *ar)
5388 : {
5389 422300 : gfc_array_spec *as;
5390 422300 : int i;
5391 :
5392 422300 : as = ar->as;
5393 422300 : i = as->rank - 1;
5394 : /* TODO: Full array sections are only allowed as actual parameters. */
5395 422300 : if (as->type == AS_ASSUMED_SIZE
5396 5768 : && (/*ar->type == AR_FULL
5397 5768 : ||*/ (ar->type == AR_SECTION
5398 514 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5399 : {
5400 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5401 : "not specified at %L", &ar->where);
5402 5 : return false;
5403 : }
5404 :
5405 422295 : if (ar->type == AR_FULL)
5406 : return true;
5407 :
5408 162735 : if (as->rank != ar->dimen)
5409 : {
5410 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5411 : &ar->where, ar->dimen, as->rank);
5412 28 : return false;
5413 : }
5414 :
5415 : /* ar->codimen == 0 is a local array. */
5416 162707 : if (as->corank != ar->codimen && ar->codimen != 0)
5417 : {
5418 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5419 : &ar->where, ar->codimen, as->corank);
5420 0 : return false;
5421 : }
5422 :
5423 367641 : for (i = 0; i < as->rank; i++)
5424 204935 : if (!check_dimension (i, ar, as))
5425 : return false;
5426 :
5427 : /* Local access has no coarray spec. */
5428 162706 : if (ar->codimen != 0)
5429 18818 : for (i = as->rank; i < as->rank + as->corank; i++)
5430 : {
5431 9790 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5432 6817 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5433 : {
5434 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5435 2 : i + 1 - as->rank, &ar->where);
5436 2 : return false;
5437 : }
5438 9788 : if (!check_dimension (i, ar, as))
5439 : return false;
5440 : }
5441 :
5442 : return true;
5443 : }
5444 :
5445 :
5446 : /* Resolve one part of an array index. */
5447 :
5448 : static bool
5449 728780 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5450 : int force_index_integer_kind)
5451 : {
5452 728780 : gfc_typespec ts;
5453 :
5454 728780 : if (index == NULL)
5455 : return true;
5456 :
5457 215667 : if (!gfc_resolve_expr (index))
5458 : return false;
5459 :
5460 215644 : if (check_scalar && index->rank != 0)
5461 : {
5462 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5463 2 : return false;
5464 : }
5465 :
5466 215642 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5467 : {
5468 4 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5469 : &index->where, gfc_basic_typename (index->ts.type));
5470 4 : return false;
5471 : }
5472 :
5473 215638 : if (index->ts.type == BT_REAL)
5474 336 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5475 : &index->where))
5476 : return false;
5477 :
5478 215638 : if ((index->ts.kind != gfc_index_integer_kind
5479 210862 : && force_index_integer_kind)
5480 184865 : || (index->ts.type != BT_INTEGER
5481 : && index->ts.type != BT_UNKNOWN))
5482 : {
5483 31108 : gfc_clear_ts (&ts);
5484 31108 : ts.type = BT_INTEGER;
5485 31108 : ts.kind = gfc_index_integer_kind;
5486 :
5487 31108 : gfc_convert_type_warn (index, &ts, 2, 0);
5488 : }
5489 :
5490 : return true;
5491 : }
5492 :
5493 : /* Resolve one part of an array index. */
5494 :
5495 : bool
5496 486071 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5497 : {
5498 486071 : return gfc_resolve_index_1 (index, check_scalar, 1);
5499 : }
5500 :
5501 : /* Resolve a dim argument to an intrinsic function. */
5502 :
5503 : bool
5504 23817 : gfc_resolve_dim_arg (gfc_expr *dim)
5505 : {
5506 23817 : if (dim == NULL)
5507 : return true;
5508 :
5509 23817 : if (!gfc_resolve_expr (dim))
5510 : return false;
5511 :
5512 23817 : if (dim->rank != 0)
5513 : {
5514 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5515 0 : return false;
5516 :
5517 : }
5518 :
5519 23817 : if (dim->ts.type != BT_INTEGER)
5520 : {
5521 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5522 0 : return false;
5523 : }
5524 :
5525 23817 : if (dim->ts.kind != gfc_index_integer_kind)
5526 : {
5527 15209 : gfc_typespec ts;
5528 :
5529 15209 : gfc_clear_ts (&ts);
5530 15209 : ts.type = BT_INTEGER;
5531 15209 : ts.kind = gfc_index_integer_kind;
5532 :
5533 15209 : gfc_convert_type_warn (dim, &ts, 2, 0);
5534 : }
5535 :
5536 : return true;
5537 : }
5538 :
5539 : /* Given an expression that contains array references, update those array
5540 : references to point to the right array specifications. While this is
5541 : filled in during matching, this information is difficult to save and load
5542 : in a module, so we take care of it here.
5543 :
5544 : The idea here is that the original array reference comes from the
5545 : base symbol. We traverse the list of reference structures, setting
5546 : the stored reference to references. Component references can
5547 : provide an additional array specification. */
5548 : static void
5549 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5550 :
5551 : static bool
5552 897 : find_array_spec (gfc_expr *e)
5553 : {
5554 897 : gfc_array_spec *as;
5555 897 : gfc_component *c;
5556 897 : gfc_ref *ref;
5557 897 : bool class_as = false;
5558 :
5559 897 : if (e->symtree->n.sym->assoc)
5560 : {
5561 217 : if (e->symtree->n.sym->assoc->target)
5562 217 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5563 217 : resolve_assoc_var (e->symtree->n.sym, false);
5564 : }
5565 :
5566 897 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5567 : {
5568 112 : as = CLASS_DATA (e->symtree->n.sym)->as;
5569 112 : class_as = true;
5570 : }
5571 : else
5572 785 : as = e->symtree->n.sym->as;
5573 :
5574 2034 : for (ref = e->ref; ref; ref = ref->next)
5575 1144 : switch (ref->type)
5576 : {
5577 899 : case REF_ARRAY:
5578 899 : if (as == NULL)
5579 : {
5580 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5581 14 : ? ref->u.ar.where : e->where);
5582 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5583 : &loc);
5584 7 : return false;
5585 : }
5586 :
5587 892 : ref->u.ar.as = as;
5588 892 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5589 : as = NULL;
5590 : break;
5591 :
5592 221 : case REF_COMPONENT:
5593 221 : c = ref->u.c.component;
5594 221 : if (c->attr.dimension)
5595 : {
5596 90 : if (as != NULL && !(class_as && as == c->as))
5597 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5598 90 : as = c->as;
5599 : }
5600 :
5601 : break;
5602 :
5603 : case REF_SUBSTRING:
5604 : case REF_INQUIRY:
5605 : break;
5606 : }
5607 :
5608 890 : if (as != NULL)
5609 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5610 :
5611 : return true;
5612 : }
5613 :
5614 :
5615 : /* Resolve an array reference. */
5616 :
5617 : static bool
5618 423026 : resolve_array_ref (gfc_array_ref *ar)
5619 : {
5620 423026 : int i, check_scalar;
5621 423026 : gfc_expr *e;
5622 :
5623 665706 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5624 : {
5625 242709 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5626 :
5627 : /* Do not force gfc_index_integer_kind for the start. We can
5628 : do fine with any integer kind. This avoids temporary arrays
5629 : created for indexing with a vector. */
5630 242709 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5631 : return false;
5632 242682 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5633 : return false;
5634 242680 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5635 : return false;
5636 :
5637 242680 : e = ar->start[i];
5638 :
5639 242680 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5640 144844 : switch (e->rank)
5641 : {
5642 143974 : case 0:
5643 143974 : ar->dimen_type[i] = DIMEN_ELEMENT;
5644 143974 : break;
5645 :
5646 870 : case 1:
5647 870 : ar->dimen_type[i] = DIMEN_VECTOR;
5648 870 : if (e->expr_type == EXPR_VARIABLE
5649 446 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5650 13 : ar->start[i] = gfc_get_parentheses (e);
5651 : break;
5652 :
5653 0 : default:
5654 0 : gfc_error ("Array index at %L is an array of rank %d",
5655 : &ar->c_where[i], e->rank);
5656 0 : return false;
5657 : }
5658 :
5659 : /* Fill in the upper bound, which may be lower than the
5660 : specified one for something like a(2:10:5), which is
5661 : identical to a(2:7:5). Only relevant for strides not equal
5662 : to one. Don't try a division by zero. */
5663 242680 : if (ar->dimen_type[i] == DIMEN_RANGE
5664 71181 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5665 8233 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5666 8086 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5667 : {
5668 8085 : mpz_t size, end;
5669 :
5670 8085 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5671 : {
5672 6380 : if (ar->end[i] == NULL)
5673 : {
5674 7926 : ar->end[i] =
5675 3963 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5676 : &ar->where);
5677 3963 : mpz_set (ar->end[i]->value.integer, end);
5678 : }
5679 2417 : else if (ar->end[i]->ts.type == BT_INTEGER
5680 2417 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5681 : {
5682 2417 : mpz_set (ar->end[i]->value.integer, end);
5683 : }
5684 : else
5685 0 : gcc_unreachable ();
5686 :
5687 6380 : mpz_clear (size);
5688 6380 : mpz_clear (end);
5689 : }
5690 : }
5691 : }
5692 :
5693 422997 : if (ar->type == AR_FULL)
5694 : {
5695 262995 : if (ar->as->rank == 0)
5696 3401 : ar->type = AR_ELEMENT;
5697 :
5698 : /* Make sure array is the same as array(:,:), this way
5699 : we don't need to special case all the time. */
5700 262995 : ar->dimen = ar->as->rank;
5701 627984 : for (i = 0; i < ar->dimen; i++)
5702 : {
5703 364989 : ar->dimen_type[i] = DIMEN_RANGE;
5704 :
5705 364989 : gcc_assert (ar->start[i] == NULL);
5706 364989 : gcc_assert (ar->end[i] == NULL);
5707 364989 : gcc_assert (ar->stride[i] == NULL);
5708 : }
5709 : }
5710 :
5711 : /* If the reference type is unknown, figure out what kind it is. */
5712 :
5713 422997 : if (ar->type == AR_UNKNOWN)
5714 : {
5715 147200 : ar->type = AR_ELEMENT;
5716 285560 : for (i = 0; i < ar->dimen; i++)
5717 175690 : if (ar->dimen_type[i] == DIMEN_RANGE
5718 175690 : || ar->dimen_type[i] == DIMEN_VECTOR)
5719 : {
5720 37330 : ar->type = AR_SECTION;
5721 37330 : break;
5722 : }
5723 : }
5724 :
5725 422997 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5726 : return false;
5727 :
5728 422961 : if (ar->as->corank && ar->codimen == 0)
5729 : {
5730 2075 : int n;
5731 2075 : ar->codimen = ar->as->corank;
5732 5916 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5733 3841 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5734 : }
5735 :
5736 422961 : if (ar->codimen)
5737 : {
5738 13605 : if (ar->team_type == TEAM_NUMBER)
5739 : {
5740 60 : if (!gfc_resolve_expr (ar->team))
5741 : return false;
5742 :
5743 60 : if (ar->team->rank != 0)
5744 : {
5745 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5746 : &ar->team->where);
5747 0 : return false;
5748 : }
5749 :
5750 60 : if (ar->team->ts.type != BT_INTEGER)
5751 : {
5752 6 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5753 : "type, found %s",
5754 6 : &ar->team->where,
5755 : gfc_basic_typename (ar->team->ts.type));
5756 6 : return false;
5757 : }
5758 : }
5759 13545 : else if (ar->team_type == TEAM_TEAM)
5760 : {
5761 42 : if (!gfc_resolve_expr (ar->team))
5762 : return false;
5763 :
5764 42 : if (ar->team->rank != 0)
5765 : {
5766 3 : gfc_error ("TEAM argument at %L must be scalar",
5767 : &ar->team->where);
5768 3 : return false;
5769 : }
5770 :
5771 39 : if (ar->team->ts.type != BT_DERIVED
5772 36 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5773 36 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5774 : {
5775 3 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5776 : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5777 3 : &ar->team->where,
5778 : gfc_basic_typename (ar->team->ts.type));
5779 3 : return false;
5780 : }
5781 : }
5782 13593 : if (ar->stat)
5783 : {
5784 62 : if (!gfc_resolve_expr (ar->stat))
5785 : return false;
5786 :
5787 62 : if (ar->stat->rank != 0)
5788 : {
5789 3 : gfc_error ("STAT argument at %L must be scalar",
5790 : &ar->stat->where);
5791 3 : return false;
5792 : }
5793 :
5794 59 : if (ar->stat->ts.type != BT_INTEGER)
5795 : {
5796 3 : gfc_error ("STAT argument at %L must be of INTEGER "
5797 : "type, found %s",
5798 3 : &ar->stat->where,
5799 : gfc_basic_typename (ar->stat->ts.type));
5800 3 : return false;
5801 : }
5802 :
5803 56 : if (ar->stat->expr_type != EXPR_VARIABLE)
5804 : {
5805 0 : gfc_error ("STAT's expression at %L must be a variable",
5806 : &ar->stat->where);
5807 0 : return false;
5808 : }
5809 : }
5810 : }
5811 : return true;
5812 : }
5813 :
5814 :
5815 : bool
5816 8376 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5817 : {
5818 8376 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5819 :
5820 8376 : if (ref->u.ss.start != NULL)
5821 : {
5822 8376 : if (!gfc_resolve_expr (ref->u.ss.start))
5823 : return false;
5824 :
5825 8376 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5826 : {
5827 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5828 : &ref->u.ss.start->where);
5829 1 : return false;
5830 : }
5831 :
5832 8375 : if (ref->u.ss.start->rank != 0)
5833 : {
5834 0 : gfc_error ("Substring start index at %L must be scalar",
5835 : &ref->u.ss.start->where);
5836 0 : return false;
5837 : }
5838 :
5839 8375 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5840 8375 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5841 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5842 : {
5843 1 : gfc_error ("Substring start index at %L is less than one",
5844 : &ref->u.ss.start->where);
5845 1 : return false;
5846 : }
5847 : }
5848 :
5849 8374 : if (ref->u.ss.end != NULL)
5850 : {
5851 8180 : if (!gfc_resolve_expr (ref->u.ss.end))
5852 : return false;
5853 :
5854 8180 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5855 : {
5856 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5857 : &ref->u.ss.end->where);
5858 1 : return false;
5859 : }
5860 :
5861 8179 : if (ref->u.ss.end->rank != 0)
5862 : {
5863 0 : gfc_error ("Substring end index at %L must be scalar",
5864 : &ref->u.ss.end->where);
5865 0 : return false;
5866 : }
5867 :
5868 8179 : if (ref->u.ss.length != NULL
5869 7844 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5870 8191 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5871 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5872 : {
5873 4 : gfc_error ("Substring end index at %L exceeds the string length",
5874 : &ref->u.ss.start->where);
5875 4 : return false;
5876 : }
5877 :
5878 8175 : if (compare_bound_mpz_t (ref->u.ss.end,
5879 8175 : gfc_integer_kinds[k].huge) == CMP_GT
5880 8175 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5881 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5882 : {
5883 4 : gfc_error ("Substring end index at %L is too large",
5884 : &ref->u.ss.end->where);
5885 4 : return false;
5886 : }
5887 : /* If the substring has the same length as the original
5888 : variable, the reference itself can be deleted. */
5889 :
5890 8171 : if (ref->u.ss.length != NULL
5891 7836 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5892 9085 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5893 228 : *equal_length = true;
5894 : }
5895 :
5896 : return true;
5897 : }
5898 :
5899 :
5900 : /* This function supplies missing substring charlens. */
5901 :
5902 : void
5903 4563 : gfc_resolve_substring_charlen (gfc_expr *e)
5904 : {
5905 4563 : gfc_ref *char_ref;
5906 4563 : gfc_expr *start, *end;
5907 4563 : gfc_typespec *ts = NULL;
5908 4563 : mpz_t diff;
5909 :
5910 8887 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5911 : {
5912 7041 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5913 : break;
5914 4324 : if (char_ref->type == REF_COMPONENT)
5915 328 : ts = &char_ref->u.c.component->ts;
5916 : }
5917 :
5918 4563 : if (!char_ref || char_ref->type == REF_INQUIRY)
5919 1908 : return;
5920 :
5921 2717 : gcc_assert (char_ref->next == NULL);
5922 :
5923 2717 : if (e->ts.u.cl)
5924 : {
5925 120 : if (e->ts.u.cl->length)
5926 108 : gfc_free_expr (e->ts.u.cl->length);
5927 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5928 : return;
5929 : }
5930 :
5931 2705 : if (!e->ts.u.cl)
5932 2597 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5933 :
5934 2705 : if (char_ref->u.ss.start)
5935 2705 : start = gfc_copy_expr (char_ref->u.ss.start);
5936 : else
5937 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5938 :
5939 2705 : if (char_ref->u.ss.end)
5940 2655 : end = gfc_copy_expr (char_ref->u.ss.end);
5941 50 : else if (e->expr_type == EXPR_VARIABLE)
5942 : {
5943 50 : if (!ts)
5944 32 : ts = &e->symtree->n.sym->ts;
5945 50 : end = gfc_copy_expr (ts->u.cl->length);
5946 : }
5947 : else
5948 : end = NULL;
5949 :
5950 2705 : if (!start || !end)
5951 : {
5952 50 : gfc_free_expr (start);
5953 50 : gfc_free_expr (end);
5954 50 : return;
5955 : }
5956 :
5957 : /* Length = (end - start + 1).
5958 : Check first whether it has a constant length. */
5959 2655 : if (gfc_dep_difference (end, start, &diff))
5960 : {
5961 2539 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5962 : &e->where);
5963 :
5964 2539 : mpz_add_ui (len->value.integer, diff, 1);
5965 2539 : mpz_clear (diff);
5966 2539 : e->ts.u.cl->length = len;
5967 : /* The check for length < 0 is handled below */
5968 : }
5969 : else
5970 : {
5971 116 : e->ts.u.cl->length = gfc_subtract (end, start);
5972 116 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5973 : gfc_get_int_expr (gfc_charlen_int_kind,
5974 : NULL, 1));
5975 : }
5976 :
5977 : /* F2008, 6.4.1: Both the starting point and the ending point shall
5978 : be within the range 1, 2, ..., n unless the starting point exceeds
5979 : the ending point, in which case the substring has length zero. */
5980 :
5981 2655 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5982 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5983 :
5984 2655 : e->ts.u.cl->length->ts.type = BT_INTEGER;
5985 2655 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5986 :
5987 : /* Make sure that the length is simplified. */
5988 2655 : gfc_simplify_expr (e->ts.u.cl->length, 1);
5989 2655 : gfc_resolve_expr (e->ts.u.cl->length);
5990 : }
5991 :
5992 :
5993 : /* Convert an array reference to an array element so that PDT KIND and LEN
5994 : or inquiry references are always scalar. */
5995 :
5996 : static void
5997 21 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
5998 : {
5999 21 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6000 21 : int dim;
6001 :
6002 21 : array_ref->u.ar.type = AR_ELEMENT;
6003 21 : expr->rank = 0;
6004 : /* Suppress the runtime bounds check. */
6005 21 : expr->no_bounds_check = 1;
6006 42 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
6007 : {
6008 21 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
6009 21 : if (array_ref->u.ar.start[dim])
6010 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
6011 :
6012 21 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
6013 9 : array_ref->u.ar.start[dim]
6014 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
6015 : else
6016 12 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
6017 :
6018 21 : if (array_ref->u.ar.end[dim])
6019 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
6020 21 : if (array_ref->u.ar.stride[dim])
6021 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
6022 : }
6023 21 : gfc_free_expr (unity);
6024 21 : }
6025 :
6026 :
6027 : /* Resolve subtype references. */
6028 :
6029 : bool
6030 538016 : gfc_resolve_ref (gfc_expr *expr)
6031 : {
6032 538016 : int current_part_dimension, n_components, seen_part_dimension;
6033 538016 : gfc_ref *ref, **prev, *array_ref;
6034 538016 : bool equal_length;
6035 538016 : gfc_symbol *last_pdt = NULL;
6036 :
6037 1056410 : for (ref = expr->ref; ref; ref = ref->next)
6038 519291 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6039 : {
6040 897 : if (!find_array_spec (expr))
6041 : return false;
6042 : break;
6043 : }
6044 :
6045 1576496 : for (prev = &expr->ref; *prev != NULL;
6046 519345 : prev = *prev == NULL ? prev : &(*prev)->next)
6047 519436 : switch ((*prev)->type)
6048 : {
6049 423026 : case REF_ARRAY:
6050 423026 : if (!resolve_array_ref (&(*prev)->u.ar))
6051 : return false;
6052 : break;
6053 :
6054 : case REF_COMPONENT:
6055 : case REF_INQUIRY:
6056 : break;
6057 :
6058 8095 : case REF_SUBSTRING:
6059 8095 : equal_length = false;
6060 8095 : if (!gfc_resolve_substring (*prev, &equal_length))
6061 : return false;
6062 :
6063 8087 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6064 : {
6065 : /* Remove the reference and move the charlen, if any. */
6066 203 : ref = *prev;
6067 203 : *prev = ref->next;
6068 203 : ref->next = NULL;
6069 203 : expr->ts.u.cl = ref->u.ss.length;
6070 203 : ref->u.ss.length = NULL;
6071 203 : gfc_free_ref_list (ref);
6072 : }
6073 : break;
6074 : }
6075 :
6076 : /* Check constraints on part references. */
6077 :
6078 537918 : current_part_dimension = 0;
6079 537918 : seen_part_dimension = 0;
6080 537918 : n_components = 0;
6081 537918 : array_ref = NULL;
6082 :
6083 537918 : if (expr->expr_type == EXPR_VARIABLE && IS_PDT (expr))
6084 534 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6085 :
6086 1057035 : for (ref = expr->ref; ref; ref = ref->next)
6087 : {
6088 519128 : switch (ref->type)
6089 : {
6090 422936 : case REF_ARRAY:
6091 422936 : array_ref = ref;
6092 422936 : switch (ref->u.ar.type)
6093 : {
6094 259592 : case AR_FULL:
6095 : /* Coarray scalar. */
6096 259592 : if (ref->u.ar.as->rank == 0)
6097 : {
6098 : current_part_dimension = 0;
6099 : break;
6100 : }
6101 : /* Fall through. */
6102 299746 : case AR_SECTION:
6103 299746 : current_part_dimension = 1;
6104 299746 : break;
6105 :
6106 123190 : case AR_ELEMENT:
6107 123190 : array_ref = NULL;
6108 123190 : current_part_dimension = 0;
6109 123190 : break;
6110 :
6111 0 : case AR_UNKNOWN:
6112 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6113 : }
6114 :
6115 : break;
6116 :
6117 87511 : case REF_COMPONENT:
6118 87511 : if (current_part_dimension || seen_part_dimension)
6119 : {
6120 : /* F03:C614. */
6121 6306 : if (ref->u.c.component->attr.pointer
6122 6303 : || ref->u.c.component->attr.proc_pointer
6123 6302 : || (ref->u.c.component->ts.type == BT_CLASS
6124 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6125 : {
6126 4 : gfc_error ("Component to the right of a part reference "
6127 : "with nonzero rank must not have the POINTER "
6128 : "attribute at %L", &expr->where);
6129 4 : return false;
6130 : }
6131 6302 : else if (ref->u.c.component->attr.allocatable
6132 6296 : || (ref->u.c.component->ts.type == BT_CLASS
6133 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6134 :
6135 : {
6136 7 : gfc_error ("Component to the right of a part reference "
6137 : "with nonzero rank must not have the ALLOCATABLE "
6138 : "attribute at %L", &expr->where);
6139 7 : return false;
6140 : }
6141 : }
6142 :
6143 : /* Sometimes the component in a component reference is that of the
6144 : pdt_template. Point to the component of pdt_type instead. This
6145 : ensures that the component gets a backend_decl in translation. */
6146 87500 : if (last_pdt)
6147 : {
6148 500 : gfc_component *cmp = last_pdt->components;
6149 1205 : for (; cmp; cmp = cmp->next)
6150 1200 : if (!strcmp (cmp->name, ref->u.c.component->name))
6151 : {
6152 495 : ref->u.c.component = cmp;
6153 495 : break;
6154 : }
6155 500 : ref->u.c.sym = last_pdt;
6156 : }
6157 :
6158 : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6159 87500 : if (ref->u.c.component->ts.type == BT_DERIVED)
6160 : {
6161 20561 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6162 : {
6163 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6164 : &ref->u.c.component->ts.u.derived,
6165 : NULL) != MATCH_YES)
6166 : return false;
6167 0 : last_pdt = ref->u.c.component->ts.u.derived;
6168 : }
6169 20561 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6170 520 : last_pdt = ref->u.c.component->ts.u.derived;
6171 : else
6172 : last_pdt = NULL;
6173 : }
6174 :
6175 : /* The F08 standard requires(See R425, R431, R435, and in particular
6176 : Note 6.7) that a PDT parameter reference be a scalar even if
6177 : the designator is an array." */
6178 87500 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6179 83 : && (ref->u.c.component->attr.pdt_kind
6180 83 : || ref->u.c.component->attr.pdt_len))
6181 7 : reset_array_ref_to_scalar (expr, array_ref);
6182 :
6183 87500 : n_components++;
6184 87500 : break;
6185 :
6186 : case REF_SUBSTRING:
6187 : break;
6188 :
6189 797 : case REF_INQUIRY:
6190 : /* Implement requirement in note 9.7 of F2018 that the result of the
6191 : LEN inquiry be a scalar. */
6192 797 : if (ref->u.i == INQUIRY_LEN && array_ref
6193 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6194 40 : || expr->ts.type == BT_INTEGER))
6195 14 : reset_array_ref_to_scalar (expr, array_ref);
6196 : break;
6197 : }
6198 :
6199 519117 : if (((ref->type == REF_COMPONENT && n_components > 1)
6200 505937 : || ref->next == NULL)
6201 : && current_part_dimension
6202 456063 : && seen_part_dimension)
6203 : {
6204 0 : gfc_error ("Two or more part references with nonzero rank must "
6205 : "not be specified at %L", &expr->where);
6206 0 : return false;
6207 : }
6208 :
6209 519117 : if (ref->type == REF_COMPONENT)
6210 : {
6211 87500 : if (current_part_dimension)
6212 6108 : seen_part_dimension = 1;
6213 :
6214 : /* reset to make sure */
6215 : current_part_dimension = 0;
6216 : }
6217 : }
6218 :
6219 : return true;
6220 : }
6221 :
6222 :
6223 : /* Given an expression, determine its shape. This is easier than it sounds.
6224 : Leaves the shape array NULL if it is not possible to determine the shape. */
6225 :
6226 : static void
6227 2584349 : expression_shape (gfc_expr *e)
6228 : {
6229 2584349 : mpz_t array[GFC_MAX_DIMENSIONS];
6230 2584349 : int i;
6231 :
6232 2584349 : if (e->rank <= 0 || e->shape != NULL)
6233 2409986 : return;
6234 :
6235 697919 : for (i = 0; i < e->rank; i++)
6236 471719 : if (!gfc_array_dimen_size (e, i, &array[i]))
6237 174363 : goto fail;
6238 :
6239 226200 : e->shape = gfc_get_shape (e->rank);
6240 :
6241 226200 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6242 :
6243 226200 : return;
6244 :
6245 174363 : fail:
6246 176034 : for (i--; i >= 0; i--)
6247 1671 : mpz_clear (array[i]);
6248 : }
6249 :
6250 :
6251 : /* Given a variable expression node, compute the rank of the expression by
6252 : examining the base symbol and any reference structures it may have. */
6253 :
6254 : void
6255 2584349 : gfc_expression_rank (gfc_expr *e)
6256 : {
6257 2584349 : gfc_ref *ref, *last_arr_ref = nullptr;
6258 2584349 : int i, rank, corank;
6259 :
6260 : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6261 : could lead to serious confusion... */
6262 2584349 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6263 :
6264 2584349 : if (e->ref == NULL)
6265 : {
6266 1907709 : if (e->expr_type == EXPR_ARRAY)
6267 70762 : goto done;
6268 : /* Constructors can have a rank different from one via RESHAPE(). */
6269 :
6270 1836947 : if (e->symtree != NULL)
6271 : {
6272 : /* After errors the ts.u.derived of a CLASS might not be set. */
6273 1836935 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6274 13805 : && e->symtree->n.sym->ts.u.derived
6275 13800 : && CLASS_DATA (e->symtree->n.sym))
6276 1836935 : ? CLASS_DATA (e->symtree->n.sym)->as
6277 : : e->symtree->n.sym->as;
6278 1836935 : if (as)
6279 : {
6280 589 : e->rank = as->rank;
6281 589 : e->corank = as->corank;
6282 589 : goto done;
6283 : }
6284 : }
6285 1836358 : e->rank = 0;
6286 1836358 : e->corank = 0;
6287 1836358 : goto done;
6288 : }
6289 :
6290 : rank = 0;
6291 : corank = 0;
6292 :
6293 1068619 : for (ref = e->ref; ref; ref = ref->next)
6294 : {
6295 780936 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6296 553 : && ref->u.c.component->attr.function && !ref->next)
6297 : {
6298 357 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6299 357 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6300 : }
6301 :
6302 780936 : if (ref->type != REF_ARRAY)
6303 154770 : continue;
6304 :
6305 626166 : last_arr_ref = ref;
6306 626166 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6307 : {
6308 344183 : rank = ref->u.ar.as->rank;
6309 344183 : break;
6310 : }
6311 :
6312 281983 : if (ref->u.ar.type == AR_SECTION)
6313 : {
6314 : /* Figure out the rank of the section. */
6315 44774 : if (rank != 0)
6316 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6317 :
6318 112033 : for (i = 0; i < ref->u.ar.dimen; i++)
6319 67259 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6320 67259 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6321 58566 : rank++;
6322 :
6323 : break;
6324 : }
6325 : }
6326 676640 : if (last_arr_ref && last_arr_ref->u.ar.as
6327 607087 : && last_arr_ref->u.ar.as->rank != -1)
6328 : {
6329 19264 : for (i = last_arr_ref->u.ar.as->rank;
6330 618243 : i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
6331 : {
6332 : /* For unknown dimen in non-resolved as assume full corank. */
6333 20151 : if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
6334 19587 : || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6335 323 : && !last_arr_ref->u.ar.as->resolved))
6336 : {
6337 : corank = last_arr_ref->u.ar.as->corank;
6338 : break;
6339 : }
6340 19264 : else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6341 19264 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6342 19166 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6343 16675 : corank++;
6344 2589 : else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6345 0 : gfc_internal_error ("Illegal coarray index");
6346 : }
6347 : }
6348 :
6349 676640 : e->rank = rank;
6350 676640 : e->corank = corank;
6351 :
6352 2584349 : done:
6353 2584349 : expression_shape (e);
6354 2584349 : }
6355 :
6356 :
6357 : /* Given two expressions, check that their rank is conformable, i.e. either
6358 : both have the same rank or at least one is a scalar. */
6359 :
6360 : bool
6361 12196206 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6362 : {
6363 12196206 : if (op1->expr_type == EXPR_VARIABLE)
6364 730034 : gfc_expression_rank (op1);
6365 12196206 : if (op2->expr_type == EXPR_VARIABLE)
6366 445941 : gfc_expression_rank (op2);
6367 :
6368 75807 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6369 12271687 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6370 30 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6371 : }
6372 :
6373 : /* Resolve a variable expression. */
6374 :
6375 : static bool
6376 1319004 : resolve_variable (gfc_expr *e)
6377 : {
6378 1319004 : gfc_symbol *sym;
6379 1319004 : bool t;
6380 :
6381 1319004 : t = true;
6382 :
6383 1319004 : if (e->symtree == NULL)
6384 : return false;
6385 1318559 : sym = e->symtree->n.sym;
6386 :
6387 : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6388 : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6389 1318559 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6390 : {
6391 183 : if (!actual_arg || inquiry_argument)
6392 : {
6393 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6394 : "be used as actual argument", sym->name, &e->where);
6395 2 : return false;
6396 : }
6397 : }
6398 : /* TS 29113, 407b. */
6399 1318376 : else if (e->ts.type == BT_ASSUMED)
6400 : {
6401 571 : if (!actual_arg)
6402 : {
6403 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6404 : "as actual argument", sym->name, &e->where);
6405 20 : return false;
6406 : }
6407 551 : else if (inquiry_argument && !first_actual_arg)
6408 : {
6409 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6410 : for all inquiry functions in resolve_function; the reason is
6411 : that the function-name resolution happens too late in that
6412 : function. */
6413 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6414 : "an inquiry function shall be the first argument",
6415 : sym->name, &e->where);
6416 0 : return false;
6417 : }
6418 : }
6419 : /* TS 29113, C535b. */
6420 1317805 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6421 36888 : && sym->ts.u.derived && CLASS_DATA (sym)
6422 36883 : && CLASS_DATA (sym)->as
6423 14354 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6424 1316895 : || (sym->ts.type != BT_CLASS && sym->as
6425 360589 : && sym->as->type == AS_ASSUMED_RANK))
6426 7900 : && !sym->attr.select_rank_temporary
6427 7900 : && !(sym->assoc && sym->assoc->ar))
6428 : {
6429 7900 : if (!actual_arg
6430 1247 : && !(cs_base && cs_base->current
6431 1246 : && (cs_base->current->op == EXEC_SELECT_RANK
6432 188 : || sym->attr.target)))
6433 : {
6434 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6435 : "actual argument", sym->name, &e->where);
6436 144 : return false;
6437 : }
6438 7756 : else if (inquiry_argument && !first_actual_arg)
6439 : {
6440 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6441 : for all inquiry functions in resolve_function; the reason is
6442 : that the function-name resolution happens too late in that
6443 : function. */
6444 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6445 : "to an inquiry function shall be the first argument",
6446 : sym->name, &e->where);
6447 0 : return false;
6448 : }
6449 : }
6450 :
6451 1318393 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6452 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6453 180 : && e->ref->next == NULL))
6454 : {
6455 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6456 : "a subobject reference", sym->name, &e->ref->u.ar.where);
6457 1 : return false;
6458 : }
6459 : /* TS 29113, 407b. */
6460 1318392 : else if (e->ts.type == BT_ASSUMED && e->ref
6461 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6462 680 : && e->ref->next == NULL))
6463 : {
6464 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6465 : "reference", sym->name, &e->ref->u.ar.where);
6466 7 : return false;
6467 : }
6468 :
6469 : /* TS 29113, C535b. */
6470 1318385 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6471 36888 : && sym->ts.u.derived && CLASS_DATA (sym)
6472 36883 : && CLASS_DATA (sym)->as
6473 14354 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6474 1317475 : || (sym->ts.type != BT_CLASS && sym->as
6475 361125 : && sym->as->type == AS_ASSUMED_RANK))
6476 8040 : && !(sym->assoc && sym->assoc->ar)
6477 8040 : && e->ref
6478 8040 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6479 8036 : && e->ref->next == NULL))
6480 : {
6481 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6482 : "reference", sym->name, &e->ref->u.ar.where);
6483 4 : return false;
6484 : }
6485 :
6486 : /* Guessed type variables are associate_names whose selector had not been
6487 : parsed at the time that the construct was parsed. Now the namespace is
6488 : being resolved, the TKR of the selector will be available for fixup of
6489 : the associate_name. */
6490 1318381 : if (IS_INFERRED_TYPE (e) && e->ref)
6491 : {
6492 384 : gfc_fixup_inferred_type_refs (e);
6493 : /* KIND inquiry ref returns the kind of the target. */
6494 384 : if (e->expr_type == EXPR_CONSTANT)
6495 : return true;
6496 : }
6497 1317997 : else if (sym->attr.select_type_temporary
6498 8924 : && sym->ns->assoc_name_inferred)
6499 92 : gfc_fixup_inferred_type_refs (e);
6500 :
6501 : /* For variables that are used in an associate (target => object) where
6502 : the object's basetype is array valued while the target is scalar,
6503 : the ts' type of the component refs is still array valued, which
6504 : can't be translated that way. */
6505 1318369 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6506 603 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6507 603 : && sym->assoc->target->ts.u.derived
6508 603 : && CLASS_DATA (sym->assoc->target)
6509 603 : && CLASS_DATA (sym->assoc->target)->as)
6510 : {
6511 : gfc_ref *ref = e->ref;
6512 697 : while (ref)
6513 : {
6514 539 : switch (ref->type)
6515 : {
6516 236 : case REF_COMPONENT:
6517 236 : ref->u.c.sym = sym->ts.u.derived;
6518 : /* Stop the loop. */
6519 236 : ref = NULL;
6520 236 : break;
6521 303 : default:
6522 303 : ref = ref->next;
6523 303 : break;
6524 : }
6525 : }
6526 : }
6527 :
6528 : /* If this is an associate-name, it may be parsed with an array reference
6529 : in error even though the target is scalar. Fail directly in this case.
6530 : TODO Understand why class scalar expressions must be excluded. */
6531 1318369 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6532 : {
6533 11381 : if (sym->ts.type == BT_CLASS)
6534 242 : gfc_fix_class_refs (e);
6535 11381 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6536 2085 : && e->ref->type == REF_ARRAY)
6537 : {
6538 : /* Unambiguously scalar! */
6539 3 : if (sym->assoc->target
6540 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6541 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6542 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6543 : sym->name, &e->where);
6544 3 : return false;
6545 : }
6546 11378 : else if ((sym->attr.dimension || sym->attr.codimension)
6547 6964 : && (!e->ref || e->ref->type != REF_ARRAY))
6548 : {
6549 : /* This can happen because the parser did not detect that the
6550 : associate name is an array and the expression had no array
6551 : part_ref. */
6552 146 : gfc_ref *ref = gfc_get_ref ();
6553 146 : ref->type = REF_ARRAY;
6554 146 : ref->u.ar.type = AR_FULL;
6555 146 : if (sym->as)
6556 : {
6557 145 : ref->u.ar.as = sym->as;
6558 145 : ref->u.ar.dimen = sym->as->rank;
6559 : }
6560 146 : ref->next = e->ref;
6561 146 : e->ref = ref;
6562 : }
6563 : }
6564 :
6565 1318366 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6566 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6567 :
6568 : /* On the other hand, the parser may not have known this is an array;
6569 : in this case, we have to add a FULL reference. */
6570 1318366 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6571 : {
6572 0 : e->ref = gfc_get_ref ();
6573 0 : e->ref->type = REF_ARRAY;
6574 0 : e->ref->u.ar.type = AR_FULL;
6575 0 : e->ref->u.ar.dimen = 0;
6576 : }
6577 :
6578 : /* Like above, but for class types, where the checking whether an array
6579 : ref is present is more complicated. Furthermore make sure not to add
6580 : the full array ref to _vptr or _len refs. */
6581 1318366 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6582 1012 : && CLASS_DATA (sym)
6583 1012 : && (CLASS_DATA (sym)->attr.dimension
6584 443 : || CLASS_DATA (sym)->attr.codimension)
6585 575 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6586 : {
6587 551 : gfc_ref *ref, *newref;
6588 :
6589 551 : newref = gfc_get_ref ();
6590 551 : newref->type = REF_ARRAY;
6591 551 : newref->u.ar.type = AR_FULL;
6592 551 : newref->u.ar.dimen = 0;
6593 :
6594 : /* Because this is an associate var and the first ref either is a ref to
6595 : the _data component or not, no traversal of the ref chain is
6596 : needed. The array ref needs to be inserted after the _data ref,
6597 : or when that is not present, which may happened for polymorphic
6598 : types, then at the first position. */
6599 551 : ref = e->ref;
6600 551 : if (!ref)
6601 18 : e->ref = newref;
6602 533 : else if (ref->type == REF_COMPONENT
6603 230 : && strcmp ("_data", ref->u.c.component->name) == 0)
6604 : {
6605 230 : if (!ref->next || ref->next->type != REF_ARRAY)
6606 : {
6607 12 : newref->next = ref->next;
6608 12 : ref->next = newref;
6609 : }
6610 : else
6611 : /* Array ref present already. */
6612 218 : gfc_free_ref_list (newref);
6613 : }
6614 303 : else if (ref->type == REF_ARRAY)
6615 : /* Array ref present already. */
6616 303 : gfc_free_ref_list (newref);
6617 : else
6618 : {
6619 0 : newref->next = ref;
6620 0 : e->ref = newref;
6621 : }
6622 : }
6623 1317815 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6624 : {
6625 485 : gfc_ref *ref;
6626 908 : for (ref = e->ref; ref; ref = ref->next)
6627 453 : if (ref->type == REF_SUBSTRING)
6628 : break;
6629 485 : if (ref == NULL)
6630 455 : e->ts = sym->ts;
6631 : }
6632 :
6633 1318366 : if (e->ref && !gfc_resolve_ref (e))
6634 : return false;
6635 :
6636 1318273 : if (sym->attr.flavor == FL_PROCEDURE
6637 31228 : && (!sym->attr.function
6638 18280 : || (sym->attr.function && sym->result
6639 17832 : && sym->result->attr.proc_pointer
6640 563 : && !sym->result->attr.function)))
6641 : {
6642 12948 : e->ts.type = BT_PROCEDURE;
6643 12948 : goto resolve_procedure;
6644 : }
6645 :
6646 1305325 : if (sym->ts.type != BT_UNKNOWN)
6647 1304682 : gfc_variable_attr (e, &e->ts);
6648 643 : else if (sym->attr.flavor == FL_PROCEDURE
6649 12 : && sym->attr.function && sym->result
6650 12 : && sym->result->ts.type != BT_UNKNOWN
6651 10 : && sym->result->attr.proc_pointer)
6652 10 : e->ts = sym->result->ts;
6653 : else
6654 : {
6655 : /* Must be a simple variable reference. */
6656 633 : if (!gfc_set_default_type (sym, 1, sym->ns))
6657 : return false;
6658 507 : e->ts = sym->ts;
6659 : }
6660 :
6661 1305199 : if (check_assumed_size_reference (sym, e))
6662 : return false;
6663 :
6664 : /* Deal with forward references to entries during gfc_resolve_code, to
6665 : satisfy, at least partially, 12.5.2.5. */
6666 1305180 : if (gfc_current_ns->entries
6667 3067 : && current_entry_id == sym->entry_id
6668 1003 : && cs_base
6669 917 : && cs_base->current
6670 917 : && cs_base->current->op != EXEC_ENTRY)
6671 : {
6672 917 : gfc_entry_list *entry;
6673 917 : gfc_formal_arglist *formal;
6674 917 : int n;
6675 917 : bool seen, saved_specification_expr;
6676 :
6677 : /* If the symbol is a dummy... */
6678 917 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6679 : {
6680 : entry = gfc_current_ns->entries;
6681 : seen = false;
6682 :
6683 : /* ...test if the symbol is a parameter of previous entries. */
6684 1038 : for (; entry && entry->id <= current_entry_id; entry = entry->next)
6685 1009 : for (formal = entry->sym->formal; formal; formal = formal->next)
6686 : {
6687 1000 : if (formal->sym && sym->name == formal->sym->name)
6688 : {
6689 : seen = true;
6690 : break;
6691 : }
6692 : }
6693 :
6694 : /* If it has not been seen as a dummy, this is an error. */
6695 455 : if (!seen)
6696 : {
6697 3 : if (specification_expr)
6698 2 : gfc_error ("Variable %qs, used in a specification expression"
6699 : ", is referenced at %L before the ENTRY statement "
6700 : "in which it is a parameter",
6701 : sym->name, &cs_base->current->loc);
6702 : else
6703 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6704 : "statement in which it is a parameter",
6705 : sym->name, &cs_base->current->loc);
6706 : t = false;
6707 : }
6708 : }
6709 :
6710 : /* Now do the same check on the specification expressions. */
6711 917 : saved_specification_expr = specification_expr;
6712 917 : specification_expr = true;
6713 917 : if (sym->ts.type == BT_CHARACTER
6714 917 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6715 : t = false;
6716 :
6717 917 : if (sym->as)
6718 : {
6719 271 : for (n = 0; n < sym->as->rank; n++)
6720 : {
6721 159 : if (!gfc_resolve_expr (sym->as->lower[n]))
6722 0 : t = false;
6723 159 : if (!gfc_resolve_expr (sym->as->upper[n]))
6724 1 : t = false;
6725 : }
6726 : }
6727 917 : specification_expr = saved_specification_expr;
6728 :
6729 917 : if (t)
6730 : /* Update the symbol's entry level. */
6731 912 : sym->entry_id = current_entry_id + 1;
6732 : }
6733 :
6734 : /* If a symbol has been host_associated mark it. This is used latter,
6735 : to identify if aliasing is possible via host association. */
6736 1305180 : if (sym->attr.flavor == FL_VARIABLE
6737 1267381 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6738 6037 : || !sym->ns->code->ext.block.assoc)
6739 1265408 : && gfc_current_ns->parent
6740 601357 : && (gfc_current_ns->parent == sym->ns
6741 563548 : || (gfc_current_ns->parent->parent
6742 11276 : && gfc_current_ns->parent->parent == sym->ns)))
6743 44427 : sym->attr.host_assoc = 1;
6744 :
6745 1305180 : if (gfc_current_ns->proc_name
6746 1301134 : && sym->attr.dimension
6747 354607 : && (sym->ns != gfc_current_ns
6748 330496 : || sym->attr.use_assoc
6749 326516 : || sym->attr.in_common))
6750 32879 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6751 :
6752 1318128 : resolve_procedure:
6753 1318128 : if (t && !resolve_procedure_expression (e))
6754 : t = false;
6755 :
6756 : /* F2008, C617 and C1229. */
6757 1317100 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6758 1414953 : && gfc_is_coindexed (e))
6759 : {
6760 356 : gfc_ref *ref, *ref2 = NULL;
6761 :
6762 439 : for (ref = e->ref; ref; ref = ref->next)
6763 : {
6764 439 : if (ref->type == REF_COMPONENT)
6765 83 : ref2 = ref;
6766 439 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6767 : break;
6768 : }
6769 :
6770 712 : for ( ; ref; ref = ref->next)
6771 368 : if (ref->type == REF_COMPONENT)
6772 : break;
6773 :
6774 : /* Expression itself is not coindexed object. */
6775 356 : if (ref && e->ts.type == BT_CLASS)
6776 : {
6777 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6778 : &e->where);
6779 3 : t = false;
6780 : }
6781 :
6782 : /* Expression itself is coindexed object. */
6783 344 : if (ref == NULL)
6784 : {
6785 344 : gfc_component *c;
6786 344 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6787 464 : for ( ; c; c = c->next)
6788 120 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6789 : {
6790 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6791 : "subcomponent at %L", &e->where);
6792 0 : t = false;
6793 0 : break;
6794 : }
6795 : }
6796 : }
6797 :
6798 1318128 : if (t)
6799 1318120 : gfc_expression_rank (e);
6800 :
6801 1318128 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6802 3 : gfc_warning (OPT_Wdeprecated_declarations,
6803 : "Using variable %qs at %L is deprecated",
6804 : sym->name, &e->where);
6805 : /* Simplify cases where access to a parameter array results in a
6806 : single constant. Suppress errors since those will have been
6807 : issued before, as warnings. */
6808 1318128 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6809 : {
6810 2727 : gfc_push_suppress_errors ();
6811 2727 : gfc_simplify_expr (e, 1);
6812 2727 : gfc_pop_suppress_errors ();
6813 : }
6814 :
6815 : return t;
6816 : }
6817 :
6818 :
6819 : /* 'sym' was initially guessed to be derived type but has been corrected
6820 : in resolve_assoc_var to be a class entity or the derived type correcting.
6821 : If a class entity it will certainly need the _data reference or the
6822 : reference derived type symbol correcting in the first component ref if
6823 : a derived type. */
6824 :
6825 : void
6826 880 : gfc_fixup_inferred_type_refs (gfc_expr *e)
6827 : {
6828 880 : gfc_ref *ref, *new_ref;
6829 880 : gfc_symbol *sym, *derived;
6830 880 : gfc_expr *target;
6831 880 : sym = e->symtree->n.sym;
6832 :
6833 : /* An associate_name whose selector is (i) a component ref of a selector
6834 : that is a inferred type associate_name; or (ii) an intrinsic type that
6835 : has been inferred from an inquiry ref. */
6836 880 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
6837 : {
6838 282 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
6839 282 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
6840 282 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
6841 : {
6842 60 : ref = e->ref;
6843 : /* A substring misidentified as an array section. */
6844 60 : if (sym->ts.type == BT_CHARACTER
6845 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
6846 6 : && !ref->u.ar.stride[0])
6847 : {
6848 6 : new_ref = gfc_get_ref ();
6849 6 : new_ref->type = REF_SUBSTRING;
6850 6 : new_ref->u.ss.start = ref->u.ar.start[0];
6851 6 : new_ref->u.ss.end = ref->u.ar.end[0];
6852 6 : new_ref->u.ss.length = sym->ts.u.cl;
6853 6 : *ref = *new_ref;
6854 6 : free (new_ref);
6855 : }
6856 : else
6857 : {
6858 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
6859 24 : gfc_error ("Invalid array reference at %L", &e->where);
6860 54 : e->ref = ref->next;
6861 54 : free (ref);
6862 : }
6863 : }
6864 :
6865 : /* It is possible for an inquiry reference to be mistaken for a
6866 : component reference. Correct this now. */
6867 282 : ref = e->ref;
6868 282 : if (ref && ref->type == REF_ARRAY)
6869 138 : ref = ref->next;
6870 150 : if (ref && ref->type == REF_COMPONENT
6871 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
6872 : {
6873 12 : e->symtree->n.sym = sym;
6874 12 : *ref = *new_ref;
6875 12 : gfc_free_ref_list (new_ref);
6876 : }
6877 :
6878 : /* The kind of the associate name is best evaluated directly from the
6879 : selector because of the guesses made in primary.cc, when the type
6880 : is still unknown. */
6881 282 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
6882 : {
6883 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6884 12 : sym->assoc->target->ts.kind);
6885 12 : gfc_replace_expr (e, ne);
6886 : }
6887 :
6888 : /* Now that the references are all sorted out, set the expression rank
6889 : and return. */
6890 282 : gfc_expression_rank (e);
6891 282 : return;
6892 : }
6893 :
6894 598 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
6895 : : sym->ts.u.derived;
6896 :
6897 : /* Ensure that class symbols have an array spec and ensure that there
6898 : is a _data field reference following class type references. */
6899 598 : if (sym->ts.type == BT_CLASS
6900 196 : && sym->assoc->target->ts.type == BT_CLASS)
6901 : {
6902 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
6903 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
6904 196 : sym->attr.dimension = 0;
6905 196 : sym->attr.codimension = 0;
6906 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
6907 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
6908 196 : if (e->ref && (e->ref->type != REF_COMPONENT
6909 160 : || e->ref->u.c.component->name[0] != '_'))
6910 : {
6911 82 : ref = gfc_get_ref ();
6912 82 : ref->type = REF_COMPONENT;
6913 82 : ref->next = e->ref;
6914 82 : e->ref = ref;
6915 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
6916 : true, true, NULL);
6917 82 : ref->u.c.sym = sym->ts.u.derived;
6918 : }
6919 : }
6920 :
6921 : /* Proceed as far as the first component reference and ensure that the
6922 : correct derived type is being used. */
6923 861 : for (ref = e->ref; ref; ref = ref->next)
6924 825 : if (ref->type == REF_COMPONENT)
6925 : {
6926 562 : if (ref->u.c.component->name[0] != '_')
6927 366 : ref->u.c.sym = derived;
6928 : else
6929 196 : ref->u.c.sym = sym->ts.u.derived;
6930 : break;
6931 : }
6932 :
6933 : /* Verify that the type inferrence mechanism has not introduced a spurious
6934 : array reference. This can happen with an associate name, whose selector
6935 : is an element of another inferred type. */
6936 598 : target = e->symtree->n.sym->assoc->target;
6937 598 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
6938 186 : && e != target && !target->rank)
6939 : {
6940 : /* First case: array ref after the scalar class or derived
6941 : associate_name. */
6942 186 : if (e->ref && e->ref->type == REF_ARRAY
6943 7 : && e->ref->u.ar.type != AR_ELEMENT)
6944 : {
6945 7 : ref = e->ref;
6946 7 : if (ref->u.ar.type == AR_UNKNOWN)
6947 1 : gfc_error ("Invalid array reference at %L", &e->where);
6948 7 : e->ref = ref->next;
6949 7 : free (ref);
6950 :
6951 : /* If it hasn't a ref to the '_data' field supply one. */
6952 7 : if (sym->ts.type == BT_CLASS
6953 0 : && !(e->ref->type == REF_COMPONENT
6954 0 : && strcmp (e->ref->u.c.component->name, "_data")))
6955 : {
6956 0 : gfc_ref *new_ref;
6957 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
6958 : "_data", true, true, &new_ref);
6959 0 : new_ref->next = e->ref;
6960 0 : e->ref = new_ref;
6961 : }
6962 : }
6963 : /* 2nd case: a ref to the '_data' field followed by an array ref. */
6964 179 : else if (e->ref && e->ref->type == REF_COMPONENT
6965 179 : && strcmp (e->ref->u.c.component->name, "_data") == 0
6966 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
6967 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
6968 : {
6969 0 : ref = e->ref->next;
6970 0 : if (ref->u.ar.type == AR_UNKNOWN)
6971 0 : gfc_error ("Invalid array reference at %L", &e->where);
6972 0 : e->ref->next = e->ref->next->next;
6973 0 : free (ref);
6974 : }
6975 : }
6976 :
6977 : /* Now that all the references are OK, get the expression rank. */
6978 598 : gfc_expression_rank (e);
6979 : }
6980 :
6981 :
6982 : /* Checks to see that the correct symbol has been host associated.
6983 : The only situations where this arises are:
6984 : (i) That in which a twice contained function is parsed after
6985 : the host association is made. On detecting this, change
6986 : the symbol in the expression and convert the array reference
6987 : into an actual arglist if the old symbol is a variable; or
6988 : (ii) That in which an external function is typed but not declared
6989 : explicitly to be external. Here, the old symbol is changed
6990 : from a variable to an external function. */
6991 : static bool
6992 1662048 : check_host_association (gfc_expr *e)
6993 : {
6994 1662048 : gfc_symbol *sym, *old_sym;
6995 1662048 : gfc_symtree *st;
6996 1662048 : int n;
6997 1662048 : gfc_ref *ref;
6998 1662048 : gfc_actual_arglist *arg, *tail = NULL;
6999 1662048 : bool retval = e->expr_type == EXPR_FUNCTION;
7000 :
7001 : /* If the expression is the result of substitution in
7002 : interface.cc(gfc_extend_expr) because there is no way in
7003 : which the host association can be wrong. */
7004 1662048 : if (e->symtree == NULL
7005 1661249 : || e->symtree->n.sym == NULL
7006 1661249 : || e->user_operator)
7007 : return retval;
7008 :
7009 1659484 : old_sym = e->symtree->n.sym;
7010 :
7011 1659484 : if (gfc_current_ns->parent
7012 725926 : && old_sym->ns != gfc_current_ns)
7013 : {
7014 : /* Use the 'USE' name so that renamed module symbols are
7015 : correctly handled. */
7016 90528 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7017 :
7018 90528 : if (sym && old_sym != sym
7019 679 : && sym->attr.flavor == FL_PROCEDURE
7020 105 : && sym->attr.contained)
7021 : {
7022 : /* Clear the shape, since it might not be valid. */
7023 83 : gfc_free_shape (&e->shape, e->rank);
7024 :
7025 : /* Give the expression the right symtree! */
7026 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7027 83 : gcc_assert (st != NULL);
7028 :
7029 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7030 59 : || e->expr_type == EXPR_FUNCTION)
7031 : {
7032 : /* Original was function so point to the new symbol, since
7033 : the actual argument list is already attached to the
7034 : expression. */
7035 30 : e->value.function.esym = NULL;
7036 30 : e->symtree = st;
7037 : }
7038 : else
7039 : {
7040 : /* Original was variable so convert array references into
7041 : an actual arglist. This does not need any checking now
7042 : since resolve_function will take care of it. */
7043 53 : e->value.function.actual = NULL;
7044 53 : e->expr_type = EXPR_FUNCTION;
7045 53 : e->symtree = st;
7046 :
7047 : /* Ambiguity will not arise if the array reference is not
7048 : the last reference. */
7049 55 : for (ref = e->ref; ref; ref = ref->next)
7050 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7051 : break;
7052 :
7053 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7054 17 : && sym->attr.proc == PROC_INTERNAL)
7055 : {
7056 4 : gfc_error ("%qs at %L is host associated at %L into "
7057 : "a contained procedure with an internal "
7058 : "procedure of the same name", sym->name,
7059 : &old_sym->declared_at, &e->where);
7060 4 : return false;
7061 : }
7062 :
7063 13 : if (ref == NULL)
7064 : return false;
7065 :
7066 36 : gcc_assert (ref->type == REF_ARRAY);
7067 :
7068 : /* Grab the start expressions from the array ref and
7069 : copy them into actual arguments. */
7070 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7071 : {
7072 48 : arg = gfc_get_actual_arglist ();
7073 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7074 48 : if (e->value.function.actual == NULL)
7075 36 : tail = e->value.function.actual = arg;
7076 : else
7077 : {
7078 12 : tail->next = arg;
7079 12 : tail = arg;
7080 : }
7081 : }
7082 :
7083 : /* Dump the reference list and set the rank. */
7084 36 : gfc_free_ref_list (e->ref);
7085 36 : e->ref = NULL;
7086 36 : e->rank = sym->as ? sym->as->rank : 0;
7087 36 : e->corank = sym->as ? sym->as->corank : 0;
7088 : }
7089 :
7090 66 : gfc_resolve_expr (e);
7091 66 : sym->refs++;
7092 : }
7093 : /* This case corresponds to a call, from a block or a contained
7094 : procedure, to an external function, which has not been declared
7095 : as being external in the main program but has been typed. */
7096 90445 : else if (sym && old_sym != sym
7097 596 : && !e->ref
7098 328 : && sym->ts.type == BT_UNKNOWN
7099 21 : && old_sym->ts.type != BT_UNKNOWN
7100 19 : && sym->attr.flavor == FL_PROCEDURE
7101 19 : && old_sym->attr.flavor == FL_VARIABLE
7102 7 : && sym->ns->parent == old_sym->ns
7103 7 : && sym->ns->proc_name
7104 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7105 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7106 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7107 : {
7108 6 : old_sym->attr.flavor = FL_PROCEDURE;
7109 6 : old_sym->attr.external = 1;
7110 6 : old_sym->attr.function = 1;
7111 6 : old_sym->result = old_sym;
7112 6 : gfc_resolve_expr (e);
7113 : }
7114 : }
7115 : /* This might have changed! */
7116 1659467 : return e->expr_type == EXPR_FUNCTION;
7117 : }
7118 :
7119 :
7120 : static void
7121 1441 : gfc_resolve_character_operator (gfc_expr *e)
7122 : {
7123 1441 : gfc_expr *op1 = e->value.op.op1;
7124 1441 : gfc_expr *op2 = e->value.op.op2;
7125 1441 : gfc_expr *e1 = NULL;
7126 1441 : gfc_expr *e2 = NULL;
7127 :
7128 1441 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7129 :
7130 1441 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7131 761 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7132 680 : else if (op1->expr_type == EXPR_CONSTANT)
7133 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7134 268 : op1->value.character.length);
7135 :
7136 1441 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7137 749 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7138 692 : else if (op2->expr_type == EXPR_CONSTANT)
7139 461 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7140 461 : op2->value.character.length);
7141 :
7142 1441 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7143 :
7144 1441 : if (!e1 || !e2)
7145 : {
7146 540 : gfc_free_expr (e1);
7147 540 : gfc_free_expr (e2);
7148 :
7149 540 : return;
7150 : }
7151 :
7152 901 : e->ts.u.cl->length = gfc_add (e1, e2);
7153 901 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7154 901 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7155 901 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7156 901 : gfc_resolve_expr (e->ts.u.cl->length);
7157 :
7158 901 : return;
7159 : }
7160 :
7161 :
7162 : /* Ensure that an character expression has a charlen and, if possible, a
7163 : length expression. */
7164 :
7165 : static void
7166 180027 : fixup_charlen (gfc_expr *e)
7167 : {
7168 : /* The cases fall through so that changes in expression type and the need
7169 : for multiple fixes are picked up. In all circumstances, a charlen should
7170 : be available for the middle end to hang a backend_decl on. */
7171 180027 : switch (e->expr_type)
7172 : {
7173 1441 : case EXPR_OP:
7174 1441 : gfc_resolve_character_operator (e);
7175 : /* FALLTHRU */
7176 :
7177 1508 : case EXPR_ARRAY:
7178 1508 : if (e->expr_type == EXPR_ARRAY)
7179 67 : gfc_resolve_character_array_constructor (e);
7180 : /* FALLTHRU */
7181 :
7182 1965 : case EXPR_SUBSTRING:
7183 1965 : if (!e->ts.u.cl && e->ref)
7184 453 : gfc_resolve_substring_charlen (e);
7185 : /* FALLTHRU */
7186 :
7187 180027 : default:
7188 180027 : if (!e->ts.u.cl)
7189 178066 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7190 :
7191 180027 : break;
7192 : }
7193 180027 : }
7194 :
7195 :
7196 : /* Update an actual argument to include the passed-object for type-bound
7197 : procedures at the right position. */
7198 :
7199 : static gfc_actual_arglist*
7200 2950 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7201 : const char *name)
7202 : {
7203 2974 : gcc_assert (argpos > 0);
7204 :
7205 2974 : if (argpos == 1)
7206 : {
7207 2825 : gfc_actual_arglist* result;
7208 :
7209 2825 : result = gfc_get_actual_arglist ();
7210 2825 : result->expr = po;
7211 2825 : result->next = lst;
7212 2825 : if (name)
7213 514 : result->name = name;
7214 :
7215 2825 : return result;
7216 : }
7217 :
7218 149 : if (lst)
7219 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7220 : else
7221 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7222 : return lst;
7223 : }
7224 :
7225 :
7226 : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7227 :
7228 : static gfc_expr*
7229 7166 : extract_compcall_passed_object (gfc_expr* e)
7230 : {
7231 7166 : gfc_expr* po;
7232 :
7233 7166 : if (e->expr_type == EXPR_UNKNOWN)
7234 : {
7235 0 : gfc_error ("Error in typebound call at %L",
7236 : &e->where);
7237 0 : return NULL;
7238 : }
7239 :
7240 7166 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7241 :
7242 7166 : if (e->value.compcall.base_object)
7243 1572 : po = gfc_copy_expr (e->value.compcall.base_object);
7244 : else
7245 : {
7246 5594 : po = gfc_get_expr ();
7247 5594 : po->expr_type = EXPR_VARIABLE;
7248 5594 : po->symtree = e->symtree;
7249 5594 : po->ref = gfc_copy_ref (e->ref);
7250 5594 : po->where = e->where;
7251 : }
7252 :
7253 7166 : if (!gfc_resolve_expr (po))
7254 : return NULL;
7255 :
7256 : return po;
7257 : }
7258 :
7259 :
7260 : /* Update the arglist of an EXPR_COMPCALL expression to include the
7261 : passed-object. */
7262 :
7263 : static bool
7264 3303 : update_compcall_arglist (gfc_expr* e)
7265 : {
7266 3303 : gfc_expr* po;
7267 3303 : gfc_typebound_proc* tbp;
7268 :
7269 3303 : tbp = e->value.compcall.tbp;
7270 :
7271 3303 : if (tbp->error)
7272 : return false;
7273 :
7274 3302 : po = extract_compcall_passed_object (e);
7275 3302 : if (!po)
7276 : return false;
7277 :
7278 3302 : if (tbp->nopass || e->value.compcall.ignore_pass)
7279 : {
7280 1110 : gfc_free_expr (po);
7281 1110 : return true;
7282 : }
7283 :
7284 2192 : if (tbp->pass_arg_num <= 0)
7285 : return false;
7286 :
7287 2191 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7288 : tbp->pass_arg_num,
7289 : tbp->pass_arg);
7290 :
7291 2191 : return true;
7292 : }
7293 :
7294 :
7295 : /* Extract the passed object from a PPC call (a copy of it). */
7296 :
7297 : static gfc_expr*
7298 85 : extract_ppc_passed_object (gfc_expr *e)
7299 : {
7300 85 : gfc_expr *po;
7301 85 : gfc_ref **ref;
7302 :
7303 85 : po = gfc_get_expr ();
7304 85 : po->expr_type = EXPR_VARIABLE;
7305 85 : po->symtree = e->symtree;
7306 85 : po->ref = gfc_copy_ref (e->ref);
7307 85 : po->where = e->where;
7308 :
7309 : /* Remove PPC reference. */
7310 85 : ref = &po->ref;
7311 91 : while ((*ref)->next)
7312 6 : ref = &(*ref)->next;
7313 85 : gfc_free_ref_list (*ref);
7314 85 : *ref = NULL;
7315 :
7316 85 : if (!gfc_resolve_expr (po))
7317 0 : return NULL;
7318 :
7319 : return po;
7320 : }
7321 :
7322 :
7323 : /* Update the actual arglist of a procedure pointer component to include the
7324 : passed-object. */
7325 :
7326 : static bool
7327 574 : update_ppc_arglist (gfc_expr* e)
7328 : {
7329 574 : gfc_expr* po;
7330 574 : gfc_component *ppc;
7331 574 : gfc_typebound_proc* tb;
7332 :
7333 574 : ppc = gfc_get_proc_ptr_comp (e);
7334 574 : if (!ppc)
7335 : return false;
7336 :
7337 574 : tb = ppc->tb;
7338 :
7339 574 : if (tb->error)
7340 : return false;
7341 572 : else if (tb->nopass)
7342 : return true;
7343 :
7344 85 : po = extract_ppc_passed_object (e);
7345 85 : if (!po)
7346 : return false;
7347 :
7348 : /* F08:R739. */
7349 85 : if (po->rank != 0)
7350 : {
7351 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7352 0 : return false;
7353 : }
7354 :
7355 : /* F08:C611. */
7356 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7357 : {
7358 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7359 : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7360 1 : return false;
7361 : }
7362 :
7363 84 : gcc_assert (tb->pass_arg_num > 0);
7364 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7365 : tb->pass_arg_num,
7366 : tb->pass_arg);
7367 :
7368 84 : return true;
7369 : }
7370 :
7371 :
7372 : /* Check that the object a TBP is called on is valid, i.e. it must not be
7373 : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7374 :
7375 : static bool
7376 3314 : check_typebound_baseobject (gfc_expr* e)
7377 : {
7378 3314 : gfc_expr* base;
7379 3314 : bool return_value = false;
7380 :
7381 3314 : base = extract_compcall_passed_object (e);
7382 3314 : if (!base)
7383 : return false;
7384 :
7385 3311 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7386 : {
7387 1 : gfc_error ("Error in typebound call at %L", &e->where);
7388 1 : goto cleanup;
7389 : }
7390 :
7391 3310 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7392 1 : return false;
7393 :
7394 : /* F08:C611. */
7395 3309 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7396 : {
7397 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7398 : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7399 3 : goto cleanup;
7400 : }
7401 :
7402 : /* F08:C1230. If the procedure called is NOPASS,
7403 : the base object must be scalar. */
7404 3306 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7405 : {
7406 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7407 : " be scalar", &e->where);
7408 1 : goto cleanup;
7409 : }
7410 :
7411 : return_value = true;
7412 :
7413 3310 : cleanup:
7414 3310 : gfc_free_expr (base);
7415 3310 : return return_value;
7416 : }
7417 :
7418 :
7419 : /* Resolve a call to a type-bound procedure, either function or subroutine,
7420 : statically from the data in an EXPR_COMPCALL expression. The adapted
7421 : arglist and the target-procedure symtree are returned. */
7422 :
7423 : static bool
7424 3303 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7425 : gfc_actual_arglist** actual)
7426 : {
7427 3303 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7428 3303 : gcc_assert (!e->value.compcall.tbp->is_generic);
7429 :
7430 : /* Update the actual arglist for PASS. */
7431 3303 : if (!update_compcall_arglist (e))
7432 : return false;
7433 :
7434 3301 : *actual = e->value.compcall.actual;
7435 3301 : *target = e->value.compcall.tbp->u.specific;
7436 :
7437 3301 : gfc_free_ref_list (e->ref);
7438 3301 : e->ref = NULL;
7439 3301 : e->value.compcall.actual = NULL;
7440 :
7441 : /* If we find a deferred typebound procedure, check for derived types
7442 : that an overriding typebound procedure has not been missed. */
7443 3301 : if (e->value.compcall.name
7444 3301 : && !e->value.compcall.tbp->non_overridable
7445 3283 : && e->value.compcall.base_object
7446 786 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7447 : {
7448 499 : gfc_symtree *st;
7449 499 : gfc_symbol *derived;
7450 :
7451 : /* Use the derived type of the base_object. */
7452 499 : derived = e->value.compcall.base_object->ts.u.derived;
7453 499 : st = NULL;
7454 :
7455 : /* If necessary, go through the inheritance chain. */
7456 1505 : while (!st && derived)
7457 : {
7458 : /* Look for the typebound procedure 'name'. */
7459 507 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7460 499 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7461 : e->value.compcall.name);
7462 507 : if (!st)
7463 8 : derived = gfc_get_derived_super_type (derived);
7464 : }
7465 :
7466 : /* Now find the specific name in the derived type namespace. */
7467 499 : if (st && st->n.tb && st->n.tb->u.specific)
7468 499 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7469 499 : derived->ns, 1, &st);
7470 499 : if (st)
7471 499 : *target = st;
7472 : }
7473 :
7474 3301 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7475 3301 : && !e->value.compcall.tbp->deferred)
7476 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7477 : " itself recursively. Declare it RECURSIVE or use"
7478 : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7479 :
7480 : return true;
7481 : }
7482 :
7483 :
7484 : /* Get the ultimate declared type from an expression. In addition,
7485 : return the last class/derived type reference and the copy of the
7486 : reference list. If check_types is set true, derived types are
7487 : identified as well as class references. */
7488 : static gfc_symbol*
7489 3245 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7490 : gfc_expr *e, bool check_types)
7491 : {
7492 3245 : gfc_symbol *declared;
7493 3245 : gfc_ref *ref;
7494 :
7495 3245 : declared = NULL;
7496 3245 : if (class_ref)
7497 2837 : *class_ref = NULL;
7498 3245 : if (new_ref)
7499 2550 : *new_ref = gfc_copy_ref (e->ref);
7500 :
7501 4034 : for (ref = e->ref; ref; ref = ref->next)
7502 : {
7503 789 : if (ref->type != REF_COMPONENT)
7504 286 : continue;
7505 :
7506 503 : if ((ref->u.c.component->ts.type == BT_CLASS
7507 256 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7508 428 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7509 : {
7510 354 : declared = ref->u.c.component->ts.u.derived;
7511 354 : if (class_ref)
7512 332 : *class_ref = ref;
7513 : }
7514 : }
7515 :
7516 3245 : if (declared == NULL)
7517 2917 : declared = e->symtree->n.sym->ts.u.derived;
7518 :
7519 3245 : return declared;
7520 : }
7521 :
7522 :
7523 : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7524 : which of the specific bindings (if any) matches the arglist and transform
7525 : the expression into a call of that binding. */
7526 :
7527 : static bool
7528 3305 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7529 : {
7530 3305 : gfc_typebound_proc* genproc;
7531 3305 : const char* genname;
7532 3305 : gfc_symtree *st;
7533 3305 : gfc_symbol *derived;
7534 :
7535 3305 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7536 3305 : genname = e->value.compcall.name;
7537 3305 : genproc = e->value.compcall.tbp;
7538 :
7539 3305 : if (!genproc->is_generic)
7540 : return true;
7541 :
7542 : /* Try the bindings on this type and in the inheritance hierarchy. */
7543 420 : for (; genproc; genproc = genproc->overridden)
7544 : {
7545 418 : gfc_tbp_generic* g;
7546 :
7547 418 : gcc_assert (genproc->is_generic);
7548 646 : for (g = genproc->u.generic; g; g = g->next)
7549 : {
7550 636 : gfc_symbol* target;
7551 636 : gfc_actual_arglist* args;
7552 636 : bool matches;
7553 :
7554 636 : gcc_assert (g->specific);
7555 :
7556 636 : if (g->specific->error)
7557 0 : continue;
7558 :
7559 636 : target = g->specific->u.specific->n.sym;
7560 :
7561 : /* Get the right arglist by handling PASS/NOPASS. */
7562 636 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7563 636 : if (!g->specific->nopass)
7564 : {
7565 550 : gfc_expr* po;
7566 550 : po = extract_compcall_passed_object (e);
7567 550 : if (!po)
7568 : {
7569 0 : gfc_free_actual_arglist (args);
7570 0 : return false;
7571 : }
7572 :
7573 550 : gcc_assert (g->specific->pass_arg_num > 0);
7574 550 : gcc_assert (!g->specific->error);
7575 550 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7576 : g->specific->pass_arg);
7577 : }
7578 636 : resolve_actual_arglist (args, target->attr.proc,
7579 636 : is_external_proc (target)
7580 636 : && gfc_sym_get_dummy_args (target) == NULL);
7581 :
7582 : /* Check if this arglist matches the formal. */
7583 636 : matches = gfc_arglist_matches_symbol (&args, target);
7584 :
7585 : /* Clean up and break out of the loop if we've found it. */
7586 636 : gfc_free_actual_arglist (args);
7587 636 : if (matches)
7588 : {
7589 408 : e->value.compcall.tbp = g->specific;
7590 408 : genname = g->specific_st->name;
7591 : /* Pass along the name for CLASS methods, where the vtab
7592 : procedure pointer component has to be referenced. */
7593 408 : if (name)
7594 161 : *name = genname;
7595 408 : goto success;
7596 : }
7597 : }
7598 : }
7599 :
7600 : /* Nothing matching found! */
7601 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7602 : " %qs at %L", genname, &e->where);
7603 2 : return false;
7604 :
7605 408 : success:
7606 : /* Make sure that we have the right specific instance for the name. */
7607 408 : derived = get_declared_from_expr (NULL, NULL, e, true);
7608 :
7609 408 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7610 408 : if (st)
7611 408 : e->value.compcall.tbp = st->n.tb;
7612 :
7613 : return true;
7614 : }
7615 :
7616 :
7617 : /* Resolve a call to a type-bound subroutine. */
7618 :
7619 : static bool
7620 1706 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7621 : {
7622 1706 : gfc_actual_arglist* newactual;
7623 1706 : gfc_symtree* target;
7624 :
7625 : /* Check that's really a SUBROUTINE. */
7626 1706 : if (!c->expr1->value.compcall.tbp->subroutine)
7627 : {
7628 17 : if (!c->expr1->value.compcall.tbp->is_generic
7629 15 : && c->expr1->value.compcall.tbp->u.specific
7630 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7631 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7632 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7633 : else
7634 : {
7635 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7636 : c->expr1->value.compcall.name, &c->loc);
7637 5 : return false;
7638 : }
7639 : }
7640 :
7641 1701 : if (!check_typebound_baseobject (c->expr1))
7642 : return false;
7643 :
7644 : /* Pass along the name for CLASS methods, where the vtab
7645 : procedure pointer component has to be referenced. */
7646 1694 : if (name)
7647 474 : *name = c->expr1->value.compcall.name;
7648 :
7649 1694 : if (!resolve_typebound_generic_call (c->expr1, name))
7650 : return false;
7651 :
7652 : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7653 1693 : if (overridable)
7654 371 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7655 :
7656 : /* Transform into an ordinary EXEC_CALL for now. */
7657 :
7658 1693 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7659 : return false;
7660 :
7661 1691 : c->ext.actual = newactual;
7662 1691 : c->symtree = target;
7663 1691 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7664 :
7665 1691 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7666 :
7667 1691 : gfc_free_expr (c->expr1);
7668 1691 : c->expr1 = gfc_get_expr ();
7669 1691 : c->expr1->expr_type = EXPR_FUNCTION;
7670 1691 : c->expr1->symtree = target;
7671 1691 : c->expr1->where = c->loc;
7672 :
7673 1691 : return resolve_call (c);
7674 : }
7675 :
7676 :
7677 : /* Resolve a component-call expression. */
7678 : static bool
7679 1632 : resolve_compcall (gfc_expr* e, const char **name)
7680 : {
7681 1632 : gfc_actual_arglist* newactual;
7682 1632 : gfc_symtree* target;
7683 :
7684 : /* Check that's really a FUNCTION. */
7685 1632 : if (!e->value.compcall.tbp->function)
7686 : {
7687 19 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7688 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7689 : &e->where);
7690 19 : return false;
7691 : }
7692 :
7693 :
7694 : /* These must not be assign-calls! */
7695 1613 : gcc_assert (!e->value.compcall.assign);
7696 :
7697 1613 : if (!check_typebound_baseobject (e))
7698 : return false;
7699 :
7700 : /* Pass along the name for CLASS methods, where the vtab
7701 : procedure pointer component has to be referenced. */
7702 1611 : if (name)
7703 864 : *name = e->value.compcall.name;
7704 :
7705 1611 : if (!resolve_typebound_generic_call (e, name))
7706 : return false;
7707 1610 : gcc_assert (!e->value.compcall.tbp->is_generic);
7708 :
7709 : /* Take the rank from the function's symbol. */
7710 1610 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7711 : {
7712 155 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7713 155 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7714 : }
7715 :
7716 : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7717 : arglist to the TBP's binding target. */
7718 :
7719 1610 : if (!resolve_typebound_static (e, &target, &newactual))
7720 : return false;
7721 :
7722 1610 : e->value.function.actual = newactual;
7723 1610 : e->value.function.name = NULL;
7724 1610 : e->value.function.esym = target->n.sym;
7725 1610 : e->value.function.isym = NULL;
7726 1610 : e->symtree = target;
7727 1610 : e->ts = target->n.sym->ts;
7728 1610 : e->expr_type = EXPR_FUNCTION;
7729 :
7730 : /* Resolution is not necessary if this is a class subroutine; this
7731 : function only has to identify the specific proc. Resolution of
7732 : the call will be done next in resolve_typebound_call. */
7733 1610 : return gfc_resolve_expr (e);
7734 : }
7735 :
7736 :
7737 : static bool resolve_fl_derived (gfc_symbol *sym);
7738 :
7739 :
7740 : /* Resolve a typebound function, or 'method'. First separate all
7741 : the non-CLASS references by calling resolve_compcall directly. */
7742 :
7743 : static bool
7744 1632 : resolve_typebound_function (gfc_expr* e)
7745 : {
7746 1632 : gfc_symbol *declared;
7747 1632 : gfc_component *c;
7748 1632 : gfc_ref *new_ref;
7749 1632 : gfc_ref *class_ref;
7750 1632 : gfc_symtree *st;
7751 1632 : const char *name;
7752 1632 : gfc_typespec ts;
7753 1632 : gfc_expr *expr;
7754 1632 : bool overridable;
7755 :
7756 1632 : st = e->symtree;
7757 :
7758 : /* Deal with typebound operators for CLASS objects. */
7759 1632 : expr = e->value.compcall.base_object;
7760 1632 : overridable = !e->value.compcall.tbp->non_overridable;
7761 1632 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7762 : {
7763 : /* Since the typebound operators are generic, we have to ensure
7764 : that any delays in resolution are corrected and that the vtab
7765 : is present. */
7766 184 : ts = expr->ts;
7767 184 : declared = ts.u.derived;
7768 184 : if (!resolve_fl_derived (declared))
7769 : return false;
7770 :
7771 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7772 184 : if (c->ts.u.derived == NULL)
7773 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7774 :
7775 184 : if (!resolve_compcall (e, &name))
7776 : return false;
7777 :
7778 : /* Use the generic name if it is there. */
7779 184 : name = name ? name : e->value.function.esym->name;
7780 184 : e->symtree = expr->symtree;
7781 184 : e->ref = gfc_copy_ref (expr->ref);
7782 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7783 :
7784 : /* Trim away the extraneous references that emerge from nested
7785 : use of interface.cc (extend_expr). */
7786 184 : if (class_ref && class_ref->next)
7787 : {
7788 0 : gfc_free_ref_list (class_ref->next);
7789 0 : class_ref->next = NULL;
7790 : }
7791 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7792 : {
7793 0 : gfc_free_ref_list (e->ref);
7794 0 : e->ref = NULL;
7795 : }
7796 :
7797 184 : gfc_add_vptr_component (e);
7798 184 : gfc_add_component_ref (e, name);
7799 184 : e->value.function.esym = NULL;
7800 184 : if (expr->expr_type != EXPR_VARIABLE)
7801 80 : e->base_expr = expr;
7802 184 : return true;
7803 : }
7804 :
7805 1448 : if (st == NULL)
7806 159 : return resolve_compcall (e, NULL);
7807 :
7808 1289 : if (!gfc_resolve_ref (e))
7809 : return false;
7810 :
7811 : /* It can happen that a generic, typebound procedure is marked as overridable
7812 : with all of the specific procedures being non-overridable. If this is the
7813 : case, it is safe to resolve the compcall. */
7814 1289 : if (!expr && overridable
7815 1281 : && e->value.compcall.tbp->is_generic
7816 186 : && e->value.compcall.tbp->u.generic->specific
7817 185 : && e->value.compcall.tbp->u.generic->specific->non_overridable)
7818 : {
7819 : gfc_tbp_generic *g = e->value.compcall.tbp->u.generic;
7820 6 : for (; g; g = g->next)
7821 4 : if (!g->specific->non_overridable)
7822 : break;
7823 2 : if (g == NULL && resolve_compcall (e, &name))
7824 : return true;
7825 : }
7826 :
7827 : /* Get the CLASS declared type. */
7828 1287 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
7829 :
7830 1287 : if (!resolve_fl_derived (declared))
7831 : return false;
7832 :
7833 : /* Weed out cases of the ultimate component being a derived type. */
7834 1287 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7835 1193 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7836 : {
7837 595 : gfc_free_ref_list (new_ref);
7838 595 : return resolve_compcall (e, NULL);
7839 : }
7840 :
7841 692 : c = gfc_find_component (declared, "_data", true, true, NULL);
7842 :
7843 : /* Treat the call as if it is a typebound procedure, in order to roll
7844 : out the correct name for the specific function. */
7845 692 : if (!resolve_compcall (e, &name))
7846 : {
7847 15 : gfc_free_ref_list (new_ref);
7848 15 : return false;
7849 : }
7850 677 : ts = e->ts;
7851 :
7852 677 : if (overridable)
7853 : {
7854 : /* Convert the expression to a procedure pointer component call. */
7855 675 : e->value.function.esym = NULL;
7856 675 : e->symtree = st;
7857 :
7858 675 : if (new_ref)
7859 125 : e->ref = new_ref;
7860 :
7861 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7862 675 : gfc_add_vptr_component (e);
7863 675 : gfc_add_component_ref (e, name);
7864 :
7865 : /* Recover the typespec for the expression. This is really only
7866 : necessary for generic procedures, where the additional call
7867 : to gfc_add_component_ref seems to throw the collection of the
7868 : correct typespec. */
7869 675 : e->ts = ts;
7870 : }
7871 2 : else if (new_ref)
7872 0 : gfc_free_ref_list (new_ref);
7873 :
7874 : return true;
7875 : }
7876 :
7877 : /* Resolve a typebound subroutine, or 'method'. First separate all
7878 : the non-CLASS references by calling resolve_typebound_call
7879 : directly. */
7880 :
7881 : static bool
7882 1706 : resolve_typebound_subroutine (gfc_code *code)
7883 : {
7884 1706 : gfc_symbol *declared;
7885 1706 : gfc_component *c;
7886 1706 : gfc_ref *new_ref;
7887 1706 : gfc_ref *class_ref;
7888 1706 : gfc_symtree *st;
7889 1706 : const char *name;
7890 1706 : gfc_typespec ts;
7891 1706 : gfc_expr *expr;
7892 1706 : bool overridable;
7893 :
7894 1706 : st = code->expr1->symtree;
7895 :
7896 : /* Deal with typebound operators for CLASS objects. */
7897 1706 : expr = code->expr1->value.compcall.base_object;
7898 1706 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
7899 1706 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7900 : {
7901 : /* If the base_object is not a variable, the corresponding actual
7902 : argument expression must be stored in e->base_expression so
7903 : that the corresponding tree temporary can be used as the base
7904 : object in gfc_conv_procedure_call. */
7905 103 : if (expr->expr_type != EXPR_VARIABLE)
7906 : {
7907 : gfc_actual_arglist *args;
7908 :
7909 : args= code->expr1->value.function.actual;
7910 : for (; args; args = args->next)
7911 : if (expr == args->expr)
7912 : expr = args->expr;
7913 : }
7914 :
7915 : /* Since the typebound operators are generic, we have to ensure
7916 : that any delays in resolution are corrected and that the vtab
7917 : is present. */
7918 103 : declared = expr->ts.u.derived;
7919 103 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7920 103 : if (c->ts.u.derived == NULL)
7921 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7922 :
7923 103 : if (!resolve_typebound_call (code, &name, NULL))
7924 : return false;
7925 :
7926 : /* Use the generic name if it is there. */
7927 103 : name = name ? name : code->expr1->value.function.esym->name;
7928 103 : code->expr1->symtree = expr->symtree;
7929 103 : code->expr1->ref = gfc_copy_ref (expr->ref);
7930 :
7931 : /* Trim away the extraneous references that emerge from nested
7932 : use of interface.cc (extend_expr). */
7933 103 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
7934 103 : if (class_ref && class_ref->next)
7935 : {
7936 0 : gfc_free_ref_list (class_ref->next);
7937 0 : class_ref->next = NULL;
7938 : }
7939 103 : else if (code->expr1->ref && !class_ref)
7940 : {
7941 12 : gfc_free_ref_list (code->expr1->ref);
7942 12 : code->expr1->ref = NULL;
7943 : }
7944 :
7945 : /* Now use the procedure in the vtable. */
7946 103 : gfc_add_vptr_component (code->expr1);
7947 103 : gfc_add_component_ref (code->expr1, name);
7948 103 : code->expr1->value.function.esym = NULL;
7949 103 : if (expr->expr_type != EXPR_VARIABLE)
7950 0 : code->expr1->base_expr = expr;
7951 103 : return true;
7952 : }
7953 :
7954 1603 : if (st == NULL)
7955 340 : return resolve_typebound_call (code, NULL, NULL);
7956 :
7957 1263 : if (!gfc_resolve_ref (code->expr1))
7958 : return false;
7959 :
7960 : /* Get the CLASS declared type. */
7961 1263 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
7962 :
7963 : /* Weed out cases of the ultimate component being a derived type. */
7964 1263 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7965 1198 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7966 : {
7967 887 : gfc_free_ref_list (new_ref);
7968 887 : return resolve_typebound_call (code, NULL, NULL);
7969 : }
7970 :
7971 376 : if (!resolve_typebound_call (code, &name, &overridable))
7972 : {
7973 5 : gfc_free_ref_list (new_ref);
7974 5 : return false;
7975 : }
7976 371 : ts = code->expr1->ts;
7977 :
7978 371 : if (overridable)
7979 : {
7980 : /* Convert the expression to a procedure pointer component call. */
7981 369 : code->expr1->value.function.esym = NULL;
7982 369 : code->expr1->symtree = st;
7983 :
7984 369 : if (new_ref)
7985 93 : code->expr1->ref = new_ref;
7986 :
7987 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7988 369 : gfc_add_vptr_component (code->expr1);
7989 369 : gfc_add_component_ref (code->expr1, name);
7990 :
7991 : /* Recover the typespec for the expression. This is really only
7992 : necessary for generic procedures, where the additional call
7993 : to gfc_add_component_ref seems to throw the collection of the
7994 : correct typespec. */
7995 369 : code->expr1->ts = ts;
7996 : }
7997 2 : else if (new_ref)
7998 0 : gfc_free_ref_list (new_ref);
7999 :
8000 : return true;
8001 : }
8002 :
8003 :
8004 : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8005 :
8006 : static bool
8007 124 : resolve_ppc_call (gfc_code* c)
8008 : {
8009 124 : gfc_component *comp;
8010 :
8011 124 : comp = gfc_get_proc_ptr_comp (c->expr1);
8012 124 : gcc_assert (comp != NULL);
8013 :
8014 124 : c->resolved_sym = c->expr1->symtree->n.sym;
8015 124 : c->expr1->expr_type = EXPR_VARIABLE;
8016 :
8017 124 : if (!comp->attr.subroutine)
8018 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8019 :
8020 124 : if (!gfc_resolve_ref (c->expr1))
8021 : return false;
8022 :
8023 124 : if (!update_ppc_arglist (c->expr1))
8024 : return false;
8025 :
8026 123 : c->ext.actual = c->expr1->value.compcall.actual;
8027 :
8028 123 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8029 123 : !(comp->ts.interface
8030 93 : && comp->ts.interface->formal)))
8031 : return false;
8032 :
8033 123 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8034 : return false;
8035 :
8036 122 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8037 :
8038 122 : return true;
8039 : }
8040 :
8041 :
8042 : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8043 :
8044 : static bool
8045 450 : resolve_expr_ppc (gfc_expr* e)
8046 : {
8047 450 : gfc_component *comp;
8048 :
8049 450 : comp = gfc_get_proc_ptr_comp (e);
8050 450 : gcc_assert (comp != NULL);
8051 :
8052 : /* Convert to EXPR_FUNCTION. */
8053 450 : e->expr_type = EXPR_FUNCTION;
8054 450 : e->value.function.isym = NULL;
8055 450 : e->value.function.actual = e->value.compcall.actual;
8056 450 : e->ts = comp->ts;
8057 450 : if (comp->as != NULL)
8058 : {
8059 28 : e->rank = comp->as->rank;
8060 28 : e->corank = comp->as->corank;
8061 : }
8062 :
8063 450 : if (!comp->attr.function)
8064 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8065 :
8066 450 : if (!gfc_resolve_ref (e))
8067 : return false;
8068 :
8069 450 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8070 450 : !(comp->ts.interface
8071 449 : && comp->ts.interface->formal)))
8072 : return false;
8073 :
8074 450 : if (!update_ppc_arglist (e))
8075 : return false;
8076 :
8077 448 : if (!check_pure_function(e))
8078 : return false;
8079 :
8080 447 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8081 :
8082 447 : return true;
8083 : }
8084 :
8085 :
8086 : static bool
8087 11367 : gfc_is_expandable_expr (gfc_expr *e)
8088 : {
8089 11367 : gfc_constructor *con;
8090 :
8091 11367 : if (e->expr_type == EXPR_ARRAY)
8092 : {
8093 : /* Traverse the constructor looking for variables that are flavor
8094 : parameter. Parameters must be expanded since they are fully used at
8095 : compile time. */
8096 11367 : con = gfc_constructor_first (e->value.constructor);
8097 30125 : for (; con; con = gfc_constructor_next (con))
8098 : {
8099 13272 : if (con->expr->expr_type == EXPR_VARIABLE
8100 5157 : && con->expr->symtree
8101 5157 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8102 5075 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8103 : return true;
8104 8115 : if (con->expr->expr_type == EXPR_ARRAY
8105 8115 : && gfc_is_expandable_expr (con->expr))
8106 : return true;
8107 : }
8108 : }
8109 :
8110 : return false;
8111 : }
8112 :
8113 :
8114 : /* Sometimes variables in specification expressions of the result
8115 : of module procedures in submodules wind up not being the 'real'
8116 : dummy. Find this, if possible, in the namespace of the first
8117 : formal argument. */
8118 :
8119 : static void
8120 3441 : fixup_unique_dummy (gfc_expr *e)
8121 : {
8122 3441 : gfc_symtree *st = NULL;
8123 3441 : gfc_symbol *s = NULL;
8124 :
8125 3441 : if (e->symtree->n.sym->ns->proc_name
8126 3411 : && e->symtree->n.sym->ns->proc_name->formal)
8127 3411 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8128 :
8129 3411 : if (s != NULL)
8130 3411 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8131 :
8132 3441 : if (st != NULL
8133 14 : && st->n.sym != NULL
8134 14 : && st->n.sym->attr.dummy)
8135 14 : e->symtree = st;
8136 3441 : }
8137 :
8138 :
8139 : /* Resolve an expression. That is, make sure that types of operands agree
8140 : with their operators, intrinsic operators are converted to function calls
8141 : for overloaded types and unresolved function references are resolved. */
8142 :
8143 : bool
8144 7097634 : gfc_resolve_expr (gfc_expr *e)
8145 : {
8146 7097634 : bool t;
8147 7097634 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8148 :
8149 7097634 : if (e == NULL || e->do_not_resolve_again)
8150 : return true;
8151 :
8152 : /* inquiry_argument only applies to variables. */
8153 5190427 : inquiry_save = inquiry_argument;
8154 5190427 : actual_arg_save = actual_arg;
8155 5190427 : first_actual_arg_save = first_actual_arg;
8156 :
8157 5190427 : if (e->expr_type != EXPR_VARIABLE)
8158 : {
8159 3871387 : inquiry_argument = false;
8160 3871387 : actual_arg = false;
8161 3871387 : first_actual_arg = false;
8162 : }
8163 1319040 : else if (e->symtree != NULL
8164 1318595 : && *e->symtree->name == '@'
8165 4148 : && e->symtree->n.sym->attr.dummy)
8166 : {
8167 : /* Deal with submodule specification expressions that are not
8168 : found to be referenced in module.cc(read_cleanup). */
8169 3441 : fixup_unique_dummy (e);
8170 : }
8171 :
8172 5190427 : switch (e->expr_type)
8173 : {
8174 530368 : case EXPR_OP:
8175 530368 : t = resolve_operator (e);
8176 530368 : break;
8177 :
8178 150 : case EXPR_CONDITIONAL:
8179 150 : t = resolve_conditional (e);
8180 150 : break;
8181 :
8182 1662048 : case EXPR_FUNCTION:
8183 1662048 : case EXPR_VARIABLE:
8184 :
8185 1662048 : if (check_host_association (e))
8186 343044 : t = resolve_function (e);
8187 : else
8188 1319004 : t = resolve_variable (e);
8189 :
8190 1662048 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8191 6911 : && e->ref->type != REF_SUBSTRING)
8192 2162 : gfc_resolve_substring_charlen (e);
8193 :
8194 : break;
8195 :
8196 1632 : case EXPR_COMPCALL:
8197 1632 : t = resolve_typebound_function (e);
8198 1632 : break;
8199 :
8200 508 : case EXPR_SUBSTRING:
8201 508 : t = gfc_resolve_ref (e);
8202 508 : break;
8203 :
8204 : case EXPR_CONSTANT:
8205 : case EXPR_NULL:
8206 : t = true;
8207 : break;
8208 :
8209 450 : case EXPR_PPC:
8210 450 : t = resolve_expr_ppc (e);
8211 450 : break;
8212 :
8213 70991 : case EXPR_ARRAY:
8214 70991 : t = false;
8215 70991 : if (!gfc_resolve_ref (e))
8216 : break;
8217 :
8218 70991 : t = gfc_resolve_array_constructor (e);
8219 : /* Also try to expand a constructor. */
8220 70991 : if (t)
8221 : {
8222 70889 : gfc_expression_rank (e);
8223 70889 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8224 66528 : gfc_expand_constructor (e, false);
8225 : }
8226 :
8227 : /* This provides the opportunity for the length of constructors with
8228 : character valued function elements to propagate the string length
8229 : to the expression. */
8230 70889 : if (t && e->ts.type == BT_CHARACTER)
8231 : {
8232 : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8233 : here rather then add a duplicate test for it above. */
8234 10727 : gfc_expand_constructor (e, false);
8235 10727 : t = gfc_resolve_character_array_constructor (e);
8236 : }
8237 :
8238 : break;
8239 :
8240 16479 : case EXPR_STRUCTURE:
8241 16479 : t = gfc_resolve_ref (e);
8242 16479 : if (!t)
8243 : break;
8244 :
8245 16479 : t = resolve_structure_cons (e, 0);
8246 16479 : if (!t)
8247 : break;
8248 :
8249 16467 : t = gfc_simplify_expr (e, 0);
8250 16467 : break;
8251 :
8252 0 : default:
8253 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8254 : }
8255 :
8256 5190427 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8257 180027 : fixup_charlen (e);
8258 :
8259 5190427 : inquiry_argument = inquiry_save;
8260 5190427 : actual_arg = actual_arg_save;
8261 5190427 : first_actual_arg = first_actual_arg_save;
8262 :
8263 : /* For some reason, resolving these expressions a second time mangles
8264 : the typespec of the expression itself. */
8265 5190427 : if (t && e->expr_type == EXPR_VARIABLE
8266 1316163 : && e->symtree->n.sym->attr.select_rank_temporary
8267 3422 : && UNLIMITED_POLY (e->symtree->n.sym))
8268 83 : e->do_not_resolve_again = 1;
8269 :
8270 5187889 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8271 6919 : t = check_import_status (e);
8272 :
8273 : return t;
8274 : }
8275 :
8276 :
8277 : /* Resolve an expression from an iterator. They must be scalar and have
8278 : INTEGER or (optionally) REAL type. */
8279 :
8280 : static bool
8281 151049 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8282 : const char *name_msgid)
8283 : {
8284 151049 : if (!gfc_resolve_expr (expr))
8285 : return false;
8286 :
8287 151044 : if (expr->rank != 0)
8288 : {
8289 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8290 0 : return false;
8291 : }
8292 :
8293 151044 : if (expr->ts.type != BT_INTEGER)
8294 : {
8295 274 : if (expr->ts.type == BT_REAL)
8296 : {
8297 274 : if (real_ok)
8298 271 : return gfc_notify_std (GFC_STD_F95_DEL,
8299 : "%s at %L must be integer",
8300 271 : _(name_msgid), &expr->where);
8301 : else
8302 : {
8303 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8304 : &expr->where);
8305 3 : return false;
8306 : }
8307 : }
8308 : else
8309 : {
8310 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8311 0 : return false;
8312 : }
8313 : }
8314 : return true;
8315 : }
8316 :
8317 :
8318 : /* Resolve the expressions in an iterator structure. If REAL_OK is
8319 : false allow only INTEGER type iterators, otherwise allow REAL types.
8320 : Set own_scope to true for ac-implied-do and data-implied-do as those
8321 : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8322 :
8323 : bool
8324 37771 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8325 : {
8326 37771 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8327 : return false;
8328 :
8329 37767 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8330 37767 : _("iterator variable")))
8331 : return false;
8332 :
8333 37761 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8334 : "Start expression in DO loop"))
8335 : return false;
8336 :
8337 37760 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8338 : "End expression in DO loop"))
8339 : return false;
8340 :
8341 37757 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8342 : "Step expression in DO loop"))
8343 : return false;
8344 :
8345 : /* Convert start, end, and step to the same type as var. */
8346 37756 : if (iter->start->ts.kind != iter->var->ts.kind
8347 37476 : || iter->start->ts.type != iter->var->ts.type)
8348 315 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8349 :
8350 37756 : if (iter->end->ts.kind != iter->var->ts.kind
8351 37503 : || iter->end->ts.type != iter->var->ts.type)
8352 278 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8353 :
8354 37756 : if (iter->step->ts.kind != iter->var->ts.kind
8355 37512 : || iter->step->ts.type != iter->var->ts.type)
8356 280 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8357 :
8358 37756 : if (iter->step->expr_type == EXPR_CONSTANT)
8359 : {
8360 36634 : if ((iter->step->ts.type == BT_INTEGER
8361 36551 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8362 73183 : || (iter->step->ts.type == BT_REAL
8363 83 : && mpfr_sgn (iter->step->value.real) == 0))
8364 : {
8365 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8366 3 : &iter->step->where);
8367 3 : return false;
8368 : }
8369 : }
8370 :
8371 37753 : if (iter->start->expr_type == EXPR_CONSTANT
8372 34622 : && iter->end->expr_type == EXPR_CONSTANT
8373 27081 : && iter->step->expr_type == EXPR_CONSTANT)
8374 : {
8375 26814 : int sgn, cmp;
8376 26814 : if (iter->start->ts.type == BT_INTEGER)
8377 : {
8378 26760 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8379 26760 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8380 : }
8381 : else
8382 : {
8383 54 : sgn = mpfr_sgn (iter->step->value.real);
8384 54 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8385 : }
8386 26814 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8387 146 : gfc_warning (OPT_Wzerotrip,
8388 : "DO loop at %L will be executed zero times",
8389 146 : &iter->step->where);
8390 : }
8391 :
8392 37753 : if (iter->end->expr_type == EXPR_CONSTANT
8393 27448 : && iter->end->ts.type == BT_INTEGER
8394 27394 : && iter->step->expr_type == EXPR_CONSTANT
8395 27084 : && iter->step->ts.type == BT_INTEGER
8396 27084 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8397 26713 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8398 : {
8399 25928 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8400 25928 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8401 :
8402 25928 : if (is_step_positive
8403 25557 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8404 7 : gfc_warning (OPT_Wundefined_do_loop,
8405 : "DO loop at %L is undefined as it overflows",
8406 7 : &iter->step->where);
8407 : else if (!is_step_positive
8408 371 : && mpz_cmp (iter->end->value.integer,
8409 371 : gfc_integer_kinds[k].min_int) == 0)
8410 7 : gfc_warning (OPT_Wundefined_do_loop,
8411 : "DO loop at %L is undefined as it underflows",
8412 7 : &iter->step->where);
8413 : }
8414 :
8415 : return true;
8416 : }
8417 :
8418 :
8419 : /* Traversal function for find_forall_index. f == 2 signals that
8420 : that variable itself is not to be checked - only the references. */
8421 :
8422 : static bool
8423 42620 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8424 : {
8425 42620 : if (expr->expr_type != EXPR_VARIABLE)
8426 : return false;
8427 :
8428 : /* A scalar assignment */
8429 18188 : if (!expr->ref || *f == 1)
8430 : {
8431 12128 : if (expr->symtree->n.sym == sym)
8432 : return true;
8433 : else
8434 : return false;
8435 : }
8436 :
8437 6060 : if (*f == 2)
8438 1731 : *f = 1;
8439 : return false;
8440 : }
8441 :
8442 :
8443 : /* Check whether the FORALL index appears in the expression or not.
8444 : Returns true if SYM is found in EXPR. */
8445 :
8446 : bool
8447 27001 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8448 : {
8449 27001 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8450 : return true;
8451 : else
8452 : return false;
8453 : }
8454 :
8455 : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8456 : This constraint specifies rules for variables in locality-specs. */
8457 :
8458 : static int
8459 717 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8460 : {
8461 717 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8462 :
8463 717 : if ((*expr)->expr_type == EXPR_VARIABLE)
8464 : {
8465 22 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8466 22 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8467 24 : list; list = list->next)
8468 : {
8469 5 : if (list->expr->symtree->n.sym == sym)
8470 : {
8471 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8472 : "must not appear in LOCAL locality-spec at %L",
8473 : sym->name, &(*expr)->where, &list->expr->where);
8474 3 : *walk_subtrees = 0;
8475 3 : return 1;
8476 : }
8477 : }
8478 : }
8479 :
8480 714 : *walk_subtrees = 1;
8481 714 : return 0;
8482 : }
8483 :
8484 : static int
8485 3969 : check_default_none_expr (gfc_expr **e, int *, void *data)
8486 : {
8487 3969 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8488 :
8489 3969 : if ((*e)->expr_type == EXPR_VARIABLE)
8490 : {
8491 1798 : gfc_symbol *sym = (*e)->symtree->n.sym;
8492 :
8493 1798 : if (d->sym_hash->contains (sym))
8494 1263 : sym->mark = 1;
8495 :
8496 535 : else if (d->default_none)
8497 : {
8498 6 : gfc_namespace *ns2 = d->ns;
8499 10 : while (ns2)
8500 : {
8501 6 : if (ns2 == sym->ns)
8502 : break;
8503 4 : ns2 = ns2->parent;
8504 : }
8505 :
8506 : /* A DO CONCURRENT iterator cannot appear in a locality spec. */
8507 6 : if (sym->ns->code->ext.concur.forall_iterator)
8508 : {
8509 : gfc_forall_iterator *iter
8510 : = sym->ns->code->ext.concur.forall_iterator;
8511 5 : for (; iter; iter = iter->next)
8512 3 : if (iter->var->symtree
8513 1 : && strcmp(sym->name, iter->var->symtree->name) == 0)
8514 1 : return 0;
8515 : }
8516 :
8517 : /* A named constant is not a variable, so skip test. */
8518 5 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8519 : {
8520 1 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8521 : "of DO CONCURRENT at %L but required due to "
8522 : "DEFAULT (NONE)",
8523 1 : sym->name, &(*e)->where, &d->code->loc);
8524 1 : d->sym_hash->add (sym);
8525 : }
8526 : }
8527 : }
8528 : return 0;
8529 : }
8530 :
8531 : static void
8532 210 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8533 : {
8534 210 : struct check_default_none_data data;
8535 210 : data.code = code;
8536 210 : data.sym_hash = new hash_set<gfc_symbol *>;
8537 210 : data.ns = ns;
8538 210 : data.default_none = code->ext.concur.default_none;
8539 :
8540 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8541 : {
8542 840 : const char *name;
8543 840 : switch (locality)
8544 : {
8545 : case LOCALITY_LOCAL: name = "LOCAL"; break;
8546 210 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8547 210 : case LOCALITY_SHARED: name = "SHARED"; break;
8548 210 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8549 : default: gcc_unreachable ();
8550 : }
8551 :
8552 1227 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8553 387 : list = list->next)
8554 : {
8555 387 : gfc_expr *expr = list->expr;
8556 :
8557 387 : if (locality == LOCALITY_REDUCE
8558 72 : && (expr->expr_type == EXPR_FUNCTION
8559 48 : || expr->expr_type == EXPR_OP))
8560 35 : continue;
8561 :
8562 363 : if (!gfc_resolve_expr (expr))
8563 3 : continue;
8564 :
8565 360 : if (expr->expr_type != EXPR_VARIABLE
8566 360 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8567 360 : || (expr->ref
8568 147 : && (expr->ref->type != REF_ARRAY
8569 147 : || expr->ref->u.ar.type != AR_FULL
8570 143 : || expr->ref->next)))
8571 : {
8572 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8573 : name, &expr->where);
8574 4 : continue;
8575 : }
8576 :
8577 356 : gfc_symbol *sym = expr->symtree->n.sym;
8578 :
8579 356 : if (data.sym_hash->contains (sym))
8580 : {
8581 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8582 : "locality-spec", sym->name, &expr->where);
8583 4 : continue;
8584 : }
8585 :
8586 352 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8587 704 : iter; iter = iter->next)
8588 : {
8589 352 : if (iter->var->symtree->n.sym == sym)
8590 : {
8591 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8592 : "locality-spec", sym->name, &expr->where);
8593 1 : continue;
8594 : }
8595 :
8596 351 : data.sym_hash->add (iter->var->symtree->n.sym);
8597 : }
8598 :
8599 352 : if (locality == LOCALITY_LOCAL
8600 352 : || locality == LOCALITY_LOCAL_INIT
8601 352 : || locality == LOCALITY_REDUCE)
8602 : {
8603 198 : if (sym->attr.optional)
8604 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8605 : "locality-spec at %L",
8606 : sym->name, name, &expr->where);
8607 :
8608 198 : if (sym->attr.dimension
8609 66 : && sym->as
8610 66 : && sym->as->type == AS_ASSUMED_SIZE)
8611 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8612 : "locality-spec at %L",
8613 : sym->name, name, &expr->where);
8614 :
8615 198 : gfc_check_vardef_context (expr, false, false, false, name);
8616 : }
8617 :
8618 198 : if (locality == LOCALITY_LOCAL
8619 : || locality == LOCALITY_LOCAL_INIT)
8620 : {
8621 181 : symbol_attribute attr = gfc_expr_attr (expr);
8622 :
8623 181 : if (attr.allocatable)
8624 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8625 : "locality-spec at %L",
8626 : sym->name, name, &expr->where);
8627 :
8628 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8629 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8630 : " for %qs in %s locality-spec at %L",
8631 : sym->name, name, &expr->where);
8632 :
8633 177 : else if (attr.codimension)
8634 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8635 : "at %L",
8636 : sym->name, name, &expr->where);
8637 :
8638 177 : else if (expr->ts.type == BT_DERIVED
8639 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8640 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8641 : "locality-spec at %L",
8642 : sym->name, name, &expr->where);
8643 :
8644 177 : else if (gfc_has_ultimate_allocatable (expr))
8645 4 : gfc_error ("Type with ultimate allocatable component not "
8646 : "permitted for %qs in %s locality-spec at %L",
8647 : sym->name, name, &expr->where);
8648 : }
8649 :
8650 171 : else if (locality == LOCALITY_REDUCE)
8651 : {
8652 17 : if (sym->attr.asynchronous)
8653 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8654 : "REDUCE locality-spec at %L",
8655 : sym->name, &expr->where);
8656 17 : if (sym->attr.volatile_)
8657 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8658 : "locality-spec at %L", sym->name, &expr->where);
8659 : }
8660 :
8661 352 : data.sym_hash->add (sym);
8662 : }
8663 :
8664 840 : if (locality == LOCALITY_LOCAL)
8665 : {
8666 210 : gcc_assert (locality == 0);
8667 :
8668 210 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8669 437 : iter; iter = iter->next)
8670 : {
8671 227 : gfc_expr_walker (&iter->start,
8672 : do_concur_locality_specs_f2023,
8673 : &data);
8674 :
8675 227 : gfc_expr_walker (&iter->end,
8676 : do_concur_locality_specs_f2023,
8677 : &data);
8678 :
8679 227 : gfc_expr_walker (&iter->stride,
8680 : do_concur_locality_specs_f2023,
8681 : &data);
8682 : }
8683 :
8684 210 : if (code->expr1)
8685 7 : gfc_expr_walker (&code->expr1,
8686 : do_concur_locality_specs_f2023,
8687 : &data);
8688 : }
8689 : }
8690 :
8691 210 : gfc_expr *reduce_op = NULL;
8692 :
8693 210 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8694 258 : list; list = list->next)
8695 : {
8696 48 : gfc_expr *expr = list->expr;
8697 :
8698 48 : if (expr->expr_type != EXPR_VARIABLE)
8699 : {
8700 24 : reduce_op = expr;
8701 24 : continue;
8702 : }
8703 :
8704 24 : if (reduce_op->expr_type == EXPR_OP)
8705 : {
8706 17 : switch (reduce_op->value.op.op)
8707 : {
8708 17 : case INTRINSIC_PLUS:
8709 17 : case INTRINSIC_TIMES:
8710 17 : if (!gfc_numeric_ts (&expr->ts))
8711 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8712 3 : "got %s", expr->symtree->n.sym->name,
8713 : &expr->where, gfc_basic_typename (expr->ts.type));
8714 : break;
8715 0 : case INTRINSIC_AND:
8716 0 : case INTRINSIC_OR:
8717 0 : case INTRINSIC_EQV:
8718 0 : case INTRINSIC_NEQV:
8719 0 : if (expr->ts.type != BT_LOGICAL)
8720 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8721 0 : "got %qs", expr->symtree->n.sym->name,
8722 : &expr->where, gfc_basic_typename (expr->ts.type));
8723 : break;
8724 0 : default:
8725 0 : gcc_unreachable ();
8726 : }
8727 : }
8728 :
8729 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8730 : {
8731 7 : switch (reduce_op->value.function.isym->id)
8732 : {
8733 6 : case GFC_ISYM_MIN:
8734 6 : case GFC_ISYM_MAX:
8735 6 : if (expr->ts.type != BT_INTEGER
8736 : && expr->ts.type != BT_REAL
8737 : && expr->ts.type != BT_CHARACTER)
8738 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8739 : "in REDUCE with MIN/MAX at %L, got %s",
8740 2 : expr->symtree->n.sym->name, &expr->where,
8741 : gfc_basic_typename (expr->ts.type));
8742 : break;
8743 1 : case GFC_ISYM_IAND:
8744 1 : case GFC_ISYM_IOR:
8745 1 : case GFC_ISYM_IEOR:
8746 1 : if (expr->ts.type != BT_INTEGER)
8747 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8748 : "IAND/IOR/IEOR at %L, got %s",
8749 1 : expr->symtree->n.sym->name, &expr->where,
8750 : gfc_basic_typename (expr->ts.type));
8751 : break;
8752 0 : default:
8753 0 : gcc_unreachable ();
8754 : }
8755 : }
8756 :
8757 : else
8758 0 : gcc_unreachable ();
8759 : }
8760 :
8761 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8762 : {
8763 1227 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8764 387 : list = list->next)
8765 : {
8766 387 : if (list->expr->expr_type == EXPR_VARIABLE)
8767 363 : list->expr->symtree->n.sym->mark = 0;
8768 : }
8769 : }
8770 :
8771 210 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8772 : check_default_none_expr, &data);
8773 :
8774 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8775 : {
8776 840 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8777 1227 : while (*plist)
8778 : {
8779 387 : gfc_expr *expr = (*plist)->expr;
8780 387 : if (expr->expr_type == EXPR_VARIABLE)
8781 : {
8782 363 : gfc_symbol *sym = expr->symtree->n.sym;
8783 363 : if (sym->mark == 0)
8784 : {
8785 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8786 : "locality-spec at %L is not used",
8787 : sym->name, &expr->where);
8788 70 : gfc_expr_list *tmp = *plist;
8789 70 : *plist = (*plist)->next;
8790 70 : gfc_free_expr (tmp->expr);
8791 70 : free (tmp);
8792 70 : continue;
8793 70 : }
8794 : }
8795 317 : plist = &((*plist)->next);
8796 : }
8797 : }
8798 :
8799 420 : delete data.sym_hash;
8800 210 : }
8801 :
8802 : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
8803 : to be a scalar INTEGER variable. The subscripts and stride are scalar
8804 : INTEGERs, and if stride is a constant it must be nonzero.
8805 : Furthermore "A subscript or stride in a forall-triplet-spec shall
8806 : not contain a reference to any index-name in the
8807 : forall-triplet-spec-list in which it appears." (7.5.4.1) */
8808 :
8809 : static void
8810 2202 : resolve_forall_iterators (gfc_forall_iterator *it)
8811 : {
8812 2202 : gfc_forall_iterator *iter, *iter2;
8813 :
8814 6320 : for (iter = it; iter; iter = iter->next)
8815 : {
8816 4118 : if (gfc_resolve_expr (iter->var)
8817 4118 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
8818 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
8819 : &iter->var->where);
8820 :
8821 4118 : if (gfc_resolve_expr (iter->start)
8822 4118 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
8823 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
8824 : &iter->start->where);
8825 4118 : if (iter->var->ts.kind != iter->start->ts.kind)
8826 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8827 :
8828 4118 : if (gfc_resolve_expr (iter->end)
8829 4118 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
8830 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
8831 : &iter->end->where);
8832 4118 : if (iter->var->ts.kind != iter->end->ts.kind)
8833 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8834 :
8835 4118 : if (gfc_resolve_expr (iter->stride))
8836 : {
8837 4118 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
8838 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
8839 : &iter->stride->where, "INTEGER");
8840 :
8841 4118 : if (iter->stride->expr_type == EXPR_CONSTANT
8842 4115 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
8843 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
8844 : &iter->stride->where);
8845 : }
8846 4118 : if (iter->var->ts.kind != iter->stride->ts.kind)
8847 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
8848 : }
8849 :
8850 6320 : for (iter = it; iter; iter = iter->next)
8851 11078 : for (iter2 = iter; iter2; iter2 = iter2->next)
8852 : {
8853 6960 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
8854 6958 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
8855 13916 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
8856 6 : gfc_error ("FORALL index %qs may not appear in triplet "
8857 6 : "specification at %L", iter->var->symtree->name,
8858 6 : &iter2->start->where);
8859 : }
8860 2202 : }
8861 :
8862 :
8863 : /* Given a pointer to a symbol that is a derived type, see if it's
8864 : inaccessible, i.e. if it's defined in another module and the components are
8865 : PRIVATE. The search is recursive if necessary. Returns zero if no
8866 : inaccessible components are found, nonzero otherwise. */
8867 :
8868 : static bool
8869 1350 : derived_inaccessible (gfc_symbol *sym)
8870 : {
8871 1350 : gfc_component *c;
8872 :
8873 1350 : if (sym->attr.use_assoc && sym->attr.private_comp)
8874 : return 1;
8875 :
8876 3997 : for (c = sym->components; c; c = c->next)
8877 : {
8878 : /* Prevent an infinite loop through this function. */
8879 2660 : if (c->ts.type == BT_DERIVED
8880 289 : && (c->attr.pointer || c->attr.allocatable)
8881 72 : && sym == c->ts.u.derived)
8882 72 : continue;
8883 :
8884 2588 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
8885 : return 1;
8886 : }
8887 :
8888 : return 0;
8889 : }
8890 :
8891 :
8892 : /* Resolve the argument of a deallocate expression. The expression must be
8893 : a pointer or a full array. */
8894 :
8895 : static bool
8896 8299 : resolve_deallocate_expr (gfc_expr *e)
8897 : {
8898 8299 : symbol_attribute attr;
8899 8299 : int allocatable, pointer;
8900 8299 : gfc_ref *ref;
8901 8299 : gfc_symbol *sym;
8902 8299 : gfc_component *c;
8903 8299 : bool unlimited;
8904 :
8905 8299 : if (!gfc_resolve_expr (e))
8906 : return false;
8907 :
8908 8299 : if (e->expr_type != EXPR_VARIABLE)
8909 0 : goto bad;
8910 :
8911 8299 : sym = e->symtree->n.sym;
8912 8299 : unlimited = UNLIMITED_POLY(sym);
8913 :
8914 8299 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
8915 : {
8916 1574 : allocatable = CLASS_DATA (sym)->attr.allocatable;
8917 1574 : pointer = CLASS_DATA (sym)->attr.class_pointer;
8918 : }
8919 : else
8920 : {
8921 6725 : allocatable = sym->attr.allocatable;
8922 6725 : pointer = sym->attr.pointer;
8923 : }
8924 16633 : for (ref = e->ref; ref; ref = ref->next)
8925 : {
8926 8334 : switch (ref->type)
8927 : {
8928 6220 : case REF_ARRAY:
8929 6220 : if (ref->u.ar.type != AR_FULL
8930 6428 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
8931 208 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
8932 : allocatable = 0;
8933 : break;
8934 :
8935 2114 : case REF_COMPONENT:
8936 2114 : c = ref->u.c.component;
8937 2114 : if (c->ts.type == BT_CLASS)
8938 : {
8939 297 : allocatable = CLASS_DATA (c)->attr.allocatable;
8940 297 : pointer = CLASS_DATA (c)->attr.class_pointer;
8941 : }
8942 : else
8943 : {
8944 1817 : allocatable = c->attr.allocatable;
8945 1817 : pointer = c->attr.pointer;
8946 : }
8947 : break;
8948 :
8949 : case REF_SUBSTRING:
8950 : case REF_INQUIRY:
8951 495 : allocatable = 0;
8952 : break;
8953 : }
8954 : }
8955 :
8956 8299 : attr = gfc_expr_attr (e);
8957 :
8958 8299 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
8959 : {
8960 3 : bad:
8961 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8962 : &e->where);
8963 3 : return false;
8964 : }
8965 :
8966 : /* F2008, C644. */
8967 8296 : if (gfc_is_coindexed (e))
8968 : {
8969 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
8970 1 : return false;
8971 : }
8972 :
8973 8295 : if (pointer
8974 10663 : && !gfc_check_vardef_context (e, true, true, false,
8975 2368 : _("DEALLOCATE object")))
8976 : return false;
8977 8293 : if (!gfc_check_vardef_context (e, false, true, false,
8978 8293 : _("DEALLOCATE object")))
8979 : return false;
8980 :
8981 : return true;
8982 : }
8983 :
8984 :
8985 : /* Returns true if the expression e contains a reference to the symbol sym. */
8986 : static bool
8987 47357 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
8988 : {
8989 47357 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
8990 2081 : return true;
8991 :
8992 : return false;
8993 : }
8994 :
8995 : bool
8996 20077 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
8997 : {
8998 20077 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
8999 : }
9000 :
9001 : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
9002 : of character expressions. */
9003 : static bool
9004 20457 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
9005 : {
9006 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
9007 : }
9008 :
9009 :
9010 : /* Given the expression node e for an allocatable/pointer of derived type to be
9011 : allocated, get the expression node to be initialized afterwards (needed for
9012 : derived types with default initializers, and derived types with allocatable
9013 : components that need nullification.) */
9014 :
9015 : gfc_expr *
9016 5743 : gfc_expr_to_initialize (gfc_expr *e)
9017 : {
9018 5743 : gfc_expr *result;
9019 5743 : gfc_ref *ref;
9020 5743 : int i;
9021 :
9022 5743 : result = gfc_copy_expr (e);
9023 :
9024 : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
9025 11364 : for (ref = result->ref; ref; ref = ref->next)
9026 8947 : if (ref->type == REF_ARRAY && ref->next == NULL)
9027 : {
9028 3326 : if (ref->u.ar.dimen == 0
9029 74 : && ref->u.ar.as && ref->u.ar.as->corank)
9030 : return result;
9031 :
9032 3252 : ref->u.ar.type = AR_FULL;
9033 :
9034 7350 : for (i = 0; i < ref->u.ar.dimen; i++)
9035 4098 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
9036 :
9037 : break;
9038 : }
9039 :
9040 5669 : gfc_free_shape (&result->shape, result->rank);
9041 :
9042 : /* Recalculate rank, shape, etc. */
9043 5669 : gfc_resolve_expr (result);
9044 5669 : return result;
9045 : }
9046 :
9047 :
9048 : /* If the last ref of an expression is an array ref, return a copy of the
9049 : expression with that one removed. Otherwise, a copy of the original
9050 : expression. This is used for allocate-expressions and pointer assignment
9051 : LHS, where there may be an array specification that needs to be stripped
9052 : off when using gfc_check_vardef_context. */
9053 :
9054 : static gfc_expr*
9055 27598 : remove_last_array_ref (gfc_expr* e)
9056 : {
9057 27598 : gfc_expr* e2;
9058 27598 : gfc_ref** r;
9059 :
9060 27598 : e2 = gfc_copy_expr (e);
9061 35590 : for (r = &e2->ref; *r; r = &(*r)->next)
9062 24265 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9063 : {
9064 16273 : gfc_free_ref_list (*r);
9065 16273 : *r = NULL;
9066 16273 : break;
9067 : }
9068 :
9069 27598 : return e2;
9070 : }
9071 :
9072 :
9073 : /* Used in resolve_allocate_expr to check that a allocation-object and
9074 : a source-expr are conformable. This does not catch all possible
9075 : cases; in particular a runtime checking is needed. */
9076 :
9077 : static bool
9078 1909 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9079 : {
9080 1909 : gfc_ref *tail;
9081 1909 : bool scalar;
9082 :
9083 2641 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9084 :
9085 : /* If MOLD= is present and is not scalar, and the allocate-object has an
9086 : explicit-shape-spec, the ranks need not agree. This may be unintended,
9087 : so let's emit a warning if -Wsurprising is given. */
9088 1909 : scalar = !tail || tail->type == REF_COMPONENT;
9089 1909 : if (e1->mold && e1->rank > 0
9090 165 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9091 : {
9092 27 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9093 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9094 : "but MOLD= expression at %L has rank %d",
9095 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9096 : &e1->where, e1->rank);
9097 30 : return true;
9098 : }
9099 :
9100 : /* First compare rank. */
9101 1879 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9102 2 : || (!tail && e1->rank != e2->rank))
9103 : {
9104 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9105 : "same rank as the allocate-object at %L",
9106 : &e1->where, &e2->where);
9107 7 : return false;
9108 : }
9109 :
9110 1872 : if (e1->shape)
9111 : {
9112 1373 : int i;
9113 1373 : mpz_t s;
9114 :
9115 1373 : mpz_init (s);
9116 :
9117 3165 : for (i = 0; i < e1->rank; i++)
9118 : {
9119 1379 : if (tail->u.ar.start[i] == NULL)
9120 : break;
9121 :
9122 419 : if (tail->u.ar.end[i])
9123 : {
9124 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9125 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9126 54 : mpz_add_ui (s, s, 1);
9127 : }
9128 : else
9129 : {
9130 365 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9131 : }
9132 :
9133 419 : if (mpz_cmp (e1->shape[i], s) != 0)
9134 : {
9135 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9136 : "have the same shape", &e1->where, &e2->where);
9137 0 : mpz_clear (s);
9138 0 : return false;
9139 : }
9140 : }
9141 :
9142 1373 : mpz_clear (s);
9143 : }
9144 :
9145 : return true;
9146 : }
9147 :
9148 :
9149 : /* Resolve the expression in an ALLOCATE statement, doing the additional
9150 : checks to see whether the expression is OK or not. The expression must
9151 : have a trailing array reference that gives the size of the array. */
9152 :
9153 : static bool
9154 17247 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9155 : {
9156 17247 : int i, pointer, allocatable, dimension, is_abstract;
9157 17247 : int codimension;
9158 17247 : bool coindexed;
9159 17247 : bool unlimited;
9160 17247 : symbol_attribute attr;
9161 17247 : gfc_ref *ref, *ref2;
9162 17247 : gfc_expr *e2;
9163 17247 : gfc_array_ref *ar;
9164 17247 : gfc_symbol *sym = NULL;
9165 17247 : gfc_alloc *a;
9166 17247 : gfc_component *c;
9167 17247 : bool t;
9168 :
9169 : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9170 : checking of coarrays. */
9171 21908 : for (ref = e->ref; ref; ref = ref->next)
9172 17748 : if (ref->next == NULL)
9173 : break;
9174 :
9175 17247 : if (ref && ref->type == REF_ARRAY)
9176 11892 : ref->u.ar.in_allocate = true;
9177 :
9178 17247 : if (!gfc_resolve_expr (e))
9179 1 : goto failure;
9180 :
9181 : /* Make sure the expression is allocatable or a pointer. If it is
9182 : pointer, the next-to-last reference must be a pointer. */
9183 :
9184 17246 : ref2 = NULL;
9185 17246 : if (e->symtree)
9186 17246 : sym = e->symtree->n.sym;
9187 :
9188 : /* Check whether ultimate component is abstract and CLASS. */
9189 34492 : is_abstract = 0;
9190 :
9191 : /* Is the allocate-object unlimited polymorphic? */
9192 17246 : unlimited = UNLIMITED_POLY(e);
9193 :
9194 17246 : if (e->expr_type != EXPR_VARIABLE)
9195 : {
9196 0 : allocatable = 0;
9197 0 : attr = gfc_expr_attr (e);
9198 0 : pointer = attr.pointer;
9199 0 : dimension = attr.dimension;
9200 0 : codimension = attr.codimension;
9201 : }
9202 : else
9203 : {
9204 17246 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9205 : {
9206 3360 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9207 3360 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9208 3360 : dimension = CLASS_DATA (sym)->attr.dimension;
9209 3360 : codimension = CLASS_DATA (sym)->attr.codimension;
9210 3360 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9211 : }
9212 : else
9213 : {
9214 13886 : allocatable = sym->attr.allocatable;
9215 13886 : pointer = sym->attr.pointer;
9216 13886 : dimension = sym->attr.dimension;
9217 13886 : codimension = sym->attr.codimension;
9218 : }
9219 :
9220 17246 : coindexed = false;
9221 :
9222 34988 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9223 : {
9224 17744 : switch (ref->type)
9225 : {
9226 13311 : case REF_ARRAY:
9227 13311 : if (ref->u.ar.codimen > 0)
9228 : {
9229 754 : int n;
9230 1052 : for (n = ref->u.ar.dimen;
9231 1052 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9232 795 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9233 : {
9234 : coindexed = true;
9235 : break;
9236 : }
9237 : }
9238 :
9239 13311 : if (ref->next != NULL)
9240 1421 : pointer = 0;
9241 : break;
9242 :
9243 4433 : case REF_COMPONENT:
9244 : /* F2008, C644. */
9245 4433 : if (coindexed)
9246 : {
9247 2 : gfc_error ("Coindexed allocatable object at %L",
9248 : &e->where);
9249 2 : goto failure;
9250 : }
9251 :
9252 4431 : c = ref->u.c.component;
9253 4431 : if (c->ts.type == BT_CLASS)
9254 : {
9255 988 : allocatable = CLASS_DATA (c)->attr.allocatable;
9256 988 : pointer = CLASS_DATA (c)->attr.class_pointer;
9257 988 : dimension = CLASS_DATA (c)->attr.dimension;
9258 988 : codimension = CLASS_DATA (c)->attr.codimension;
9259 988 : is_abstract = CLASS_DATA (c)->attr.abstract;
9260 : }
9261 : else
9262 : {
9263 3443 : allocatable = c->attr.allocatable;
9264 3443 : pointer = c->attr.pointer;
9265 3443 : dimension = c->attr.dimension;
9266 3443 : codimension = c->attr.codimension;
9267 3443 : is_abstract = c->attr.abstract;
9268 : }
9269 : break;
9270 :
9271 0 : case REF_SUBSTRING:
9272 0 : case REF_INQUIRY:
9273 0 : allocatable = 0;
9274 0 : pointer = 0;
9275 0 : break;
9276 : }
9277 : }
9278 : }
9279 :
9280 : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9281 : pointer or an allocatable variable. */
9282 17244 : if (allocatable == 0 && pointer == 0)
9283 : {
9284 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9285 : &e->where);
9286 4 : goto failure;
9287 : }
9288 :
9289 : /* Some checks for the SOURCE tag. */
9290 17240 : if (code->expr3)
9291 : {
9292 : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9293 : rank as allocate-object". This would require the MOLD argument to
9294 : NULL() as source-expr for subsequent checking. However, even the
9295 : resulting disassociated pointer or unallocated array has no shape that
9296 : could be used for SOURCE= or MOLD=. */
9297 3840 : if (code->expr3->expr_type == EXPR_NULL)
9298 : {
9299 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9300 : &code->expr3->where);
9301 4 : goto failure;
9302 : }
9303 :
9304 : /* Check F03:C631. */
9305 3836 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9306 : {
9307 10 : gfc_error ("Type of entity at %L is type incompatible with "
9308 10 : "source-expr at %L", &e->where, &code->expr3->where);
9309 10 : goto failure;
9310 : }
9311 :
9312 : /* Check F03:C632 and restriction following Note 6.18. */
9313 3826 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9314 7 : goto failure;
9315 :
9316 : /* Check F03:C633. */
9317 3819 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9318 : {
9319 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9320 : "shall have the same kind type parameter",
9321 : &e->where, &code->expr3->where);
9322 1 : goto failure;
9323 : }
9324 :
9325 : /* Check F2008, C642. */
9326 3818 : if (code->expr3->ts.type == BT_DERIVED
9327 3818 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9328 1192 : || (code->expr3->ts.u.derived->from_intmod
9329 : == INTMOD_ISO_FORTRAN_ENV
9330 0 : && code->expr3->ts.u.derived->intmod_sym_id
9331 : == ISOFORTRAN_LOCK_TYPE)))
9332 : {
9333 0 : gfc_error ("The source-expr at %L shall neither be of type "
9334 : "LOCK_TYPE nor have a LOCK_TYPE component if "
9335 : "allocate-object at %L is a coarray",
9336 0 : &code->expr3->where, &e->where);
9337 0 : goto failure;
9338 : }
9339 :
9340 : /* Check F2008:C639: "Corresponding kind type parameters of
9341 : allocate-object and source-expr shall have the same values." */
9342 3818 : if (e->ts.type == BT_CHARACTER
9343 816 : && !e->ts.deferred
9344 162 : && e->ts.u.cl->length
9345 162 : && code->expr3->ts.type == BT_CHARACTER
9346 3980 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9347 : "SOURCE= or MOLD= specifier"))
9348 17 : goto failure;
9349 :
9350 : /* Check TS18508, C702/C703. */
9351 3801 : if (code->expr3->ts.type == BT_DERIVED
9352 4993 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9353 1192 : || (code->expr3->ts.u.derived->from_intmod
9354 : == INTMOD_ISO_FORTRAN_ENV
9355 0 : && code->expr3->ts.u.derived->intmod_sym_id
9356 : == ISOFORTRAN_EVENT_TYPE)))
9357 : {
9358 0 : gfc_error ("The source-expr at %L shall neither be of type "
9359 : "EVENT_TYPE nor have a EVENT_TYPE component if "
9360 : "allocate-object at %L is a coarray",
9361 0 : &code->expr3->where, &e->where);
9362 0 : goto failure;
9363 : }
9364 : }
9365 :
9366 : /* Check F08:C629. */
9367 17201 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9368 153 : && !code->expr3)
9369 : {
9370 2 : gcc_assert (e->ts.type == BT_CLASS);
9371 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9372 : "type-spec or source-expr", sym->name, &e->where);
9373 2 : goto failure;
9374 : }
9375 :
9376 : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9377 : if and only if each allocate-object is a dummy argument for which the
9378 : corresponding type parameter is assumed. */
9379 17199 : if (code->ext.alloc.ts.type == BT_CHARACTER
9380 513 : && code->ext.alloc.ts.u.cl->length != NULL
9381 498 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9382 23 : && e->ts.u.cl->length == NULL
9383 2 : && e->symtree->n.sym->attr.dummy)
9384 : {
9385 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9386 : "shall be an asterisk as allocate object %qs at %L is a "
9387 : "dummy argument with assumed type parameter",
9388 : sym->name, &e->where);
9389 2 : goto failure;
9390 : }
9391 :
9392 : /* Check F08:C632. */
9393 17197 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9394 60 : && !UNLIMITED_POLY (e))
9395 : {
9396 36 : int cmp;
9397 :
9398 36 : if (!e->ts.u.cl->length)
9399 15 : goto failure;
9400 :
9401 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9402 21 : code->ext.alloc.ts.u.cl->length);
9403 21 : if (cmp == 1 || cmp == -1 || cmp == -3)
9404 : {
9405 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9406 : "character-length parameter as in the declaration",
9407 : sym->name, &e->where);
9408 2 : goto failure;
9409 : }
9410 : }
9411 :
9412 : /* In the variable definition context checks, gfc_expr_attr is used
9413 : on the expression. This is fooled by the array specification
9414 : present in e, thus we have to eliminate that one temporarily. */
9415 17180 : e2 = remove_last_array_ref (e);
9416 17180 : t = true;
9417 17180 : if (t && pointer)
9418 3857 : t = gfc_check_vardef_context (e2, true, true, false,
9419 3857 : _("ALLOCATE object"));
9420 3857 : if (t)
9421 17172 : t = gfc_check_vardef_context (e2, false, true, false,
9422 17172 : _("ALLOCATE object"));
9423 17180 : gfc_free_expr (e2);
9424 17180 : if (!t)
9425 11 : goto failure;
9426 :
9427 17169 : code->ext.alloc.expr3_not_explicit = 0;
9428 17169 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9429 1599 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9430 : {
9431 : /* For class arrays, the initialization with SOURCE is done
9432 : using _copy and trans_call. It is convenient to exploit that
9433 : when the allocated type is different from the declared type but
9434 : no SOURCE exists by setting expr3. */
9435 293 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9436 293 : code->ext.alloc.expr3_not_explicit = 1;
9437 : }
9438 16876 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9439 2596 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9440 6 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9441 : {
9442 : /* We have to zero initialize the integer variable. */
9443 2 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9444 2 : code->ext.alloc.expr3_not_explicit = 1;
9445 : }
9446 :
9447 17169 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9448 : {
9449 : /* Make sure the vtab symbol is present when
9450 : the module variables are generated. */
9451 2960 : gfc_typespec ts = e->ts;
9452 2960 : if (code->expr3)
9453 1319 : ts = code->expr3->ts;
9454 1641 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9455 714 : ts = code->ext.alloc.ts;
9456 :
9457 : /* Finding the vtab also publishes the type's symbol. Therefore this
9458 : statement is necessary. */
9459 2960 : gfc_find_derived_vtab (ts.u.derived);
9460 2960 : }
9461 14209 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9462 : {
9463 : /* Again, make sure the vtab symbol is present when
9464 : the module variables are generated. */
9465 434 : gfc_typespec *ts = NULL;
9466 434 : if (code->expr3)
9467 347 : ts = &code->expr3->ts;
9468 : else
9469 87 : ts = &code->ext.alloc.ts;
9470 :
9471 434 : gcc_assert (ts);
9472 :
9473 : /* Finding the vtab also publishes the type's symbol. Therefore this
9474 : statement is necessary. */
9475 434 : gfc_find_vtab (ts);
9476 : }
9477 :
9478 17169 : if (dimension == 0 && codimension == 0)
9479 5308 : goto success;
9480 :
9481 : /* Make sure the last reference node is an array specification. */
9482 :
9483 11861 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9484 10629 : || (dimension && ref2->u.ar.dimen == 0))
9485 : {
9486 : /* F08:C633. */
9487 1232 : if (code->expr3)
9488 : {
9489 1231 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9490 : "in ALLOCATE statement at %L", &e->where))
9491 0 : goto failure;
9492 1231 : if (code->expr3->rank != 0)
9493 1230 : *array_alloc_wo_spec = true;
9494 : else
9495 : {
9496 1 : gfc_error ("Array specification or array-valued SOURCE= "
9497 : "expression required in ALLOCATE statement at %L",
9498 : &e->where);
9499 1 : goto failure;
9500 : }
9501 : }
9502 : else
9503 : {
9504 1 : gfc_error ("Array specification required in ALLOCATE statement "
9505 : "at %L", &e->where);
9506 1 : goto failure;
9507 : }
9508 : }
9509 :
9510 : /* Make sure that the array section reference makes sense in the
9511 : context of an ALLOCATE specification. */
9512 :
9513 11859 : ar = &ref2->u.ar;
9514 :
9515 11859 : if (codimension)
9516 1173 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9517 : {
9518 689 : switch (ar->dimen_type[i])
9519 : {
9520 2 : case DIMEN_THIS_IMAGE:
9521 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9522 : "at %L", &e->where);
9523 2 : goto failure;
9524 :
9525 98 : case DIMEN_RANGE:
9526 : /* F2018:R937:
9527 : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9528 : */
9529 98 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9530 : {
9531 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9532 : "at %L", &e->where);
9533 8 : goto failure;
9534 : }
9535 90 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9536 : {
9537 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9538 2 : &ar->start[i]->where);
9539 2 : goto failure;
9540 : }
9541 : break;
9542 :
9543 105 : case DIMEN_ELEMENT:
9544 105 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9545 : {
9546 97 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9547 97 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9548 : {
9549 1 : gfc_error ("Upper cobound is less than lower cobound "
9550 : "of 1 at %L", &ar->start[i]->where);
9551 1 : goto failure;
9552 : }
9553 : }
9554 : break;
9555 :
9556 : case DIMEN_STAR:
9557 : break;
9558 :
9559 0 : default:
9560 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9561 : &e->where);
9562 0 : goto failure;
9563 :
9564 : }
9565 : }
9566 29071 : for (i = 0; i < ar->dimen; i++)
9567 : {
9568 17229 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9569 14519 : goto check_symbols;
9570 :
9571 2710 : switch (ar->dimen_type[i])
9572 : {
9573 : case DIMEN_ELEMENT:
9574 : break;
9575 :
9576 2444 : case DIMEN_RANGE:
9577 2444 : if (ar->start[i] != NULL
9578 2444 : && ar->end[i] != NULL
9579 2443 : && ar->stride[i] == NULL)
9580 : break;
9581 :
9582 : /* Fall through. */
9583 :
9584 1 : case DIMEN_UNKNOWN:
9585 1 : case DIMEN_VECTOR:
9586 1 : case DIMEN_STAR:
9587 1 : case DIMEN_THIS_IMAGE:
9588 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9589 : &e->where);
9590 1 : goto failure;
9591 : }
9592 :
9593 2443 : check_symbols:
9594 44879 : for (a = code->ext.alloc.list; a; a = a->next)
9595 : {
9596 27654 : sym = a->expr->symtree->n.sym;
9597 :
9598 : /* TODO - check derived type components. */
9599 27654 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9600 9239 : continue;
9601 :
9602 18415 : if ((ar->start[i] != NULL
9603 17735 : && gfc_find_var_in_expr (sym, ar->start[i]))
9604 36147 : || (ar->end[i] != NULL
9605 2722 : && gfc_find_var_in_expr (sym, ar->end[i])))
9606 : {
9607 3 : gfc_error ("%qs must not appear in the array specification at "
9608 : "%L in the same ALLOCATE statement where it is "
9609 : "itself allocated", sym->name, &ar->where);
9610 3 : goto failure;
9611 : }
9612 : }
9613 : }
9614 :
9615 12033 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9616 : {
9617 865 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9618 674 : || ar->dimen_type[i] == DIMEN_RANGE)
9619 : {
9620 191 : if (i == (ar->dimen + ar->codimen - 1))
9621 : {
9622 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9623 : "statement at %L", &e->where);
9624 0 : goto failure;
9625 : }
9626 191 : continue;
9627 : }
9628 :
9629 483 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9630 483 : && ar->stride[i] == NULL)
9631 : break;
9632 :
9633 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9634 : &e->where);
9635 0 : goto failure;
9636 : }
9637 :
9638 11842 : success:
9639 : return true;
9640 :
9641 : failure:
9642 : return false;
9643 : }
9644 :
9645 :
9646 : static void
9647 20263 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9648 : {
9649 20263 : gfc_expr *stat, *errmsg, *pe, *qe;
9650 20263 : gfc_alloc *a, *p, *q;
9651 :
9652 20263 : stat = code->expr1;
9653 20263 : errmsg = code->expr2;
9654 :
9655 : /* Check the stat variable. */
9656 20263 : if (stat)
9657 : {
9658 661 : if (!gfc_check_vardef_context (stat, false, false, false,
9659 661 : _("STAT variable")))
9660 8 : goto done_stat;
9661 :
9662 653 : if (stat->ts.type != BT_INTEGER
9663 644 : || stat->rank > 0)
9664 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9665 : "variable", &stat->where);
9666 :
9667 653 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9668 0 : goto done_stat;
9669 :
9670 : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9671 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9672 : */
9673 1354 : for (p = code->ext.alloc.list; p; p = p->next)
9674 708 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9675 : {
9676 9 : gfc_ref *ref1, *ref2;
9677 9 : bool found = true;
9678 :
9679 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9680 7 : ref1 = ref1->next, ref2 = ref2->next)
9681 : {
9682 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9683 5 : continue;
9684 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9685 : {
9686 : found = false;
9687 : break;
9688 : }
9689 : }
9690 :
9691 9 : if (found)
9692 : {
9693 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9694 : "the same %s statement", &stat->where, fcn, fcn);
9695 7 : break;
9696 : }
9697 : }
9698 : }
9699 :
9700 19602 : done_stat:
9701 :
9702 : /* Check the errmsg variable. */
9703 20263 : if (errmsg)
9704 : {
9705 150 : if (!stat)
9706 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9707 : &errmsg->where);
9708 :
9709 150 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9710 150 : _("ERRMSG variable")))
9711 6 : goto done_errmsg;
9712 :
9713 : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9714 : F18:R930 errmsg-variable is scalar-default-char-variable
9715 : F18:R906 default-char-variable is variable
9716 : F18:C906 default-char-variable shall be default character. */
9717 144 : if (errmsg->ts.type != BT_CHARACTER
9718 142 : || errmsg->rank > 0
9719 141 : || errmsg->ts.kind != gfc_default_character_kind)
9720 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9721 : "variable", &errmsg->where);
9722 :
9723 144 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9724 0 : goto done_errmsg;
9725 :
9726 : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9727 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9728 : */
9729 286 : for (p = code->ext.alloc.list; p; p = p->next)
9730 147 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9731 : {
9732 9 : gfc_ref *ref1, *ref2;
9733 9 : bool found = true;
9734 :
9735 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9736 7 : ref1 = ref1->next, ref2 = ref2->next)
9737 : {
9738 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9739 4 : continue;
9740 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9741 : {
9742 : found = false;
9743 : break;
9744 : }
9745 : }
9746 :
9747 9 : if (found)
9748 : {
9749 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9750 : "the same %s statement", &errmsg->where, fcn, fcn);
9751 5 : break;
9752 : }
9753 : }
9754 : }
9755 :
9756 20113 : done_errmsg:
9757 :
9758 : /* Check that an allocate-object appears only once in the statement. */
9759 :
9760 45809 : for (p = code->ext.alloc.list; p; p = p->next)
9761 : {
9762 25546 : pe = p->expr;
9763 34806 : for (q = p->next; q; q = q->next)
9764 : {
9765 9260 : qe = q->expr;
9766 9260 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9767 : {
9768 : /* This is a potential collision. */
9769 2093 : gfc_ref *pr = pe->ref;
9770 2093 : gfc_ref *qr = qe->ref;
9771 :
9772 : /* Follow the references until
9773 : a) They start to differ, in which case there is no error;
9774 : you can deallocate a%b and a%c in a single statement
9775 : b) Both of them stop, which is an error
9776 : c) One of them stops, which is also an error. */
9777 4517 : while (1)
9778 : {
9779 3305 : if (pr == NULL && qr == NULL)
9780 : {
9781 7 : gfc_error ("Allocate-object at %L also appears at %L",
9782 : &pe->where, &qe->where);
9783 7 : break;
9784 : }
9785 3298 : else if (pr != NULL && qr == NULL)
9786 : {
9787 2 : gfc_error ("Allocate-object at %L is subobject of"
9788 : " object at %L", &pe->where, &qe->where);
9789 2 : break;
9790 : }
9791 3296 : else if (pr == NULL && qr != NULL)
9792 : {
9793 2 : gfc_error ("Allocate-object at %L is subobject of"
9794 : " object at %L", &qe->where, &pe->where);
9795 2 : break;
9796 : }
9797 : /* Here, pr != NULL && qr != NULL */
9798 3294 : gcc_assert(pr->type == qr->type);
9799 3294 : if (pr->type == REF_ARRAY)
9800 : {
9801 : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
9802 : which are legal. */
9803 1065 : gcc_assert (qr->type == REF_ARRAY);
9804 :
9805 1065 : if (pr->next && qr->next)
9806 : {
9807 : int i;
9808 : gfc_array_ref *par = &(pr->u.ar);
9809 : gfc_array_ref *qar = &(qr->u.ar);
9810 :
9811 1840 : for (i=0; i<par->dimen; i++)
9812 : {
9813 954 : if ((par->start[i] != NULL
9814 0 : || qar->start[i] != NULL)
9815 1908 : && gfc_dep_compare_expr (par->start[i],
9816 954 : qar->start[i]) != 0)
9817 168 : goto break_label;
9818 : }
9819 : }
9820 : }
9821 : else
9822 : {
9823 2229 : if (pr->u.c.component->name != qr->u.c.component->name)
9824 : break;
9825 : }
9826 :
9827 1212 : pr = pr->next;
9828 1212 : qr = qr->next;
9829 1212 : }
9830 9260 : break_label:
9831 : ;
9832 : }
9833 : }
9834 : }
9835 :
9836 20263 : if (strcmp (fcn, "ALLOCATE") == 0)
9837 : {
9838 14220 : bool arr_alloc_wo_spec = false;
9839 :
9840 : /* Resolving the expr3 in the loop over all objects to allocate would
9841 : execute loop invariant code for each loop item. Therefore do it just
9842 : once here. */
9843 14220 : if (code->expr3 && code->expr3->mold
9844 350 : && code->expr3->ts.type == BT_DERIVED
9845 24 : && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
9846 : {
9847 : /* Default initialization via MOLD (non-polymorphic). */
9848 22 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
9849 22 : if (rhs != NULL)
9850 : {
9851 9 : gfc_resolve_expr (rhs);
9852 9 : gfc_free_expr (code->expr3);
9853 9 : code->expr3 = rhs;
9854 : }
9855 : }
9856 31467 : for (a = code->ext.alloc.list; a; a = a->next)
9857 17247 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
9858 :
9859 14220 : if (arr_alloc_wo_spec && code->expr3)
9860 : {
9861 : /* Mark the allocate to have to take the array specification
9862 : from the expr3. */
9863 1224 : code->ext.alloc.arr_spec_from_expr3 = 1;
9864 : }
9865 : }
9866 : else
9867 : {
9868 14342 : for (a = code->ext.alloc.list; a; a = a->next)
9869 8299 : resolve_deallocate_expr (a->expr);
9870 : }
9871 20263 : }
9872 :
9873 :
9874 : /************ SELECT CASE resolution subroutines ************/
9875 :
9876 : /* Callback function for our mergesort variant. Determines interval
9877 : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
9878 : op1 > op2. Assumes we're not dealing with the default case.
9879 : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
9880 : There are nine situations to check. */
9881 :
9882 : static int
9883 1578 : compare_cases (const gfc_case *op1, const gfc_case *op2)
9884 : {
9885 1578 : int retval;
9886 :
9887 1578 : if (op1->low == NULL) /* op1 = (:L) */
9888 : {
9889 : /* op2 = (:N), so overlap. */
9890 52 : retval = 0;
9891 : /* op2 = (M:) or (M:N), L < M */
9892 52 : if (op2->low != NULL
9893 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9894 : retval = -1;
9895 : }
9896 1526 : else if (op1->high == NULL) /* op1 = (K:) */
9897 : {
9898 : /* op2 = (M:), so overlap. */
9899 10 : retval = 0;
9900 : /* op2 = (:N) or (M:N), K > N */
9901 10 : if (op2->high != NULL
9902 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9903 : retval = 1;
9904 : }
9905 : else /* op1 = (K:L) */
9906 : {
9907 1516 : if (op2->low == NULL) /* op2 = (:N), K > N */
9908 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9909 18 : ? 1 : 0;
9910 1498 : else if (op2->high == NULL) /* op2 = (M:), L < M */
9911 14 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9912 10 : ? -1 : 0;
9913 : else /* op2 = (M:N) */
9914 : {
9915 1488 : retval = 0;
9916 : /* L < M */
9917 1488 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9918 : retval = -1;
9919 : /* K > N */
9920 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9921 438 : retval = 1;
9922 : }
9923 : }
9924 :
9925 1578 : return retval;
9926 : }
9927 :
9928 :
9929 : /* Merge-sort a double linked case list, detecting overlap in the
9930 : process. LIST is the head of the double linked case list before it
9931 : is sorted. Returns the head of the sorted list if we don't see any
9932 : overlap, or NULL otherwise. */
9933 :
9934 : static gfc_case *
9935 646 : check_case_overlap (gfc_case *list)
9936 : {
9937 646 : gfc_case *p, *q, *e, *tail;
9938 646 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
9939 :
9940 : /* If the passed list was empty, return immediately. */
9941 646 : if (!list)
9942 : return NULL;
9943 :
9944 : overlap_seen = 0;
9945 : insize = 1;
9946 :
9947 : /* Loop unconditionally. The only exit from this loop is a return
9948 : statement, when we've finished sorting the case list. */
9949 1350 : for (;;)
9950 : {
9951 998 : p = list;
9952 998 : list = NULL;
9953 998 : tail = NULL;
9954 :
9955 : /* Count the number of merges we do in this pass. */
9956 998 : nmerges = 0;
9957 :
9958 : /* Loop while there exists a merge to be done. */
9959 2523 : while (p)
9960 : {
9961 1525 : int i;
9962 :
9963 : /* Count this merge. */
9964 1525 : nmerges++;
9965 :
9966 : /* Cut the list in two pieces by stepping INSIZE places
9967 : forward in the list, starting from P. */
9968 1525 : psize = 0;
9969 1525 : q = p;
9970 3208 : for (i = 0; i < insize; i++)
9971 : {
9972 2243 : psize++;
9973 2243 : q = q->right;
9974 2243 : if (!q)
9975 : break;
9976 : }
9977 : qsize = insize;
9978 :
9979 : /* Now we have two lists. Merge them! */
9980 5013 : while (psize > 0 || (qsize > 0 && q != NULL))
9981 : {
9982 : /* See from which the next case to merge comes from. */
9983 807 : if (psize == 0)
9984 : {
9985 : /* P is empty so the next case must come from Q. */
9986 807 : e = q;
9987 807 : q = q->right;
9988 807 : qsize--;
9989 : }
9990 2681 : else if (qsize == 0 || q == NULL)
9991 : {
9992 : /* Q is empty. */
9993 1103 : e = p;
9994 1103 : p = p->right;
9995 1103 : psize--;
9996 : }
9997 : else
9998 : {
9999 1578 : cmp = compare_cases (p, q);
10000 1578 : if (cmp < 0)
10001 : {
10002 : /* The whole case range for P is less than the
10003 : one for Q. */
10004 1136 : e = p;
10005 1136 : p = p->right;
10006 1136 : psize--;
10007 : }
10008 442 : else if (cmp > 0)
10009 : {
10010 : /* The whole case range for Q is greater than
10011 : the case range for P. */
10012 438 : e = q;
10013 438 : q = q->right;
10014 438 : qsize--;
10015 : }
10016 : else
10017 : {
10018 : /* The cases overlap, or they are the same
10019 : element in the list. Either way, we must
10020 : issue an error and get the next case from P. */
10021 : /* FIXME: Sort P and Q by line number. */
10022 4 : gfc_error ("CASE label at %L overlaps with CASE "
10023 : "label at %L", &p->where, &q->where);
10024 4 : overlap_seen = 1;
10025 4 : e = p;
10026 4 : p = p->right;
10027 4 : psize--;
10028 : }
10029 : }
10030 :
10031 : /* Add the next element to the merged list. */
10032 3488 : if (tail)
10033 2490 : tail->right = e;
10034 : else
10035 : list = e;
10036 3488 : e->left = tail;
10037 3488 : tail = e;
10038 : }
10039 :
10040 : /* P has now stepped INSIZE places along, and so has Q. So
10041 : they're the same. */
10042 : p = q;
10043 : }
10044 998 : tail->right = NULL;
10045 :
10046 : /* If we have done only one merge or none at all, we've
10047 : finished sorting the cases. */
10048 998 : if (nmerges <= 1)
10049 : {
10050 646 : if (!overlap_seen)
10051 : return list;
10052 : else
10053 : return NULL;
10054 : }
10055 :
10056 : /* Otherwise repeat, merging lists twice the size. */
10057 352 : insize *= 2;
10058 352 : }
10059 : }
10060 :
10061 :
10062 : /* Check to see if an expression is suitable for use in a CASE statement.
10063 : Makes sure that all case expressions are scalar constants of the same
10064 : type. Return false if anything is wrong. */
10065 :
10066 : static bool
10067 3307 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10068 : {
10069 3307 : if (e == NULL) return true;
10070 :
10071 3214 : if (e->ts.type != case_expr->ts.type)
10072 : {
10073 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10074 : &e->where, gfc_basic_typename (case_expr->ts.type));
10075 4 : return false;
10076 : }
10077 :
10078 : /* C805 (R808) For a given case-construct, each case-value shall be of
10079 : the same type as case-expr. For character type, length differences
10080 : are allowed, but the kind type parameters shall be the same. */
10081 :
10082 3210 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10083 : {
10084 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10085 : &e->where, case_expr->ts.kind);
10086 4 : return false;
10087 : }
10088 :
10089 : /* Convert the case value kind to that of case expression kind,
10090 : if needed */
10091 :
10092 3206 : if (e->ts.kind != case_expr->ts.kind)
10093 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10094 :
10095 3206 : if (e->rank != 0)
10096 : {
10097 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10098 : &e->where);
10099 0 : return false;
10100 : }
10101 :
10102 : return true;
10103 : }
10104 :
10105 :
10106 : /* Given a completely parsed select statement, we:
10107 :
10108 : - Validate all expressions and code within the SELECT.
10109 : - Make sure that the selection expression is not of the wrong type.
10110 : - Make sure that no case ranges overlap.
10111 : - Eliminate unreachable cases and unreachable code resulting from
10112 : removing case labels.
10113 :
10114 : The standard does allow unreachable cases, e.g. CASE (5:3). But
10115 : they are a hassle for code generation, and to prevent that, we just
10116 : cut them out here. This is not necessary for overlapping cases
10117 : because they are illegal and we never even try to generate code.
10118 :
10119 : We have the additional caveat that a SELECT construct could have
10120 : been a computed GOTO in the source code. Fortunately we can fairly
10121 : easily work around that here: The case_expr for a "real" SELECT CASE
10122 : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10123 : we have to do is make sure that the case_expr is a scalar integer
10124 : expression. */
10125 :
10126 : static void
10127 687 : resolve_select (gfc_code *code, bool select_type)
10128 : {
10129 687 : gfc_code *body;
10130 687 : gfc_expr *case_expr;
10131 687 : gfc_case *cp, *default_case, *tail, *head;
10132 687 : int seen_unreachable;
10133 687 : int seen_logical;
10134 687 : int ncases;
10135 687 : bt type;
10136 687 : bool t;
10137 :
10138 687 : if (code->expr1 == NULL)
10139 : {
10140 : /* This was actually a computed GOTO statement. */
10141 5 : case_expr = code->expr2;
10142 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10143 3 : gfc_error ("Selection expression in computed GOTO statement "
10144 : "at %L must be a scalar integer expression",
10145 : &case_expr->where);
10146 :
10147 : /* Further checking is not necessary because this SELECT was built
10148 : by the compiler, so it should always be OK. Just move the
10149 : case_expr from expr2 to expr so that we can handle computed
10150 : GOTOs as normal SELECTs from here on. */
10151 5 : code->expr1 = code->expr2;
10152 5 : code->expr2 = NULL;
10153 5 : return;
10154 : }
10155 :
10156 682 : case_expr = code->expr1;
10157 682 : type = case_expr->ts.type;
10158 :
10159 : /* F08:C830. */
10160 682 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10161 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10162 :
10163 : {
10164 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10165 : &case_expr->where, gfc_typename (case_expr));
10166 :
10167 : /* Punt. Going on here just produce more garbage error messages. */
10168 0 : return;
10169 : }
10170 :
10171 : /* F08:R842. */
10172 682 : if (!select_type && case_expr->rank != 0)
10173 : {
10174 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10175 : "expression", &case_expr->where);
10176 :
10177 : /* Punt. */
10178 1 : return;
10179 : }
10180 :
10181 : /* Raise a warning if an INTEGER case value exceeds the range of
10182 : the case-expr. Later, all expressions will be promoted to the
10183 : largest kind of all case-labels. */
10184 :
10185 681 : if (type == BT_INTEGER)
10186 1927 : for (body = code->block; body; body = body->block)
10187 2852 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10188 : {
10189 1462 : if (cp->low
10190 1462 : && gfc_check_integer_range (cp->low->value.integer,
10191 : case_expr->ts.kind) != ARITH_OK)
10192 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10193 6 : "not in the range of %s", &cp->low->where,
10194 : gfc_typename (case_expr));
10195 :
10196 1462 : if (cp->high
10197 1178 : && cp->low != cp->high
10198 1570 : && gfc_check_integer_range (cp->high->value.integer,
10199 : case_expr->ts.kind) != ARITH_OK)
10200 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10201 0 : "not in the range of %s", &cp->high->where,
10202 : gfc_typename (case_expr));
10203 : }
10204 :
10205 : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10206 : of the SELECT CASE expression and its CASE values. Walk the lists
10207 : of case values, and if we find a mismatch, promote case_expr to
10208 : the appropriate kind. */
10209 :
10210 681 : if (type == BT_LOGICAL || type == BT_INTEGER)
10211 : {
10212 2113 : for (body = code->block; body; body = body->block)
10213 : {
10214 : /* Walk the case label list. */
10215 3113 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10216 : {
10217 : /* Intercept the DEFAULT case. It does not have a kind. */
10218 1597 : if (cp->low == NULL && cp->high == NULL)
10219 292 : continue;
10220 :
10221 : /* Unreachable case ranges are discarded, so ignore. */
10222 1260 : if (cp->low != NULL && cp->high != NULL
10223 1212 : && cp->low != cp->high
10224 1370 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10225 33 : continue;
10226 :
10227 1272 : if (cp->low != NULL
10228 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10229 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10230 :
10231 1272 : if (cp->high != NULL
10232 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10233 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10234 : }
10235 : }
10236 : }
10237 :
10238 : /* Assume there is no DEFAULT case. */
10239 681 : default_case = NULL;
10240 681 : head = tail = NULL;
10241 681 : ncases = 0;
10242 681 : seen_logical = 0;
10243 :
10244 2502 : for (body = code->block; body; body = body->block)
10245 : {
10246 : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10247 1821 : t = true;
10248 1821 : seen_unreachable = 0;
10249 :
10250 : /* Walk the case label list, making sure that all case labels
10251 : are legal. */
10252 3829 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10253 : {
10254 : /* Count the number of cases in the whole construct. */
10255 2019 : ncases++;
10256 :
10257 : /* Intercept the DEFAULT case. */
10258 2019 : if (cp->low == NULL && cp->high == NULL)
10259 : {
10260 362 : if (default_case != NULL)
10261 : {
10262 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10263 : "by a second DEFAULT CASE at %L",
10264 : &default_case->where, &cp->where);
10265 0 : t = false;
10266 0 : break;
10267 : }
10268 : else
10269 : {
10270 362 : default_case = cp;
10271 362 : continue;
10272 : }
10273 : }
10274 :
10275 : /* Deal with single value cases and case ranges. Errors are
10276 : issued from the validation function. */
10277 1657 : if (!validate_case_label_expr (cp->low, case_expr)
10278 1657 : || !validate_case_label_expr (cp->high, case_expr))
10279 : {
10280 : t = false;
10281 : break;
10282 : }
10283 :
10284 1649 : if (type == BT_LOGICAL
10285 78 : && ((cp->low == NULL || cp->high == NULL)
10286 76 : || cp->low != cp->high))
10287 : {
10288 2 : gfc_error ("Logical range in CASE statement at %L is not "
10289 : "allowed",
10290 1 : cp->low ? &cp->low->where : &cp->high->where);
10291 2 : t = false;
10292 2 : break;
10293 : }
10294 :
10295 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10296 : {
10297 76 : int value;
10298 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10299 76 : if (value & seen_logical)
10300 : {
10301 1 : gfc_error ("Constant logical value in CASE statement "
10302 : "is repeated at %L",
10303 : &cp->low->where);
10304 1 : t = false;
10305 1 : break;
10306 : }
10307 75 : seen_logical |= value;
10308 : }
10309 :
10310 1602 : if (cp->low != NULL && cp->high != NULL
10311 1555 : && cp->low != cp->high
10312 1758 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10313 : {
10314 35 : if (warn_surprising)
10315 1 : gfc_warning (OPT_Wsurprising,
10316 : "Range specification at %L can never be matched",
10317 : &cp->where);
10318 :
10319 35 : cp->unreachable = 1;
10320 35 : seen_unreachable = 1;
10321 : }
10322 : else
10323 : {
10324 : /* If the case range can be matched, it can also overlap with
10325 : other cases. To make sure it does not, we put it in a
10326 : double linked list here. We sort that with a merge sort
10327 : later on to detect any overlapping cases. */
10328 1611 : if (!head)
10329 : {
10330 646 : head = tail = cp;
10331 646 : head->right = head->left = NULL;
10332 : }
10333 : else
10334 : {
10335 965 : tail->right = cp;
10336 965 : tail->right->left = tail;
10337 965 : tail = tail->right;
10338 965 : tail->right = NULL;
10339 : }
10340 : }
10341 : }
10342 :
10343 : /* It there was a failure in the previous case label, give up
10344 : for this case label list. Continue with the next block. */
10345 1821 : if (!t)
10346 11 : continue;
10347 :
10348 : /* See if any case labels that are unreachable have been seen.
10349 : If so, we eliminate them. This is a bit of a kludge because
10350 : the case lists for a single case statement (label) is a
10351 : single forward linked lists. */
10352 1810 : if (seen_unreachable)
10353 : {
10354 : /* Advance until the first case in the list is reachable. */
10355 69 : while (body->ext.block.case_list != NULL
10356 69 : && body->ext.block.case_list->unreachable)
10357 : {
10358 34 : gfc_case *n = body->ext.block.case_list;
10359 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10360 34 : n->next = NULL;
10361 34 : gfc_free_case_list (n);
10362 : }
10363 :
10364 : /* Strip all other unreachable cases. */
10365 35 : if (body->ext.block.case_list)
10366 : {
10367 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10368 : {
10369 1 : if (cp->next->unreachable)
10370 : {
10371 1 : gfc_case *n = cp->next;
10372 1 : cp->next = cp->next->next;
10373 1 : n->next = NULL;
10374 1 : gfc_free_case_list (n);
10375 : }
10376 : }
10377 : }
10378 : }
10379 : }
10380 :
10381 : /* See if there were overlapping cases. If the check returns NULL,
10382 : there was overlap. In that case we don't do anything. If head
10383 : is non-NULL, we prepend the DEFAULT case. The sorted list can
10384 : then used during code generation for SELECT CASE constructs with
10385 : a case expression of a CHARACTER type. */
10386 681 : if (head)
10387 : {
10388 646 : head = check_case_overlap (head);
10389 :
10390 : /* Prepend the default_case if it is there. */
10391 646 : if (head != NULL && default_case)
10392 : {
10393 345 : default_case->left = NULL;
10394 345 : default_case->right = head;
10395 345 : head->left = default_case;
10396 : }
10397 : }
10398 :
10399 : /* Eliminate dead blocks that may be the result if we've seen
10400 : unreachable case labels for a block. */
10401 2468 : for (body = code; body && body->block; body = body->block)
10402 : {
10403 1787 : if (body->block->ext.block.case_list == NULL)
10404 : {
10405 : /* Cut the unreachable block from the code chain. */
10406 34 : gfc_code *c = body->block;
10407 34 : body->block = c->block;
10408 :
10409 : /* Kill the dead block, but not the blocks below it. */
10410 34 : c->block = NULL;
10411 34 : gfc_free_statements (c);
10412 : }
10413 : }
10414 :
10415 : /* More than two cases is legal but insane for logical selects.
10416 : Issue a warning for it. */
10417 681 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10418 0 : gfc_warning (OPT_Wsurprising,
10419 : "Logical SELECT CASE block at %L has more that two cases",
10420 : &code->loc);
10421 : }
10422 :
10423 :
10424 : /* Check if a derived type is extensible. */
10425 :
10426 : bool
10427 23771 : gfc_type_is_extensible (gfc_symbol *sym)
10428 : {
10429 23771 : return !(sym->attr.is_bind_c || sym->attr.sequence
10430 23755 : || (sym->attr.is_class
10431 2208 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10432 : }
10433 :
10434 :
10435 : static void
10436 : resolve_types (gfc_namespace *ns);
10437 :
10438 : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10439 : correct as well as possibly the array-spec. */
10440 :
10441 : static void
10442 12748 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10443 : {
10444 12748 : gfc_expr* target;
10445 12748 : bool parentheses = false;
10446 :
10447 12748 : gcc_assert (sym->assoc);
10448 12748 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10449 :
10450 12748 : if (sym->assoc->target
10451 7600 : && sym->assoc->target->expr_type == EXPR_FUNCTION
10452 540 : && sym->assoc->target->symtree
10453 540 : && sym->assoc->target->symtree->n.sym
10454 540 : && sym->assoc->target->symtree->n.sym->attr.generic)
10455 : {
10456 33 : if (gfc_resolve_expr (sym->assoc->target))
10457 33 : sym->ts = sym->assoc->target->ts;
10458 : else
10459 : {
10460 0 : gfc_error ("%s could not be resolved to a specific function at %L",
10461 0 : sym->assoc->target->symtree->n.sym->name,
10462 0 : &sym->assoc->target->where);
10463 0 : return;
10464 : }
10465 : }
10466 :
10467 : /* If this is for SELECT TYPE, the target may not yet be set. In that
10468 : case, return. Resolution will be called later manually again when
10469 : this is done. */
10470 12748 : target = sym->assoc->target;
10471 12748 : if (!target)
10472 : return;
10473 7600 : gcc_assert (!sym->assoc->dangling);
10474 :
10475 7600 : if (target->expr_type == EXPR_OP
10476 260 : && target->value.op.op == INTRINSIC_PARENTHESES
10477 42 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
10478 : {
10479 23 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
10480 23 : gfc_free_expr (target);
10481 23 : target = sym->assoc->target;
10482 23 : parentheses = true;
10483 : }
10484 :
10485 7600 : if (resolve_target && !gfc_resolve_expr (target))
10486 : return;
10487 :
10488 7595 : if (sym->assoc->ar)
10489 : {
10490 : int dim;
10491 : gfc_array_ref *ar = sym->assoc->ar;
10492 68 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10493 : {
10494 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10495 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10496 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10497 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10498 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10499 : "remapping of associate name %s at %L",
10500 : sym->name, &sym->declared_at);
10501 : }
10502 : }
10503 :
10504 : /* For variable targets, we get some attributes from the target. */
10505 7595 : if (target->expr_type == EXPR_VARIABLE)
10506 : {
10507 6611 : gfc_symbol *tsym, *dsym;
10508 :
10509 6611 : gcc_assert (target->symtree);
10510 6611 : tsym = target->symtree->n.sym;
10511 :
10512 6611 : if (gfc_expr_attr (target).proc_pointer)
10513 : {
10514 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10515 : tsym->name, &target->where);
10516 0 : return;
10517 : }
10518 :
10519 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10520 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10521 6612 : && dsym->attr.flavor == FL_DERIVED)
10522 : {
10523 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10524 : tsym->name, &target->where);
10525 1 : return;
10526 : }
10527 :
10528 6610 : if (tsym->attr.flavor == FL_PROCEDURE)
10529 : {
10530 73 : bool is_error = true;
10531 73 : if (tsym->attr.function && tsym->result == tsym)
10532 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10533 137 : if (tsym == ns->proc_name)
10534 : {
10535 : is_error = false;
10536 : break;
10537 : }
10538 64 : if (is_error)
10539 : {
10540 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10541 : tsym->name, &target->where);
10542 13 : return;
10543 : }
10544 : }
10545 :
10546 6597 : sym->attr.asynchronous = tsym->attr.asynchronous;
10547 6597 : sym->attr.volatile_ = tsym->attr.volatile_;
10548 :
10549 13194 : sym->attr.target = tsym->attr.target
10550 6597 : || gfc_expr_attr (target).pointer;
10551 6597 : if (is_subref_array (target))
10552 402 : sym->attr.subref_array_pointer = 1;
10553 : }
10554 984 : else if (target->ts.type == BT_PROCEDURE)
10555 : {
10556 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10557 : &target->where);
10558 0 : return;
10559 : }
10560 :
10561 7581 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10562 : {
10563 : /* By now, the type of the target has been fixed up. */
10564 293 : symbol_attribute attr;
10565 :
10566 293 : if (sym->ts.type == BT_DERIVED
10567 166 : && target->ts.type == BT_CLASS
10568 31 : && !UNLIMITED_POLY (target))
10569 : {
10570 : /* Inferred to be derived type but the target has type class. */
10571 31 : sym->ts = CLASS_DATA (target)->ts;
10572 31 : if (!sym->as)
10573 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10574 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10575 31 : sym->attr.dimension = target->rank ? 1 : 0;
10576 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10577 : target->corank);
10578 31 : sym->as = NULL;
10579 : }
10580 262 : else if (target->ts.type == BT_DERIVED
10581 135 : && target->symtree && target->symtree->n.sym
10582 111 : && target->symtree->n.sym->ts.type == BT_CLASS
10583 0 : && IS_INFERRED_TYPE (target)
10584 0 : && target->ref && target->ref->next
10585 0 : && target->ref->next->type == REF_ARRAY
10586 0 : && !target->ref->next->next)
10587 : {
10588 : /* A inferred type selector whose symbol has been determined to be
10589 : a class array but which only has an array reference. Change the
10590 : associate name and the selector to class type. */
10591 0 : sym->ts = target->ts;
10592 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10593 0 : sym->attr.dimension = target->rank ? 1 : 0;
10594 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10595 : target->corank);
10596 0 : sym->as = NULL;
10597 0 : target->ts = sym->ts;
10598 : }
10599 262 : else if ((target->ts.type == BT_DERIVED)
10600 127 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10601 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10602 : /* Confirmed to be either a derived type or misidentified to be a
10603 : scalar class object, when the selector is a class array. */
10604 141 : sym->ts = target->ts;
10605 : }
10606 :
10607 :
10608 7581 : if (target->expr_type == EXPR_NULL)
10609 : {
10610 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10611 1 : return;
10612 : }
10613 7580 : else if (target->ts.type == BT_UNKNOWN)
10614 : {
10615 2 : gfc_error ("Selector at %L has no type", &target->where);
10616 2 : return;
10617 : }
10618 :
10619 : /* Get type if this was not already set. Note that it can be
10620 : some other type than the target in case this is a SELECT TYPE
10621 : selector! So we must not update when the type is already there. */
10622 7578 : if (sym->ts.type == BT_UNKNOWN)
10623 257 : sym->ts = target->ts;
10624 :
10625 7578 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10626 :
10627 : /* See if this is a valid association-to-variable. */
10628 15156 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10629 6597 : && !parentheses
10630 6576 : && !gfc_has_vector_subscript (target))
10631 7626 : || gfc_is_ptr_fcn (target));
10632 :
10633 : /* Finally resolve if this is an array or not. */
10634 7578 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10635 179 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10636 : {
10637 103 : gfc_expression_rank (target);
10638 103 : if (target->ts.type == BT_DERIVED
10639 56 : && !sym->as
10640 56 : && target->symtree->n.sym->as)
10641 : {
10642 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10643 0 : sym->attr.dimension = 1;
10644 : }
10645 103 : else if (target->ts.type == BT_CLASS
10646 47 : && CLASS_DATA (target)->as)
10647 : {
10648 0 : target->rank = CLASS_DATA (target)->as->rank;
10649 0 : target->corank = CLASS_DATA (target)->as->corank;
10650 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10651 : {
10652 0 : sym->ts = target->ts;
10653 0 : sym->attr.dimension = 0;
10654 : }
10655 : }
10656 : }
10657 :
10658 :
10659 7578 : if (sym->attr.dimension && target->rank == 0)
10660 : {
10661 : /* primary.cc makes the assumption that a reference to an associate
10662 : name followed by a left parenthesis is an array reference. */
10663 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10664 : {
10665 12 : gfc_expression_rank (sym->assoc->target);
10666 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10667 12 : if (!sym->attr.dimension && sym->as)
10668 0 : sym->as = NULL;
10669 : }
10670 :
10671 17 : if (sym->attr.dimension && target->rank == 0)
10672 : {
10673 5 : if (sym->ts.type != BT_CHARACTER)
10674 5 : gfc_error ("Associate-name %qs at %L is used as array",
10675 : sym->name, &sym->declared_at);
10676 5 : sym->attr.dimension = 0;
10677 5 : return;
10678 : }
10679 : }
10680 :
10681 : /* We cannot deal with class selectors that need temporaries. */
10682 7573 : if (target->ts.type == BT_CLASS
10683 7573 : && gfc_ref_needs_temporary_p (target->ref))
10684 : {
10685 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10686 : "yet implemented", &target->where);
10687 1 : return;
10688 : }
10689 :
10690 7572 : if (target->ts.type == BT_CLASS)
10691 2779 : gfc_fix_class_refs (target);
10692 :
10693 7572 : if ((target->rank > 0 || target->corank > 0)
10694 2725 : && !sym->attr.select_rank_temporary)
10695 : {
10696 2725 : gfc_array_spec *as;
10697 : /* The rank may be incorrectly guessed at parsing, therefore make sure
10698 : it is corrected now. */
10699 2725 : if (sym->ts.type != BT_CLASS
10700 2149 : && (!sym->as || sym->as->corank != target->corank))
10701 : {
10702 140 : if (!sym->as)
10703 133 : sym->as = gfc_get_array_spec ();
10704 140 : as = sym->as;
10705 140 : as->rank = target->rank;
10706 140 : as->type = AS_DEFERRED;
10707 140 : as->corank = target->corank;
10708 140 : sym->attr.dimension = 1;
10709 140 : if (as->corank != 0)
10710 7 : sym->attr.codimension = 1;
10711 : }
10712 2585 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10713 575 : && (!CLASS_DATA (sym)->as
10714 575 : || CLASS_DATA (sym)->as->corank != target->corank))
10715 : {
10716 0 : if (!CLASS_DATA (sym)->as)
10717 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10718 0 : as = CLASS_DATA (sym)->as;
10719 0 : as->rank = target->rank;
10720 0 : as->type = AS_DEFERRED;
10721 0 : as->corank = target->corank;
10722 0 : CLASS_DATA (sym)->attr.dimension = 1;
10723 0 : if (as->corank != 0)
10724 0 : CLASS_DATA (sym)->attr.codimension = 1;
10725 : }
10726 : }
10727 4847 : else if (!sym->attr.select_rank_temporary)
10728 : {
10729 : /* target's rank is 0, but the type of the sym is still array valued,
10730 : which has to be corrected. */
10731 3464 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10732 700 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10733 : {
10734 24 : gfc_array_spec *as;
10735 24 : symbol_attribute attr;
10736 : /* The associated variable's type is still the array type
10737 : correct this now. */
10738 24 : gfc_typespec *ts = &target->ts;
10739 24 : gfc_ref *ref;
10740 : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10741 : */
10742 24 : bool internal_ref = true;
10743 :
10744 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10745 : {
10746 48 : switch (ref->type)
10747 : {
10748 24 : case REF_COMPONENT:
10749 24 : ts = &ref->u.c.component->ts;
10750 24 : internal_ref
10751 24 : = target->ref == ref && ref->next
10752 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10753 : break;
10754 24 : case REF_ARRAY:
10755 24 : if (ts->type == BT_CLASS)
10756 0 : ts = &ts->u.derived->components->ts;
10757 24 : if (internal_ref && ref->u.ar.codimen > 0)
10758 0 : for (int i = ref->u.ar.dimen;
10759 : internal_ref
10760 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
10761 : ++i)
10762 0 : internal_ref
10763 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
10764 : break;
10765 : default:
10766 : break;
10767 : }
10768 : }
10769 : /* Only rewrite the type of this symbol, when the refs are not the
10770 : internal ones for class and co-array this-image. */
10771 24 : if (!internal_ref)
10772 : {
10773 : /* Create a scalar instance of the current class type. Because
10774 : the rank of a class array goes into its name, the type has to
10775 : be rebuilt. The alternative of (re-)setting just the
10776 : attributes and as in the current type, destroys the type also
10777 : in other places. */
10778 0 : as = NULL;
10779 0 : sym->ts = *ts;
10780 0 : sym->ts.type = BT_CLASS;
10781 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10782 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
10783 0 : sym->as = NULL;
10784 : }
10785 : }
10786 : }
10787 :
10788 : /* Mark this as an associate variable. */
10789 7572 : sym->attr.associate_var = 1;
10790 :
10791 : /* Fix up the type-spec for CHARACTER types. */
10792 7572 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
10793 : {
10794 502 : gfc_ref *ref;
10795 787 : for (ref = target->ref; ref; ref = ref->next)
10796 311 : if (ref->type == REF_SUBSTRING
10797 74 : && (ref->u.ss.start == NULL
10798 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
10799 74 : || ref->u.ss.end == NULL
10800 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
10801 : break;
10802 :
10803 502 : if (!sym->ts.u.cl)
10804 182 : sym->ts.u.cl = target->ts.u.cl;
10805 :
10806 502 : if (sym->ts.deferred
10807 189 : && sym->ts.u.cl == target->ts.u.cl)
10808 : {
10809 110 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10810 110 : sym->ts.deferred = 1;
10811 : }
10812 :
10813 502 : if (!sym->ts.u.cl->length
10814 326 : && !sym->ts.deferred
10815 137 : && target->expr_type == EXPR_CONSTANT)
10816 : {
10817 30 : sym->ts.u.cl->length =
10818 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
10819 30 : target->value.character.length);
10820 : }
10821 472 : else if (((!sym->ts.u.cl->length
10822 176 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10823 302 : && target->expr_type != EXPR_VARIABLE)
10824 350 : || ref)
10825 : {
10826 148 : if (!sym->ts.deferred)
10827 : {
10828 44 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10829 44 : sym->ts.deferred = 1;
10830 : }
10831 :
10832 : /* This is reset in trans-stmt.cc after the assignment
10833 : of the target expression to the associate name. */
10834 148 : if (ref && sym->as)
10835 26 : sym->attr.pointer = 1;
10836 : else
10837 122 : sym->attr.allocatable = 1;
10838 : }
10839 : }
10840 :
10841 7572 : if (sym->ts.type == BT_CLASS
10842 1421 : && IS_INFERRED_TYPE (target)
10843 13 : && target->ts.type == BT_DERIVED
10844 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
10845 0 : && target->ref && target->ref->next && !target->ref->next->next
10846 0 : && target->ref->next->type == REF_ARRAY)
10847 0 : target->ts = target->symtree->n.sym->ts;
10848 :
10849 : /* If the target is a good class object, so is the associate variable. */
10850 7572 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
10851 713 : sym->attr.class_ok = 1;
10852 :
10853 : /* If the target is a contiguous pointer, so is the associate variable. */
10854 7572 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
10855 3 : sym->attr.contiguous = 1;
10856 : }
10857 :
10858 :
10859 : /* Ensure that SELECT TYPE expressions have the correct rank and a full
10860 : array reference, where necessary. The symbols are artificial and so
10861 : the dimension attribute and arrayspec can also be set. In addition,
10862 : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
10863 : This is corrected here as well.*/
10864 :
10865 : static void
10866 1681 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
10867 : gfc_ref *ref)
10868 : {
10869 1681 : gfc_ref *nref = (*expr1)->ref;
10870 1681 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
10871 1681 : gfc_symbol *sym2;
10872 1681 : gfc_expr *selector = gfc_copy_expr (expr2);
10873 :
10874 1681 : (*expr1)->rank = rank;
10875 1681 : (*expr1)->corank = corank;
10876 1681 : if (selector)
10877 : {
10878 311 : gfc_resolve_expr (selector);
10879 311 : if (selector->expr_type == EXPR_OP
10880 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
10881 2 : sym2 = selector->value.op.op1->symtree->n.sym;
10882 309 : else if (selector->expr_type == EXPR_VARIABLE
10883 7 : || selector->expr_type == EXPR_FUNCTION)
10884 309 : sym2 = selector->symtree->n.sym;
10885 : else
10886 0 : gcc_unreachable ();
10887 : }
10888 : else
10889 : sym2 = NULL;
10890 :
10891 1681 : if (sym1->ts.type == BT_CLASS)
10892 : {
10893 1681 : if ((*expr1)->ts.type != BT_CLASS)
10894 13 : (*expr1)->ts = sym1->ts;
10895 :
10896 1681 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
10897 1681 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
10898 1681 : if (CLASS_DATA (sym1)->as == NULL && sym2)
10899 1 : CLASS_DATA (sym1)->as
10900 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
10901 : }
10902 : else
10903 : {
10904 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
10905 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
10906 0 : if (sym1->as == NULL && sym2)
10907 0 : sym1->as = gfc_copy_array_spec (sym2->as);
10908 : }
10909 :
10910 3045 : for (; nref; nref = nref->next)
10911 2734 : if (nref->next == NULL)
10912 : break;
10913 :
10914 1681 : if (ref && nref && nref->type != REF_ARRAY)
10915 6 : nref->next = gfc_copy_ref (ref);
10916 1675 : else if (ref && !nref)
10917 302 : (*expr1)->ref = gfc_copy_ref (ref);
10918 1373 : else if (ref && nref->u.ar.codimen != corank)
10919 : {
10920 976 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
10921 915 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
10922 61 : nref->u.ar.codimen = corank;
10923 : }
10924 1681 : }
10925 :
10926 :
10927 : static gfc_expr *
10928 6740 : build_loc_call (gfc_expr *sym_expr)
10929 : {
10930 6740 : gfc_expr *loc_call;
10931 6740 : loc_call = gfc_get_expr ();
10932 6740 : loc_call->expr_type = EXPR_FUNCTION;
10933 6740 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
10934 6740 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
10935 6740 : loc_call->symtree->n.sym->attr.intrinsic = 1;
10936 6740 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
10937 6740 : gfc_commit_symbol (loc_call->symtree->n.sym);
10938 6740 : loc_call->ts.type = BT_INTEGER;
10939 6740 : loc_call->ts.kind = gfc_index_integer_kind;
10940 6740 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
10941 6740 : loc_call->value.function.actual = gfc_get_actual_arglist ();
10942 6740 : loc_call->value.function.actual->expr = sym_expr;
10943 6740 : loc_call->where = sym_expr->where;
10944 6740 : return loc_call;
10945 : }
10946 :
10947 : /* Resolve a SELECT TYPE statement. */
10948 :
10949 : static void
10950 3023 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
10951 : {
10952 3023 : gfc_symbol *selector_type;
10953 3023 : gfc_code *body, *new_st, *if_st, *tail;
10954 3023 : gfc_code *class_is = NULL, *default_case = NULL;
10955 3023 : gfc_case *c;
10956 3023 : gfc_symtree *st;
10957 3023 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
10958 3023 : gfc_namespace *ns;
10959 3023 : int error = 0;
10960 3023 : int rank = 0, corank = 0;
10961 3023 : gfc_ref* ref = NULL;
10962 3023 : gfc_expr *selector_expr = NULL;
10963 3023 : gfc_code *old_code = code;
10964 :
10965 3023 : ns = code->ext.block.ns;
10966 3023 : if (code->expr2)
10967 : {
10968 : /* Set this, or coarray checks in resolve will fail. */
10969 639 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
10970 : }
10971 3023 : gfc_resolve (ns);
10972 :
10973 : /* Check for F03:C813. */
10974 3023 : if (code->expr1->ts.type != BT_CLASS
10975 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
10976 : {
10977 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
10978 : "at %L", &code->loc);
10979 42 : return;
10980 : }
10981 :
10982 : /* Prevent segfault, when class type is not initialized due to previous
10983 : error. */
10984 3010 : if (!code->expr1->symtree->n.sym->attr.class_ok
10985 3008 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
10986 : return;
10987 :
10988 3003 : if (code->expr2)
10989 : {
10990 630 : gfc_ref *ref2 = NULL;
10991 1466 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
10992 836 : if (ref->type == REF_COMPONENT
10993 432 : && ref->u.c.component->ts.type == BT_CLASS)
10994 836 : ref2 = ref;
10995 :
10996 630 : if (ref2)
10997 : {
10998 340 : if (code->expr1->symtree->n.sym->attr.untyped)
10999 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
11000 340 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
11001 : }
11002 : else
11003 : {
11004 290 : if (code->expr1->symtree->n.sym->attr.untyped)
11005 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
11006 : /* Sometimes the selector expression is given the typespec of the
11007 : '_data' field, which is logical enough but inappropriate here. */
11008 290 : if (code->expr2->ts.type == BT_DERIVED
11009 80 : && code->expr2->symtree
11010 80 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
11011 80 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
11012 290 : selector_type = CLASS_DATA (code->expr2)
11013 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
11014 : }
11015 :
11016 630 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
11017 : {
11018 297 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
11019 297 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
11020 297 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
11021 : }
11022 :
11023 : /* F2008: C803 The selector expression must not be coindexed. */
11024 630 : if (gfc_is_coindexed (code->expr2))
11025 : {
11026 4 : gfc_error ("Selector at %L must not be coindexed",
11027 4 : &code->expr2->where);
11028 4 : return;
11029 : }
11030 :
11031 : }
11032 : else
11033 : {
11034 2373 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
11035 :
11036 2373 : if (gfc_is_coindexed (code->expr1))
11037 : {
11038 0 : gfc_error ("Selector at %L must not be coindexed",
11039 0 : &code->expr1->where);
11040 0 : return;
11041 : }
11042 : }
11043 :
11044 : /* Loop over TYPE IS / CLASS IS cases. */
11045 8367 : for (body = code->block; body; body = body->block)
11046 : {
11047 5369 : c = body->ext.block.case_list;
11048 :
11049 5369 : if (!error)
11050 : {
11051 : /* Check for repeated cases. */
11052 8334 : for (tail = code->block; tail; tail = tail->block)
11053 : {
11054 8334 : gfc_case *d = tail->ext.block.case_list;
11055 8334 : if (tail == body)
11056 : break;
11057 :
11058 2974 : if (c->ts.type == d->ts.type
11059 516 : && ((c->ts.type == BT_DERIVED
11060 418 : && c->ts.u.derived && d->ts.u.derived
11061 418 : && !strcmp (c->ts.u.derived->name,
11062 : d->ts.u.derived->name))
11063 515 : || c->ts.type == BT_UNKNOWN
11064 515 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11065 55 : && c->ts.kind == d->ts.kind)))
11066 : {
11067 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11068 : &c->where, &d->where);
11069 1 : return;
11070 : }
11071 : }
11072 : }
11073 :
11074 : /* Check F03:C815. */
11075 3404 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11076 2312 : && selector_type
11077 2312 : && !selector_type->attr.unlimited_polymorphic
11078 7359 : && !gfc_type_is_extensible (c->ts.u.derived))
11079 : {
11080 1 : gfc_error ("Derived type %qs at %L must be extensible",
11081 1 : c->ts.u.derived->name, &c->where);
11082 1 : error++;
11083 1 : continue;
11084 : }
11085 :
11086 : /* Check F03:C816. */
11087 5373 : if (c->ts.type != BT_UNKNOWN
11088 3757 : && selector_type && !selector_type->attr.unlimited_polymorphic
11089 7361 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11090 1990 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11091 : {
11092 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11093 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11094 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11095 : else
11096 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11097 : gfc_basic_typename (c->ts.type), &c->where);
11098 6 : error++;
11099 6 : continue;
11100 : }
11101 :
11102 : /* Check F03:C814. */
11103 5361 : if (c->ts.type == BT_CHARACTER
11104 736 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11105 : {
11106 0 : gfc_error ("The type-spec at %L shall specify that each length "
11107 : "type parameter is assumed", &c->where);
11108 0 : error++;
11109 0 : continue;
11110 : }
11111 :
11112 : /* Intercept the DEFAULT case. */
11113 5361 : if (c->ts.type == BT_UNKNOWN)
11114 : {
11115 : /* Check F03:C818. */
11116 1610 : if (default_case)
11117 : {
11118 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11119 : "by a second DEFAULT CASE at %L",
11120 1 : &default_case->ext.block.case_list->where, &c->where);
11121 1 : error++;
11122 1 : continue;
11123 : }
11124 :
11125 : default_case = body;
11126 : }
11127 : }
11128 :
11129 2998 : if (error > 0)
11130 : return;
11131 :
11132 : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11133 : target if present. If there are any EXIT statements referring to the
11134 : SELECT TYPE construct, this is no problem because the gfc_code
11135 : reference stays the same and EXIT is equally possible from the BLOCK
11136 : it is changed to. */
11137 2995 : code->op = EXEC_BLOCK;
11138 2995 : if (code->expr2)
11139 : {
11140 626 : gfc_association_list* assoc;
11141 :
11142 626 : assoc = gfc_get_association_list ();
11143 626 : assoc->st = code->expr1->symtree;
11144 626 : assoc->target = gfc_copy_expr (code->expr2);
11145 626 : assoc->target->where = code->expr2->where;
11146 : /* assoc->variable will be set by resolve_assoc_var. */
11147 :
11148 626 : code->ext.block.assoc = assoc;
11149 626 : code->expr1->symtree->n.sym->assoc = assoc;
11150 :
11151 626 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11152 : }
11153 : else
11154 2369 : code->ext.block.assoc = NULL;
11155 :
11156 : /* Ensure that the selector rank and arrayspec are available to
11157 : correct expressions in which they might be missing. */
11158 2995 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11159 : {
11160 311 : rank = code->expr2->rank;
11161 311 : corank = code->expr2->corank;
11162 585 : for (ref = code->expr2->ref; ref; ref = ref->next)
11163 576 : if (ref->next == NULL)
11164 : break;
11165 311 : if (ref && ref->type == REF_ARRAY)
11166 302 : ref = gfc_copy_ref (ref);
11167 :
11168 : /* Fixup expr1 if necessary. */
11169 311 : if (rank || corank)
11170 311 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11171 : }
11172 2684 : else if (code->expr1->rank || code->expr1->corank)
11173 : {
11174 878 : rank = code->expr1->rank;
11175 878 : corank = code->expr1->corank;
11176 878 : for (ref = code->expr1->ref; ref; ref = ref->next)
11177 878 : if (ref->next == NULL)
11178 : break;
11179 878 : if (ref && ref->type == REF_ARRAY)
11180 878 : ref = gfc_copy_ref (ref);
11181 : }
11182 :
11183 2995 : gfc_expr *orig_expr1 = code->expr1;
11184 :
11185 : /* Add EXEC_SELECT to switch on type. */
11186 2995 : new_st = gfc_get_code (code->op);
11187 2995 : new_st->expr1 = code->expr1;
11188 2995 : new_st->expr2 = code->expr2;
11189 2995 : new_st->block = code->block;
11190 2995 : code->expr1 = code->expr2 = NULL;
11191 2995 : code->block = NULL;
11192 2995 : if (!ns->code)
11193 2995 : ns->code = new_st;
11194 : else
11195 0 : ns->code->next = new_st;
11196 2995 : code = new_st;
11197 2995 : code->op = EXEC_SELECT_TYPE;
11198 :
11199 : /* Use the intrinsic LOC function to generate an integer expression
11200 : for the vtable of the selector. Note that the rank of the selector
11201 : expression has to be set to zero. */
11202 2995 : gfc_add_vptr_component (code->expr1);
11203 2995 : code->expr1->rank = 0;
11204 2995 : code->expr1->corank = 0;
11205 2995 : code->expr1 = build_loc_call (code->expr1);
11206 2995 : selector_expr = code->expr1->value.function.actual->expr;
11207 :
11208 : /* Loop over TYPE IS / CLASS IS cases. */
11209 8348 : for (body = code->block; body; body = body->block)
11210 : {
11211 5353 : gfc_symbol *vtab;
11212 5353 : c = body->ext.block.case_list;
11213 :
11214 : /* Generate an index integer expression for address of the
11215 : TYPE/CLASS vtable and store it in c->low. The hash expression
11216 : is stored in c->high and is used to resolve intrinsic cases. */
11217 5353 : if (c->ts.type != BT_UNKNOWN)
11218 : {
11219 3745 : gfc_expr *e;
11220 3745 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11221 : {
11222 2303 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11223 2303 : gcc_assert (vtab);
11224 2303 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11225 2303 : c->ts.u.derived->hash_value);
11226 : }
11227 : else
11228 : {
11229 1442 : vtab = gfc_find_vtab (&c->ts);
11230 1442 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11231 1442 : e = CLASS_DATA (vtab)->initializer;
11232 1442 : c->high = gfc_copy_expr (e);
11233 1442 : if (c->high->ts.kind != gfc_integer_4_kind)
11234 : {
11235 1 : gfc_typespec ts;
11236 1 : ts.kind = gfc_integer_4_kind;
11237 1 : ts.type = BT_INTEGER;
11238 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11239 : }
11240 : }
11241 :
11242 3745 : e = gfc_lval_expr_from_sym (vtab);
11243 3745 : c->low = build_loc_call (e);
11244 : }
11245 : else
11246 1608 : continue;
11247 :
11248 : /* Associate temporary to selector. This should only be done
11249 : when this case is actually true, so build a new ASSOCIATE
11250 : that does precisely this here (instead of using the
11251 : 'global' one). */
11252 :
11253 : /* First check the derived type import status. */
11254 3745 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11255 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11256 : {
11257 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11258 6 : c->ts.u.derived->name);
11259 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11260 : gfc_current_ns))
11261 6 : error++;
11262 : }
11263 :
11264 3745 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11265 3745 : if (c->ts.type == BT_CLASS)
11266 346 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11267 346 : c->ts.u.derived->name, var_name);
11268 3399 : else if (c->ts.type == BT_DERIVED)
11269 1957 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11270 1957 : c->ts.u.derived->name, var_name);
11271 1442 : else if (c->ts.type == BT_CHARACTER)
11272 : {
11273 736 : HOST_WIDE_INT charlen = 0;
11274 736 : if (c->ts.u.cl && c->ts.u.cl->length
11275 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11276 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11277 736 : snprintf (name, sizeof (name),
11278 : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11279 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11280 : var_name);
11281 : }
11282 : else
11283 706 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11284 : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11285 :
11286 3745 : st = gfc_find_symtree (ns->sym_root, name);
11287 3745 : gcc_assert (st->n.sym->assoc);
11288 3745 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11289 3745 : st->n.sym->assoc->target->where = selector_expr->where;
11290 3745 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11291 : {
11292 3399 : gfc_add_data_component (st->n.sym->assoc->target);
11293 : /* Fixup the target expression if necessary. */
11294 3399 : if (rank || corank)
11295 1370 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11296 : ref);
11297 : }
11298 :
11299 3745 : new_st = gfc_get_code (EXEC_BLOCK);
11300 3745 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11301 3745 : new_st->ext.block.ns->code = body->next;
11302 3745 : body->next = new_st;
11303 :
11304 : /* Chain in the new list only if it is marked as dangling. Otherwise
11305 : there is a CASE label overlap and this is already used. Just ignore,
11306 : the error is diagnosed elsewhere. */
11307 3745 : if (st->n.sym->assoc->dangling)
11308 : {
11309 3744 : new_st->ext.block.assoc = st->n.sym->assoc;
11310 3744 : st->n.sym->assoc->dangling = 0;
11311 : }
11312 :
11313 3745 : resolve_assoc_var (st->n.sym, false);
11314 : }
11315 :
11316 : /* Take out CLASS IS cases for separate treatment. */
11317 : body = code;
11318 8348 : while (body && body->block)
11319 : {
11320 5353 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11321 : {
11322 : /* Add to class_is list. */
11323 346 : if (class_is == NULL)
11324 : {
11325 315 : class_is = body->block;
11326 315 : tail = class_is;
11327 : }
11328 : else
11329 : {
11330 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11331 31 : tail->block = body->block;
11332 31 : tail = tail->block;
11333 : }
11334 : /* Remove from EXEC_SELECT list. */
11335 346 : body->block = body->block->block;
11336 346 : tail->block = NULL;
11337 : }
11338 : else
11339 : body = body->block;
11340 : }
11341 :
11342 2995 : if (class_is)
11343 : {
11344 315 : gfc_symbol *vtab;
11345 :
11346 315 : if (!default_case)
11347 : {
11348 : /* Add a default case to hold the CLASS IS cases. */
11349 313 : for (tail = code; tail->block; tail = tail->block) ;
11350 205 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11351 205 : tail = tail->block;
11352 205 : tail->ext.block.case_list = gfc_get_case ();
11353 205 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11354 205 : tail->next = NULL;
11355 205 : default_case = tail;
11356 : }
11357 :
11358 : /* More than one CLASS IS block? */
11359 315 : if (class_is->block)
11360 : {
11361 37 : gfc_code **c1,*c2;
11362 37 : bool swapped;
11363 : /* Sort CLASS IS blocks by extension level. */
11364 36 : do
11365 : {
11366 37 : swapped = false;
11367 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11368 : {
11369 61 : c2 = (*c1)->block;
11370 : /* F03:C817 (check for doubles). */
11371 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11372 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11373 : {
11374 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11375 : "statement at %L",
11376 : &c2->ext.block.case_list->where);
11377 1 : return;
11378 : }
11379 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11380 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11381 : {
11382 : /* Swap. */
11383 24 : (*c1)->block = c2->block;
11384 24 : c2->block = *c1;
11385 24 : *c1 = c2;
11386 24 : swapped = true;
11387 : }
11388 : }
11389 : }
11390 : while (swapped);
11391 : }
11392 :
11393 : /* Generate IF chain. */
11394 314 : if_st = gfc_get_code (EXEC_IF);
11395 314 : new_st = if_st;
11396 658 : for (body = class_is; body; body = body->block)
11397 : {
11398 344 : new_st->block = gfc_get_code (EXEC_IF);
11399 344 : new_st = new_st->block;
11400 : /* Set up IF condition: Call _gfortran_is_extension_of. */
11401 344 : new_st->expr1 = gfc_get_expr ();
11402 344 : new_st->expr1->expr_type = EXPR_FUNCTION;
11403 344 : new_st->expr1->ts.type = BT_LOGICAL;
11404 344 : new_st->expr1->ts.kind = 4;
11405 344 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11406 344 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11407 344 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11408 : /* Set up arguments. */
11409 344 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11410 344 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11411 344 : new_st->expr1->value.function.actual->expr->where = code->loc;
11412 344 : new_st->expr1->where = code->loc;
11413 344 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11414 344 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11415 344 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11416 344 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11417 344 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11418 344 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11419 : /* Set up types in formal arg list. */
11420 344 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11421 344 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11422 344 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11423 344 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11424 :
11425 344 : new_st->next = body->next;
11426 : }
11427 314 : if (default_case->next)
11428 : {
11429 110 : new_st->block = gfc_get_code (EXEC_IF);
11430 110 : new_st = new_st->block;
11431 110 : new_st->next = default_case->next;
11432 : }
11433 :
11434 : /* Replace CLASS DEFAULT code by the IF chain. */
11435 314 : default_case->next = if_st;
11436 : }
11437 :
11438 : /* Resolve the internal code. This cannot be done earlier because
11439 : it requires that the sym->assoc of selectors is set already. */
11440 2994 : gfc_current_ns = ns;
11441 2994 : gfc_resolve_blocks (code->block, gfc_current_ns);
11442 2994 : gfc_current_ns = old_ns;
11443 :
11444 2994 : free (ref);
11445 : }
11446 :
11447 :
11448 : /* Resolve a SELECT RANK statement. */
11449 :
11450 : static void
11451 1018 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11452 : {
11453 1018 : gfc_namespace *ns;
11454 1018 : gfc_code *body, *new_st, *tail;
11455 1018 : gfc_case *c;
11456 1018 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11457 1018 : char name[2 * GFC_MAX_SYMBOL_LEN];
11458 1018 : gfc_symtree *st;
11459 1018 : gfc_expr *selector_expr = NULL;
11460 1018 : int case_value;
11461 1018 : HOST_WIDE_INT charlen = 0;
11462 :
11463 1018 : ns = code->ext.block.ns;
11464 1018 : gfc_resolve (ns);
11465 :
11466 1018 : code->op = EXEC_BLOCK;
11467 1018 : if (code->expr2)
11468 : {
11469 42 : gfc_association_list* assoc;
11470 :
11471 42 : assoc = gfc_get_association_list ();
11472 42 : assoc->st = code->expr1->symtree;
11473 42 : assoc->target = gfc_copy_expr (code->expr2);
11474 42 : assoc->target->where = code->expr2->where;
11475 : /* assoc->variable will be set by resolve_assoc_var. */
11476 :
11477 42 : code->ext.block.assoc = assoc;
11478 42 : code->expr1->symtree->n.sym->assoc = assoc;
11479 :
11480 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11481 : }
11482 : else
11483 976 : code->ext.block.assoc = NULL;
11484 :
11485 : /* Loop over RANK cases. Note that returning on the errors causes a
11486 : cascade of further errors because the case blocks do not compile
11487 : correctly. */
11488 3320 : for (body = code->block; body; body = body->block)
11489 : {
11490 2302 : c = body->ext.block.case_list;
11491 2302 : if (c->low)
11492 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11493 : else
11494 : case_value = -2;
11495 :
11496 : /* Check for repeated cases. */
11497 5836 : for (tail = code->block; tail; tail = tail->block)
11498 : {
11499 5836 : gfc_case *d = tail->ext.block.case_list;
11500 5836 : int case_value2;
11501 :
11502 5836 : if (tail == body)
11503 : break;
11504 :
11505 : /* Check F2018: C1153. */
11506 3534 : if (!c->low && !d->low)
11507 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11508 : &c->where, &d->where);
11509 :
11510 3534 : if (!c->low || !d->low)
11511 1253 : continue;
11512 :
11513 : /* Check F2018: C1153. */
11514 2281 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11515 2281 : if ((case_value == case_value2) && case_value == -1)
11516 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11517 : &c->where, &d->where);
11518 2280 : else if (case_value == case_value2)
11519 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11520 : case_value, &c->where, &d->where);
11521 : }
11522 :
11523 2302 : if (!c->low)
11524 919 : continue;
11525 :
11526 : /* Check F2018: C1155. */
11527 1383 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11528 1381 : || gfc_expr_attr (code->expr1).pointer))
11529 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11530 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11531 : }
11532 :
11533 : /* Add EXEC_SELECT to switch on rank. */
11534 1018 : new_st = gfc_get_code (code->op);
11535 1018 : new_st->expr1 = code->expr1;
11536 1018 : new_st->expr2 = code->expr2;
11537 1018 : new_st->block = code->block;
11538 1018 : code->expr1 = code->expr2 = NULL;
11539 1018 : code->block = NULL;
11540 1018 : if (!ns->code)
11541 1018 : ns->code = new_st;
11542 : else
11543 0 : ns->code->next = new_st;
11544 1018 : code = new_st;
11545 1018 : code->op = EXEC_SELECT_RANK;
11546 :
11547 1018 : selector_expr = code->expr1;
11548 :
11549 : /* Loop over SELECT RANK cases. */
11550 3320 : for (body = code->block; body; body = body->block)
11551 : {
11552 2302 : c = body->ext.block.case_list;
11553 2302 : int case_value;
11554 :
11555 : /* Pass on the default case. */
11556 2302 : if (c->low == NULL)
11557 919 : continue;
11558 :
11559 : /* Associate temporary to selector. This should only be done
11560 : when this case is actually true, so build a new ASSOCIATE
11561 : that does precisely this here (instead of using the
11562 : 'global' one). */
11563 1383 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11564 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11565 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11566 :
11567 1383 : if (c->ts.type == BT_CLASS)
11568 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11569 1238 : else if (c->ts.type == BT_DERIVED)
11570 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11571 1128 : else if (c->ts.type != BT_CHARACTER)
11572 569 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11573 : else
11574 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11575 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11576 :
11577 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11578 1383 : if (case_value >= 0)
11579 1350 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11580 : else
11581 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11582 :
11583 1383 : st = gfc_find_symtree (ns->sym_root, name);
11584 1383 : gcc_assert (st->n.sym->assoc);
11585 :
11586 1383 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11587 1383 : st->n.sym->assoc->target->where = selector_expr->where;
11588 :
11589 1383 : new_st = gfc_get_code (EXEC_BLOCK);
11590 1383 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11591 1383 : new_st->ext.block.ns->code = body->next;
11592 1383 : body->next = new_st;
11593 :
11594 : /* Chain in the new list only if it is marked as dangling. Otherwise
11595 : there is a CASE label overlap and this is already used. Just ignore,
11596 : the error is diagnosed elsewhere. */
11597 1383 : if (st->n.sym->assoc->dangling)
11598 : {
11599 1381 : new_st->ext.block.assoc = st->n.sym->assoc;
11600 1381 : st->n.sym->assoc->dangling = 0;
11601 : }
11602 :
11603 1383 : resolve_assoc_var (st->n.sym, false);
11604 : }
11605 :
11606 1018 : gfc_current_ns = ns;
11607 1018 : gfc_resolve_blocks (code->block, gfc_current_ns);
11608 1018 : gfc_current_ns = old_ns;
11609 1018 : }
11610 :
11611 :
11612 : /* Resolve a transfer statement. This is making sure that:
11613 : -- a derived type being transferred has only non-pointer components
11614 : -- a derived type being transferred doesn't have private components, unless
11615 : it's being transferred from the module where the type was defined
11616 : -- we're not trying to transfer a whole assumed size array. */
11617 :
11618 : static void
11619 46354 : resolve_transfer (gfc_code *code)
11620 : {
11621 46354 : gfc_symbol *sym, *derived;
11622 46354 : gfc_ref *ref;
11623 46354 : gfc_expr *exp;
11624 46354 : bool write = false;
11625 46354 : bool formatted = false;
11626 46354 : gfc_dt *dt = code->ext.dt;
11627 46354 : gfc_symbol *dtio_sub = NULL;
11628 :
11629 46354 : exp = code->expr1;
11630 :
11631 92714 : while (exp != NULL && exp->expr_type == EXPR_OP
11632 47269 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11633 6 : exp = exp->value.op.op1;
11634 :
11635 46354 : if (exp && exp->expr_type == EXPR_NULL
11636 2 : && code->ext.dt)
11637 : {
11638 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11639 : &exp->where);
11640 2 : return;
11641 : }
11642 :
11643 : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11644 : && exp->expr_type != EXPR_FUNCTION
11645 : && exp->expr_type != EXPR_ARRAY
11646 : && exp->expr_type != EXPR_STRUCTURE))
11647 : return;
11648 :
11649 : /* If we are reading, the variable will be changed. Note that
11650 : code->ext.dt may be NULL if the TRANSFER is related to
11651 : an INQUIRE statement -- but in this case, we are not reading, either. */
11652 25296 : if (dt && dt->dt_io_kind->value.iokind == M_READ
11653 32764 : && !gfc_check_vardef_context (exp, false, false, false,
11654 7320 : _("item in READ")))
11655 : return;
11656 :
11657 25440 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11658 25440 : || exp->expr_type == EXPR_FUNCTION
11659 21066 : || exp->expr_type == EXPR_ARRAY
11660 46506 : ? &exp->ts : &exp->symtree->n.sym->ts;
11661 :
11662 : /* Go to actual component transferred. */
11663 33138 : for (ref = exp->ref; ref; ref = ref->next)
11664 7698 : if (ref->type == REF_COMPONENT)
11665 2181 : ts = &ref->u.c.component->ts;
11666 :
11667 25440 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11668 25292 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11669 : {
11670 718 : derived = ts->u.derived;
11671 :
11672 : /* Determine when to use the formatted DTIO procedure. */
11673 718 : if (dt && (dt->format_expr || dt->format_label))
11674 643 : formatted = true;
11675 :
11676 718 : write = dt->dt_io_kind->value.iokind == M_WRITE
11677 718 : || dt->dt_io_kind->value.iokind == M_PRINT;
11678 718 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11679 :
11680 718 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11681 : {
11682 449 : dt->udtio = exp;
11683 449 : sym = exp->symtree->n.sym->ns->proc_name;
11684 : /* Check to see if this is a nested DTIO call, with the
11685 : dummy as the io-list object. */
11686 449 : if (sym && sym == dtio_sub && sym->formal
11687 30 : && sym->formal->sym == exp->symtree->n.sym
11688 30 : && exp->ref == NULL)
11689 : {
11690 0 : if (!sym->attr.recursive)
11691 : {
11692 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11693 : sym->name, &sym->declared_at);
11694 0 : return;
11695 : }
11696 : }
11697 : }
11698 : }
11699 :
11700 25440 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11701 : {
11702 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11703 : "it is processed by a defined input/output procedure",
11704 : &code->loc);
11705 3 : return;
11706 : }
11707 :
11708 25437 : if (ts->type == BT_DERIVED)
11709 : {
11710 : /* Check that transferred derived type doesn't contain POINTER
11711 : components unless it is processed by a defined input/output
11712 : procedure". */
11713 686 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11714 : {
11715 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11716 : "components unless it is processed by a defined "
11717 : "input/output procedure", &code->loc);
11718 2 : return;
11719 : }
11720 :
11721 : /* F08:C935. */
11722 684 : if (ts->u.derived->attr.proc_pointer_comp)
11723 : {
11724 2 : gfc_error ("Data transfer element at %L cannot have "
11725 : "procedure pointer components", &code->loc);
11726 2 : return;
11727 : }
11728 :
11729 682 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11730 : {
11731 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11732 : "components unless it is processed by a defined "
11733 : "input/output procedure", &code->loc);
11734 6 : return;
11735 : }
11736 :
11737 : /* C_PTR and C_FUNPTR have private components which means they cannot
11738 : be printed. However, if -std=gnu and not -pedantic, allow
11739 : the component to be printed to help debugging. */
11740 676 : if (ts->u.derived->ts.f90_type == BT_VOID)
11741 : {
11742 4 : gfc_error ("Data transfer element at %L "
11743 : "cannot have PRIVATE components", &code->loc);
11744 4 : return;
11745 : }
11746 672 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11747 : {
11748 4 : gfc_error ("Data transfer element at %L cannot have "
11749 : "PRIVATE components unless it is processed by "
11750 : "a defined input/output procedure", &code->loc);
11751 4 : return;
11752 : }
11753 : }
11754 :
11755 25419 : if (exp->expr_type == EXPR_STRUCTURE)
11756 : return;
11757 :
11758 25374 : if (exp->expr_type == EXPR_ARRAY)
11759 : return;
11760 :
11761 24998 : sym = exp->symtree->n.sym;
11762 :
11763 24998 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
11764 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
11765 : {
11766 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
11767 : "an assumed-size array", &code->loc);
11768 1 : return;
11769 : }
11770 : }
11771 :
11772 :
11773 : /*********** Toplevel code resolution subroutines ***********/
11774 :
11775 : /* Find the set of labels that are reachable from this block. We also
11776 : record the last statement in each block. */
11777 :
11778 : static void
11779 673663 : find_reachable_labels (gfc_code *block)
11780 : {
11781 673663 : gfc_code *c;
11782 :
11783 673663 : if (!block)
11784 : return;
11785 :
11786 422473 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
11787 :
11788 : /* Collect labels in this block. We don't keep those corresponding
11789 : to END {IF|SELECT}, these are checked in resolve_branch by going
11790 : up through the code_stack. */
11791 1550045 : for (c = block; c; c = c->next)
11792 : {
11793 1127572 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
11794 3661 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
11795 : }
11796 :
11797 : /* Merge with labels from parent block. */
11798 422473 : if (cs_base->prev)
11799 : {
11800 347020 : gcc_assert (cs_base->prev->reachable_labels);
11801 347020 : bitmap_ior_into (cs_base->reachable_labels,
11802 : cs_base->prev->reachable_labels);
11803 : }
11804 : }
11805 :
11806 : static void
11807 197 : resolve_lock_unlock_event (gfc_code *code)
11808 : {
11809 197 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
11810 197 : && (code->expr1->ts.type != BT_DERIVED
11811 137 : || code->expr1->expr_type != EXPR_VARIABLE
11812 137 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11813 136 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
11814 136 : || code->expr1->rank != 0
11815 181 : || (!gfc_is_coarray (code->expr1) &&
11816 46 : !gfc_is_coindexed (code->expr1))))
11817 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
11818 4 : &code->expr1->where);
11819 193 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
11820 58 : && (code->expr1->ts.type != BT_DERIVED
11821 58 : || code->expr1->expr_type != EXPR_VARIABLE
11822 58 : || code->expr1->ts.u.derived->from_intmod
11823 : != INTMOD_ISO_FORTRAN_ENV
11824 58 : || code->expr1->ts.u.derived->intmod_sym_id
11825 : != ISOFORTRAN_EVENT_TYPE
11826 58 : || code->expr1->rank != 0))
11827 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
11828 : &code->expr1->where);
11829 34 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
11830 209 : && !gfc_is_coindexed (code->expr1))
11831 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
11832 0 : &code->expr1->where);
11833 193 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
11834 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
11835 0 : "coindexed", &code->expr1->where);
11836 :
11837 : /* Check STAT. */
11838 197 : if (code->expr2
11839 54 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
11840 54 : || code->expr2->expr_type != EXPR_VARIABLE))
11841 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11842 : &code->expr2->where);
11843 :
11844 197 : if (code->expr2
11845 251 : && !gfc_check_vardef_context (code->expr2, false, false, false,
11846 54 : _("STAT variable")))
11847 : return;
11848 :
11849 : /* Check ERRMSG. */
11850 197 : if (code->expr3
11851 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
11852 2 : || code->expr3->expr_type != EXPR_VARIABLE))
11853 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
11854 : &code->expr3->where);
11855 :
11856 197 : if (code->expr3
11857 199 : && !gfc_check_vardef_context (code->expr3, false, false, false,
11858 2 : _("ERRMSG variable")))
11859 : return;
11860 :
11861 : /* Check for LOCK the ACQUIRED_LOCK. */
11862 197 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11863 22 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
11864 22 : || code->expr4->expr_type != EXPR_VARIABLE))
11865 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
11866 : "variable", &code->expr4->where);
11867 :
11868 173 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11869 219 : && !gfc_check_vardef_context (code->expr4, false, false, false,
11870 22 : _("ACQUIRED_LOCK variable")))
11871 : return;
11872 :
11873 : /* Check for EVENT WAIT the UNTIL_COUNT. */
11874 197 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
11875 : {
11876 36 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
11877 36 : || code->expr4->rank != 0)
11878 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
11879 0 : "expression", &code->expr4->where);
11880 : }
11881 : }
11882 :
11883 : static void
11884 246 : resolve_team_argument (gfc_expr *team)
11885 : {
11886 246 : gfc_resolve_expr (team);
11887 246 : if (team->rank != 0 || team->ts.type != BT_DERIVED
11888 239 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11889 239 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
11890 : {
11891 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
11892 : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
11893 : &team->where);
11894 : }
11895 246 : }
11896 :
11897 : static void
11898 1358 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
11899 : gfc_expr *e)
11900 : {
11901 1358 : gfc_resolve_expr (e);
11902 1358 : if (e
11903 139 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
11904 124 : || e->expr_type != EXPR_VARIABLE))
11905 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
11906 : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
11907 : exp_kind);
11908 1358 : }
11909 :
11910 : void
11911 679 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
11912 : {
11913 679 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
11914 679 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
11915 : gfc_default_character_kind,
11916 : sync_stat->errmsg);
11917 679 : }
11918 :
11919 : static void
11920 260 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
11921 : gfc_expr *e)
11922 : {
11923 260 : gfc_resolve_expr (e);
11924 260 : if (e
11925 161 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
11926 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
11927 : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
11928 260 : }
11929 :
11930 : static void
11931 130 : resolve_form_team (gfc_code *code)
11932 : {
11933 130 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
11934 : code->expr1);
11935 130 : resolve_team_argument (code->expr2);
11936 130 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
11937 : code->expr3);
11938 130 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11939 130 : }
11940 :
11941 : static void resolve_block_construct (gfc_code *);
11942 :
11943 : static void
11944 73 : resolve_change_team (gfc_code *code)
11945 : {
11946 73 : resolve_team_argument (code->expr1);
11947 73 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
11948 146 : resolve_block_construct (code);
11949 : /* Map the coarray bounds as selected. */
11950 76 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
11951 3 : if (a->ar)
11952 : {
11953 3 : gfc_array_spec *src = a->ar->as, *dst;
11954 3 : if (a->st->n.sym->ts.type == BT_CLASS)
11955 0 : dst = CLASS_DATA (a->st->n.sym)->as;
11956 : else
11957 3 : dst = a->st->n.sym->as;
11958 3 : dst->corank = src->corank;
11959 3 : dst->cotype = src->cotype;
11960 6 : for (int i = 0; i < src->corank; ++i)
11961 : {
11962 3 : dst->lower[dst->rank + i] = src->lower[i];
11963 3 : dst->upper[dst->rank + i] = src->upper[i];
11964 3 : src->lower[i] = src->upper[i] = nullptr;
11965 : }
11966 3 : gfc_free_array_spec (src);
11967 3 : free (a->ar);
11968 3 : a->ar = nullptr;
11969 3 : dst->resolved = false;
11970 3 : gfc_resolve_array_spec (dst, 0);
11971 : }
11972 73 : }
11973 :
11974 : static void
11975 43 : resolve_sync_team (gfc_code *code)
11976 : {
11977 43 : resolve_team_argument (code->expr1);
11978 43 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11979 43 : }
11980 :
11981 : static void
11982 71 : resolve_end_team (gfc_code *code)
11983 : {
11984 71 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11985 71 : }
11986 :
11987 : static void
11988 54 : resolve_critical (gfc_code *code)
11989 : {
11990 54 : gfc_symtree *symtree;
11991 54 : gfc_symbol *lock_type;
11992 54 : char name[GFC_MAX_SYMBOL_LEN];
11993 54 : static int serial = 0;
11994 :
11995 54 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11996 :
11997 54 : if (flag_coarray != GFC_FCOARRAY_LIB)
11998 30 : return;
11999 :
12000 24 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12001 : GFC_PREFIX ("lock_type"));
12002 24 : if (symtree)
12003 12 : lock_type = symtree->n.sym;
12004 : else
12005 : {
12006 12 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
12007 : false) != 0)
12008 0 : gcc_unreachable ();
12009 12 : lock_type = symtree->n.sym;
12010 12 : lock_type->attr.flavor = FL_DERIVED;
12011 12 : lock_type->attr.zero_comp = 1;
12012 12 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
12013 12 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
12014 : }
12015 :
12016 24 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
12017 24 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
12018 0 : gcc_unreachable ();
12019 :
12020 24 : code->resolved_sym = symtree->n.sym;
12021 24 : symtree->n.sym->attr.flavor = FL_VARIABLE;
12022 24 : symtree->n.sym->attr.referenced = 1;
12023 24 : symtree->n.sym->attr.artificial = 1;
12024 24 : symtree->n.sym->attr.codimension = 1;
12025 24 : symtree->n.sym->ts.type = BT_DERIVED;
12026 24 : symtree->n.sym->ts.u.derived = lock_type;
12027 24 : symtree->n.sym->as = gfc_get_array_spec ();
12028 24 : symtree->n.sym->as->corank = 1;
12029 24 : symtree->n.sym->as->type = AS_EXPLICIT;
12030 24 : symtree->n.sym->as->cotype = AS_EXPLICIT;
12031 24 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
12032 : NULL, 1);
12033 24 : gfc_commit_symbols();
12034 : }
12035 :
12036 :
12037 : static void
12038 1307 : resolve_sync (gfc_code *code)
12039 : {
12040 : /* Check imageset. The * case matches expr1 == NULL. */
12041 1307 : if (code->expr1)
12042 : {
12043 71 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
12044 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
12045 : "INTEGER expression", &code->expr1->where);
12046 71 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
12047 27 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
12048 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
12049 : &code->expr1->where);
12050 70 : else if (code->expr1->expr_type == EXPR_ARRAY
12051 70 : && gfc_simplify_expr (code->expr1, 0))
12052 : {
12053 20 : gfc_constructor *cons;
12054 20 : cons = gfc_constructor_first (code->expr1->value.constructor);
12055 60 : for (; cons; cons = gfc_constructor_next (cons))
12056 20 : if (cons->expr->expr_type == EXPR_CONSTANT
12057 20 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
12058 0 : gfc_error ("Imageset argument at %L must between 1 and "
12059 : "num_images()", &cons->expr->where);
12060 : }
12061 : }
12062 :
12063 : /* Check STAT. */
12064 1307 : gfc_resolve_expr (code->expr2);
12065 1307 : if (code->expr2)
12066 : {
12067 108 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12068 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12069 : &code->expr2->where);
12070 : else
12071 107 : gfc_check_vardef_context (code->expr2, false, false, false,
12072 107 : _("STAT variable"));
12073 : }
12074 :
12075 : /* Check ERRMSG. */
12076 1307 : gfc_resolve_expr (code->expr3);
12077 1307 : if (code->expr3)
12078 : {
12079 90 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12080 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12081 : &code->expr3->where);
12082 : else
12083 86 : gfc_check_vardef_context (code->expr3, false, false, false,
12084 86 : _("ERRMSG variable"));
12085 : }
12086 1307 : }
12087 :
12088 :
12089 : /* Given a branch to a label, see if the branch is conforming.
12090 : The code node describes where the branch is located. */
12091 :
12092 : static void
12093 108132 : resolve_branch (gfc_st_label *label, gfc_code *code)
12094 : {
12095 108132 : code_stack *stack;
12096 :
12097 108132 : if (label == NULL)
12098 : return;
12099 :
12100 : /* Step one: is this a valid branching target? */
12101 :
12102 2460 : if (label->defined == ST_LABEL_UNKNOWN)
12103 : {
12104 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12105 : &code->loc);
12106 4 : return;
12107 : }
12108 :
12109 2456 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12110 : {
12111 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12112 : "for the branch statement at %L", &label->where, &code->loc);
12113 4 : return;
12114 : }
12115 :
12116 : /* Step two: make sure this branch is not a branch to itself ;-) */
12117 :
12118 2452 : if (code->here == label)
12119 : {
12120 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12121 : &code->loc);
12122 0 : return;
12123 : }
12124 :
12125 : /* Step three: See if the label is in the same block as the
12126 : branching statement. The hard work has been done by setting up
12127 : the bitmap reachable_labels. */
12128 :
12129 2452 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12130 : {
12131 : /* Check now whether there is a CRITICAL construct; if so, check
12132 : whether the label is still visible outside of the CRITICAL block,
12133 : which is invalid. */
12134 6267 : for (stack = cs_base; stack; stack = stack->prev)
12135 : {
12136 3883 : if (stack->current->op == EXEC_CRITICAL
12137 3883 : && bitmap_bit_p (stack->reachable_labels, label->value))
12138 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12139 : "label at %L", &code->loc, &label->where);
12140 3881 : else if (stack->current->op == EXEC_DO_CONCURRENT
12141 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12142 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12143 : "for label at %L", &code->loc, &label->where);
12144 3881 : else if (stack->current->op == EXEC_CHANGE_TEAM
12145 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12146 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12147 : "for label at %L", &code->loc, &label->where);
12148 : }
12149 :
12150 : return;
12151 : }
12152 :
12153 : /* Step four: If we haven't found the label in the bitmap, it may
12154 : still be the label of the END of the enclosing block, in which
12155 : case we find it by going up the code_stack. */
12156 :
12157 167 : for (stack = cs_base; stack; stack = stack->prev)
12158 : {
12159 131 : if (stack->current->next && stack->current->next->here == label)
12160 : break;
12161 101 : if (stack->current->op == EXEC_CRITICAL)
12162 : {
12163 : /* Note: A label at END CRITICAL does not leave the CRITICAL
12164 : construct as END CRITICAL is still part of it. */
12165 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12166 : " at %L", &code->loc, &label->where);
12167 2 : return;
12168 : }
12169 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12170 : {
12171 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12172 : "label at %L", &code->loc, &label->where);
12173 0 : return;
12174 : }
12175 : }
12176 :
12177 66 : if (stack)
12178 : {
12179 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12180 : return;
12181 : }
12182 :
12183 : /* The label is not in an enclosing block, so illegal. This was
12184 : allowed in Fortran 66, so we allow it as extension. No
12185 : further checks are necessary in this case. */
12186 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12187 : "as the GOTO statement at %L", &label->where,
12188 : &code->loc);
12189 36 : return;
12190 : }
12191 :
12192 :
12193 : /* Check whether EXPR1 has the same shape as EXPR2. */
12194 :
12195 : static bool
12196 1467 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12197 : {
12198 1467 : mpz_t shape[GFC_MAX_DIMENSIONS];
12199 1467 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12200 1467 : bool result = false;
12201 1467 : int i;
12202 :
12203 : /* Compare the rank. */
12204 1467 : if (expr1->rank != expr2->rank)
12205 : return result;
12206 :
12207 : /* Compare the size of each dimension. */
12208 2811 : for (i=0; i<expr1->rank; i++)
12209 : {
12210 1495 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12211 151 : goto ignore;
12212 :
12213 1344 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12214 0 : goto ignore;
12215 :
12216 1344 : if (mpz_cmp (shape[i], shape2[i]))
12217 0 : goto over;
12218 : }
12219 :
12220 : /* When either of the two expression is an assumed size array, we
12221 : ignore the comparison of dimension sizes. */
12222 1316 : ignore:
12223 : result = true;
12224 :
12225 1467 : over:
12226 1467 : gfc_clear_shape (shape, i);
12227 1467 : gfc_clear_shape (shape2, i);
12228 1467 : return result;
12229 : }
12230 :
12231 :
12232 : /* Check whether a WHERE assignment target or a WHERE mask expression
12233 : has the same shape as the outermost WHERE mask expression. */
12234 :
12235 : static void
12236 509 : resolve_where (gfc_code *code, gfc_expr *mask)
12237 : {
12238 509 : gfc_code *cblock;
12239 509 : gfc_code *cnext;
12240 509 : gfc_expr *e = NULL;
12241 :
12242 509 : cblock = code->block;
12243 :
12244 : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12245 : In case of nested WHERE, only the outermost one is stored. */
12246 509 : if (mask == NULL) /* outermost WHERE */
12247 453 : e = cblock->expr1;
12248 : else /* inner WHERE */
12249 509 : e = mask;
12250 :
12251 1387 : while (cblock)
12252 : {
12253 878 : if (cblock->expr1)
12254 : {
12255 : /* Check if the mask-expr has a consistent shape with the
12256 : outermost WHERE mask-expr. */
12257 714 : if (!resolve_where_shape (cblock->expr1, e))
12258 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12259 0 : &cblock->expr1->where);
12260 : }
12261 :
12262 : /* the assignment statement of a WHERE statement, or the first
12263 : statement in where-body-construct of a WHERE construct */
12264 878 : cnext = cblock->next;
12265 1733 : while (cnext)
12266 : {
12267 855 : switch (cnext->op)
12268 : {
12269 : /* WHERE assignment statement */
12270 753 : case EXEC_ASSIGN:
12271 :
12272 : /* Check shape consistent for WHERE assignment target. */
12273 753 : if (e && !resolve_where_shape (cnext->expr1, e))
12274 0 : gfc_error ("WHERE assignment target at %L has "
12275 0 : "inconsistent shape", &cnext->expr1->where);
12276 :
12277 753 : if (cnext->op == EXEC_ASSIGN
12278 753 : && gfc_may_be_finalized (cnext->expr1->ts))
12279 0 : cnext->expr1->must_finalize = 1;
12280 :
12281 : break;
12282 :
12283 :
12284 46 : case EXEC_ASSIGN_CALL:
12285 46 : resolve_call (cnext);
12286 46 : if (!cnext->resolved_sym->attr.elemental)
12287 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12288 2 : &cnext->ext.actual->expr->where);
12289 : break;
12290 :
12291 : /* WHERE or WHERE construct is part of a where-body-construct */
12292 56 : case EXEC_WHERE:
12293 56 : resolve_where (cnext, e);
12294 56 : break;
12295 :
12296 0 : default:
12297 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12298 : &cnext->loc);
12299 : }
12300 : /* the next statement within the same where-body-construct */
12301 855 : cnext = cnext->next;
12302 : }
12303 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12304 878 : cblock = cblock->block;
12305 : }
12306 509 : }
12307 :
12308 :
12309 : /* Resolve assignment in FORALL construct.
12310 : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12311 : FORALL index variables. */
12312 :
12313 : static void
12314 2375 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12315 : {
12316 2375 : int n;
12317 2375 : gfc_symbol *forall_index;
12318 :
12319 6771 : for (n = 0; n < nvar; n++)
12320 : {
12321 4396 : forall_index = var_expr[n]->symtree->n.sym;
12322 :
12323 : /* Check whether the assignment target is one of the FORALL index
12324 : variable. */
12325 4396 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12326 4396 : && (code->expr1->symtree->n.sym == forall_index))
12327 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12328 : &code->expr1->where);
12329 : else
12330 : {
12331 : /* If one of the FORALL index variables doesn't appear in the
12332 : assignment variable, then there could be a many-to-one
12333 : assignment. Emit a warning rather than an error because the
12334 : mask could be resolving this problem.
12335 : DO NOT emit this warning for DO CONCURRENT - reduction-like
12336 : many-to-one assignments are semantically valid (formalized with
12337 : the REDUCE locality-spec in Fortran 2023). */
12338 4396 : if (!find_forall_index (code->expr1, forall_index, 0)
12339 4396 : && !gfc_do_concurrent_flag)
12340 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12341 : "left side of the assignment at %L and so might "
12342 : "cause multiple assignment to this object",
12343 0 : var_expr[n]->symtree->name, &code->expr1->where);
12344 : }
12345 : }
12346 2375 : }
12347 :
12348 :
12349 : /* Resolve WHERE statement in FORALL construct. */
12350 :
12351 : static void
12352 47 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12353 : gfc_expr **var_expr)
12354 : {
12355 47 : gfc_code *cblock;
12356 47 : gfc_code *cnext;
12357 :
12358 47 : cblock = code->block;
12359 113 : while (cblock)
12360 : {
12361 : /* the assignment statement of a WHERE statement, or the first
12362 : statement in where-body-construct of a WHERE construct */
12363 66 : cnext = cblock->next;
12364 132 : while (cnext)
12365 : {
12366 66 : switch (cnext->op)
12367 : {
12368 : /* WHERE assignment statement */
12369 66 : case EXEC_ASSIGN:
12370 66 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12371 :
12372 66 : if (cnext->op == EXEC_ASSIGN
12373 66 : && gfc_may_be_finalized (cnext->expr1->ts))
12374 0 : cnext->expr1->must_finalize = 1;
12375 :
12376 : break;
12377 :
12378 : /* WHERE operator assignment statement */
12379 0 : case EXEC_ASSIGN_CALL:
12380 0 : resolve_call (cnext);
12381 0 : if (!cnext->resolved_sym->attr.elemental)
12382 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12383 0 : &cnext->ext.actual->expr->where);
12384 : break;
12385 :
12386 : /* WHERE or WHERE construct is part of a where-body-construct */
12387 0 : case EXEC_WHERE:
12388 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12389 0 : break;
12390 :
12391 0 : default:
12392 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12393 : &cnext->loc);
12394 : }
12395 : /* the next statement within the same where-body-construct */
12396 66 : cnext = cnext->next;
12397 : }
12398 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12399 66 : cblock = cblock->block;
12400 : }
12401 47 : }
12402 :
12403 :
12404 : /* Traverse the FORALL body to check whether the following errors exist:
12405 : 1. For assignment, check if a many-to-one assignment happens.
12406 : 2. For WHERE statement, check the WHERE body to see if there is any
12407 : many-to-one assignment. */
12408 :
12409 : static void
12410 2202 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12411 : {
12412 2202 : gfc_code *c;
12413 :
12414 2202 : c = code->block->next;
12415 4827 : while (c)
12416 : {
12417 2625 : switch (c->op)
12418 : {
12419 2309 : case EXEC_ASSIGN:
12420 2309 : case EXEC_POINTER_ASSIGN:
12421 2309 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12422 :
12423 2309 : if (c->op == EXEC_ASSIGN
12424 2309 : && gfc_may_be_finalized (c->expr1->ts))
12425 0 : c->expr1->must_finalize = 1;
12426 :
12427 : break;
12428 :
12429 0 : case EXEC_ASSIGN_CALL:
12430 0 : resolve_call (c);
12431 0 : break;
12432 :
12433 : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12434 : there is no need to handle it here. */
12435 : case EXEC_FORALL:
12436 : break;
12437 47 : case EXEC_WHERE:
12438 47 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12439 47 : break;
12440 : default:
12441 : break;
12442 : }
12443 : /* The next statement in the FORALL body. */
12444 2625 : c = c->next;
12445 : }
12446 2202 : }
12447 :
12448 :
12449 : /* Counts the number of iterators needed inside a forall construct, including
12450 : nested forall constructs. This is used to allocate the needed memory
12451 : in gfc_resolve_forall. */
12452 :
12453 : static int gfc_count_forall_iterators (gfc_code *code);
12454 :
12455 : /* Return the deepest nested FORALL/DO CONCURRENT iterator count in CODE's
12456 : next-chain, descending into block arms such as IF/ELSE branches. */
12457 :
12458 : static int
12459 2387 : gfc_max_forall_iterators_in_chain (gfc_code *code)
12460 : {
12461 2387 : int max_iters = 0;
12462 :
12463 5226 : for (gfc_code *c = code; c; c = c->next)
12464 : {
12465 2839 : int sub_iters = 0;
12466 :
12467 2839 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12468 94 : sub_iters = gfc_count_forall_iterators (c);
12469 2745 : else if (c->op == EXEC_BLOCK)
12470 : {
12471 : /* BLOCK/ASSOCIATE bodies live in the block namespace code chain,
12472 : not in the generic c->block arm list used by IF/SELECT. */
12473 21 : if (c->ext.block.ns && c->ext.block.ns->code)
12474 21 : sub_iters = gfc_max_forall_iterators_in_chain (c->ext.block.ns->code);
12475 : }
12476 2724 : else if (c->block)
12477 307 : for (gfc_code *b = c->block; b; b = b->block)
12478 : {
12479 164 : int arm_iters = gfc_max_forall_iterators_in_chain (b->next);
12480 164 : if (arm_iters > sub_iters)
12481 : sub_iters = arm_iters;
12482 : }
12483 :
12484 2839 : if (sub_iters > max_iters)
12485 : max_iters = sub_iters;
12486 : }
12487 :
12488 2387 : return max_iters;
12489 : }
12490 :
12491 :
12492 : static int
12493 2202 : gfc_count_forall_iterators (gfc_code *code)
12494 : {
12495 2202 : int current_iters = 0;
12496 2202 : gfc_forall_iterator *fa;
12497 :
12498 2202 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12499 :
12500 6320 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12501 4118 : current_iters++;
12502 :
12503 2202 : return current_iters + gfc_max_forall_iterators_in_chain (code->block->next);
12504 : }
12505 :
12506 :
12507 : /* Given a FORALL construct.
12508 : 1) Resolve the FORALL iterator.
12509 : 2) Check for shadow index-name(s) and update code block.
12510 : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12511 :
12512 : /* Custom recursive expression walker that replaces symbols.
12513 : This ensures we visit ALL expressions including those in array subscripts. */
12514 :
12515 : static void
12516 114 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st)
12517 : {
12518 144 : if (!expr)
12519 : return;
12520 :
12521 : /* Check if this is a variable reference to replace */
12522 108 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12523 : {
12524 18 : expr->symtree = new_st;
12525 18 : expr->ts = new_st->n.sym->ts;
12526 : }
12527 :
12528 : /* Walk through reference chain (array subscripts, substrings, etc.) */
12529 108 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
12530 : {
12531 0 : if (ref->type == REF_ARRAY)
12532 : {
12533 : gfc_array_ref *ar = &ref->u.ar;
12534 0 : for (int i = 0; i < ar->dimen; i++)
12535 : {
12536 0 : replace_in_expr_recursive (ar->start[i], old_sym, new_st);
12537 0 : replace_in_expr_recursive (ar->end[i], old_sym, new_st);
12538 0 : replace_in_expr_recursive (ar->stride[i], old_sym, new_st);
12539 : }
12540 : }
12541 0 : else if (ref->type == REF_SUBSTRING)
12542 : {
12543 0 : replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st);
12544 0 : replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st);
12545 : }
12546 : }
12547 :
12548 : /* Walk through sub-expressions based on expression type */
12549 108 : switch (expr->expr_type)
12550 : {
12551 30 : case EXPR_OP:
12552 30 : replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st);
12553 30 : replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st);
12554 30 : break;
12555 :
12556 6 : case EXPR_FUNCTION:
12557 18 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
12558 12 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12559 : break;
12560 :
12561 0 : case EXPR_ARRAY:
12562 0 : case EXPR_STRUCTURE:
12563 0 : for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
12564 0 : c; c = gfc_constructor_next (c))
12565 : {
12566 0 : replace_in_expr_recursive (c->expr, old_sym, new_st);
12567 0 : if (c->iterator)
12568 : {
12569 0 : replace_in_expr_recursive (c->iterator->start, old_sym, new_st);
12570 0 : replace_in_expr_recursive (c->iterator->end, old_sym, new_st);
12571 0 : replace_in_expr_recursive (c->iterator->step, old_sym, new_st);
12572 : }
12573 : }
12574 : break;
12575 :
12576 : default:
12577 : break;
12578 : }
12579 : }
12580 :
12581 :
12582 : /* Walk code tree and replace all variable references */
12583 :
12584 : static void
12585 18 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12586 : {
12587 18 : if (!code)
12588 : return;
12589 :
12590 36 : for (gfc_code *c = code; c; c = c->next)
12591 : {
12592 : /* Replace in expressions associated with this code node */
12593 18 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12594 18 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12595 18 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12596 18 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12597 :
12598 : /* Handle special code types with additional expressions */
12599 18 : switch (c->op)
12600 : {
12601 0 : case EXEC_DO:
12602 0 : if (c->ext.iterator)
12603 : {
12604 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12605 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12606 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12607 : }
12608 : break;
12609 :
12610 0 : case EXEC_CALL:
12611 0 : case EXEC_ASSIGN_CALL:
12612 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12613 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12614 : break;
12615 :
12616 0 : case EXEC_SELECT:
12617 0 : for (gfc_code *b = c->block; b; b = b->block)
12618 : {
12619 0 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12620 : {
12621 0 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12622 0 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12623 : }
12624 0 : replace_in_code_recursive (b->next, old_sym, new_st);
12625 : }
12626 : break;
12627 :
12628 0 : case EXEC_FORALL:
12629 0 : case EXEC_DO_CONCURRENT:
12630 0 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12631 : {
12632 0 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12633 0 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12634 0 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12635 : }
12636 : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12637 : they'll be handled separately */
12638 : break;
12639 :
12640 : default:
12641 : break;
12642 : }
12643 :
12644 : /* Recurse into blocks */
12645 18 : if (c->block)
12646 0 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12647 : }
12648 : }
12649 :
12650 :
12651 : /* Replace all references to outer_sym with shadow_st in the given code. */
12652 :
12653 : static void
12654 18 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12655 : gfc_symtree *shadow_st)
12656 : {
12657 : /* Use custom recursive walker to ensure we visit ALL expressions */
12658 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12659 18 : }
12660 :
12661 :
12662 : static void
12663 2202 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12664 : {
12665 2202 : static gfc_expr **var_expr;
12666 2202 : static int total_var = 0;
12667 2202 : static int nvar = 0;
12668 2202 : int i, old_nvar, tmp;
12669 2202 : gfc_forall_iterator *fa;
12670 2202 : bool shadow = false;
12671 :
12672 2202 : old_nvar = nvar;
12673 :
12674 : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12675 2202 : if (code->op == EXEC_FORALL
12676 2202 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12677 : return;
12678 :
12679 : /* Start to resolve a FORALL construct */
12680 : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12681 : forall_save==0 means we're not nested in a FORALL in the current scope,
12682 : but nvar==0 ensures we're not nested in a parent scope either (prevents
12683 : double allocation when FORALL is nested inside DO CONCURRENT). */
12684 2202 : if (forall_save == 0 && nvar == 0)
12685 : {
12686 : /* Count the total number of FORALL indices in the nested FORALL
12687 : construct in order to allocate the VAR_EXPR with proper size. */
12688 2108 : total_var = gfc_count_forall_iterators (code);
12689 :
12690 : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12691 2108 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12692 : }
12693 :
12694 : /* The information about FORALL iterator, including FORALL indices start,
12695 : end and stride. An outer FORALL indice cannot appear in start, end or
12696 : stride. Check for a shadow index-name. */
12697 6320 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12698 : {
12699 : /* Fortran 2008: C738 (R753). */
12700 4118 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12701 : {
12702 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12703 : "of type integer", &fa->var->where);
12704 2 : continue;
12705 : }
12706 :
12707 : /* Check if any outer FORALL index name is the same as the current
12708 : one. Skip this check if the iterator is a shadow variable (from
12709 : DO CONCURRENT type spec) which may not have a symtree yet. */
12710 7125 : for (i = 0; i < nvar; i++)
12711 : {
12712 3009 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12713 3009 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12714 0 : gfc_error ("An outer FORALL construct already has an index "
12715 : "with this name %L", &fa->var->where);
12716 : }
12717 :
12718 4116 : if (fa->shadow)
12719 18 : shadow = true;
12720 :
12721 : /* Record the current FORALL index. */
12722 4116 : var_expr[nvar] = gfc_copy_expr (fa->var);
12723 :
12724 4116 : nvar++;
12725 :
12726 : /* No memory leak. */
12727 4116 : gcc_assert (nvar <= total_var);
12728 : }
12729 :
12730 : /* Need to walk the code and replace references to the index-name with
12731 : references to the shadow index-name. This must be done BEFORE resolving
12732 : the body so that resolution uses the correct shadow variables. */
12733 2202 : if (shadow)
12734 : {
12735 : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
12736 42 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12737 : {
12738 24 : if (fa->shadow)
12739 : {
12740 18 : gfc_symtree *shadow_st;
12741 18 : const char *shadow_name_str;
12742 18 : char *outer_name;
12743 :
12744 : /* fa->var now points to the shadow variable "_name". */
12745 18 : shadow_name_str = fa->var->symtree->name;
12746 18 : shadow_st = fa->var->symtree;
12747 :
12748 18 : if (shadow_name_str[0] != '_')
12749 0 : gfc_internal_error ("Expected shadow variable name to start with _");
12750 :
12751 18 : outer_name = (char *) alloca (strlen (shadow_name_str));
12752 18 : strcpy (outer_name, shadow_name_str + 1);
12753 :
12754 : /* Find the ITERATOR symbol in the current namespace.
12755 : This is the local DO CONCURRENT variable that body expressions reference. */
12756 18 : gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name);
12757 :
12758 18 : if (!iter_st)
12759 : /* No iterator variable found - this shouldn't happen */
12760 0 : continue;
12761 :
12762 18 : gfc_symbol *iter_sym = iter_st->n.sym;
12763 :
12764 : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
12765 18 : if (code->block && code->block->next)
12766 18 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
12767 : }
12768 : }
12769 : }
12770 :
12771 : /* Resolve the FORALL body. */
12772 2202 : gfc_resolve_forall_body (code, nvar, var_expr);
12773 :
12774 : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
12775 2202 : gfc_resolve_blocks (code->block, ns);
12776 :
12777 2202 : tmp = nvar;
12778 2202 : nvar = old_nvar;
12779 : /* Free only the VAR_EXPRs allocated in this frame. */
12780 6318 : for (i = nvar; i < tmp; i++)
12781 4116 : gfc_free_expr (var_expr[i]);
12782 :
12783 2202 : if (nvar == 0)
12784 : {
12785 : /* We are in the outermost FORALL construct. */
12786 2108 : gcc_assert (forall_save == 0);
12787 :
12788 : /* VAR_EXPR is not needed any more. */
12789 2108 : free (var_expr);
12790 2108 : total_var = 0;
12791 : }
12792 : }
12793 :
12794 :
12795 : /* Resolve a BLOCK construct statement. */
12796 :
12797 : static void
12798 8000 : resolve_block_construct (gfc_code* code)
12799 : {
12800 8000 : gfc_namespace *ns = code->ext.block.ns;
12801 :
12802 : /* For an ASSOCIATE block, the associations (and their targets) will be
12803 : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
12804 : namespace. */
12805 8000 : gfc_resolve (ns);
12806 0 : }
12807 :
12808 :
12809 : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
12810 : DO code nodes. */
12811 :
12812 : void
12813 329677 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
12814 : {
12815 329677 : bool t;
12816 :
12817 670785 : for (; b; b = b->block)
12818 : {
12819 341108 : t = gfc_resolve_expr (b->expr1);
12820 341108 : if (!gfc_resolve_expr (b->expr2))
12821 0 : t = false;
12822 :
12823 341108 : switch (b->op)
12824 : {
12825 235752 : case EXEC_IF:
12826 235752 : if (t && b->expr1 != NULL
12827 231471 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
12828 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12829 : &b->expr1->where);
12830 : break;
12831 :
12832 764 : case EXEC_WHERE:
12833 764 : if (t
12834 764 : && b->expr1 != NULL
12835 631 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
12836 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
12837 : &b->expr1->where);
12838 : break;
12839 :
12840 76 : case EXEC_GOTO:
12841 76 : resolve_branch (b->label1, b);
12842 76 : break;
12843 :
12844 0 : case EXEC_BLOCK:
12845 0 : resolve_block_construct (b);
12846 0 : break;
12847 :
12848 : case EXEC_SELECT:
12849 : case EXEC_SELECT_TYPE:
12850 : case EXEC_SELECT_RANK:
12851 : case EXEC_FORALL:
12852 : case EXEC_DO:
12853 : case EXEC_DO_WHILE:
12854 : case EXEC_DO_CONCURRENT:
12855 : case EXEC_CRITICAL:
12856 : case EXEC_READ:
12857 : case EXEC_WRITE:
12858 : case EXEC_IOLENGTH:
12859 : case EXEC_WAIT:
12860 : break;
12861 :
12862 2697 : case EXEC_OMP_ATOMIC:
12863 2697 : case EXEC_OACC_ATOMIC:
12864 2697 : {
12865 : /* Verify this before calling gfc_resolve_code, which might
12866 : change it. */
12867 2697 : gcc_assert (b->op == EXEC_OMP_ATOMIC
12868 : || (b->next && b->next->op == EXEC_ASSIGN));
12869 : }
12870 : break;
12871 :
12872 : case EXEC_OACC_PARALLEL_LOOP:
12873 : case EXEC_OACC_PARALLEL:
12874 : case EXEC_OACC_KERNELS_LOOP:
12875 : case EXEC_OACC_KERNELS:
12876 : case EXEC_OACC_SERIAL_LOOP:
12877 : case EXEC_OACC_SERIAL:
12878 : case EXEC_OACC_DATA:
12879 : case EXEC_OACC_HOST_DATA:
12880 : case EXEC_OACC_LOOP:
12881 : case EXEC_OACC_UPDATE:
12882 : case EXEC_OACC_WAIT:
12883 : case EXEC_OACC_CACHE:
12884 : case EXEC_OACC_ENTER_DATA:
12885 : case EXEC_OACC_EXIT_DATA:
12886 : case EXEC_OACC_ROUTINE:
12887 : case EXEC_OMP_ALLOCATE:
12888 : case EXEC_OMP_ALLOCATORS:
12889 : case EXEC_OMP_ASSUME:
12890 : case EXEC_OMP_CRITICAL:
12891 : case EXEC_OMP_DISPATCH:
12892 : case EXEC_OMP_DISTRIBUTE:
12893 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12894 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12895 : case EXEC_OMP_DISTRIBUTE_SIMD:
12896 : case EXEC_OMP_DO:
12897 : case EXEC_OMP_DO_SIMD:
12898 : case EXEC_OMP_ERROR:
12899 : case EXEC_OMP_LOOP:
12900 : case EXEC_OMP_MASKED:
12901 : case EXEC_OMP_MASKED_TASKLOOP:
12902 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12903 : case EXEC_OMP_MASTER:
12904 : case EXEC_OMP_MASTER_TASKLOOP:
12905 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12906 : case EXEC_OMP_ORDERED:
12907 : case EXEC_OMP_PARALLEL:
12908 : case EXEC_OMP_PARALLEL_DO:
12909 : case EXEC_OMP_PARALLEL_DO_SIMD:
12910 : case EXEC_OMP_PARALLEL_LOOP:
12911 : case EXEC_OMP_PARALLEL_MASKED:
12912 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12913 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12914 : case EXEC_OMP_PARALLEL_MASTER:
12915 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12916 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12917 : case EXEC_OMP_PARALLEL_SECTIONS:
12918 : case EXEC_OMP_PARALLEL_WORKSHARE:
12919 : case EXEC_OMP_SECTIONS:
12920 : case EXEC_OMP_SIMD:
12921 : case EXEC_OMP_SCOPE:
12922 : case EXEC_OMP_SINGLE:
12923 : case EXEC_OMP_TARGET:
12924 : case EXEC_OMP_TARGET_DATA:
12925 : case EXEC_OMP_TARGET_ENTER_DATA:
12926 : case EXEC_OMP_TARGET_EXIT_DATA:
12927 : case EXEC_OMP_TARGET_PARALLEL:
12928 : case EXEC_OMP_TARGET_PARALLEL_DO:
12929 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12930 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12931 : case EXEC_OMP_TARGET_SIMD:
12932 : case EXEC_OMP_TARGET_TEAMS:
12933 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12934 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12935 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12936 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12937 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12938 : case EXEC_OMP_TARGET_UPDATE:
12939 : case EXEC_OMP_TASK:
12940 : case EXEC_OMP_TASKGROUP:
12941 : case EXEC_OMP_TASKLOOP:
12942 : case EXEC_OMP_TASKLOOP_SIMD:
12943 : case EXEC_OMP_TASKWAIT:
12944 : case EXEC_OMP_TASKYIELD:
12945 : case EXEC_OMP_TEAMS:
12946 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12947 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12948 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12949 : case EXEC_OMP_TEAMS_LOOP:
12950 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12951 : case EXEC_OMP_TILE:
12952 : case EXEC_OMP_UNROLL:
12953 : case EXEC_OMP_WORKSHARE:
12954 : break;
12955 :
12956 0 : default:
12957 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
12958 : }
12959 :
12960 341108 : gfc_resolve_code (b->next, ns);
12961 : }
12962 329677 : }
12963 :
12964 : bool
12965 0 : caf_possible_reallocate (gfc_expr *e)
12966 : {
12967 0 : symbol_attribute caf_attr;
12968 0 : gfc_ref *last_arr_ref = nullptr;
12969 :
12970 0 : caf_attr = gfc_caf_attr (e);
12971 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
12972 : return false;
12973 :
12974 : /* Only full array refs can indicate a needed reallocation. */
12975 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
12976 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
12977 0 : last_arr_ref = ref;
12978 :
12979 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
12980 : }
12981 :
12982 : /* Does everything to resolve an ordinary assignment. Returns true
12983 : if this is an interface assignment. */
12984 : static bool
12985 284447 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
12986 : {
12987 284447 : bool rval = false;
12988 284447 : gfc_expr *lhs;
12989 284447 : gfc_expr *rhs;
12990 284447 : int n;
12991 284447 : gfc_ref *ref;
12992 284447 : symbol_attribute attr;
12993 :
12994 284447 : if (gfc_extend_assign (code, ns))
12995 : {
12996 804 : gfc_expr** rhsptr;
12997 :
12998 804 : if (code->op == EXEC_ASSIGN_CALL)
12999 : {
13000 361 : lhs = code->ext.actual->expr;
13001 361 : rhsptr = &code->ext.actual->next->expr;
13002 : }
13003 : else
13004 : {
13005 443 : gfc_actual_arglist* args;
13006 443 : gfc_typebound_proc* tbp;
13007 :
13008 443 : gcc_assert (code->op == EXEC_COMPCALL);
13009 :
13010 443 : args = code->expr1->value.compcall.actual;
13011 443 : lhs = args->expr;
13012 443 : rhsptr = &args->next->expr;
13013 :
13014 443 : tbp = code->expr1->value.compcall.tbp;
13015 443 : gcc_assert (!tbp->is_generic);
13016 : }
13017 :
13018 : /* Make a temporary rhs when there is a default initializer
13019 : and rhs is the same symbol as the lhs. */
13020 804 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
13021 399 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
13022 340 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
13023 996 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
13024 24 : *rhsptr = gfc_get_parentheses (*rhsptr);
13025 :
13026 804 : return true;
13027 : }
13028 :
13029 283643 : lhs = code->expr1;
13030 283643 : rhs = code->expr2;
13031 :
13032 283643 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
13033 264021 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
13034 22144 : && !lhs->symtree->n.sym->attr.proc_pointer
13035 305787 : && gfc_expr_attr (lhs).proc_pointer)
13036 : {
13037 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
13038 : "pointer component",
13039 : &lhs->where);
13040 1 : return false;
13041 : }
13042 :
13043 334160 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
13044 248518 : && rhs->ts.type == BT_CHARACTER
13045 284035 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
13046 : {
13047 : /* Use of -fdec-char-conversions allows assignment of character data
13048 : to non-character variables. This not permitted for nonconstant
13049 : strings. */
13050 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
13051 : gfc_typename (lhs), &rhs->where);
13052 29 : return false;
13053 : }
13054 :
13055 283613 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
13056 : {
13057 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
13058 : gfc_typename (lhs), &rhs->where);
13059 0 : return false;
13060 : }
13061 :
13062 : /* Handle the case of a BOZ literal on the RHS. */
13063 283613 : if (rhs->ts.type == BT_BOZ)
13064 : {
13065 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
13066 : "statement value nor an actual argument of "
13067 : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
13068 : &rhs->where))
13069 : return false;
13070 :
13071 1 : switch (lhs->ts.type)
13072 : {
13073 0 : case BT_INTEGER:
13074 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
13075 : return false;
13076 : break;
13077 1 : case BT_REAL:
13078 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
13079 : return false;
13080 : break;
13081 0 : default:
13082 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13083 0 : return false;
13084 : }
13085 : }
13086 :
13087 283611 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13088 : {
13089 64 : HOST_WIDE_INT llen = 0, rlen = 0;
13090 64 : if (lhs->ts.u.cl != NULL
13091 64 : && lhs->ts.u.cl->length != NULL
13092 53 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13093 53 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13094 :
13095 64 : if (rhs->expr_type == EXPR_CONSTANT)
13096 26 : rlen = rhs->value.character.length;
13097 :
13098 38 : else if (rhs->ts.u.cl != NULL
13099 38 : && rhs->ts.u.cl->length != NULL
13100 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13101 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13102 :
13103 64 : if (rlen && llen && rlen > llen)
13104 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13105 : "CHARACTER expression will be truncated "
13106 : "in assignment (%wd/%wd) at %L",
13107 : llen, rlen, &code->loc);
13108 : }
13109 :
13110 : /* Ensure that a vector index expression for the lvalue is evaluated
13111 : to a temporary if the lvalue symbol is referenced in it. */
13112 283611 : if (lhs->rank)
13113 : {
13114 110719 : for (ref = lhs->ref; ref; ref= ref->next)
13115 59007 : if (ref->type == REF_ARRAY)
13116 : {
13117 131130 : for (n = 0; n < ref->u.ar.dimen; n++)
13118 77664 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13119 77894 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13120 230 : ref->u.ar.start[n]))
13121 14 : ref->u.ar.start[n]
13122 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13123 : }
13124 : }
13125 :
13126 283611 : if (gfc_pure (NULL))
13127 : {
13128 3346 : if (lhs->ts.type == BT_DERIVED
13129 136 : && lhs->expr_type == EXPR_VARIABLE
13130 136 : && lhs->ts.u.derived->attr.pointer_comp
13131 4 : && rhs->expr_type == EXPR_VARIABLE
13132 3349 : && (gfc_impure_variable (rhs->symtree->n.sym)
13133 2 : || gfc_is_coindexed (rhs)))
13134 : {
13135 : /* F2008, C1283. */
13136 2 : if (gfc_is_coindexed (rhs))
13137 1 : gfc_error ("Coindexed expression at %L is assigned to "
13138 : "a derived type variable with a POINTER "
13139 : "component in a PURE procedure",
13140 : &rhs->where);
13141 : else
13142 : /* F2008, C1283 (4). */
13143 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13144 : "shall not be used as the expr at %L of an intrinsic "
13145 : "assignment statement in which the variable is of a "
13146 : "derived type if the derived type has a pointer "
13147 : "component at any level of component selection.",
13148 : &rhs->where);
13149 2 : return rval;
13150 : }
13151 :
13152 : /* Fortran 2008, C1283. */
13153 3344 : if (gfc_is_coindexed (lhs))
13154 : {
13155 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13156 : "procedure", &rhs->where);
13157 1 : return rval;
13158 : }
13159 : }
13160 :
13161 283608 : if (gfc_implicit_pure (NULL))
13162 : {
13163 7189 : if (lhs->expr_type == EXPR_VARIABLE
13164 7189 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13165 5118 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13166 253 : gfc_unset_implicit_pure (NULL);
13167 :
13168 7189 : if (lhs->ts.type == BT_DERIVED
13169 320 : && lhs->expr_type == EXPR_VARIABLE
13170 320 : && lhs->ts.u.derived->attr.pointer_comp
13171 7 : && rhs->expr_type == EXPR_VARIABLE
13172 7196 : && (gfc_impure_variable (rhs->symtree->n.sym)
13173 7 : || gfc_is_coindexed (rhs)))
13174 0 : gfc_unset_implicit_pure (NULL);
13175 :
13176 : /* Fortran 2008, C1283. */
13177 7189 : if (gfc_is_coindexed (lhs))
13178 0 : gfc_unset_implicit_pure (NULL);
13179 : }
13180 :
13181 : /* F2008, 7.2.1.2. */
13182 283608 : attr = gfc_expr_attr (lhs);
13183 283608 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13184 : {
13185 975 : if (attr.codimension)
13186 : {
13187 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13188 : "permitted", &lhs->where);
13189 1 : return false;
13190 : }
13191 974 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13192 : "polymorphic variable at %L", &lhs->where))
13193 : return false;
13194 973 : if (!flag_realloc_lhs)
13195 : {
13196 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13197 : "requires %<-frealloc-lhs%>", &lhs->where);
13198 1 : return false;
13199 : }
13200 : }
13201 282633 : else if (lhs->ts.type == BT_CLASS)
13202 : {
13203 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13204 : "assignment at %L - check that there is a matching specific "
13205 : "subroutine for %<=%> operator", &lhs->where);
13206 9 : return false;
13207 : }
13208 :
13209 283596 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13210 :
13211 : /* F2008, Section 7.2.1.2. */
13212 283596 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13213 : {
13214 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13215 : "component in assignment at %L", &lhs->where);
13216 1 : return false;
13217 : }
13218 :
13219 : /* Assign the 'data' of a class object to a derived type. */
13220 283595 : if (lhs->ts.type == BT_DERIVED
13221 7093 : && rhs->ts.type == BT_CLASS
13222 144 : && rhs->expr_type != EXPR_ARRAY)
13223 138 : gfc_add_data_component (rhs);
13224 :
13225 : /* Make sure there is a vtable and, in particular, a _copy for the
13226 : rhs type. */
13227 283595 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13228 609 : gfc_find_vtab (&rhs->ts);
13229 :
13230 283595 : gfc_check_assign (lhs, rhs, 1);
13231 :
13232 283595 : return false;
13233 : }
13234 :
13235 :
13236 : /* Add a component reference onto an expression. */
13237 :
13238 : static void
13239 665 : add_comp_ref (gfc_expr *e, gfc_component *c)
13240 : {
13241 665 : gfc_ref **ref;
13242 665 : ref = &(e->ref);
13243 889 : while (*ref)
13244 224 : ref = &((*ref)->next);
13245 665 : *ref = gfc_get_ref ();
13246 665 : (*ref)->type = REF_COMPONENT;
13247 665 : (*ref)->u.c.sym = e->ts.u.derived;
13248 665 : (*ref)->u.c.component = c;
13249 665 : e->ts = c->ts;
13250 :
13251 : /* Add a full array ref, as necessary. */
13252 665 : if (c->as)
13253 : {
13254 84 : gfc_add_full_array_ref (e, c->as);
13255 84 : e->rank = c->as->rank;
13256 84 : e->corank = c->as->corank;
13257 : }
13258 665 : }
13259 :
13260 :
13261 : /* Build an assignment. Keep the argument 'op' for future use, so that
13262 : pointer assignments can be made. */
13263 :
13264 : static gfc_code *
13265 952 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13266 : gfc_component *comp1, gfc_component *comp2, locus loc)
13267 : {
13268 952 : gfc_code *this_code;
13269 :
13270 952 : this_code = gfc_get_code (op);
13271 952 : this_code->next = NULL;
13272 952 : this_code->expr1 = gfc_copy_expr (expr1);
13273 952 : this_code->expr2 = gfc_copy_expr (expr2);
13274 952 : this_code->loc = loc;
13275 952 : if (comp1 && comp2)
13276 : {
13277 288 : add_comp_ref (this_code->expr1, comp1);
13278 288 : add_comp_ref (this_code->expr2, comp2);
13279 : }
13280 :
13281 952 : return this_code;
13282 : }
13283 :
13284 :
13285 : /* Makes a temporary variable expression based on the characteristics of
13286 : a given variable expression. */
13287 :
13288 : static gfc_expr*
13289 446 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
13290 : {
13291 446 : static int serial = 0;
13292 446 : char name[GFC_MAX_SYMBOL_LEN];
13293 446 : gfc_symtree *tmp;
13294 446 : gfc_array_spec *as;
13295 446 : gfc_array_ref *aref;
13296 446 : gfc_ref *ref;
13297 :
13298 446 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13299 446 : gfc_get_sym_tree (name, ns, &tmp, false);
13300 446 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13301 :
13302 446 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13303 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13304 : NULL,
13305 0 : e->value.character.length);
13306 :
13307 446 : as = NULL;
13308 446 : ref = NULL;
13309 446 : aref = NULL;
13310 :
13311 : /* Obtain the arrayspec for the temporary. */
13312 446 : if (e->rank && e->expr_type != EXPR_ARRAY
13313 : && e->expr_type != EXPR_FUNCTION
13314 : && e->expr_type != EXPR_OP)
13315 : {
13316 52 : aref = gfc_find_array_ref (e);
13317 52 : if (e->expr_type == EXPR_VARIABLE
13318 52 : && e->symtree->n.sym->as == aref->as)
13319 : as = aref->as;
13320 : else
13321 : {
13322 0 : for (ref = e->ref; ref; ref = ref->next)
13323 0 : if (ref->type == REF_COMPONENT
13324 0 : && ref->u.c.component->as == aref->as)
13325 : {
13326 : as = aref->as;
13327 : break;
13328 : }
13329 : }
13330 : }
13331 :
13332 : /* Add the attributes and the arrayspec to the temporary. */
13333 446 : tmp->n.sym->attr = gfc_expr_attr (e);
13334 446 : tmp->n.sym->attr.function = 0;
13335 446 : tmp->n.sym->attr.proc_pointer = 0;
13336 446 : tmp->n.sym->attr.result = 0;
13337 446 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13338 446 : tmp->n.sym->attr.dummy = 0;
13339 446 : tmp->n.sym->attr.use_assoc = 0;
13340 446 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13341 :
13342 :
13343 446 : if (as)
13344 : {
13345 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13346 52 : if (!ref)
13347 52 : ref = e->ref;
13348 52 : if (as->type == AS_DEFERRED)
13349 46 : tmp->n.sym->attr.allocatable = 1;
13350 : }
13351 394 : else if ((e->rank || e->corank)
13352 94 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13353 0 : || e->expr_type == EXPR_OP))
13354 : {
13355 94 : tmp->n.sym->as = gfc_get_array_spec ();
13356 94 : tmp->n.sym->as->type = AS_DEFERRED;
13357 94 : tmp->n.sym->as->rank = e->rank;
13358 94 : tmp->n.sym->as->corank = e->corank;
13359 94 : tmp->n.sym->attr.allocatable = 1;
13360 94 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13361 188 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13362 : }
13363 : else
13364 300 : tmp->n.sym->attr.dimension = 0;
13365 :
13366 446 : gfc_set_sym_referenced (tmp->n.sym);
13367 446 : gfc_commit_symbol (tmp->n.sym);
13368 446 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13369 :
13370 : /* Should the lhs be a section, use its array ref for the
13371 : temporary expression. */
13372 446 : if (aref && aref->type != AR_FULL)
13373 : {
13374 6 : gfc_free_ref_list (e->ref);
13375 6 : e->ref = gfc_copy_ref (ref);
13376 : }
13377 446 : return e;
13378 : }
13379 :
13380 :
13381 : /* Add one line of code to the code chain, making sure that 'head' and
13382 : 'tail' are appropriately updated. */
13383 :
13384 : static void
13385 656 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13386 : {
13387 656 : gcc_assert (this_code);
13388 656 : if (*head == NULL)
13389 308 : *head = *tail = *this_code;
13390 : else
13391 348 : *tail = gfc_append_code (*tail, *this_code);
13392 656 : *this_code = NULL;
13393 656 : }
13394 :
13395 :
13396 : /* Generate a final call from a variable expression */
13397 :
13398 : static void
13399 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13400 : {
13401 81 : gfc_code *this_code;
13402 81 : gfc_expr *final_expr = NULL;
13403 81 : gfc_expr *size_expr;
13404 81 : gfc_expr *fini_coarray;
13405 :
13406 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13407 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13408 75 : return;
13409 :
13410 : /* Now generate the finalizer call. */
13411 6 : this_code = gfc_get_code (EXEC_CALL);
13412 6 : this_code->symtree = final_expr->symtree;
13413 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13414 :
13415 : //* Expression to be finalized */
13416 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13417 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13418 :
13419 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13420 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13421 6 : size_expr = gfc_get_expr ();
13422 6 : size_expr->where = gfc_current_locus;
13423 6 : size_expr->expr_type = EXPR_OP;
13424 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13425 6 : size_expr->value.op.op1
13426 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13427 : "storage_size", gfc_current_locus, 2,
13428 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13429 : gfc_get_int_expr (gfc_index_integer_kind,
13430 : NULL, 0));
13431 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13432 : gfc_character_storage_size);
13433 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13434 6 : size_expr->ts = size_expr->value.op.op1->ts;
13435 6 : this_code->ext.actual->next->expr = size_expr;
13436 :
13437 : /* fini_coarray */
13438 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13439 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13440 : &tmp_expr->where);
13441 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13442 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13443 :
13444 6 : add_code_to_chain (&this_code, head, tail);
13445 :
13446 : }
13447 :
13448 : /* Counts the potential number of part array references that would
13449 : result from resolution of typebound defined assignments. */
13450 :
13451 :
13452 : static int
13453 243 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13454 : {
13455 243 : gfc_component *c;
13456 243 : int c_depth = 0, t_depth;
13457 :
13458 584 : for (c= derived->components; c; c = c->next)
13459 : {
13460 341 : if ((!gfc_bt_struct (c->ts.type)
13461 261 : || c->attr.pointer
13462 261 : || c->attr.allocatable
13463 260 : || c->attr.proc_pointer_comp
13464 260 : || c->attr.class_pointer
13465 260 : || c->attr.proc_pointer)
13466 81 : && !c->attr.defined_assign_comp)
13467 81 : continue;
13468 :
13469 260 : if (c->as && c_depth == 0)
13470 260 : c_depth = 1;
13471 :
13472 260 : if (c->ts.u.derived->attr.defined_assign_comp)
13473 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13474 : c->as ? 1 : 0);
13475 : else
13476 : t_depth = 0;
13477 :
13478 260 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13479 : }
13480 243 : return depth + c_depth;
13481 : }
13482 :
13483 :
13484 : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13485 : "An intrinsic assignment where the variable is of derived type is performed
13486 : as if each component of the variable were assigned from the corresponding
13487 : component of expr using pointer assignment (10.2.2) for each pointer
13488 : component, defined assignment for each nonpointer nonallocatable component
13489 : of a type that has a type-bound defined assignment consistent with the
13490 : component, intrinsic assignment for each other nonpointer nonallocatable
13491 : component, and intrinsic assignment for each allocated coarray component.
13492 : For unallocated coarray components, the corresponding component of the
13493 : variable shall be unallocated. For a noncoarray allocatable component the
13494 : following sequence of operations is applied.
13495 : (1) If the component of the variable is allocated, it is deallocated.
13496 : (2) If the component of the value of expr is allocated, the
13497 : corresponding component of the variable is allocated with the same
13498 : dynamic type and type parameters as the component of the value of
13499 : expr. If it is an array, it is allocated with the same bounds. The
13500 : value of the component of the value of expr is then assigned to the
13501 : corresponding component of the variable using defined assignment if
13502 : the declared type of the component has a type-bound defined
13503 : assignment consistent with the component, and intrinsic assignment
13504 : for the dynamic type of that component otherwise."
13505 :
13506 : The pointer assignments are taken care of by the intrinsic assignment of the
13507 : structure itself. This function recursively adds defined assignments where
13508 : required. The recursion is accomplished by calling gfc_resolve_code.
13509 :
13510 : When the lhs in a defined assignment has intent INOUT or is intent OUT
13511 : and the component of 'var' is finalizable, we need a temporary for the
13512 : lhs. In pseudo-code for an assignment var = expr:
13513 :
13514 : ! Confine finalization of temporaries, as far as possible.
13515 : Enclose the code for the assignment in a block
13516 : ! Only call function 'expr' once.
13517 : #if ('expr is not a constant or an variable)
13518 : temp_expr = expr
13519 : expr = temp_x
13520 : ! Do the intrinsic assignment
13521 : #if typeof ('var') has a typebound final subroutine
13522 : finalize (var)
13523 : var = expr
13524 : ! Now do the component assignments
13525 : #do over derived type components [%cmp]
13526 : #if (cmp is a pointer of any kind)
13527 : continue
13528 : build the assignment
13529 : resolve the code
13530 : #if the code is a typebound assignment
13531 : #if (arg1 is INOUT or finalizable OUT && !t1)
13532 : t1 = var
13533 : arg1 = t1
13534 : deal with allocatation or not of var and this component
13535 : #elseif the code is an assignment by itself
13536 : #if this component does not need finalization
13537 : delete code and continue
13538 : #else
13539 : remove the leading assignment
13540 : #endif
13541 : commit the code
13542 : #if (t1 and (arg1 is INOUT or finalizable OUT))
13543 : var%cmp = t1%cmp
13544 : #enddo
13545 : put all code chunks involving t1 to the top of the generated code
13546 : insert the generated block in place of the original code
13547 : */
13548 :
13549 : static bool
13550 381 : is_finalizable_type (gfc_typespec ts)
13551 : {
13552 381 : gfc_component *c;
13553 :
13554 381 : if (ts.type != BT_DERIVED)
13555 : return false;
13556 :
13557 : /* (1) Check for FINAL subroutines. */
13558 381 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13559 : return true;
13560 :
13561 : /* (2) Check for components of finalizable type. */
13562 809 : for (c = ts.u.derived->components; c; c = c->next)
13563 470 : if (c->ts.type == BT_DERIVED
13564 243 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13565 242 : && c->ts.u.derived->f2k_derived
13566 242 : && c->ts.u.derived->f2k_derived->finalizers)
13567 : return true;
13568 :
13569 : return false;
13570 : }
13571 :
13572 : /* The temporary assignments have to be put on top of the additional
13573 : code to avoid the result being changed by the intrinsic assignment.
13574 : */
13575 : static int component_assignment_level = 0;
13576 : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13577 : static bool finalizable_comp;
13578 :
13579 : static void
13580 188 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13581 : {
13582 188 : gfc_component *comp1, *comp2;
13583 188 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13584 188 : gfc_code *tmp_code = NULL;
13585 188 : gfc_expr *t1 = NULL;
13586 188 : gfc_expr *tmp_expr = NULL;
13587 188 : int error_count, depth;
13588 188 : bool finalizable_lhs;
13589 :
13590 188 : gfc_get_errors (NULL, &error_count);
13591 :
13592 : /* Filter out continuing processing after an error. */
13593 188 : if (error_count
13594 188 : || (*code)->expr1->ts.type != BT_DERIVED
13595 188 : || (*code)->expr2->ts.type != BT_DERIVED)
13596 140 : return;
13597 :
13598 : /* TODO: Handle more than one part array reference in assignments. */
13599 188 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13600 188 : (*code)->expr1->rank ? 1 : 0);
13601 188 : if (depth > 1)
13602 : {
13603 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13604 : "done because multiple part array references would "
13605 : "occur in intermediate expressions.", &(*code)->loc);
13606 6 : return;
13607 : }
13608 :
13609 182 : if (!component_assignment_level)
13610 134 : finalizable_comp = true;
13611 :
13612 : /* Build a block so that function result temporaries are finalized
13613 : locally on exiting the rather than enclosing scope. */
13614 182 : if (!component_assignment_level)
13615 : {
13616 134 : ns = gfc_build_block_ns (ns);
13617 134 : tmp_code = gfc_get_code (EXEC_NOP);
13618 134 : *tmp_code = **code;
13619 134 : tmp_code->next = NULL;
13620 134 : (*code)->op = EXEC_BLOCK;
13621 134 : (*code)->ext.block.ns = ns;
13622 134 : (*code)->ext.block.assoc = NULL;
13623 134 : (*code)->expr1 = (*code)->expr2 = NULL;
13624 134 : ns->code = tmp_code;
13625 134 : code = &ns->code;
13626 : }
13627 :
13628 182 : component_assignment_level++;
13629 :
13630 182 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13631 :
13632 : /* Create a temporary so that functions get called only once. */
13633 182 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13634 182 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13635 : {
13636 : /* Assign the rhs to the temporary. */
13637 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13638 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13639 : {
13640 : /* Use allocate on assignment for the sake of simplicity. The
13641 : temporary must not take on the optional attribute. Assume
13642 : that the assignment is guarded by a PRESENT condition if the
13643 : lhs is optional. */
13644 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13645 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
13646 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13647 : }
13648 162 : this_code = build_assignment (EXEC_ASSIGN,
13649 : tmp_expr, (*code)->expr2,
13650 81 : NULL, NULL, (*code)->loc);
13651 81 : this_code->expr2->must_finalize = 1;
13652 : /* Add the code and substitute the rhs expression. */
13653 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13654 81 : gfc_free_expr ((*code)->expr2);
13655 81 : (*code)->expr2 = tmp_expr;
13656 : }
13657 :
13658 : /* Do the intrinsic assignment. This is not needed if the lhs is one
13659 : of the temporaries generated here, since the intrinsic assignment
13660 : to the final result already does this. */
13661 182 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
13662 : {
13663 182 : if (finalizable_lhs)
13664 18 : (*code)->expr1->must_finalize = 1;
13665 182 : this_code = build_assignment (EXEC_ASSIGN,
13666 : (*code)->expr1, (*code)->expr2,
13667 : NULL, NULL, (*code)->loc);
13668 182 : add_code_to_chain (&this_code, &head, &tail);
13669 : }
13670 :
13671 182 : comp1 = (*code)->expr1->ts.u.derived->components;
13672 182 : comp2 = (*code)->expr2->ts.u.derived->components;
13673 :
13674 449 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
13675 : {
13676 267 : bool inout = false;
13677 267 : bool finalizable_out = false;
13678 :
13679 : /* The intrinsic assignment does the right thing for pointers
13680 : of all kinds and allocatable components. */
13681 267 : if (!gfc_bt_struct (comp1->ts.type)
13682 200 : || comp1->attr.pointer
13683 200 : || comp1->attr.allocatable
13684 199 : || comp1->attr.proc_pointer_comp
13685 199 : || comp1->attr.class_pointer
13686 199 : || comp1->attr.proc_pointer)
13687 68 : continue;
13688 :
13689 398 : finalizable_comp = is_finalizable_type (comp1->ts)
13690 199 : && !finalizable_lhs;
13691 :
13692 : /* Make an assignment for this component. */
13693 398 : this_code = build_assignment (EXEC_ASSIGN,
13694 : (*code)->expr1, (*code)->expr2,
13695 199 : comp1, comp2, (*code)->loc);
13696 :
13697 : /* Convert the assignment if there is a defined assignment for
13698 : this type. Otherwise, using the call from gfc_resolve_code,
13699 : recurse into its components. */
13700 199 : gfc_resolve_code (this_code, ns);
13701 :
13702 199 : if (this_code->op == EXEC_ASSIGN_CALL)
13703 : {
13704 144 : gfc_formal_arglist *dummy_args;
13705 144 : gfc_symbol *rsym;
13706 : /* Check that there is a typebound defined assignment. If not,
13707 : then this must be a module defined assignment. We cannot
13708 : use the defined_assign_comp attribute here because it must
13709 : be this derived type that has the defined assignment and not
13710 : a parent type. */
13711 144 : if (!(comp1->ts.u.derived->f2k_derived
13712 : && comp1->ts.u.derived->f2k_derived
13713 144 : ->tb_op[INTRINSIC_ASSIGN]))
13714 : {
13715 1 : gfc_free_statements (this_code);
13716 1 : this_code = NULL;
13717 1 : continue;
13718 : }
13719 :
13720 : /* If the first argument of the subroutine has intent INOUT
13721 : a temporary must be generated and used instead. */
13722 143 : rsym = this_code->resolved_sym;
13723 143 : dummy_args = gfc_sym_get_dummy_args (rsym);
13724 268 : finalizable_out = gfc_may_be_finalized (comp1->ts)
13725 18 : && dummy_args
13726 161 : && dummy_args->sym->attr.intent == INTENT_OUT;
13727 286 : inout = dummy_args
13728 268 : && dummy_args->sym->attr.intent == INTENT_INOUT;
13729 72 : if ((inout || finalizable_out)
13730 89 : && !comp1->attr.allocatable)
13731 : {
13732 89 : gfc_code *temp_code;
13733 89 : inout = true;
13734 :
13735 : /* Build the temporary required for the assignment and put
13736 : it at the head of the generated code. */
13737 89 : if (!t1)
13738 : {
13739 89 : gfc_namespace *tmp_ns = ns;
13740 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
13741 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
13742 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
13743 89 : t1->symtree->n.sym->attr.artificial = 1;
13744 178 : temp_code = build_assignment (EXEC_ASSIGN,
13745 : t1, (*code)->expr1,
13746 89 : NULL, NULL, (*code)->loc);
13747 :
13748 : /* For allocatable LHS, check whether it is allocated. Note
13749 : that allocatable components with defined assignment are
13750 : not yet support. See PR 57696. */
13751 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
13752 : {
13753 24 : gfc_code *block;
13754 24 : gfc_expr *e =
13755 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13756 24 : block = gfc_get_code (EXEC_IF);
13757 24 : block->block = gfc_get_code (EXEC_IF);
13758 24 : block->block->expr1
13759 48 : = gfc_build_intrinsic_call (ns,
13760 : GFC_ISYM_ALLOCATED, "allocated",
13761 24 : (*code)->loc, 1, e);
13762 24 : block->block->next = temp_code;
13763 24 : temp_code = block;
13764 : }
13765 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
13766 : }
13767 :
13768 : /* Replace the first actual arg with the component of the
13769 : temporary. */
13770 89 : gfc_free_expr (this_code->ext.actual->expr);
13771 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
13772 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
13773 :
13774 : /* If the LHS variable is allocatable and wasn't allocated and
13775 : the temporary is allocatable, pointer assign the address of
13776 : the freshly allocated LHS to the temporary. */
13777 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
13778 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
13779 : {
13780 18 : gfc_code *block;
13781 18 : gfc_expr *cond;
13782 :
13783 18 : cond = gfc_get_expr ();
13784 18 : cond->ts.type = BT_LOGICAL;
13785 18 : cond->ts.kind = gfc_default_logical_kind;
13786 18 : cond->expr_type = EXPR_OP;
13787 18 : cond->where = (*code)->loc;
13788 18 : cond->value.op.op = INTRINSIC_NOT;
13789 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
13790 : GFC_ISYM_ALLOCATED, "allocated",
13791 18 : (*code)->loc, 1, gfc_copy_expr (t1));
13792 18 : block = gfc_get_code (EXEC_IF);
13793 18 : block->block = gfc_get_code (EXEC_IF);
13794 18 : block->block->expr1 = cond;
13795 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13796 : t1, (*code)->expr1,
13797 18 : NULL, NULL, (*code)->loc);
13798 18 : add_code_to_chain (&block, &head, &tail);
13799 : }
13800 : }
13801 : }
13802 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
13803 : {
13804 : /* Don't add intrinsic assignments since they are already
13805 : effected by the intrinsic assignment of the structure, unless
13806 : finalization is required. */
13807 7 : if (finalizable_comp)
13808 0 : this_code->expr1->must_finalize = 1;
13809 : else
13810 : {
13811 7 : gfc_free_statements (this_code);
13812 7 : this_code = NULL;
13813 7 : continue;
13814 : }
13815 : }
13816 : else
13817 : {
13818 : /* Resolution has expanded an assignment of a derived type with
13819 : defined assigned components. Remove the redundant, leading
13820 : assignment. */
13821 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
13822 48 : gfc_code *tmp = this_code;
13823 48 : this_code = this_code->next;
13824 48 : tmp->next = NULL;
13825 48 : gfc_free_statements (tmp);
13826 : }
13827 :
13828 191 : add_code_to_chain (&this_code, &head, &tail);
13829 :
13830 191 : if (t1 && (inout || finalizable_out))
13831 : {
13832 : /* Transfer the value to the final result. */
13833 178 : this_code = build_assignment (EXEC_ASSIGN,
13834 : (*code)->expr1, t1,
13835 89 : comp1, comp2, (*code)->loc);
13836 89 : this_code->expr1->must_finalize = 0;
13837 89 : add_code_to_chain (&this_code, &head, &tail);
13838 : }
13839 : }
13840 :
13841 : /* Put the temporary assignments at the top of the generated code. */
13842 182 : if (tmp_head && component_assignment_level == 1)
13843 : {
13844 126 : gfc_append_code (tmp_head, head);
13845 126 : head = tmp_head;
13846 126 : tmp_head = tmp_tail = NULL;
13847 : }
13848 :
13849 : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
13850 : not accidentally deallocated. Hence, nullify t1. */
13851 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
13852 271 : && gfc_expr_attr ((*code)->expr1).allocatable)
13853 : {
13854 18 : gfc_code *block;
13855 18 : gfc_expr *cond;
13856 18 : gfc_expr *e;
13857 :
13858 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13859 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
13860 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
13861 18 : block = gfc_get_code (EXEC_IF);
13862 18 : block->block = gfc_get_code (EXEC_IF);
13863 18 : block->block->expr1 = cond;
13864 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13865 : t1, gfc_get_null_expr (&(*code)->loc),
13866 18 : NULL, NULL, (*code)->loc);
13867 18 : gfc_append_code (tail, block);
13868 18 : tail = block;
13869 : }
13870 :
13871 182 : component_assignment_level--;
13872 :
13873 : /* Make an explicit final call for the function result. */
13874 182 : if (tmp_expr)
13875 81 : generate_final_call (tmp_expr, &head, &tail);
13876 :
13877 182 : if (tmp_code)
13878 : {
13879 134 : ns->code = head;
13880 134 : return;
13881 : }
13882 :
13883 : /* Now attach the remaining code chain to the input code. Step on
13884 : to the end of the new code since resolution is complete. */
13885 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
13886 48 : tail->next = (*code)->next;
13887 : /* Overwrite 'code' because this would place the intrinsic assignment
13888 : before the temporary for the lhs is created. */
13889 48 : gfc_free_expr ((*code)->expr1);
13890 48 : gfc_free_expr ((*code)->expr2);
13891 48 : **code = *head;
13892 48 : if (head != tail)
13893 48 : free (head);
13894 48 : *code = tail;
13895 : }
13896 :
13897 :
13898 : /* F2008: Pointer function assignments are of the form:
13899 : ptr_fcn (args) = expr
13900 : This function breaks these assignments into two statements:
13901 : temporary_pointer => ptr_fcn(args)
13902 : temporary_pointer = expr */
13903 :
13904 : static bool
13905 284691 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
13906 : {
13907 284691 : gfc_expr *tmp_ptr_expr;
13908 284691 : gfc_code *this_code;
13909 284691 : gfc_component *comp;
13910 284691 : gfc_symbol *s;
13911 :
13912 284691 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
13913 : return false;
13914 :
13915 : /* Even if standard does not support this feature, continue to build
13916 : the two statements to avoid upsetting frontend_passes.c. */
13917 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
13918 : "%L", &(*code)->loc);
13919 :
13920 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
13921 :
13922 205 : if (comp)
13923 6 : s = comp->ts.interface;
13924 : else
13925 199 : s = (*code)->expr1->symtree->n.sym;
13926 :
13927 205 : if (s == NULL || !s->result->attr.pointer)
13928 : {
13929 5 : gfc_error ("The function result on the lhs of the assignment at "
13930 : "%L must have the pointer attribute.",
13931 5 : &(*code)->expr1->where);
13932 5 : (*code)->op = EXEC_NOP;
13933 5 : return false;
13934 : }
13935 :
13936 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
13937 :
13938 : /* get_temp_from_expression is set up for ordinary assignments. To that
13939 : end, where array bounds are not known, arrays are made allocatable.
13940 : Change the temporary to a pointer here. */
13941 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
13942 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
13943 200 : tmp_ptr_expr->where = (*code)->loc;
13944 :
13945 : /* A new charlen is required to ensure that the variable string length
13946 : is different to that of the original lhs for deferred results. */
13947 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
13948 : {
13949 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
13950 60 : tmp_ptr_expr->ts.deferred = 1;
13951 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
13952 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
13953 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
13954 : }
13955 :
13956 400 : this_code = build_assignment (EXEC_ASSIGN,
13957 : tmp_ptr_expr, (*code)->expr2,
13958 200 : NULL, NULL, (*code)->loc);
13959 200 : this_code->next = (*code)->next;
13960 200 : (*code)->next = this_code;
13961 200 : (*code)->op = EXEC_POINTER_ASSIGN;
13962 200 : (*code)->expr2 = (*code)->expr1;
13963 200 : (*code)->expr1 = tmp_ptr_expr;
13964 :
13965 200 : return true;
13966 : }
13967 :
13968 :
13969 : /* Deferred character length assignments from an operator expression
13970 : require a temporary because the character length of the lhs can
13971 : change in the course of the assignment. */
13972 :
13973 : static bool
13974 283643 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
13975 : {
13976 283643 : gfc_expr *tmp_expr;
13977 283643 : gfc_code *this_code;
13978 :
13979 283643 : if (!((*code)->expr1->ts.type == BT_CHARACTER
13980 27045 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
13981 836 : && (*code)->expr2->ts.type == BT_CHARACTER
13982 835 : && (*code)->expr2->expr_type == EXPR_OP))
13983 : return false;
13984 :
13985 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
13986 : return false;
13987 :
13988 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
13989 : return false;
13990 :
13991 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13992 22 : tmp_expr->where = (*code)->loc;
13993 :
13994 : /* A new charlen is required to ensure that the variable string
13995 : length is different to that of the original lhs. */
13996 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
13997 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
13998 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
13999 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
14000 :
14001 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
14002 :
14003 22 : this_code = build_assignment (EXEC_ASSIGN,
14004 22 : (*code)->expr1,
14005 : gfc_copy_expr (tmp_expr),
14006 : NULL, NULL, (*code)->loc);
14007 :
14008 22 : (*code)->expr1 = tmp_expr;
14009 :
14010 22 : this_code->next = (*code)->next;
14011 22 : (*code)->next = this_code;
14012 :
14013 22 : return true;
14014 : }
14015 :
14016 :
14017 : /* Given a block of code, recursively resolve everything pointed to by this
14018 : code block. */
14019 :
14020 : void
14021 673663 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
14022 : {
14023 673663 : int omp_workshare_save;
14024 673663 : int forall_save, do_concurrent_save;
14025 673663 : code_stack frame;
14026 673663 : bool t;
14027 :
14028 673663 : frame.prev = cs_base;
14029 673663 : frame.head = code;
14030 673663 : cs_base = &frame;
14031 :
14032 673663 : find_reachable_labels (code);
14033 :
14034 1801509 : for (; code; code = code->next)
14035 : {
14036 1127847 : frame.current = code;
14037 1127847 : forall_save = forall_flag;
14038 1127847 : do_concurrent_save = gfc_do_concurrent_flag;
14039 :
14040 1127847 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
14041 : {
14042 2202 : if (code->op == EXEC_FORALL)
14043 1992 : forall_flag = 1;
14044 210 : else if (code->op == EXEC_DO_CONCURRENT)
14045 210 : gfc_do_concurrent_flag = 1;
14046 2202 : gfc_resolve_forall (code, ns, forall_save);
14047 2202 : if (code->op == EXEC_FORALL)
14048 1992 : forall_flag = 2;
14049 210 : else if (code->op == EXEC_DO_CONCURRENT)
14050 210 : gfc_do_concurrent_flag = 2;
14051 : }
14052 1125645 : else if (code->op == EXEC_OMP_METADIRECTIVE)
14053 138 : for (gfc_omp_variant *variant
14054 : = code->ext.omp_variants;
14055 448 : variant; variant = variant->next)
14056 310 : gfc_resolve_code (variant->code, ns);
14057 1125507 : else if (code->block)
14058 : {
14059 327478 : omp_workshare_save = -1;
14060 327478 : switch (code->op)
14061 : {
14062 10115 : case EXEC_OACC_PARALLEL_LOOP:
14063 10115 : case EXEC_OACC_PARALLEL:
14064 10115 : case EXEC_OACC_KERNELS_LOOP:
14065 10115 : case EXEC_OACC_KERNELS:
14066 10115 : case EXEC_OACC_SERIAL_LOOP:
14067 10115 : case EXEC_OACC_SERIAL:
14068 10115 : case EXEC_OACC_DATA:
14069 10115 : case EXEC_OACC_HOST_DATA:
14070 10115 : case EXEC_OACC_LOOP:
14071 10115 : gfc_resolve_oacc_blocks (code, ns);
14072 10115 : break;
14073 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
14074 54 : omp_workshare_save = omp_workshare_flag;
14075 54 : omp_workshare_flag = 1;
14076 54 : gfc_resolve_omp_parallel_blocks (code, ns);
14077 54 : break;
14078 5975 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14079 5975 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14080 5975 : case EXEC_OMP_MASKED_TASKLOOP:
14081 5975 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14082 5975 : case EXEC_OMP_MASTER_TASKLOOP:
14083 5975 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14084 5975 : case EXEC_OMP_PARALLEL:
14085 5975 : case EXEC_OMP_PARALLEL_DO:
14086 5975 : case EXEC_OMP_PARALLEL_DO_SIMD:
14087 5975 : case EXEC_OMP_PARALLEL_LOOP:
14088 5975 : case EXEC_OMP_PARALLEL_MASKED:
14089 5975 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14090 5975 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14091 5975 : case EXEC_OMP_PARALLEL_MASTER:
14092 5975 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14093 5975 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14094 5975 : case EXEC_OMP_PARALLEL_SECTIONS:
14095 5975 : case EXEC_OMP_TARGET_PARALLEL:
14096 5975 : case EXEC_OMP_TARGET_PARALLEL_DO:
14097 5975 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14098 5975 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14099 5975 : case EXEC_OMP_TARGET_TEAMS:
14100 5975 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14101 5975 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14102 5975 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14103 5975 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14104 5975 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14105 5975 : case EXEC_OMP_TASK:
14106 5975 : case EXEC_OMP_TASKLOOP:
14107 5975 : case EXEC_OMP_TASKLOOP_SIMD:
14108 5975 : case EXEC_OMP_TEAMS:
14109 5975 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14110 5975 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14111 5975 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14112 5975 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14113 5975 : case EXEC_OMP_TEAMS_LOOP:
14114 5975 : omp_workshare_save = omp_workshare_flag;
14115 5975 : omp_workshare_flag = 0;
14116 5975 : gfc_resolve_omp_parallel_blocks (code, ns);
14117 5975 : break;
14118 3063 : case EXEC_OMP_DISTRIBUTE:
14119 3063 : case EXEC_OMP_DISTRIBUTE_SIMD:
14120 3063 : case EXEC_OMP_DO:
14121 3063 : case EXEC_OMP_DO_SIMD:
14122 3063 : case EXEC_OMP_LOOP:
14123 3063 : case EXEC_OMP_SIMD:
14124 3063 : case EXEC_OMP_TARGET_SIMD:
14125 3063 : case EXEC_OMP_TILE:
14126 3063 : case EXEC_OMP_UNROLL:
14127 3063 : gfc_resolve_omp_do_blocks (code, ns);
14128 3063 : break;
14129 : case EXEC_SELECT_TYPE:
14130 : case EXEC_SELECT_RANK:
14131 : /* Blocks are handled in resolve_select_type/rank because we
14132 : have to transform the SELECT TYPE into ASSOCIATE first. */
14133 : break;
14134 : case EXEC_DO_CONCURRENT:
14135 : gfc_do_concurrent_flag = 1;
14136 : gfc_resolve_blocks (code->block, ns);
14137 : gfc_do_concurrent_flag = 2;
14138 : break;
14139 39 : case EXEC_OMP_WORKSHARE:
14140 39 : omp_workshare_save = omp_workshare_flag;
14141 39 : omp_workshare_flag = 1;
14142 : /* FALL THROUGH */
14143 304256 : default:
14144 304256 : gfc_resolve_blocks (code->block, ns);
14145 304256 : break;
14146 : }
14147 :
14148 323463 : if (omp_workshare_save != -1)
14149 6068 : omp_workshare_flag = omp_workshare_save;
14150 : }
14151 798029 : start:
14152 1128052 : t = true;
14153 1128052 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14154 1126665 : t = gfc_resolve_expr (code->expr1);
14155 :
14156 1128052 : forall_flag = forall_save;
14157 1128052 : gfc_do_concurrent_flag = do_concurrent_save;
14158 :
14159 1128052 : if (!gfc_resolve_expr (code->expr2))
14160 637 : t = false;
14161 :
14162 1128052 : if (code->op == EXEC_ALLOCATE
14163 1128052 : && !gfc_resolve_expr (code->expr3))
14164 : t = false;
14165 :
14166 1128052 : switch (code->op)
14167 : {
14168 : case EXEC_NOP:
14169 : case EXEC_END_BLOCK:
14170 : case EXEC_END_NESTED_BLOCK:
14171 : case EXEC_CYCLE:
14172 : case EXEC_PAUSE:
14173 : break;
14174 :
14175 216188 : case EXEC_STOP:
14176 216188 : case EXEC_ERROR_STOP:
14177 216188 : if (code->expr2 != NULL
14178 37 : && (code->expr2->ts.type != BT_LOGICAL
14179 37 : || code->expr2->rank != 0))
14180 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14181 : &code->expr2->where);
14182 : break;
14183 :
14184 : case EXEC_EXIT:
14185 : case EXEC_CONTINUE:
14186 : case EXEC_DT_END:
14187 : case EXEC_ASSIGN_CALL:
14188 : break;
14189 :
14190 54 : case EXEC_CRITICAL:
14191 54 : resolve_critical (code);
14192 54 : break;
14193 :
14194 1307 : case EXEC_SYNC_ALL:
14195 1307 : case EXEC_SYNC_IMAGES:
14196 1307 : case EXEC_SYNC_MEMORY:
14197 1307 : resolve_sync (code);
14198 1307 : break;
14199 :
14200 197 : case EXEC_LOCK:
14201 197 : case EXEC_UNLOCK:
14202 197 : case EXEC_EVENT_POST:
14203 197 : case EXEC_EVENT_WAIT:
14204 197 : resolve_lock_unlock_event (code);
14205 197 : break;
14206 :
14207 : case EXEC_FAIL_IMAGE:
14208 : break;
14209 :
14210 130 : case EXEC_FORM_TEAM:
14211 130 : resolve_form_team (code);
14212 130 : break;
14213 :
14214 73 : case EXEC_CHANGE_TEAM:
14215 73 : resolve_change_team (code);
14216 73 : break;
14217 :
14218 71 : case EXEC_END_TEAM:
14219 71 : resolve_end_team (code);
14220 71 : break;
14221 :
14222 43 : case EXEC_SYNC_TEAM:
14223 43 : resolve_sync_team (code);
14224 43 : break;
14225 :
14226 1424 : case EXEC_ENTRY:
14227 : /* Keep track of which entry we are up to. */
14228 1424 : current_entry_id = code->ext.entry->id;
14229 1424 : break;
14230 :
14231 453 : case EXEC_WHERE:
14232 453 : resolve_where (code, NULL);
14233 453 : break;
14234 :
14235 1250 : case EXEC_GOTO:
14236 1250 : if (code->expr1 != NULL)
14237 : {
14238 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14239 76 : || code->expr1->ts.type != BT_INTEGER
14240 76 : || (code->expr1->ref
14241 1 : && code->expr1->ref->type == REF_ARRAY)
14242 75 : || code->expr1->symtree == NULL
14243 75 : || (code->expr1->symtree->n.sym
14244 75 : && (code->expr1->symtree->n.sym->attr.flavor
14245 75 : == FL_PARAMETER)))
14246 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14247 : "scalar INTEGER variable", &code->expr1->where);
14248 74 : else if (code->expr1->symtree->n.sym
14249 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14250 1 : gfc_error ("Variable %qs has not been assigned a target "
14251 : "label at %L", code->expr1->symtree->n.sym->name,
14252 : &code->expr1->where);
14253 : }
14254 : else
14255 1172 : resolve_branch (code->label1, code);
14256 : break;
14257 :
14258 3189 : case EXEC_RETURN:
14259 3189 : if (code->expr1 != NULL
14260 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14261 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14262 : "INTEGER return specifier", &code->expr1->where);
14263 : break;
14264 :
14265 : case EXEC_INIT_ASSIGN:
14266 : case EXEC_END_PROCEDURE:
14267 : break;
14268 :
14269 285866 : case EXEC_ASSIGN:
14270 285866 : if (!t)
14271 : break;
14272 :
14273 285191 : if (flag_coarray == GFC_FCOARRAY_LIB
14274 285191 : && gfc_is_coindexed (code->expr1))
14275 : {
14276 : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14277 : coindexed variable. */
14278 500 : code->op = EXEC_CALL;
14279 500 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14280 : true);
14281 500 : code->resolved_sym = code->symtree->n.sym;
14282 500 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14283 500 : code->resolved_sym->attr.intrinsic = 1;
14284 500 : code->resolved_sym->attr.subroutine = 1;
14285 500 : code->resolved_isym
14286 500 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14287 500 : gfc_commit_symbol (code->resolved_sym);
14288 500 : code->ext.actual = gfc_get_actual_arglist ();
14289 500 : code->ext.actual->expr = code->expr1;
14290 500 : code->ext.actual->next = gfc_get_actual_arglist ();
14291 500 : if (code->expr2->expr_type != EXPR_VARIABLE
14292 500 : && code->expr2->expr_type != EXPR_CONSTANT)
14293 : {
14294 : /* Convert assignments of expr1[...] = expr2 into
14295 : tvar = expr2
14296 : expr1[...] = tvar
14297 : when expr2 is not trivial. */
14298 54 : gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
14299 54 : gfc_code next_code = *code;
14300 54 : gfc_code *rhs_code
14301 108 : = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
14302 54 : NULL, code->expr2->where);
14303 54 : *code = *rhs_code;
14304 54 : code->next = rhs_code;
14305 54 : *rhs_code = next_code;
14306 :
14307 54 : rhs_code->ext.actual->next->expr = tvar;
14308 54 : rhs_code->expr1 = NULL;
14309 54 : rhs_code->expr2 = NULL;
14310 : }
14311 : else
14312 : {
14313 446 : code->ext.actual->next->expr = code->expr2;
14314 :
14315 446 : code->expr1 = NULL;
14316 446 : code->expr2 = NULL;
14317 : }
14318 : break;
14319 : }
14320 :
14321 284691 : if (code->expr1->ts.type == BT_CLASS)
14322 1090 : gfc_find_vtab (&code->expr2->ts);
14323 :
14324 : /* If this is a pointer function in an lvalue variable context,
14325 : the new code will have to be resolved afresh. This is also the
14326 : case with an error, where the code is transformed into NOP to
14327 : prevent ICEs downstream. */
14328 284691 : if (resolve_ptr_fcn_assign (&code, ns)
14329 284691 : || code->op == EXEC_NOP)
14330 205 : goto start;
14331 :
14332 284486 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14333 284486 : _("assignment")))
14334 : break;
14335 :
14336 284447 : if (resolve_ordinary_assign (code, ns))
14337 : {
14338 804 : if (omp_workshare_flag)
14339 : {
14340 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14341 1 : "at %L", &code->loc);
14342 1 : break;
14343 : }
14344 803 : if (code->op == EXEC_COMPCALL)
14345 443 : goto compcall;
14346 : else
14347 360 : goto call;
14348 : }
14349 :
14350 : /* Check for dependencies in deferred character length array
14351 : assignments and generate a temporary, if necessary. */
14352 283643 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14353 : break;
14354 :
14355 : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14356 283621 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14357 7096 : && code->expr1->ts.u.derived
14358 7096 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14359 188 : generate_component_assignments (&code, ns);
14360 283433 : else if (code->op == EXEC_ASSIGN)
14361 : {
14362 283433 : if (gfc_may_be_finalized (code->expr1->ts))
14363 1241 : code->expr1->must_finalize = 1;
14364 283433 : if (code->expr2->expr_type == EXPR_ARRAY
14365 283433 : && gfc_may_be_finalized (code->expr2->ts))
14366 49 : code->expr2->must_finalize = 1;
14367 : }
14368 :
14369 : break;
14370 :
14371 126 : case EXEC_LABEL_ASSIGN:
14372 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14373 0 : gfc_error ("Label %d referenced at %L is never defined",
14374 : code->label1->value, &code->label1->where);
14375 126 : if (t
14376 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14377 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14378 126 : || code->expr1->symtree->n.sym->ts.kind
14379 126 : != gfc_default_integer_kind
14380 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14381 125 : || code->expr1->symtree->n.sym->as != NULL))
14382 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14383 : "default INTEGER variable", &code->expr1->where);
14384 : break;
14385 :
14386 10423 : case EXEC_POINTER_ASSIGN:
14387 10423 : {
14388 10423 : gfc_expr* e;
14389 :
14390 10423 : if (!t)
14391 : break;
14392 :
14393 : /* This is both a variable definition and pointer assignment
14394 : context, so check both of them. For rank remapping, a final
14395 : array ref may be present on the LHS and fool gfc_expr_attr
14396 : used in gfc_check_vardef_context. Remove it. */
14397 10418 : e = remove_last_array_ref (code->expr1);
14398 20836 : t = gfc_check_vardef_context (e, true, false, false,
14399 10418 : _("pointer assignment"));
14400 10418 : if (t)
14401 10389 : t = gfc_check_vardef_context (e, false, false, false,
14402 10389 : _("pointer assignment"));
14403 10418 : gfc_free_expr (e);
14404 :
14405 1138122 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14406 :
14407 10276 : if (!t)
14408 : break;
14409 :
14410 : /* Assigning a class object always is a regular assign. */
14411 10276 : if (code->expr2->ts.type == BT_CLASS
14412 581 : && code->expr1->ts.type == BT_CLASS
14413 490 : && CLASS_DATA (code->expr2)
14414 489 : && !CLASS_DATA (code->expr2)->attr.dimension
14415 10912 : && !(gfc_expr_attr (code->expr1).proc_pointer
14416 55 : && code->expr2->expr_type == EXPR_VARIABLE
14417 43 : && code->expr2->symtree->n.sym->attr.flavor
14418 43 : == FL_PROCEDURE))
14419 339 : code->op = EXEC_ASSIGN;
14420 : break;
14421 : }
14422 :
14423 72 : case EXEC_ARITHMETIC_IF:
14424 72 : {
14425 72 : gfc_expr *e = code->expr1;
14426 :
14427 72 : gfc_resolve_expr (e);
14428 72 : if (e->expr_type == EXPR_NULL)
14429 1 : gfc_error ("Invalid NULL at %L", &e->where);
14430 :
14431 72 : if (t && (e->rank > 0
14432 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14433 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14434 : "REAL or INTEGER expression", &e->where);
14435 :
14436 72 : resolve_branch (code->label1, code);
14437 72 : resolve_branch (code->label2, code);
14438 72 : resolve_branch (code->label3, code);
14439 : }
14440 72 : break;
14441 :
14442 229598 : case EXEC_IF:
14443 229598 : if (t && code->expr1 != NULL
14444 0 : && (code->expr1->ts.type != BT_LOGICAL
14445 0 : || code->expr1->rank != 0))
14446 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14447 : &code->expr1->where);
14448 : break;
14449 :
14450 78947 : case EXEC_CALL:
14451 78947 : call:
14452 78947 : resolve_call (code);
14453 78947 : break;
14454 :
14455 1706 : case EXEC_COMPCALL:
14456 1706 : compcall:
14457 1706 : resolve_typebound_subroutine (code);
14458 1706 : break;
14459 :
14460 124 : case EXEC_CALL_PPC:
14461 124 : resolve_ppc_call (code);
14462 124 : break;
14463 :
14464 687 : case EXEC_SELECT:
14465 : /* Select is complicated. Also, a SELECT construct could be
14466 : a transformed computed GOTO. */
14467 687 : resolve_select (code, false);
14468 687 : break;
14469 :
14470 3023 : case EXEC_SELECT_TYPE:
14471 3023 : resolve_select_type (code, ns);
14472 3023 : break;
14473 :
14474 1018 : case EXEC_SELECT_RANK:
14475 1018 : resolve_select_rank (code, ns);
14476 1018 : break;
14477 :
14478 7927 : case EXEC_BLOCK:
14479 7927 : resolve_block_construct (code);
14480 7927 : break;
14481 :
14482 32744 : case EXEC_DO:
14483 32744 : if (code->ext.iterator != NULL)
14484 : {
14485 32744 : gfc_iterator *iter = code->ext.iterator;
14486 32744 : if (gfc_resolve_iterator (iter, true, false))
14487 32730 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14488 : true);
14489 : }
14490 : break;
14491 :
14492 531 : case EXEC_DO_WHILE:
14493 531 : if (code->expr1 == NULL)
14494 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14495 : "DO WHILE");
14496 531 : if (t
14497 531 : && (code->expr1->rank != 0
14498 531 : || code->expr1->ts.type != BT_LOGICAL))
14499 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14500 : "a scalar LOGICAL expression", &code->expr1->where);
14501 : break;
14502 :
14503 14222 : case EXEC_ALLOCATE:
14504 14222 : if (t)
14505 14220 : resolve_allocate_deallocate (code, "ALLOCATE");
14506 :
14507 : break;
14508 :
14509 6043 : case EXEC_DEALLOCATE:
14510 6043 : if (t)
14511 6043 : resolve_allocate_deallocate (code, "DEALLOCATE");
14512 :
14513 : break;
14514 :
14515 3897 : case EXEC_OPEN:
14516 3897 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14517 : break;
14518 :
14519 3670 : resolve_branch (code->ext.open->err, code);
14520 3670 : break;
14521 :
14522 3085 : case EXEC_CLOSE:
14523 3085 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14524 : break;
14525 :
14526 3051 : resolve_branch (code->ext.close->err, code);
14527 3051 : break;
14528 :
14529 2797 : case EXEC_BACKSPACE:
14530 2797 : case EXEC_ENDFILE:
14531 2797 : case EXEC_REWIND:
14532 2797 : case EXEC_FLUSH:
14533 2797 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14534 : break;
14535 :
14536 2731 : resolve_branch (code->ext.filepos->err, code);
14537 2731 : break;
14538 :
14539 817 : case EXEC_INQUIRE:
14540 817 : if (!gfc_resolve_inquire (code->ext.inquire))
14541 : break;
14542 :
14543 769 : resolve_branch (code->ext.inquire->err, code);
14544 769 : break;
14545 :
14546 92 : case EXEC_IOLENGTH:
14547 92 : gcc_assert (code->ext.inquire != NULL);
14548 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14549 : break;
14550 :
14551 90 : resolve_branch (code->ext.inquire->err, code);
14552 90 : break;
14553 :
14554 89 : case EXEC_WAIT:
14555 89 : if (!gfc_resolve_wait (code->ext.wait))
14556 : break;
14557 :
14558 74 : resolve_branch (code->ext.wait->err, code);
14559 74 : resolve_branch (code->ext.wait->end, code);
14560 74 : resolve_branch (code->ext.wait->eor, code);
14561 74 : break;
14562 :
14563 32353 : case EXEC_READ:
14564 32353 : case EXEC_WRITE:
14565 32353 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14566 : break;
14567 :
14568 32045 : resolve_branch (code->ext.dt->err, code);
14569 32045 : resolve_branch (code->ext.dt->end, code);
14570 32045 : resolve_branch (code->ext.dt->eor, code);
14571 32045 : break;
14572 :
14573 46354 : case EXEC_TRANSFER:
14574 46354 : resolve_transfer (code);
14575 46354 : break;
14576 :
14577 2202 : case EXEC_DO_CONCURRENT:
14578 2202 : case EXEC_FORALL:
14579 2202 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14580 :
14581 2202 : if (code->expr1 != NULL
14582 732 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14583 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14584 : "expression", &code->expr1->where);
14585 :
14586 2202 : if (code->op == EXEC_DO_CONCURRENT)
14587 210 : resolve_locality_spec (code, ns);
14588 : break;
14589 :
14590 13164 : case EXEC_OACC_PARALLEL_LOOP:
14591 13164 : case EXEC_OACC_PARALLEL:
14592 13164 : case EXEC_OACC_KERNELS_LOOP:
14593 13164 : case EXEC_OACC_KERNELS:
14594 13164 : case EXEC_OACC_SERIAL_LOOP:
14595 13164 : case EXEC_OACC_SERIAL:
14596 13164 : case EXEC_OACC_DATA:
14597 13164 : case EXEC_OACC_HOST_DATA:
14598 13164 : case EXEC_OACC_LOOP:
14599 13164 : case EXEC_OACC_UPDATE:
14600 13164 : case EXEC_OACC_WAIT:
14601 13164 : case EXEC_OACC_CACHE:
14602 13164 : case EXEC_OACC_ENTER_DATA:
14603 13164 : case EXEC_OACC_EXIT_DATA:
14604 13164 : case EXEC_OACC_ATOMIC:
14605 13164 : case EXEC_OACC_DECLARE:
14606 13164 : gfc_resolve_oacc_directive (code, ns);
14607 13164 : break;
14608 :
14609 16891 : case EXEC_OMP_ALLOCATE:
14610 16891 : case EXEC_OMP_ALLOCATORS:
14611 16891 : case EXEC_OMP_ASSUME:
14612 16891 : case EXEC_OMP_ATOMIC:
14613 16891 : case EXEC_OMP_BARRIER:
14614 16891 : case EXEC_OMP_CANCEL:
14615 16891 : case EXEC_OMP_CANCELLATION_POINT:
14616 16891 : case EXEC_OMP_CRITICAL:
14617 16891 : case EXEC_OMP_FLUSH:
14618 16891 : case EXEC_OMP_DEPOBJ:
14619 16891 : case EXEC_OMP_DISPATCH:
14620 16891 : case EXEC_OMP_DISTRIBUTE:
14621 16891 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14622 16891 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14623 16891 : case EXEC_OMP_DISTRIBUTE_SIMD:
14624 16891 : case EXEC_OMP_DO:
14625 16891 : case EXEC_OMP_DO_SIMD:
14626 16891 : case EXEC_OMP_ERROR:
14627 16891 : case EXEC_OMP_INTEROP:
14628 16891 : case EXEC_OMP_LOOP:
14629 16891 : case EXEC_OMP_MASTER:
14630 16891 : case EXEC_OMP_MASTER_TASKLOOP:
14631 16891 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14632 16891 : case EXEC_OMP_MASKED:
14633 16891 : case EXEC_OMP_MASKED_TASKLOOP:
14634 16891 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14635 16891 : case EXEC_OMP_METADIRECTIVE:
14636 16891 : case EXEC_OMP_ORDERED:
14637 16891 : case EXEC_OMP_SCAN:
14638 16891 : case EXEC_OMP_SCOPE:
14639 16891 : case EXEC_OMP_SECTIONS:
14640 16891 : case EXEC_OMP_SIMD:
14641 16891 : case EXEC_OMP_SINGLE:
14642 16891 : case EXEC_OMP_TARGET:
14643 16891 : case EXEC_OMP_TARGET_DATA:
14644 16891 : case EXEC_OMP_TARGET_ENTER_DATA:
14645 16891 : case EXEC_OMP_TARGET_EXIT_DATA:
14646 16891 : case EXEC_OMP_TARGET_PARALLEL:
14647 16891 : case EXEC_OMP_TARGET_PARALLEL_DO:
14648 16891 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14649 16891 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14650 16891 : case EXEC_OMP_TARGET_SIMD:
14651 16891 : case EXEC_OMP_TARGET_TEAMS:
14652 16891 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14653 16891 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14654 16891 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14655 16891 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14656 16891 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14657 16891 : case EXEC_OMP_TARGET_UPDATE:
14658 16891 : case EXEC_OMP_TASK:
14659 16891 : case EXEC_OMP_TASKGROUP:
14660 16891 : case EXEC_OMP_TASKLOOP:
14661 16891 : case EXEC_OMP_TASKLOOP_SIMD:
14662 16891 : case EXEC_OMP_TASKWAIT:
14663 16891 : case EXEC_OMP_TASKYIELD:
14664 16891 : case EXEC_OMP_TEAMS:
14665 16891 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14666 16891 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14667 16891 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14668 16891 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14669 16891 : case EXEC_OMP_TEAMS_LOOP:
14670 16891 : case EXEC_OMP_TILE:
14671 16891 : case EXEC_OMP_UNROLL:
14672 16891 : case EXEC_OMP_WORKSHARE:
14673 16891 : gfc_resolve_omp_directive (code, ns);
14674 16891 : break;
14675 :
14676 3886 : case EXEC_OMP_PARALLEL:
14677 3886 : case EXEC_OMP_PARALLEL_DO:
14678 3886 : case EXEC_OMP_PARALLEL_DO_SIMD:
14679 3886 : case EXEC_OMP_PARALLEL_LOOP:
14680 3886 : case EXEC_OMP_PARALLEL_MASKED:
14681 3886 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14682 3886 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14683 3886 : case EXEC_OMP_PARALLEL_MASTER:
14684 3886 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14685 3886 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14686 3886 : case EXEC_OMP_PARALLEL_SECTIONS:
14687 3886 : case EXEC_OMP_PARALLEL_WORKSHARE:
14688 3886 : omp_workshare_save = omp_workshare_flag;
14689 3886 : omp_workshare_flag = 0;
14690 3886 : gfc_resolve_omp_directive (code, ns);
14691 3886 : omp_workshare_flag = omp_workshare_save;
14692 3886 : break;
14693 :
14694 0 : default:
14695 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
14696 : }
14697 : }
14698 :
14699 673662 : cs_base = frame.prev;
14700 673662 : }
14701 :
14702 :
14703 : /* Resolve initial values and make sure they are compatible with
14704 : the variable. */
14705 :
14706 : static void
14707 1841570 : resolve_values (gfc_symbol *sym)
14708 : {
14709 1841570 : bool t;
14710 :
14711 1841570 : if (sym->value == NULL)
14712 : return;
14713 :
14714 414692 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
14715 14 : gfc_warning (OPT_Wdeprecated_declarations,
14716 : "Using parameter %qs declared at %L is deprecated",
14717 : sym->name, &sym->declared_at);
14718 :
14719 414692 : if (sym->value->expr_type == EXPR_STRUCTURE)
14720 39557 : t= resolve_structure_cons (sym->value, 1);
14721 : else
14722 375135 : t = gfc_resolve_expr (sym->value);
14723 :
14724 414692 : if (!t)
14725 : return;
14726 :
14727 414690 : gfc_check_assign_symbol (sym, NULL, sym->value);
14728 : }
14729 :
14730 :
14731 : /* Verify any BIND(C) derived types in the namespace so we can report errors
14732 : for them once, rather than for each variable declared of that type. */
14733 :
14734 : static void
14735 1812540 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
14736 : {
14737 1812540 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
14738 82814 : && derived_sym->attr.is_bind_c == 1)
14739 26990 : verify_bind_c_derived_type (derived_sym);
14740 :
14741 1812540 : return;
14742 : }
14743 :
14744 :
14745 : /* Check the interfaces of DTIO procedures associated with derived
14746 : type 'sym'. These procedures can either have typebound bindings or
14747 : can appear in DTIO generic interfaces. */
14748 :
14749 : static void
14750 1842540 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
14751 : {
14752 1842540 : if (!sym || sym->attr.flavor != FL_DERIVED)
14753 : return;
14754 :
14755 92038 : gfc_check_dtio_interfaces (sym);
14756 :
14757 92038 : return;
14758 : }
14759 :
14760 : /* Verify that any binding labels used in a given namespace do not collide
14761 : with the names or binding labels of any global symbols. Multiple INTERFACE
14762 : for the same procedure are permitted. Abstract interfaces and dummy
14763 : arguments are not checked. */
14764 :
14765 : static void
14766 1842540 : gfc_verify_binding_labels (gfc_symbol *sym)
14767 : {
14768 1842540 : gfc_gsymbol *gsym;
14769 1842540 : const char *module;
14770 :
14771 1842540 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
14772 61677 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
14773 33771 : || sym->attr.abstract || sym->attr.dummy)
14774 : return;
14775 :
14776 33671 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
14777 :
14778 33671 : if (sym->module)
14779 : module = sym->module;
14780 11961 : else if (sym->ns && sym->ns->proc_name
14781 11961 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
14782 4507 : module = sym->ns->proc_name->name;
14783 7454 : else if (sym->ns && sym->ns->parent
14784 358 : && sym->ns && sym->ns->parent->proc_name
14785 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
14786 272 : module = sym->ns->parent->proc_name->name;
14787 : else
14788 : module = NULL;
14789 :
14790 33671 : if (!gsym
14791 11349 : || (!gsym->defined
14792 8509 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
14793 : {
14794 22322 : if (!gsym)
14795 22322 : gsym = gfc_get_gsymbol (sym->binding_label, true);
14796 30831 : gsym->where = sym->declared_at;
14797 30831 : gsym->sym_name = sym->name;
14798 30831 : gsym->binding_label = sym->binding_label;
14799 30831 : gsym->ns = sym->ns;
14800 30831 : gsym->mod_name = module;
14801 30831 : if (sym->attr.function)
14802 19943 : gsym->type = GSYM_FUNCTION;
14803 10888 : else if (sym->attr.subroutine)
14804 10749 : gsym->type = GSYM_SUBROUTINE;
14805 : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
14806 30831 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
14807 30831 : return;
14808 : }
14809 :
14810 2840 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
14811 : {
14812 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
14813 : "identifier as entity at %L", sym->name,
14814 : sym->binding_label, &sym->declared_at, &gsym->where);
14815 : /* Clear the binding label to prevent checking multiple times. */
14816 1 : sym->binding_label = NULL;
14817 1 : return;
14818 : }
14819 :
14820 2839 : if (sym->attr.flavor == FL_VARIABLE && module
14821 37 : && (strcmp (module, gsym->mod_name) != 0
14822 35 : || strcmp (sym->name, gsym->sym_name) != 0))
14823 : {
14824 : /* This can only happen if the variable is defined in a module - if it
14825 : isn't the same module, reject it. */
14826 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
14827 : "uses the same global identifier as entity at %L from module %qs",
14828 : sym->name, module, sym->binding_label,
14829 : &sym->declared_at, &gsym->where, gsym->mod_name);
14830 3 : sym->binding_label = NULL;
14831 3 : return;
14832 : }
14833 :
14834 2836 : if ((sym->attr.function || sym->attr.subroutine)
14835 2800 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
14836 2798 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
14837 2485 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
14838 2091 : && (module != gsym->mod_name
14839 2087 : || strcmp (gsym->sym_name, sym->name) != 0
14840 2087 : || (module && strcmp (module, gsym->mod_name) != 0)))
14841 : {
14842 : /* Print an error if the procedure is defined multiple times; we have to
14843 : exclude references to the same procedure via module association or
14844 : multiple checks for the same procedure. */
14845 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
14846 : "global identifier as entity at %L", sym->name,
14847 : sym->binding_label, &sym->declared_at, &gsym->where);
14848 4 : sym->binding_label = NULL;
14849 : }
14850 : }
14851 :
14852 :
14853 : /* Resolve an index expression. */
14854 :
14855 : static bool
14856 264517 : resolve_index_expr (gfc_expr *e)
14857 : {
14858 264517 : if (!gfc_resolve_expr (e))
14859 : return false;
14860 :
14861 264507 : if (!gfc_simplify_expr (e, 0))
14862 : return false;
14863 :
14864 264505 : if (!gfc_specification_expr (e))
14865 : return false;
14866 :
14867 : return true;
14868 : }
14869 :
14870 :
14871 : /* Resolve a charlen structure. */
14872 :
14873 : static bool
14874 103021 : resolve_charlen (gfc_charlen *cl)
14875 : {
14876 103021 : int k;
14877 103021 : bool saved_specification_expr;
14878 :
14879 103021 : if (cl->resolved)
14880 : return true;
14881 :
14882 94678 : cl->resolved = 1;
14883 94678 : saved_specification_expr = specification_expr;
14884 94678 : specification_expr = true;
14885 :
14886 94678 : if (cl->length_from_typespec)
14887 : {
14888 2114 : if (!gfc_resolve_expr (cl->length))
14889 : {
14890 1 : specification_expr = saved_specification_expr;
14891 1 : return false;
14892 : }
14893 :
14894 2113 : if (!gfc_simplify_expr (cl->length, 0))
14895 : {
14896 0 : specification_expr = saved_specification_expr;
14897 0 : return false;
14898 : }
14899 :
14900 : /* cl->length has been resolved. It should have an integer type. */
14901 2113 : if (cl->length
14902 2112 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
14903 : {
14904 4 : gfc_error ("Scalar INTEGER expression expected at %L",
14905 : &cl->length->where);
14906 4 : return false;
14907 : }
14908 : }
14909 : else
14910 : {
14911 92564 : if (!resolve_index_expr (cl->length))
14912 : {
14913 19 : specification_expr = saved_specification_expr;
14914 19 : return false;
14915 : }
14916 : }
14917 :
14918 : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
14919 : a negative value, the length of character entities declared is zero. */
14920 94654 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14921 56282 : && mpz_sgn (cl->length->value.integer) < 0)
14922 0 : gfc_replace_expr (cl->length,
14923 : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
14924 :
14925 : /* Check that the character length is not too large. */
14926 94654 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
14927 94654 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14928 56282 : && cl->length->ts.type == BT_INTEGER
14929 56282 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
14930 : {
14931 4 : gfc_error ("String length at %L is too large", &cl->length->where);
14932 4 : specification_expr = saved_specification_expr;
14933 4 : return false;
14934 : }
14935 :
14936 94650 : specification_expr = saved_specification_expr;
14937 94650 : return true;
14938 : }
14939 :
14940 :
14941 : /* Test for non-constant shape arrays. */
14942 :
14943 : static bool
14944 117191 : is_non_constant_shape_array (gfc_symbol *sym)
14945 : {
14946 117191 : gfc_expr *e;
14947 117191 : int i;
14948 117191 : bool not_constant;
14949 :
14950 117191 : not_constant = false;
14951 117191 : if (sym->as != NULL)
14952 : {
14953 : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
14954 : has not been simplified; parameter array references. Do the
14955 : simplification now. */
14956 154703 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
14957 : {
14958 89365 : if (i == GFC_MAX_DIMENSIONS)
14959 : break;
14960 :
14961 89363 : e = sym->as->lower[i];
14962 89363 : if (e && (!resolve_index_expr(e)
14963 86558 : || !gfc_is_constant_expr (e)))
14964 : not_constant = true;
14965 89363 : e = sym->as->upper[i];
14966 89363 : if (e && (!resolve_index_expr(e)
14967 85367 : || !gfc_is_constant_expr (e)))
14968 : not_constant = true;
14969 : }
14970 : }
14971 117191 : return not_constant;
14972 : }
14973 :
14974 : /* Given a symbol and an initialization expression, add code to initialize
14975 : the symbol to the function entry. */
14976 : static void
14977 2075 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
14978 : {
14979 2075 : gfc_expr *lval;
14980 2075 : gfc_code *init_st;
14981 2075 : gfc_namespace *ns = sym->ns;
14982 :
14983 2075 : if (sym->attr.function && sym->result == sym && IS_PDT (sym))
14984 : {
14985 46 : gfc_free_expr (init);
14986 46 : return;
14987 : }
14988 :
14989 : /* Search for the function namespace if this is a contained
14990 : function without an explicit result. */
14991 2029 : if (sym->attr.function && sym == sym->result
14992 293 : && sym->name != sym->ns->proc_name->name)
14993 : {
14994 292 : ns = ns->contained;
14995 1346 : for (;ns; ns = ns->sibling)
14996 1285 : if (strcmp (ns->proc_name->name, sym->name) == 0)
14997 : break;
14998 : }
14999 :
15000 2029 : if (ns == NULL)
15001 : {
15002 61 : gfc_free_expr (init);
15003 61 : return;
15004 : }
15005 :
15006 : /* Build an l-value expression for the result. */
15007 1968 : lval = gfc_lval_expr_from_sym (sym);
15008 :
15009 : /* Add the code at scope entry. */
15010 1968 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
15011 1968 : init_st->next = ns->code;
15012 1968 : ns->code = init_st;
15013 :
15014 : /* Assign the default initializer to the l-value. */
15015 1968 : init_st->loc = sym->declared_at;
15016 1968 : init_st->expr1 = lval;
15017 1968 : init_st->expr2 = init;
15018 : }
15019 :
15020 :
15021 : /* Whether or not we can generate a default initializer for a symbol. */
15022 :
15023 : static bool
15024 29869 : can_generate_init (gfc_symbol *sym)
15025 : {
15026 29869 : symbol_attribute *a;
15027 29869 : if (!sym)
15028 : return false;
15029 29869 : a = &sym->attr;
15030 :
15031 : /* These symbols should never have a default initialization. */
15032 49055 : return !(
15033 29869 : a->allocatable
15034 29869 : || a->external
15035 28710 : || a->pointer
15036 28710 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
15037 5686 : && (CLASS_DATA (sym)->attr.class_pointer
15038 3731 : || CLASS_DATA (sym)->attr.proc_pointer))
15039 26755 : || a->in_equivalence
15040 26634 : || a->in_common
15041 26587 : || a->data
15042 26409 : || sym->module
15043 22584 : || a->cray_pointee
15044 22522 : || a->cray_pointer
15045 22522 : || sym->assoc
15046 19856 : || (!a->referenced && !a->result)
15047 19186 : || (a->dummy && (a->intent != INTENT_OUT
15048 1081 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
15049 19186 : || (a->function && sym != sym->result)
15050 : );
15051 : }
15052 :
15053 :
15054 : /* Assign the default initializer to a derived type variable or result. */
15055 :
15056 : static void
15057 11417 : apply_default_init (gfc_symbol *sym)
15058 : {
15059 11417 : gfc_expr *init = NULL;
15060 :
15061 11417 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15062 : return;
15063 :
15064 11173 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
15065 10320 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15066 :
15067 11173 : if (init == NULL && sym->ts.type != BT_CLASS)
15068 : return;
15069 :
15070 1693 : build_init_assign (sym, init);
15071 1693 : sym->attr.referenced = 1;
15072 : }
15073 :
15074 :
15075 : /* Build an initializer for a local. Returns null if the symbol should not have
15076 : a default initialization. */
15077 :
15078 : static gfc_expr *
15079 203644 : build_default_init_expr (gfc_symbol *sym)
15080 : {
15081 : /* These symbols should never have a default initialization. */
15082 203644 : if (sym->attr.allocatable
15083 189983 : || sym->attr.external
15084 189983 : || sym->attr.dummy
15085 124870 : || sym->attr.pointer
15086 116759 : || sym->attr.in_equivalence
15087 114383 : || sym->attr.in_common
15088 111282 : || sym->attr.data
15089 108984 : || sym->module
15090 106468 : || sym->attr.cray_pointee
15091 106167 : || sym->attr.cray_pointer
15092 105865 : || sym->assoc)
15093 : return NULL;
15094 :
15095 : /* Get the appropriate init expression. */
15096 101151 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
15097 : }
15098 :
15099 : /* Add an initialization expression to a local variable. */
15100 : static void
15101 203644 : apply_default_init_local (gfc_symbol *sym)
15102 : {
15103 203644 : gfc_expr *init = NULL;
15104 :
15105 : /* The symbol should be a variable or a function return value. */
15106 203644 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15107 203644 : || (sym->attr.function && sym->result != sym))
15108 : return;
15109 :
15110 : /* Try to build the initializer expression. If we can't initialize
15111 : this symbol, then init will be NULL. */
15112 203644 : init = build_default_init_expr (sym);
15113 203644 : if (init == NULL)
15114 : return;
15115 :
15116 : /* For saved variables, we don't want to add an initializer at function
15117 : entry, so we just add a static initializer. Note that automatic variables
15118 : are stack allocated even with -fno-automatic; we have also to exclude
15119 : result variable, which are also nonstatic. */
15120 419 : if (!sym->attr.automatic
15121 419 : && (sym->attr.save || sym->ns->save_all
15122 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15123 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15124 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15125 : {
15126 : /* Don't clobber an existing initializer! */
15127 37 : gcc_assert (sym->value == NULL);
15128 37 : sym->value = init;
15129 37 : return;
15130 : }
15131 :
15132 382 : build_init_assign (sym, init);
15133 : }
15134 :
15135 :
15136 : /* Resolution of common features of flavors variable and procedure. */
15137 :
15138 : static bool
15139 963461 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15140 : {
15141 963461 : gfc_array_spec *as;
15142 :
15143 963461 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15144 19169 : && sym->ts.u.derived && CLASS_DATA (sym))
15145 19163 : as = CLASS_DATA (sym)->as;
15146 : else
15147 944298 : as = sym->as;
15148 :
15149 : /* Constraints on deferred shape variable. */
15150 963461 : if (as == NULL || as->type != AS_DEFERRED)
15151 : {
15152 939240 : bool pointer, allocatable, dimension;
15153 :
15154 939240 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15155 15974 : && sym->ts.u.derived && CLASS_DATA (sym))
15156 : {
15157 15968 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15158 15968 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15159 15968 : dimension = CLASS_DATA (sym)->attr.dimension;
15160 : }
15161 : else
15162 : {
15163 923272 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15164 923272 : allocatable = sym->attr.allocatable;
15165 923272 : dimension = sym->attr.dimension;
15166 : }
15167 :
15168 939240 : if (allocatable)
15169 : {
15170 8018 : if (dimension
15171 8018 : && as
15172 524 : && as->type != AS_ASSUMED_RANK
15173 5 : && !sym->attr.select_rank_temporary)
15174 : {
15175 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15176 : "shape or assumed rank", sym->name, &sym->declared_at);
15177 3 : return false;
15178 : }
15179 8015 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15180 : "%qs at %L may not be ALLOCATABLE",
15181 : sym->name, &sym->declared_at))
15182 : return false;
15183 : }
15184 :
15185 939236 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15186 : {
15187 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15188 : "assumed rank", sym->name, &sym->declared_at);
15189 4 : sym->error = 1;
15190 4 : return false;
15191 : }
15192 : }
15193 : else
15194 : {
15195 24221 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15196 4648 : && sym->ts.type != BT_CLASS && !sym->assoc)
15197 : {
15198 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15199 : sym->name, &sym->declared_at);
15200 3 : return false;
15201 : }
15202 : }
15203 :
15204 : /* Constraints on polymorphic variables. */
15205 963450 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15206 : {
15207 : /* F03:C502. */
15208 18502 : if (sym->attr.class_ok
15209 18446 : && sym->ts.u.derived
15210 18441 : && !sym->attr.select_type_temporary
15211 17340 : && !UNLIMITED_POLY (sym)
15212 14830 : && CLASS_DATA (sym)
15213 14829 : && CLASS_DATA (sym)->ts.u.derived
15214 33330 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15215 : {
15216 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15217 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15218 : &sym->declared_at);
15219 5 : return false;
15220 : }
15221 :
15222 : /* F03:C509. */
15223 : /* Assume that use associated symbols were checked in the module ns.
15224 : Class-variables that are associate-names are also something special
15225 : and excepted from the test. */
15226 18497 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15227 54 : && !sym->attr.select_type_temporary
15228 54 : && !sym->attr.select_rank_temporary)
15229 : {
15230 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15231 : "or pointer", sym->name, &sym->declared_at);
15232 54 : return false;
15233 : }
15234 : }
15235 :
15236 : return true;
15237 : }
15238 :
15239 :
15240 : /* Additional checks for symbols with flavor variable and derived
15241 : type. To be called from resolve_fl_variable. */
15242 :
15243 : static bool
15244 81696 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15245 : {
15246 81696 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15247 :
15248 : /* Check to see if a derived type is blocked from being host
15249 : associated by the presence of another class I symbol in the same
15250 : namespace. 14.6.1.3 of the standard and the discussion on
15251 : comp.lang.fortran. */
15252 81696 : if (sym->ts.u.derived
15253 81691 : && sym->ns != sym->ts.u.derived->ns
15254 46788 : && !sym->ts.u.derived->attr.use_assoc
15255 17294 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15256 : {
15257 16324 : gfc_symbol *s;
15258 16324 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15259 16324 : if (s && s->attr.generic)
15260 2 : s = gfc_find_dt_in_generic (s);
15261 16324 : if (s && !gfc_fl_struct (s->attr.flavor))
15262 : {
15263 2 : gfc_error ("The type %qs cannot be host associated at %L "
15264 : "because it is blocked by an incompatible object "
15265 : "of the same name declared at %L",
15266 2 : sym->ts.u.derived->name, &sym->declared_at,
15267 : &s->declared_at);
15268 2 : return false;
15269 : }
15270 : }
15271 :
15272 : /* 4th constraint in section 11.3: "If an object of a type for which
15273 : component-initialization is specified (R429) appears in the
15274 : specification-part of a module and does not have the ALLOCATABLE
15275 : or POINTER attribute, the object shall have the SAVE attribute."
15276 :
15277 : The check for initializers is performed with
15278 : gfc_has_default_initializer because gfc_default_initializer generates
15279 : a hidden default for allocatable components. */
15280 81035 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15281 18299 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15282 413 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15283 21 : && !sym->attr.pointer && !sym->attr.allocatable
15284 21 : && gfc_has_default_initializer (sym->ts.u.derived)
15285 81703 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15286 : "%qs at %L, needed due to the default "
15287 : "initialization", sym->name, &sym->declared_at))
15288 : return false;
15289 :
15290 : /* Assign default initializer. */
15291 81692 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15292 75499 : && (!no_init_flag
15293 59001 : || (sym->attr.intent == INTENT_OUT
15294 3225 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15295 19549 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15296 :
15297 : return true;
15298 : }
15299 :
15300 :
15301 : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15302 : except in the declaration of an entity or component that has the POINTER
15303 : or ALLOCATABLE attribute. */
15304 :
15305 : static bool
15306 1500223 : deferred_requirements (gfc_symbol *sym)
15307 : {
15308 1500223 : if (sym->ts.deferred
15309 7899 : && !(sym->attr.pointer
15310 2371 : || sym->attr.allocatable
15311 92 : || sym->attr.associate_var
15312 7 : || sym->attr.omp_udr_artificial_var))
15313 : {
15314 : /* If a function has a result variable, only check the variable. */
15315 7 : if (sym->result && sym->name != sym->result->name)
15316 : return true;
15317 :
15318 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15319 : "requires either the POINTER or ALLOCATABLE attribute",
15320 : sym->name, &sym->declared_at);
15321 6 : return false;
15322 : }
15323 : return true;
15324 : }
15325 :
15326 :
15327 : /* Resolve symbols with flavor variable. */
15328 :
15329 : static bool
15330 646298 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15331 : {
15332 646298 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15333 : "SAVE attribute");
15334 :
15335 646298 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15336 : return false;
15337 :
15338 : /* Set this flag to check that variables are parameters of all entries.
15339 : This check is effected by the call to gfc_resolve_expr through
15340 : is_non_constant_shape_array. */
15341 646238 : bool saved_specification_expr = specification_expr;
15342 646238 : specification_expr = true;
15343 :
15344 646238 : if (sym->ns->proc_name
15345 646143 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15346 641153 : || sym->ns->proc_name->attr.is_main_program)
15347 82226 : && !sym->attr.use_assoc
15348 79089 : && !sym->attr.allocatable
15349 73388 : && !sym->attr.pointer
15350 715992 : && is_non_constant_shape_array (sym))
15351 : {
15352 : /* F08:C541. The shape of an array defined in a main program or module
15353 : * needs to be constant. */
15354 3 : gfc_error ("The module or main program array %qs at %L must "
15355 : "have constant shape", sym->name, &sym->declared_at);
15356 3 : specification_expr = saved_specification_expr;
15357 3 : return false;
15358 : }
15359 :
15360 : /* Constraints on deferred type parameter. */
15361 646235 : if (!deferred_requirements (sym))
15362 : return false;
15363 :
15364 646231 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15365 : {
15366 : /* Make sure that character string variables with assumed length are
15367 : dummy arguments. */
15368 35845 : gfc_expr *e = NULL;
15369 :
15370 35845 : if (sym->ts.u.cl)
15371 35845 : e = sym->ts.u.cl->length;
15372 : else
15373 : return false;
15374 :
15375 35845 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15376 2580 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15377 2 : && !sym->attr.omp_udr_artificial_var)
15378 : {
15379 2 : gfc_error ("Entity with assumed character length at %L must be a "
15380 : "dummy argument or a PARAMETER", &sym->declared_at);
15381 2 : specification_expr = saved_specification_expr;
15382 2 : return false;
15383 : }
15384 :
15385 20736 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15386 : {
15387 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15388 1 : specification_expr = saved_specification_expr;
15389 1 : return false;
15390 : }
15391 :
15392 35842 : if (!gfc_is_constant_expr (e)
15393 35842 : && !(e->expr_type == EXPR_VARIABLE
15394 1388 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
15395 : {
15396 2184 : if (!sym->attr.use_assoc && sym->ns->proc_name
15397 1680 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15398 1679 : || sym->ns->proc_name->attr.is_main_program))
15399 : {
15400 3 : gfc_error ("%qs at %L must have constant character length "
15401 : "in this context", sym->name, &sym->declared_at);
15402 3 : specification_expr = saved_specification_expr;
15403 3 : return false;
15404 : }
15405 2181 : if (sym->attr.in_common)
15406 : {
15407 1 : gfc_error ("COMMON variable %qs at %L must have constant "
15408 : "character length", sym->name, &sym->declared_at);
15409 1 : specification_expr = saved_specification_expr;
15410 1 : return false;
15411 : }
15412 : }
15413 : }
15414 :
15415 646224 : if (sym->value == NULL && sym->attr.referenced
15416 205529 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
15417 203644 : apply_default_init_local (sym); /* Try to apply a default initialization. */
15418 :
15419 : /* Determine if the symbol may not have an initializer. */
15420 646224 : int no_init_flag = 0, automatic_flag = 0;
15421 646224 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
15422 170056 : || sym->attr.intrinsic || sym->attr.result)
15423 : no_init_flag = 1;
15424 137817 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
15425 172270 : && is_non_constant_shape_array (sym))
15426 : {
15427 1345 : no_init_flag = automatic_flag = 1;
15428 :
15429 : /* Also, they must not have the SAVE attribute.
15430 : SAVE_IMPLICIT is checked below. */
15431 1345 : if (sym->as && sym->attr.codimension)
15432 : {
15433 7 : int corank = sym->as->corank;
15434 7 : sym->as->corank = 0;
15435 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
15436 7 : sym->as->corank = corank;
15437 : }
15438 1345 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
15439 : {
15440 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15441 2 : specification_expr = saved_specification_expr;
15442 2 : return false;
15443 : }
15444 : }
15445 :
15446 : /* Ensure that any initializer is simplified. */
15447 646222 : if (sym->value)
15448 7973 : gfc_simplify_expr (sym->value, 1);
15449 :
15450 : /* Reject illegal initializers. */
15451 646222 : if (!sym->mark && sym->value)
15452 : {
15453 7973 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
15454 67 : && CLASS_DATA (sym)->attr.allocatable))
15455 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
15456 : sym->name, &sym->declared_at);
15457 7972 : else if (sym->attr.external)
15458 0 : gfc_error ("External %qs at %L cannot have an initializer",
15459 : sym->name, &sym->declared_at);
15460 7972 : else if (sym->attr.dummy)
15461 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
15462 : sym->name, &sym->declared_at);
15463 7969 : else if (sym->attr.intrinsic)
15464 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
15465 : sym->name, &sym->declared_at);
15466 7969 : else if (sym->attr.result)
15467 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
15468 : sym->name, &sym->declared_at);
15469 7968 : else if (automatic_flag)
15470 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
15471 : sym->name, &sym->declared_at);
15472 : else
15473 7963 : goto no_init_error;
15474 10 : specification_expr = saved_specification_expr;
15475 10 : return false;
15476 : }
15477 :
15478 638249 : no_init_error:
15479 646212 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
15480 : {
15481 81696 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
15482 81696 : specification_expr = saved_specification_expr;
15483 81696 : return res;
15484 : }
15485 :
15486 564516 : specification_expr = saved_specification_expr;
15487 564516 : return true;
15488 : }
15489 :
15490 :
15491 : /* Compare the dummy characteristics of a module procedure interface
15492 : declaration with the corresponding declaration in a submodule. */
15493 : static gfc_formal_arglist *new_formal;
15494 : static char errmsg[200];
15495 :
15496 : static void
15497 1324 : compare_fsyms (gfc_symbol *sym)
15498 : {
15499 1324 : gfc_symbol *fsym;
15500 :
15501 1324 : if (sym == NULL || new_formal == NULL)
15502 : return;
15503 :
15504 1324 : fsym = new_formal->sym;
15505 :
15506 1324 : if (sym == fsym)
15507 : return;
15508 :
15509 1300 : if (strcmp (sym->name, fsym->name) == 0)
15510 : {
15511 499 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
15512 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
15513 : }
15514 : }
15515 :
15516 :
15517 : /* Resolve a procedure. */
15518 :
15519 : static bool
15520 473174 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
15521 : {
15522 473174 : gfc_formal_arglist *arg;
15523 473174 : bool allocatable_or_pointer = false;
15524 :
15525 473174 : if (sym->attr.function
15526 473174 : && !resolve_fl_var_and_proc (sym, mp_flag))
15527 : return false;
15528 :
15529 : /* Constraints on deferred type parameter. */
15530 473164 : if (!deferred_requirements (sym))
15531 : return false;
15532 :
15533 473163 : if (sym->ts.type == BT_CHARACTER)
15534 : {
15535 11565 : gfc_charlen *cl = sym->ts.u.cl;
15536 :
15537 7470 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
15538 12735 : && !resolve_charlen (cl))
15539 : return false;
15540 :
15541 11564 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
15542 10395 : && sym->attr.proc == PROC_ST_FUNCTION)
15543 : {
15544 0 : gfc_error ("Character-valued statement function %qs at %L must "
15545 : "have constant length", sym->name, &sym->declared_at);
15546 0 : return false;
15547 : }
15548 : }
15549 :
15550 : /* Ensure that derived type for are not of a private type. Internal
15551 : module procedures are excluded by 2.2.3.3 - i.e., they are not
15552 : externally accessible and can access all the objects accessible in
15553 : the host. */
15554 108981 : if (!(sym->ns->parent && sym->ns->parent->proc_name
15555 108981 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15556 557927 : && gfc_check_symbol_access (sym))
15557 : {
15558 442012 : gfc_interface *iface;
15559 :
15560 932336 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
15561 : {
15562 490325 : if (arg->sym
15563 490184 : && arg->sym->ts.type == BT_DERIVED
15564 42874 : && arg->sym->ts.u.derived
15565 42874 : && !arg->sym->ts.u.derived->attr.use_assoc
15566 4420 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15567 490334 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
15568 : "and cannot be a dummy argument"
15569 : " of %qs, which is PUBLIC at %L",
15570 9 : arg->sym->name, sym->name,
15571 : &sym->declared_at))
15572 : {
15573 : /* Stop this message from recurring. */
15574 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15575 1 : return false;
15576 : }
15577 : }
15578 :
15579 : /* PUBLIC interfaces may expose PRIVATE procedures that take types
15580 : PRIVATE to the containing module. */
15581 629162 : for (iface = sym->generic; iface; iface = iface->next)
15582 : {
15583 436925 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
15584 : {
15585 249774 : if (arg->sym
15586 249742 : && arg->sym->ts.type == BT_DERIVED
15587 8010 : && !arg->sym->ts.u.derived->attr.use_assoc
15588 244 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15589 249778 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
15590 : "PUBLIC interface %qs at %L "
15591 : "takes dummy arguments of %qs which "
15592 : "is PRIVATE", iface->sym->name,
15593 4 : sym->name, &iface->sym->declared_at,
15594 4 : gfc_typename(&arg->sym->ts)))
15595 : {
15596 : /* Stop this message from recurring. */
15597 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15598 1 : return false;
15599 : }
15600 : }
15601 : }
15602 : }
15603 :
15604 473160 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
15605 67 : && !sym->attr.proc_pointer)
15606 : {
15607 2 : gfc_error ("Function %qs at %L cannot have an initializer",
15608 : sym->name, &sym->declared_at);
15609 :
15610 : /* Make sure no second error is issued for this. */
15611 2 : sym->value->error = 1;
15612 2 : return false;
15613 : }
15614 :
15615 : /* An external symbol may not have an initializer because it is taken to be
15616 : a procedure. Exception: Procedure Pointers. */
15617 473158 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
15618 : {
15619 0 : gfc_error ("External object %qs at %L may not have an initializer",
15620 : sym->name, &sym->declared_at);
15621 0 : return false;
15622 : }
15623 :
15624 : /* An elemental function is required to return a scalar 12.7.1 */
15625 473158 : if (sym->attr.elemental && sym->attr.function
15626 86275 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15627 2 : && CLASS_DATA (sym)->as)))
15628 : {
15629 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
15630 : "result", sym->name, &sym->declared_at);
15631 : /* Reset so that the error only occurs once. */
15632 3 : sym->attr.elemental = 0;
15633 3 : return false;
15634 : }
15635 :
15636 473155 : if (sym->attr.proc == PROC_ST_FUNCTION
15637 223 : && (sym->attr.allocatable || sym->attr.pointer))
15638 : {
15639 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
15640 : "allocatable attribute", sym->name, &sym->declared_at);
15641 2 : return false;
15642 : }
15643 :
15644 : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
15645 : char-len-param shall not be array-valued, pointer-valued, recursive
15646 : or pure. ....snip... A character value of * may only be used in the
15647 : following ways: (i) Dummy arg of procedure - dummy associates with
15648 : actual length; (ii) To declare a named constant; or (iii) External
15649 : function - but length must be declared in calling scoping unit. */
15650 473153 : if (sym->attr.function
15651 317144 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
15652 6557 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
15653 : {
15654 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
15655 178 : || (sym->attr.recursive) || (sym->attr.pure))
15656 : {
15657 4 : if (sym->as && sym->as->rank)
15658 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15659 : "array-valued", sym->name, &sym->declared_at);
15660 :
15661 4 : if (sym->attr.pointer)
15662 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15663 : "pointer-valued", sym->name, &sym->declared_at);
15664 :
15665 4 : if (sym->attr.pure)
15666 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15667 : "pure", sym->name, &sym->declared_at);
15668 :
15669 4 : if (sym->attr.recursive)
15670 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15671 : "recursive", sym->name, &sym->declared_at);
15672 :
15673 4 : return false;
15674 : }
15675 :
15676 : /* Appendix B.2 of the standard. Contained functions give an
15677 : error anyway. Deferred character length is an F2003 feature.
15678 : Don't warn on intrinsic conversion functions, which start
15679 : with two underscores. */
15680 176 : if (!sym->attr.contained && !sym->ts.deferred
15681 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
15682 172 : gfc_notify_std (GFC_STD_F95_OBS,
15683 : "CHARACTER(*) function %qs at %L",
15684 : sym->name, &sym->declared_at);
15685 : }
15686 :
15687 : /* F2008, C1218. */
15688 473149 : if (sym->attr.elemental)
15689 : {
15690 89505 : if (sym->attr.proc_pointer)
15691 : {
15692 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
15693 : : sym->name);
15694 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
15695 : name, &sym->declared_at);
15696 7 : return false;
15697 : }
15698 89498 : if (sym->attr.dummy)
15699 : {
15700 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
15701 : sym->name, &sym->declared_at);
15702 3 : return false;
15703 : }
15704 : }
15705 :
15706 : /* F2018, C15100: "The result of an elemental function shall be scalar,
15707 : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
15708 : pointer is tested and caught elsewhere. */
15709 473139 : if (sym->result)
15710 266297 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
15711 266297 : && CLASS_DATA (sym->result) ?
15712 1663 : (CLASS_DATA (sym->result)->attr.allocatable
15713 1663 : || CLASS_DATA (sym->result)->attr.pointer) :
15714 264634 : (sym->result->attr.allocatable
15715 264634 : || sym->result->attr.pointer);
15716 :
15717 473139 : if (sym->attr.elemental && sym->result
15718 85900 : && allocatable_or_pointer)
15719 : {
15720 4 : gfc_error ("Function result variable %qs at %L of elemental "
15721 : "function %qs shall not have an ALLOCATABLE or POINTER "
15722 : "attribute", sym->result->name,
15723 : &sym->result->declared_at, sym->name);
15724 4 : return false;
15725 : }
15726 :
15727 : /* F2018:C1585: "The function result of a pure function shall not be both
15728 : polymorphic and allocatable, or have a polymorphic allocatable ultimate
15729 : component." */
15730 473135 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
15731 : {
15732 2459 : if (sym->ts.type == BT_CLASS
15733 5 : && sym->attr.class_ok
15734 4 : && CLASS_DATA (sym->result)
15735 4 : && CLASS_DATA (sym->result)->attr.allocatable)
15736 : {
15737 4 : gfc_error ("Result variable %qs of pure function at %L is "
15738 : "polymorphic allocatable",
15739 : sym->result->name, &sym->result->declared_at);
15740 4 : return false;
15741 : }
15742 :
15743 2455 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
15744 : {
15745 : gfc_component *c = sym->ts.u.derived->components;
15746 4491 : for (; c; c = c->next)
15747 2345 : if (c->ts.type == BT_CLASS
15748 2 : && CLASS_DATA (c)
15749 2 : && CLASS_DATA (c)->attr.allocatable)
15750 : {
15751 2 : gfc_error ("Result variable %qs of pure function at %L has "
15752 : "polymorphic allocatable component %qs",
15753 : sym->result->name, &sym->result->declared_at,
15754 : c->name);
15755 2 : return false;
15756 : }
15757 : }
15758 : }
15759 :
15760 473129 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
15761 : {
15762 6585 : gfc_formal_arglist *curr_arg;
15763 6585 : int has_non_interop_arg = 0;
15764 :
15765 6585 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15766 6585 : sym->common_block))
15767 : {
15768 : /* Clear these to prevent looking at them again if there was an
15769 : error. */
15770 2 : sym->attr.is_bind_c = 0;
15771 2 : sym->attr.is_c_interop = 0;
15772 2 : sym->ts.is_c_interop = 0;
15773 : }
15774 : else
15775 : {
15776 : /* So far, no errors have been found. */
15777 6583 : sym->attr.is_c_interop = 1;
15778 6583 : sym->ts.is_c_interop = 1;
15779 : }
15780 :
15781 6585 : curr_arg = gfc_sym_get_dummy_args (sym);
15782 29588 : while (curr_arg != NULL)
15783 : {
15784 : /* Skip implicitly typed dummy args here. */
15785 16418 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
15786 16361 : if (!gfc_verify_c_interop_param (curr_arg->sym))
15787 : /* If something is found to fail, record the fact so we
15788 : can mark the symbol for the procedure as not being
15789 : BIND(C) to try and prevent multiple errors being
15790 : reported. */
15791 16418 : has_non_interop_arg = 1;
15792 :
15793 16418 : curr_arg = curr_arg->next;
15794 : }
15795 :
15796 : /* See if any of the arguments were not interoperable and if so, clear
15797 : the procedure symbol to prevent duplicate error messages. */
15798 6585 : if (has_non_interop_arg != 0)
15799 : {
15800 128 : sym->attr.is_c_interop = 0;
15801 128 : sym->ts.is_c_interop = 0;
15802 128 : sym->attr.is_bind_c = 0;
15803 : }
15804 : }
15805 :
15806 473129 : if (!sym->attr.proc_pointer)
15807 : {
15808 472082 : if (sym->attr.save == SAVE_EXPLICIT)
15809 : {
15810 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
15811 : "in %qs at %L", sym->name, &sym->declared_at);
15812 5 : return false;
15813 : }
15814 472077 : if (sym->attr.intent)
15815 : {
15816 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
15817 : "in %qs at %L", sym->name, &sym->declared_at);
15818 1 : return false;
15819 : }
15820 472076 : if (sym->attr.subroutine && sym->attr.result)
15821 : {
15822 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
15823 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
15824 2 : return false;
15825 : }
15826 472074 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
15827 134606 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
15828 134603 : || sym->attr.contained))
15829 : {
15830 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
15831 : "in %qs at %L", sym->name, &sym->declared_at);
15832 3 : return false;
15833 : }
15834 472071 : if (strcmp ("ppr@", sym->name) == 0)
15835 : {
15836 0 : gfc_error ("Procedure pointer result %qs at %L "
15837 : "is missing the pointer attribute",
15838 0 : sym->ns->proc_name->name, &sym->declared_at);
15839 0 : return false;
15840 : }
15841 : }
15842 :
15843 : /* Assume that a procedure whose body is not known has references
15844 : to external arrays. */
15845 473118 : if (sym->attr.if_source != IFSRC_DECL)
15846 325469 : sym->attr.array_outer_dependency = 1;
15847 :
15848 : /* Compare the characteristics of a module procedure with the
15849 : interface declaration. Ideally this would be done with
15850 : gfc_compare_interfaces but, at present, the formal interface
15851 : cannot be copied to the ts.interface. */
15852 473118 : if (sym->attr.module_procedure
15853 1515 : && sym->attr.if_source == IFSRC_DECL)
15854 : {
15855 629 : gfc_symbol *iface;
15856 629 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
15857 629 : char *module_name;
15858 629 : char *submodule_name;
15859 629 : strcpy (name, sym->ns->proc_name->name);
15860 629 : module_name = strtok (name, ".");
15861 629 : submodule_name = strtok (NULL, ".");
15862 :
15863 629 : iface = sym->tlink;
15864 629 : sym->tlink = NULL;
15865 :
15866 : /* Make sure that the result uses the correct charlen for deferred
15867 : length results. */
15868 629 : if (iface && sym->result
15869 189 : && iface->ts.type == BT_CHARACTER
15870 19 : && iface->ts.deferred)
15871 6 : sym->result->ts.u.cl = iface->ts.u.cl;
15872 :
15873 6 : if (iface == NULL)
15874 195 : goto check_formal;
15875 :
15876 : /* Check the procedure characteristics. */
15877 434 : if (sym->attr.elemental != iface->attr.elemental)
15878 : {
15879 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
15880 : "PROCEDURE at %L and its interface in %s",
15881 : &sym->declared_at, module_name);
15882 10 : return false;
15883 : }
15884 :
15885 433 : if (sym->attr.pure != iface->attr.pure)
15886 : {
15887 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
15888 : "PROCEDURE at %L and its interface in %s",
15889 : &sym->declared_at, module_name);
15890 2 : return false;
15891 : }
15892 :
15893 431 : if (sym->attr.recursive != iface->attr.recursive)
15894 : {
15895 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
15896 : "PROCEDURE at %L and its interface in %s",
15897 : &sym->declared_at, module_name);
15898 2 : return false;
15899 : }
15900 :
15901 : /* Check the result characteristics. */
15902 429 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
15903 : {
15904 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
15905 : "in MODULE %qs and the declaration at %L in "
15906 : "(SUB)MODULE %qs",
15907 : errmsg, module_name, &sym->declared_at,
15908 : submodule_name ? submodule_name : module_name);
15909 5 : return false;
15910 : }
15911 :
15912 424 : check_formal:
15913 : /* Check the characteristics of the formal arguments. */
15914 619 : if (sym->formal && sym->formal_ns)
15915 : {
15916 1212 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
15917 : {
15918 697 : new_formal = arg;
15919 697 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
15920 : }
15921 : }
15922 : }
15923 :
15924 : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
15925 : BIND(C) attribute. */
15926 473108 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
15927 : {
15928 1 : gfc_error ("Interface of %qs at %L must be explicit",
15929 : sym->name, &sym->declared_at);
15930 1 : return false;
15931 : }
15932 :
15933 : return true;
15934 : }
15935 :
15936 :
15937 : /* Resolve a list of finalizer procedures. That is, after they have hopefully
15938 : been defined and we now know their defined arguments, check that they fulfill
15939 : the requirements of the standard for procedures used as finalizers. */
15940 :
15941 : static bool
15942 111358 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
15943 : {
15944 111358 : gfc_finalizer *list, *pdt_finalizers = NULL;
15945 111358 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
15946 111358 : bool result = true;
15947 111358 : bool seen_scalar = false;
15948 111358 : gfc_symbol *vtab;
15949 111358 : gfc_component *c;
15950 111358 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
15951 :
15952 111358 : if (parent)
15953 15461 : gfc_resolve_finalizers (parent, finalizable);
15954 :
15955 : /* Ensure that derived-type components have a their finalizers resolved. */
15956 111358 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
15957 350620 : for (c = derived->components; c; c = c->next)
15958 239262 : if (c->ts.type == BT_DERIVED
15959 67115 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
15960 : {
15961 8288 : bool has_final2 = false;
15962 8288 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
15963 0 : return false; /* Error. */
15964 8288 : has_final = has_final || has_final2;
15965 : }
15966 : /* Return early if not finalizable. */
15967 111358 : if (!has_final)
15968 : {
15969 108823 : if (finalizable)
15970 8202 : *finalizable = false;
15971 108823 : return true;
15972 : }
15973 :
15974 : /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of
15975 : the template. If the finalizers field has the same value, it needs to be
15976 : supplied with finalizers of the same pdt_type. */
15977 2535 : if (derived->attr.pdt_type
15978 30 : && derived->template_sym
15979 12 : && derived->template_sym->f2k_derived
15980 12 : && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers)
15981 2547 : && derived->f2k_derived->finalizers == pdt_finalizers)
15982 : {
15983 12 : gfc_finalizer *tmp = NULL;
15984 12 : derived->f2k_derived->finalizers = NULL;
15985 12 : prev_link = &derived->f2k_derived->finalizers;
15986 48 : for (list = pdt_finalizers; list; list = list->next)
15987 : {
15988 36 : gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym);
15989 36 : if (args->sym
15990 36 : && args->sym->ts.type == BT_DERIVED
15991 36 : && args->sym->ts.u.derived
15992 36 : && !strcmp (args->sym->ts.u.derived->name, derived->name))
15993 : {
15994 18 : tmp = gfc_get_finalizer ();
15995 18 : *tmp = *list;
15996 18 : tmp->next = NULL;
15997 18 : if (*prev_link)
15998 : {
15999 6 : (*prev_link)->next = tmp;
16000 6 : prev_link = &tmp;
16001 : }
16002 : else
16003 12 : *prev_link = tmp;
16004 18 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16005 : }
16006 : }
16007 : }
16008 :
16009 : /* Walk over the list of finalizer-procedures, check them, and if any one
16010 : does not fit in with the standard's definition, print an error and remove
16011 : it from the list. */
16012 2535 : prev_link = &derived->f2k_derived->finalizers;
16013 5230 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
16014 : {
16015 2695 : gfc_formal_arglist *dummy_args;
16016 2695 : gfc_symbol* arg;
16017 2695 : gfc_finalizer* i;
16018 2695 : int my_rank;
16019 :
16020 : /* Skip this finalizer if we already resolved it. */
16021 2695 : if (list->proc_tree)
16022 : {
16023 2162 : if (list->proc_tree->n.sym->formal->sym->as == NULL
16024 584 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
16025 1578 : seen_scalar = true;
16026 2162 : prev_link = &(list->next);
16027 2162 : continue;
16028 : }
16029 :
16030 : /* Check this exists and is a SUBROUTINE. */
16031 533 : if (!list->proc_sym->attr.subroutine)
16032 : {
16033 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
16034 : list->proc_sym->name, &list->where);
16035 3 : goto error;
16036 : }
16037 :
16038 : /* We should have exactly one argument. */
16039 530 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
16040 530 : if (!dummy_args || dummy_args->next)
16041 : {
16042 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
16043 : &list->where);
16044 2 : goto error;
16045 : }
16046 528 : arg = dummy_args->sym;
16047 :
16048 528 : if (!arg)
16049 : {
16050 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16051 1 : &list->proc_sym->declared_at, derived->name);
16052 1 : goto error;
16053 : }
16054 :
16055 527 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
16056 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
16057 : {
16058 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
16059 : "be the only finalizer with the same kind/type "
16060 : "(F2018: C790)", &list->where);
16061 0 : goto error;
16062 : }
16063 :
16064 : /* This argument must be of our type. */
16065 527 : if (!derived->attr.pdt_template
16066 527 : && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived))
16067 : {
16068 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16069 : &arg->declared_at, derived->name);
16070 2 : goto error;
16071 : }
16072 :
16073 : /* It must neither be a pointer nor allocatable nor optional. */
16074 525 : if (arg->attr.pointer)
16075 : {
16076 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
16077 : &arg->declared_at);
16078 1 : goto error;
16079 : }
16080 524 : if (arg->attr.allocatable)
16081 : {
16082 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16083 : " ALLOCATABLE", &arg->declared_at);
16084 1 : goto error;
16085 : }
16086 523 : if (arg->attr.optional)
16087 : {
16088 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
16089 : &arg->declared_at);
16090 1 : goto error;
16091 : }
16092 :
16093 : /* It must not be INTENT(OUT). */
16094 522 : if (arg->attr.intent == INTENT_OUT)
16095 : {
16096 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16097 : " INTENT(OUT)", &arg->declared_at);
16098 1 : goto error;
16099 : }
16100 :
16101 : /* Warn if the procedure is non-scalar and not assumed shape. */
16102 521 : if (warn_surprising && arg->as && arg->as->rank != 0
16103 3 : && arg->as->type != AS_ASSUMED_SHAPE)
16104 2 : gfc_warning (OPT_Wsurprising,
16105 : "Non-scalar FINAL procedure at %L should have assumed"
16106 : " shape argument", &arg->declared_at);
16107 :
16108 : /* Check that it does not match in kind and rank with a FINAL procedure
16109 : defined earlier. To really loop over the *earlier* declarations,
16110 : we need to walk the tail of the list as new ones were pushed at the
16111 : front. */
16112 : /* TODO: Handle kind parameters once they are implemented. */
16113 521 : my_rank = (arg->as ? arg->as->rank : 0);
16114 616 : for (i = list->next; i; i = i->next)
16115 : {
16116 97 : gfc_formal_arglist *dummy_args;
16117 :
16118 : /* Argument list might be empty; that is an error signalled earlier,
16119 : but we nevertheless continued resolving. */
16120 97 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
16121 97 : if (dummy_args && !derived->attr.pdt_template)
16122 : {
16123 95 : gfc_symbol* i_arg = dummy_args->sym;
16124 95 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
16125 95 : if (i_rank == my_rank)
16126 : {
16127 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
16128 : " rank (%d) as %qs",
16129 2 : list->proc_sym->name, &list->where, my_rank,
16130 2 : i->proc_sym->name);
16131 2 : goto error;
16132 : }
16133 : }
16134 : }
16135 :
16136 : /* Is this the/a scalar finalizer procedure? */
16137 519 : if (my_rank == 0)
16138 393 : seen_scalar = true;
16139 :
16140 : /* Find the symtree for this procedure. */
16141 519 : gcc_assert (!list->proc_tree);
16142 519 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16143 :
16144 519 : prev_link = &list->next;
16145 519 : continue;
16146 :
16147 : /* Remove wrong nodes immediately from the list so we don't risk any
16148 : troubles in the future when they might fail later expectations. */
16149 14 : error:
16150 14 : i = list;
16151 14 : *prev_link = list->next;
16152 14 : gfc_free_finalizer (i);
16153 14 : result = false;
16154 519 : }
16155 :
16156 2535 : if (result == false)
16157 : return false;
16158 :
16159 : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16160 : were nodes in the list, must have been for arrays. It is surely a good
16161 : idea to have a scalar version there if there's something to finalize. */
16162 2531 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16163 1 : gfc_warning (OPT_Wsurprising,
16164 : "Only array FINAL procedures declared for derived type %qs"
16165 : " defined at %L, suggest also scalar one unless an assumed"
16166 : " rank finalizer has been declared",
16167 : derived->name, &derived->declared_at);
16168 :
16169 2531 : if (!derived->attr.pdt_template)
16170 : {
16171 2507 : vtab = gfc_find_derived_vtab (derived);
16172 2507 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16173 2507 : if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym)
16174 2507 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16175 : }
16176 :
16177 2531 : if (finalizable)
16178 640 : *finalizable = true;
16179 :
16180 : return true;
16181 : }
16182 :
16183 :
16184 : static gfc_symbol * containing_dt;
16185 :
16186 : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16187 : arguments whose declared types are PDT instances only transmit the PASS arg
16188 : if they match the enclosing derived type. */
16189 :
16190 : static bool
16191 1460 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16192 : {
16193 1460 : gfc_formal_arglist *dummy_args;
16194 1460 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16195 : {
16196 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16197 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16198 126 : dummy_args = dummy_args->next;
16199 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16200 532 : if (dummy_args->sym->ts.type == BT_CLASS
16201 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16202 : containing_dt->name))
16203 : return true;
16204 : }
16205 : return false;
16206 : }
16207 :
16208 :
16209 : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16210 :
16211 : static bool
16212 732 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16213 : const char* generic_name, locus where)
16214 : {
16215 732 : gfc_symbol *sym1, *sym2;
16216 732 : const char *pass1, *pass2;
16217 732 : gfc_formal_arglist *dummy_args;
16218 :
16219 732 : gcc_assert (t1->specific && t2->specific);
16220 732 : gcc_assert (!t1->specific->is_generic);
16221 732 : gcc_assert (!t2->specific->is_generic);
16222 732 : gcc_assert (t1->is_operator == t2->is_operator);
16223 :
16224 732 : sym1 = t1->specific->u.specific->n.sym;
16225 732 : sym2 = t2->specific->u.specific->n.sym;
16226 :
16227 732 : if (sym1 == sym2)
16228 : return true;
16229 :
16230 : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16231 732 : if (sym1->attr.subroutine != sym2->attr.subroutine
16232 730 : || sym1->attr.function != sym2->attr.function)
16233 : {
16234 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16235 : " GENERIC %qs at %L",
16236 : sym1->name, sym2->name, generic_name, &where);
16237 2 : return false;
16238 : }
16239 :
16240 : /* Determine PASS arguments. */
16241 730 : if (t1->specific->nopass)
16242 : pass1 = NULL;
16243 679 : else if (t1->specific->pass_arg)
16244 : pass1 = t1->specific->pass_arg;
16245 : else
16246 : {
16247 420 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16248 420 : if (dummy_args)
16249 419 : pass1 = dummy_args->sym->name;
16250 : else
16251 : pass1 = NULL;
16252 : }
16253 730 : if (t2->specific->nopass)
16254 : pass2 = NULL;
16255 678 : else if (t2->specific->pass_arg)
16256 : pass2 = t2->specific->pass_arg;
16257 : else
16258 : {
16259 541 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16260 541 : if (dummy_args)
16261 540 : pass2 = dummy_args->sym->name;
16262 : else
16263 : pass2 = NULL;
16264 : }
16265 :
16266 : /* Care must be taken with pdt types and templates because the declared type
16267 : of the argument that is not 'no_pass' need not be the same as the
16268 : containing derived type. If this is the case, subject the argument to
16269 : the full interface check, even though it cannot be used in the type
16270 : bound context. */
16271 730 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16272 730 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16273 :
16274 730 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16275 730 : pass1 = pass2 = NULL;
16276 :
16277 : /* Compare the interfaces. */
16278 730 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16279 : NULL, 0, pass1, pass2))
16280 : {
16281 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16282 : sym1->name, sym2->name, generic_name, &where);
16283 8 : return false;
16284 : }
16285 :
16286 : return true;
16287 : }
16288 :
16289 :
16290 : /* Worker function for resolving a generic procedure binding; this is used to
16291 : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16292 :
16293 : The difference between those cases is finding possible inherited bindings
16294 : that are overridden, as one has to look for them in tb_sym_root,
16295 : tb_uop_root or tb_op, respectively. Thus the caller must already find
16296 : the super-type and set p->overridden correctly. */
16297 :
16298 : static bool
16299 2296 : resolve_tb_generic_targets (gfc_symbol* super_type,
16300 : gfc_typebound_proc* p, const char* name)
16301 : {
16302 2296 : gfc_tbp_generic* target;
16303 2296 : gfc_symtree* first_target;
16304 2296 : gfc_symtree* inherited;
16305 :
16306 2296 : gcc_assert (p && p->is_generic);
16307 :
16308 : /* Try to find the specific bindings for the symtrees in our target-list. */
16309 2296 : gcc_assert (p->u.generic);
16310 5172 : for (target = p->u.generic; target; target = target->next)
16311 2893 : if (!target->specific)
16312 : {
16313 2514 : gfc_typebound_proc* overridden_tbp;
16314 2514 : gfc_tbp_generic* g;
16315 2514 : const char* target_name;
16316 :
16317 2514 : target_name = target->specific_st->name;
16318 :
16319 : /* Defined for this type directly. */
16320 2514 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16321 : {
16322 2505 : target->specific = target->specific_st->n.tb;
16323 2505 : goto specific_found;
16324 : }
16325 :
16326 : /* Look for an inherited specific binding. */
16327 9 : if (super_type)
16328 : {
16329 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16330 : true, NULL);
16331 :
16332 5 : if (inherited)
16333 : {
16334 5 : gcc_assert (inherited->n.tb);
16335 5 : target->specific = inherited->n.tb;
16336 5 : goto specific_found;
16337 : }
16338 : }
16339 :
16340 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16341 : " at %L", target_name, name, &p->where);
16342 4 : return false;
16343 :
16344 : /* Once we've found the specific binding, check it is not ambiguous with
16345 : other specifics already found or inherited for the same GENERIC. */
16346 2510 : specific_found:
16347 2510 : gcc_assert (target->specific);
16348 :
16349 : /* This must really be a specific binding! */
16350 2510 : if (target->specific->is_generic)
16351 : {
16352 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16353 : " %qs is GENERIC, too", name, &p->where, target_name);
16354 3 : return false;
16355 : }
16356 :
16357 : /* Check those already resolved on this type directly. */
16358 6428 : for (g = p->u.generic; g; g = g->next)
16359 1428 : if (g != target && g->specific
16360 4642 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16361 : return false;
16362 :
16363 : /* Check for ambiguity with inherited specific targets. */
16364 2516 : for (overridden_tbp = p->overridden; overridden_tbp;
16365 16 : overridden_tbp = overridden_tbp->overridden)
16366 19 : if (overridden_tbp->is_generic)
16367 : {
16368 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16369 : {
16370 18 : gcc_assert (g->specific);
16371 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16372 : return false;
16373 : }
16374 : }
16375 : }
16376 :
16377 : /* If we attempt to "overwrite" a specific binding, this is an error. */
16378 2279 : if (p->overridden && !p->overridden->is_generic)
16379 : {
16380 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16381 : " the same name", name, &p->where);
16382 1 : return false;
16383 : }
16384 :
16385 : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16386 : all must have the same attributes here. */
16387 2278 : first_target = p->u.generic->specific->u.specific;
16388 2278 : gcc_assert (first_target);
16389 2278 : p->subroutine = first_target->n.sym->attr.subroutine;
16390 2278 : p->function = first_target->n.sym->attr.function;
16391 :
16392 2278 : return true;
16393 : }
16394 :
16395 :
16396 : /* Resolve a GENERIC procedure binding for a derived type. */
16397 :
16398 : static bool
16399 1202 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
16400 : {
16401 1202 : gfc_symbol* super_type;
16402 :
16403 : /* Find the overridden binding if any. */
16404 1202 : st->n.tb->overridden = NULL;
16405 1202 : super_type = gfc_get_derived_super_type (derived);
16406 1202 : if (super_type)
16407 : {
16408 40 : gfc_symtree* overridden;
16409 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
16410 : true, NULL);
16411 :
16412 40 : if (overridden && overridden->n.tb)
16413 21 : st->n.tb->overridden = overridden->n.tb;
16414 : }
16415 :
16416 : /* Resolve using worker function. */
16417 1202 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
16418 : }
16419 :
16420 :
16421 : /* Retrieve the target-procedure of an operator binding and do some checks in
16422 : common for intrinsic and user-defined type-bound operators. */
16423 :
16424 : static gfc_symbol*
16425 1166 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
16426 : {
16427 1166 : gfc_symbol* target_proc;
16428 :
16429 1166 : gcc_assert (target->specific && !target->specific->is_generic);
16430 1166 : target_proc = target->specific->u.specific->n.sym;
16431 1166 : gcc_assert (target_proc);
16432 :
16433 : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
16434 1166 : if (target->specific->nopass)
16435 : {
16436 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
16437 2 : return NULL;
16438 : }
16439 :
16440 : return target_proc;
16441 : }
16442 :
16443 :
16444 : /* Resolve a type-bound intrinsic operator. */
16445 :
16446 : static bool
16447 1035 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
16448 : gfc_typebound_proc* p)
16449 : {
16450 1035 : gfc_symbol* super_type;
16451 1035 : gfc_tbp_generic* target;
16452 :
16453 : /* If there's already an error here, do nothing (but don't fail again). */
16454 1035 : if (p->error)
16455 : return true;
16456 :
16457 : /* Operators should always be GENERIC bindings. */
16458 1035 : gcc_assert (p->is_generic);
16459 :
16460 : /* Look for an overridden binding. */
16461 1035 : super_type = gfc_get_derived_super_type (derived);
16462 1035 : if (super_type && super_type->f2k_derived)
16463 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
16464 : op, true, NULL);
16465 : else
16466 1034 : p->overridden = NULL;
16467 :
16468 : /* Resolve general GENERIC properties using worker function. */
16469 1035 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
16470 1 : goto error;
16471 :
16472 : /* Check the targets to be procedures of correct interface. */
16473 2115 : for (target = p->u.generic; target; target = target->next)
16474 : {
16475 1106 : gfc_symbol* target_proc;
16476 :
16477 1106 : target_proc = get_checked_tb_operator_target (target, p->where);
16478 1106 : if (!target_proc)
16479 1 : goto error;
16480 :
16481 1105 : if (!gfc_check_operator_interface (target_proc, op, p->where))
16482 3 : goto error;
16483 :
16484 : /* Add target to non-typebound operator list. */
16485 1102 : if (!target->specific->deferred && !derived->attr.use_assoc
16486 385 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
16487 : {
16488 383 : gfc_interface *head, *intr;
16489 :
16490 : /* Preempt 'gfc_check_new_interface' for submodules, where the
16491 : mechanism for handling module procedures winds up resolving
16492 : operator interfaces twice and would otherwise cause an error.
16493 : Likewise, new instances of PDTs can cause the operator inter-
16494 : faces to be resolved multiple times. */
16495 455 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
16496 91 : if (intr->sym == target_proc
16497 21 : && (target_proc->attr.used_in_submodule
16498 4 : || derived->attr.pdt_type
16499 2 : || derived->attr.pdt_template))
16500 : return true;
16501 :
16502 364 : if (!gfc_check_new_interface (derived->ns->op[op],
16503 : target_proc, p->where))
16504 : return false;
16505 362 : head = derived->ns->op[op];
16506 362 : intr = gfc_get_interface ();
16507 362 : intr->sym = target_proc;
16508 362 : intr->where = p->where;
16509 362 : intr->next = head;
16510 362 : derived->ns->op[op] = intr;
16511 : }
16512 : }
16513 :
16514 : return true;
16515 :
16516 5 : error:
16517 5 : p->error = 1;
16518 5 : return false;
16519 : }
16520 :
16521 :
16522 : /* Resolve a type-bound user operator (tree-walker callback). */
16523 :
16524 : static gfc_symbol* resolve_bindings_derived;
16525 : static bool resolve_bindings_result;
16526 :
16527 : static bool check_uop_procedure (gfc_symbol* sym, locus where);
16528 :
16529 : static void
16530 59 : resolve_typebound_user_op (gfc_symtree* stree)
16531 : {
16532 59 : gfc_symbol* super_type;
16533 59 : gfc_tbp_generic* target;
16534 :
16535 59 : gcc_assert (stree && stree->n.tb);
16536 :
16537 59 : if (stree->n.tb->error)
16538 : return;
16539 :
16540 : /* Operators should always be GENERIC bindings. */
16541 59 : gcc_assert (stree->n.tb->is_generic);
16542 :
16543 : /* Find overridden procedure, if any. */
16544 59 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16545 59 : if (super_type && super_type->f2k_derived)
16546 : {
16547 0 : gfc_symtree* overridden;
16548 0 : overridden = gfc_find_typebound_user_op (super_type, NULL,
16549 : stree->name, true, NULL);
16550 :
16551 0 : if (overridden && overridden->n.tb)
16552 0 : stree->n.tb->overridden = overridden->n.tb;
16553 : }
16554 : else
16555 59 : stree->n.tb->overridden = NULL;
16556 :
16557 : /* Resolve basically using worker function. */
16558 59 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
16559 0 : goto error;
16560 :
16561 : /* Check the targets to be functions of correct interface. */
16562 116 : for (target = stree->n.tb->u.generic; target; target = target->next)
16563 : {
16564 60 : gfc_symbol* target_proc;
16565 :
16566 60 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
16567 60 : if (!target_proc)
16568 1 : goto error;
16569 :
16570 59 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
16571 2 : goto error;
16572 : }
16573 :
16574 : return;
16575 :
16576 3 : error:
16577 3 : resolve_bindings_result = false;
16578 3 : stree->n.tb->error = 1;
16579 : }
16580 :
16581 :
16582 : /* Resolve the type-bound procedures for a derived type. */
16583 :
16584 : static void
16585 9899 : resolve_typebound_procedure (gfc_symtree* stree)
16586 : {
16587 9899 : gfc_symbol* proc;
16588 9899 : locus where;
16589 9899 : gfc_symbol* me_arg;
16590 9899 : gfc_symbol* super_type;
16591 9899 : gfc_component* comp;
16592 :
16593 9899 : gcc_assert (stree);
16594 :
16595 : /* Undefined specific symbol from GENERIC target definition. */
16596 9899 : if (!stree->n.tb)
16597 9817 : return;
16598 :
16599 9893 : if (stree->n.tb->error)
16600 : return;
16601 :
16602 : /* If this is a GENERIC binding, use that routine. */
16603 9877 : if (stree->n.tb->is_generic)
16604 : {
16605 1202 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
16606 17 : goto error;
16607 : return;
16608 : }
16609 :
16610 : /* Get the target-procedure to check it. */
16611 8675 : gcc_assert (!stree->n.tb->is_generic);
16612 8675 : gcc_assert (stree->n.tb->u.specific);
16613 8675 : proc = stree->n.tb->u.specific->n.sym;
16614 8675 : where = stree->n.tb->where;
16615 :
16616 : /* Default access should already be resolved from the parser. */
16617 8675 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
16618 :
16619 8675 : if (stree->n.tb->deferred)
16620 : {
16621 676 : if (!check_proc_interface (proc, &where))
16622 5 : goto error;
16623 : }
16624 : else
16625 : {
16626 : /* If proc has not been resolved at this point, proc->name may
16627 : actually be a USE associated entity. See PR fortran/89647. */
16628 7999 : if (!proc->resolve_symbol_called
16629 5327 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
16630 : {
16631 11 : gfc_symbol *tmp;
16632 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
16633 11 : if (tmp && tmp->attr.use_assoc)
16634 : {
16635 1 : proc->module = tmp->module;
16636 1 : proc->attr.proc = tmp->attr.proc;
16637 1 : proc->attr.function = tmp->attr.function;
16638 1 : proc->attr.subroutine = tmp->attr.subroutine;
16639 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
16640 1 : proc->ts = tmp->ts;
16641 1 : proc->result = tmp->result;
16642 : }
16643 : }
16644 :
16645 : /* Check for F08:C465. */
16646 7999 : if ((!proc->attr.subroutine && !proc->attr.function)
16647 7989 : || (proc->attr.proc != PROC_MODULE
16648 70 : && proc->attr.if_source != IFSRC_IFBODY
16649 7 : && !proc->attr.module_procedure)
16650 7988 : || proc->attr.abstract)
16651 : {
16652 12 : gfc_error ("%qs must be a module procedure or an external "
16653 : "procedure with an explicit interface at %L",
16654 : proc->name, &where);
16655 12 : goto error;
16656 : }
16657 : }
16658 :
16659 8658 : stree->n.tb->subroutine = proc->attr.subroutine;
16660 8658 : stree->n.tb->function = proc->attr.function;
16661 :
16662 : /* Find the super-type of the current derived type. We could do this once and
16663 : store in a global if speed is needed, but as long as not I believe this is
16664 : more readable and clearer. */
16665 8658 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16666 :
16667 : /* If PASS, resolve and check arguments if not already resolved / loaded
16668 : from a .mod file. */
16669 8658 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
16670 : {
16671 2749 : gfc_formal_arglist *dummy_args;
16672 :
16673 2749 : dummy_args = gfc_sym_get_dummy_args (proc);
16674 2749 : if (stree->n.tb->pass_arg)
16675 : {
16676 462 : gfc_formal_arglist *i;
16677 :
16678 : /* If an explicit passing argument name is given, walk the arg-list
16679 : and look for it. */
16680 :
16681 462 : me_arg = NULL;
16682 462 : stree->n.tb->pass_arg_num = 1;
16683 589 : for (i = dummy_args; i; i = i->next)
16684 : {
16685 587 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
16686 : {
16687 : me_arg = i->sym;
16688 : break;
16689 : }
16690 127 : ++stree->n.tb->pass_arg_num;
16691 : }
16692 :
16693 462 : if (!me_arg)
16694 : {
16695 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
16696 : " argument %qs",
16697 : proc->name, stree->n.tb->pass_arg, &where,
16698 : stree->n.tb->pass_arg);
16699 2 : goto error;
16700 : }
16701 : }
16702 : else
16703 : {
16704 : /* Otherwise, take the first one; there should in fact be at least
16705 : one. */
16706 2287 : stree->n.tb->pass_arg_num = 1;
16707 2287 : if (!dummy_args)
16708 : {
16709 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
16710 : " least one argument", proc->name, &where);
16711 2 : goto error;
16712 : }
16713 2285 : me_arg = dummy_args->sym;
16714 : }
16715 :
16716 : /* Now check that the argument-type matches and the passed-object
16717 : dummy argument is generally fine. */
16718 :
16719 2285 : gcc_assert (me_arg);
16720 :
16721 2745 : if (me_arg->ts.type != BT_CLASS)
16722 : {
16723 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
16724 : " at %L", proc->name, &where);
16725 5 : goto error;
16726 : }
16727 :
16728 : /* The derived type is not a PDT template or type. Resolve as usual. */
16729 2740 : if (!resolve_bindings_derived->attr.pdt_template
16730 2731 : && !(containing_dt && containing_dt->attr.pdt_type
16731 60 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
16732 2711 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
16733 : {
16734 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16735 : "the derived-type %qs", me_arg->name, proc->name,
16736 : me_arg->name, &where, resolve_bindings_derived->name);
16737 0 : goto error;
16738 : }
16739 :
16740 2740 : if (resolve_bindings_derived->attr.pdt_template
16741 2749 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
16742 9 : CLASS_DATA (me_arg)->ts.u.derived))
16743 : {
16744 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16745 : "the parametric derived-type %qs", me_arg->name,
16746 : proc->name, me_arg->name, &where,
16747 : resolve_bindings_derived->name);
16748 0 : goto error;
16749 : }
16750 :
16751 2740 : if (((resolve_bindings_derived->attr.pdt_template
16752 9 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
16753 9 : CLASS_DATA (me_arg)->ts.u.derived))
16754 2731 : || resolve_bindings_derived->attr.pdt_type)
16755 69 : && (me_arg->param_list != NULL)
16756 2809 : && (gfc_spec_list_type (me_arg->param_list,
16757 69 : CLASS_DATA(me_arg)->ts.u.derived)
16758 : != SPEC_ASSUMED))
16759 : {
16760 :
16761 : /* Add a check to verify if there are any LEN parameters in the
16762 : first place. If there are LEN parameters, throw this error.
16763 : If there are only KIND parameters, then don't trigger
16764 : this error. */
16765 6 : gfc_component *c;
16766 6 : bool seen_len_param = false;
16767 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
16768 :
16769 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
16770 : {
16771 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
16772 : me_arg_param->name, true, true, NULL);
16773 :
16774 6 : gcc_assert (c != NULL);
16775 :
16776 6 : if (c->attr.pdt_kind)
16777 0 : continue;
16778 :
16779 : /* Getting here implies that there is a pdt_len parameter
16780 : in the list. */
16781 : seen_len_param = true;
16782 : break;
16783 : }
16784 :
16785 6 : if (seen_len_param)
16786 : {
16787 6 : gfc_error ("All LEN type parameters of the passed dummy "
16788 : "argument %qs of %qs at %L must be ASSUMED.",
16789 : me_arg->name, proc->name, &where);
16790 6 : goto error;
16791 : }
16792 : }
16793 :
16794 2734 : gcc_assert (me_arg->ts.type == BT_CLASS);
16795 2734 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
16796 : {
16797 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
16798 : " scalar", proc->name, &where);
16799 1 : goto error;
16800 : }
16801 2733 : if (CLASS_DATA (me_arg)->attr.allocatable)
16802 : {
16803 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16804 : " be ALLOCATABLE", proc->name, &where);
16805 2 : goto error;
16806 : }
16807 2731 : if (CLASS_DATA (me_arg)->attr.class_pointer)
16808 : {
16809 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16810 : " be POINTER", proc->name, &where);
16811 2 : goto error;
16812 : }
16813 : }
16814 :
16815 : /* If we are extending some type, check that we don't override a procedure
16816 : flagged NON_OVERRIDABLE. */
16817 8638 : stree->n.tb->overridden = NULL;
16818 8638 : if (super_type)
16819 : {
16820 1491 : gfc_symtree* overridden;
16821 1491 : overridden = gfc_find_typebound_proc (super_type, NULL,
16822 : stree->name, true, NULL);
16823 :
16824 1491 : if (overridden)
16825 : {
16826 1214 : if (overridden->n.tb)
16827 1214 : stree->n.tb->overridden = overridden->n.tb;
16828 :
16829 1214 : if (!gfc_check_typebound_override (stree, overridden))
16830 26 : goto error;
16831 : }
16832 : }
16833 :
16834 : /* See if there's a name collision with a component directly in this type. */
16835 20766 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
16836 12155 : if (!strcmp (comp->name, stree->name))
16837 : {
16838 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
16839 : " %qs",
16840 : stree->name, &where, resolve_bindings_derived->name);
16841 1 : goto error;
16842 : }
16843 :
16844 : /* Try to find a name collision with an inherited component. */
16845 8611 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
16846 : NULL))
16847 : {
16848 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
16849 : " component of %qs",
16850 : stree->name, &where, resolve_bindings_derived->name);
16851 1 : goto error;
16852 : }
16853 :
16854 8610 : stree->n.tb->error = 0;
16855 8610 : return;
16856 :
16857 82 : error:
16858 82 : resolve_bindings_result = false;
16859 82 : stree->n.tb->error = 1;
16860 : }
16861 :
16862 :
16863 : static bool
16864 85517 : resolve_typebound_procedures (gfc_symbol* derived)
16865 : {
16866 85517 : int op;
16867 85517 : gfc_symbol* super_type;
16868 :
16869 85517 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
16870 : return true;
16871 :
16872 4720 : super_type = gfc_get_derived_super_type (derived);
16873 4720 : if (super_type)
16874 857 : resolve_symbol (super_type);
16875 :
16876 4720 : resolve_bindings_derived = derived;
16877 4720 : resolve_bindings_result = true;
16878 :
16879 4720 : containing_dt = derived; /* Needed for checks of PDTs. */
16880 4720 : if (derived->f2k_derived->tb_sym_root)
16881 4720 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
16882 : &resolve_typebound_procedure);
16883 :
16884 4720 : if (derived->f2k_derived->tb_uop_root)
16885 55 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
16886 : &resolve_typebound_user_op);
16887 4720 : containing_dt = NULL;
16888 :
16889 136880 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
16890 : {
16891 132160 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
16892 132160 : if (p && !resolve_typebound_intrinsic_op (derived,
16893 : (gfc_intrinsic_op)op, p))
16894 7 : resolve_bindings_result = false;
16895 : }
16896 :
16897 4720 : return resolve_bindings_result;
16898 : }
16899 :
16900 :
16901 : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
16902 : to give all identical derived types the same backend_decl. */
16903 : static void
16904 175502 : add_dt_to_dt_list (gfc_symbol *derived)
16905 : {
16906 175502 : if (!derived->dt_next)
16907 : {
16908 81682 : if (gfc_derived_types)
16909 : {
16910 66985 : derived->dt_next = gfc_derived_types->dt_next;
16911 66985 : gfc_derived_types->dt_next = derived;
16912 : }
16913 : else
16914 : {
16915 14697 : derived->dt_next = derived;
16916 : }
16917 81682 : gfc_derived_types = derived;
16918 : }
16919 175502 : }
16920 :
16921 :
16922 : /* Ensure that a derived-type is really not abstract, meaning that every
16923 : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
16924 :
16925 : static bool
16926 7086 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
16927 : {
16928 7086 : if (!st)
16929 : return true;
16930 :
16931 2772 : if (!ensure_not_abstract_walker (sub, st->left))
16932 : return false;
16933 2772 : if (!ensure_not_abstract_walker (sub, st->right))
16934 : return false;
16935 :
16936 2771 : if (st->n.tb && st->n.tb->deferred)
16937 : {
16938 2019 : gfc_symtree* overriding;
16939 2019 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
16940 2019 : if (!overriding)
16941 : return false;
16942 2018 : gcc_assert (overriding->n.tb);
16943 2018 : if (overriding->n.tb->deferred)
16944 : {
16945 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
16946 : " %qs is DEFERRED and not overridden",
16947 : sub->name, &sub->declared_at, st->name);
16948 5 : return false;
16949 : }
16950 : }
16951 :
16952 : return true;
16953 : }
16954 :
16955 : static bool
16956 1394 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
16957 : {
16958 : /* The algorithm used here is to recursively travel up the ancestry of sub
16959 : and for each ancestor-type, check all bindings. If any of them is
16960 : DEFERRED, look it up starting from sub and see if the found (overriding)
16961 : binding is not DEFERRED.
16962 : This is not the most efficient way to do this, but it should be ok and is
16963 : clearer than something sophisticated. */
16964 :
16965 1543 : gcc_assert (ancestor && !sub->attr.abstract);
16966 :
16967 1543 : if (!ancestor->attr.abstract)
16968 : return true;
16969 :
16970 : /* Walk bindings of this ancestor. */
16971 1542 : if (ancestor->f2k_derived)
16972 : {
16973 1542 : bool t;
16974 1542 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
16975 1542 : if (!t)
16976 : return false;
16977 : }
16978 :
16979 : /* Find next ancestor type and recurse on it. */
16980 1536 : ancestor = gfc_get_derived_super_type (ancestor);
16981 1536 : if (ancestor)
16982 : return ensure_not_abstract (sub, ancestor);
16983 :
16984 : return true;
16985 : }
16986 :
16987 :
16988 : /* This check for typebound defined assignments is done recursively
16989 : since the order in which derived types are resolved is not always in
16990 : order of the declarations. */
16991 :
16992 : static void
16993 179990 : check_defined_assignments (gfc_symbol *derived)
16994 : {
16995 179990 : gfc_component *c;
16996 :
16997 603020 : for (c = derived->components; c; c = c->next)
16998 : {
16999 424807 : if (!gfc_bt_struct (c->ts.type)
17000 102447 : || c->attr.pointer
17001 20329 : || c->attr.proc_pointer_comp
17002 20329 : || c->attr.class_pointer
17003 20323 : || c->attr.proc_pointer)
17004 404928 : continue;
17005 :
17006 19879 : if (c->ts.u.derived->attr.defined_assign_comp
17007 19644 : || (c->ts.u.derived->f2k_derived
17008 19074 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
17009 : {
17010 1753 : derived->attr.defined_assign_comp = 1;
17011 1753 : return;
17012 : }
17013 :
17014 18126 : if (c->attr.allocatable)
17015 6529 : continue;
17016 :
17017 11597 : check_defined_assignments (c->ts.u.derived);
17018 11597 : if (c->ts.u.derived->attr.defined_assign_comp)
17019 : {
17020 24 : derived->attr.defined_assign_comp = 1;
17021 24 : return;
17022 : }
17023 : }
17024 : }
17025 :
17026 :
17027 : /* Resolve a single component of a derived type or structure. */
17028 :
17029 : static bool
17030 405178 : resolve_component (gfc_component *c, gfc_symbol *sym)
17031 : {
17032 405178 : gfc_symbol *super_type;
17033 405178 : symbol_attribute *attr;
17034 :
17035 405178 : if (c->attr.artificial)
17036 : return true;
17037 :
17038 : /* Do not allow vtype components to be resolved in nameless namespaces
17039 : such as block data because the procedure pointers will cause ICEs
17040 : and vtables are not needed in these contexts. */
17041 276736 : if (sym->attr.vtype && sym->attr.use_assoc
17042 48289 : && sym->ns->proc_name == NULL)
17043 : return true;
17044 :
17045 : /* F2008, C442. */
17046 276727 : if ((!sym->attr.is_class || c != sym->components)
17047 276727 : && c->attr.codimension
17048 208 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
17049 : {
17050 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
17051 : "deferred shape", c->name, &c->loc);
17052 4 : return false;
17053 : }
17054 :
17055 : /* F2008, C443. */
17056 276723 : if (c->attr.codimension && c->ts.type == BT_DERIVED
17057 85 : && c->ts.u.derived->ts.is_iso_c)
17058 : {
17059 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17060 : "shall not be a coarray", c->name, &c->loc);
17061 1 : return false;
17062 : }
17063 :
17064 : /* F2008, C444. */
17065 276722 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
17066 28 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
17067 26 : || c->attr.allocatable))
17068 : {
17069 3 : gfc_error ("Component %qs at %L with coarray component "
17070 : "shall be a nonpointer, nonallocatable scalar",
17071 : c->name, &c->loc);
17072 3 : return false;
17073 : }
17074 :
17075 : /* F2008, C448. */
17076 276719 : if (c->ts.type == BT_CLASS)
17077 : {
17078 6916 : if (c->attr.class_ok && CLASS_DATA (c))
17079 : {
17080 6908 : attr = &(CLASS_DATA (c)->attr);
17081 :
17082 : /* Fix up contiguous attribute. */
17083 6908 : if (c->attr.contiguous)
17084 11 : attr->contiguous = 1;
17085 : }
17086 : else
17087 : attr = NULL;
17088 : }
17089 : else
17090 269803 : attr = &c->attr;
17091 :
17092 276722 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
17093 : {
17094 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
17095 : "is not an array pointer", c->name, &c->loc);
17096 5 : return false;
17097 : }
17098 :
17099 : /* F2003, 15.2.1 - length has to be one. */
17100 40500 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
17101 276733 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
17102 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
17103 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
17104 : {
17105 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
17106 : c->name, &c->loc);
17107 1 : return false;
17108 : }
17109 :
17110 51340 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
17111 306 : && !sym->attr.pdt_type && !sym->attr.pdt_template
17112 276721 : && !(gfc_get_derived_super_type (sym)
17113 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
17114 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
17115 : {
17116 8 : gfc_actual_arglist *type_spec_list;
17117 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
17118 : &type_spec_list)
17119 : != MATCH_YES)
17120 0 : return false;
17121 8 : gfc_free_actual_arglist (c->param_list);
17122 8 : c->param_list = type_spec_list;
17123 8 : if (!sym->attr.pdt_type)
17124 8 : sym->attr.pdt_comp = 1;
17125 : }
17126 276705 : else if (IS_PDT (c) && !sym->attr.pdt_type)
17127 54 : sym->attr.pdt_comp = 1;
17128 :
17129 276713 : if (c->attr.proc_pointer && c->ts.interface)
17130 : {
17131 14534 : gfc_symbol *ifc = c->ts.interface;
17132 :
17133 14534 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
17134 : {
17135 6 : c->tb->error = 1;
17136 6 : return false;
17137 : }
17138 :
17139 14528 : if (ifc->attr.if_source || ifc->attr.intrinsic)
17140 : {
17141 : /* Resolve interface and copy attributes. */
17142 14479 : if (ifc->formal && !ifc->formal_ns)
17143 2535 : resolve_symbol (ifc);
17144 14479 : if (ifc->attr.intrinsic)
17145 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17146 :
17147 14479 : if (ifc->result)
17148 : {
17149 7601 : c->ts = ifc->result->ts;
17150 7601 : c->attr.allocatable = ifc->result->attr.allocatable;
17151 7601 : c->attr.pointer = ifc->result->attr.pointer;
17152 7601 : c->attr.dimension = ifc->result->attr.dimension;
17153 7601 : c->as = gfc_copy_array_spec (ifc->result->as);
17154 7601 : c->attr.class_ok = ifc->result->attr.class_ok;
17155 : }
17156 : else
17157 : {
17158 6878 : c->ts = ifc->ts;
17159 6878 : c->attr.allocatable = ifc->attr.allocatable;
17160 6878 : c->attr.pointer = ifc->attr.pointer;
17161 6878 : c->attr.dimension = ifc->attr.dimension;
17162 6878 : c->as = gfc_copy_array_spec (ifc->as);
17163 6878 : c->attr.class_ok = ifc->attr.class_ok;
17164 : }
17165 14479 : c->ts.interface = ifc;
17166 14479 : c->attr.function = ifc->attr.function;
17167 14479 : c->attr.subroutine = ifc->attr.subroutine;
17168 :
17169 14479 : c->attr.pure = ifc->attr.pure;
17170 14479 : c->attr.elemental = ifc->attr.elemental;
17171 14479 : c->attr.recursive = ifc->attr.recursive;
17172 14479 : c->attr.always_explicit = ifc->attr.always_explicit;
17173 14479 : c->attr.ext_attr |= ifc->attr.ext_attr;
17174 : /* Copy char length. */
17175 14479 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17176 : {
17177 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17178 454 : if (cl->length && !cl->resolved
17179 601 : && !gfc_resolve_expr (cl->length))
17180 : {
17181 0 : c->tb->error = 1;
17182 0 : return false;
17183 : }
17184 491 : c->ts.u.cl = cl;
17185 : }
17186 : }
17187 : }
17188 262179 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17189 : {
17190 : /* Since PPCs are not implicitly typed, a PPC without an explicit
17191 : interface must be a subroutine. */
17192 116 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17193 : }
17194 :
17195 : /* Procedure pointer components: Check PASS arg. */
17196 276707 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17197 805 : && !sym->attr.vtype)
17198 : {
17199 95 : gfc_symbol* me_arg;
17200 :
17201 95 : if (c->tb->pass_arg)
17202 : {
17203 20 : gfc_formal_arglist* i;
17204 :
17205 : /* If an explicit passing argument name is given, walk the arg-list
17206 : and look for it. */
17207 :
17208 20 : me_arg = NULL;
17209 20 : c->tb->pass_arg_num = 1;
17210 34 : for (i = c->ts.interface->formal; i; i = i->next)
17211 : {
17212 33 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17213 : {
17214 : me_arg = i->sym;
17215 : break;
17216 : }
17217 14 : c->tb->pass_arg_num++;
17218 : }
17219 :
17220 20 : if (!me_arg)
17221 : {
17222 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17223 : "at %L has no argument %qs", c->name,
17224 : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17225 1 : c->tb->error = 1;
17226 1 : return false;
17227 : }
17228 : }
17229 : else
17230 : {
17231 : /* Otherwise, take the first one; there should in fact be at least
17232 : one. */
17233 75 : c->tb->pass_arg_num = 1;
17234 75 : if (!c->ts.interface->formal)
17235 : {
17236 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17237 : "must have at least one argument",
17238 : c->name, &c->loc);
17239 3 : c->tb->error = 1;
17240 3 : return false;
17241 : }
17242 72 : me_arg = c->ts.interface->formal->sym;
17243 : }
17244 :
17245 : /* Now check that the argument-type matches. */
17246 72 : gcc_assert (me_arg);
17247 91 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17248 90 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17249 90 : || (me_arg->ts.type == BT_CLASS
17250 82 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17251 : {
17252 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17253 : " the derived type %qs", me_arg->name, c->name,
17254 : me_arg->name, &c->loc, sym->name);
17255 1 : c->tb->error = 1;
17256 1 : return false;
17257 : }
17258 :
17259 : /* Check for F03:C453. */
17260 90 : if (CLASS_DATA (me_arg)->attr.dimension)
17261 : {
17262 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17263 : "must be scalar", me_arg->name, c->name, me_arg->name,
17264 : &c->loc);
17265 1 : c->tb->error = 1;
17266 1 : return false;
17267 : }
17268 :
17269 89 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17270 : {
17271 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17272 : "may not have the POINTER attribute", me_arg->name,
17273 : c->name, me_arg->name, &c->loc);
17274 1 : c->tb->error = 1;
17275 1 : return false;
17276 : }
17277 :
17278 88 : if (CLASS_DATA (me_arg)->attr.allocatable)
17279 : {
17280 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17281 : "may not be ALLOCATABLE", me_arg->name, c->name,
17282 : me_arg->name, &c->loc);
17283 1 : c->tb->error = 1;
17284 1 : return false;
17285 : }
17286 :
17287 87 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17288 : {
17289 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17290 : " at %L", c->name, &c->loc);
17291 2 : return false;
17292 : }
17293 :
17294 : }
17295 :
17296 : /* Check type-spec if this is not the parent-type component. */
17297 276697 : if (((sym->attr.is_class
17298 12252 : && (!sym->components->ts.u.derived->attr.extension
17299 2385 : || c != CLASS_DATA (sym->components)))
17300 265781 : || (!sym->attr.is_class
17301 264445 : && (!sym->attr.extension || c != sym->components)))
17302 268604 : && !sym->attr.vtype
17303 438092 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17304 : return false;
17305 :
17306 276696 : super_type = gfc_get_derived_super_type (sym);
17307 :
17308 : /* If this type is an extension, set the accessibility of the parent
17309 : component. */
17310 276696 : if (super_type
17311 25404 : && ((sym->attr.is_class
17312 12252 : && c == CLASS_DATA (sym->components))
17313 16920 : || (!sym->attr.is_class && c == sym->components))
17314 15241 : && strcmp (super_type->name, c->name) == 0)
17315 6595 : c->attr.access = super_type->attr.access;
17316 :
17317 : /* If this type is an extension, see if this component has the same name
17318 : as an inherited type-bound procedure. */
17319 25404 : if (super_type && !sym->attr.is_class
17320 13152 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17321 : {
17322 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17323 : " inherited type-bound procedure",
17324 : c->name, sym->name, &c->loc);
17325 1 : return false;
17326 : }
17327 :
17328 276695 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17329 9392 : && !c->ts.deferred)
17330 : {
17331 7166 : if (sym->attr.pdt_template || c->attr.pdt_string)
17332 258 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17333 :
17334 7166 : if (c->ts.u.cl->length == NULL
17335 7160 : || !resolve_charlen(c->ts.u.cl)
17336 14325 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17337 : {
17338 9 : gfc_error ("Character length of component %qs needs to "
17339 : "be a constant specification expression at %L",
17340 : c->name,
17341 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17342 9 : return false;
17343 : }
17344 :
17345 7157 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17346 : {
17347 2 : if (!c->ts.u.cl->length->error)
17348 : {
17349 1 : gfc_error ("Character length expression of component %qs at %L "
17350 : "must be of INTEGER type, found %s",
17351 1 : c->name, &c->ts.u.cl->length->where,
17352 : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17353 1 : c->ts.u.cl->length->error = 1;
17354 : }
17355 2 : return false;
17356 : }
17357 : }
17358 :
17359 276684 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17360 2262 : && !c->attr.pointer && !c->attr.allocatable)
17361 : {
17362 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17363 : "length must be a POINTER or ALLOCATABLE",
17364 : c->name, sym->name, &c->loc);
17365 1 : return false;
17366 : }
17367 :
17368 : /* Add the hidden deferred length field. */
17369 276683 : if (c->ts.type == BT_CHARACTER
17370 9892 : && (c->ts.deferred || c->attr.pdt_string)
17371 2438 : && !c->attr.function
17372 2402 : && !sym->attr.is_class)
17373 : {
17374 2255 : char name[GFC_MAX_SYMBOL_LEN+9];
17375 2255 : gfc_component *strlen;
17376 2255 : sprintf (name, "_%s_length", c->name);
17377 2255 : strlen = gfc_find_component (sym, name, true, true, NULL);
17378 2255 : if (strlen == NULL)
17379 : {
17380 479 : if (!gfc_add_component (sym, name, &strlen))
17381 0 : return false;
17382 479 : strlen->ts.type = BT_INTEGER;
17383 479 : strlen->ts.kind = gfc_charlen_int_kind;
17384 479 : strlen->attr.access = ACCESS_PRIVATE;
17385 479 : strlen->attr.artificial = 1;
17386 : }
17387 : }
17388 :
17389 276683 : if (c->ts.type == BT_DERIVED
17390 51520 : && sym->component_access != ACCESS_PRIVATE
17391 50500 : && gfc_check_symbol_access (sym)
17392 98964 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
17393 49430 : && !c->ts.u.derived->attr.use_assoc
17394 26478 : && !gfc_check_symbol_access (c->ts.u.derived)
17395 276879 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
17396 : "PRIVATE type and cannot be a component of "
17397 : "%qs, which is PUBLIC at %L", c->name,
17398 : sym->name, &sym->declared_at))
17399 : return false;
17400 :
17401 276682 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
17402 : {
17403 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
17404 : "type %s", c->name, &c->loc, sym->name);
17405 2 : return false;
17406 : }
17407 :
17408 276680 : if (sym->attr.sequence)
17409 : {
17410 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
17411 : {
17412 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
17413 : "not have the SEQUENCE attribute",
17414 : c->ts.u.derived->name, &sym->declared_at);
17415 0 : return false;
17416 : }
17417 : }
17418 :
17419 276680 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
17420 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
17421 276680 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
17422 7248 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
17423 0 : CLASS_DATA (c)->ts.u.derived
17424 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
17425 :
17426 : /* If an allocatable component derived type is of the same type as
17427 : the enclosing derived type, we need a vtable generating so that
17428 : the __deallocate procedure is created. */
17429 276680 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
17430 58778 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
17431 399 : gfc_find_vtab (&c->ts);
17432 :
17433 : /* Ensure that all the derived type components are put on the
17434 : derived type list; even in formal namespaces, where derived type
17435 : pointer components might not have been declared. */
17436 276680 : if (c->ts.type == BT_DERIVED
17437 51519 : && c->ts.u.derived
17438 51519 : && c->ts.u.derived->components
17439 48255 : && c->attr.pointer
17440 33129 : && sym != c->ts.u.derived)
17441 4248 : add_dt_to_dt_list (c->ts.u.derived);
17442 :
17443 276680 : if (c->as && c->as->type != AS_DEFERRED
17444 6246 : && (c->attr.pointer || c->attr.allocatable))
17445 : return false;
17446 :
17447 276666 : if (!gfc_resolve_array_spec (c->as,
17448 276666 : !(c->attr.pointer || c->attr.proc_pointer
17449 225230 : || c->attr.allocatable)))
17450 : return false;
17451 :
17452 104154 : if (c->initializer && !sym->attr.vtype
17453 31831 : && !c->attr.pdt_kind && !c->attr.pdt_len
17454 305417 : && !gfc_check_assign_symbol (sym, c, c->initializer))
17455 : return false;
17456 :
17457 : return true;
17458 : }
17459 :
17460 :
17461 : /* Be nice about the locus for a structure expression - show the locus of the
17462 : first non-null sub-expression if we can. */
17463 :
17464 : static locus *
17465 4 : cons_where (gfc_expr *struct_expr)
17466 : {
17467 4 : gfc_constructor *cons;
17468 :
17469 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
17470 :
17471 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
17472 12 : for (; cons; cons = gfc_constructor_next (cons))
17473 : {
17474 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
17475 4 : return &cons->expr->where;
17476 : }
17477 :
17478 0 : return &struct_expr->where;
17479 : }
17480 :
17481 : /* Resolve the components of a structure type. Much less work than derived
17482 : types. */
17483 :
17484 : static bool
17485 913 : resolve_fl_struct (gfc_symbol *sym)
17486 : {
17487 913 : gfc_component *c;
17488 913 : gfc_expr *init = NULL;
17489 913 : bool success;
17490 :
17491 : /* Make sure UNIONs do not have overlapping initializers. */
17492 913 : if (sym->attr.flavor == FL_UNION)
17493 : {
17494 498 : for (c = sym->components; c; c = c->next)
17495 : {
17496 331 : if (init && c->initializer)
17497 : {
17498 2 : gfc_error ("Conflicting initializers in union at %L and %L",
17499 : cons_where (init), cons_where (c->initializer));
17500 2 : gfc_free_expr (c->initializer);
17501 2 : c->initializer = NULL;
17502 : }
17503 291 : if (init == NULL)
17504 291 : init = c->initializer;
17505 : }
17506 : }
17507 :
17508 913 : success = true;
17509 2830 : for (c = sym->components; c; c = c->next)
17510 1917 : if (!resolve_component (c, sym))
17511 0 : success = false;
17512 :
17513 913 : if (!success)
17514 : return false;
17515 :
17516 913 : if (sym->components)
17517 862 : add_dt_to_dt_list (sym);
17518 :
17519 : return true;
17520 : }
17521 :
17522 : /* Figure if the derived type is using itself directly in one of its components
17523 : or through referencing other derived types. The information is required to
17524 : generate the __deallocate and __final type bound procedures to ensure
17525 : freeing larger hierarchies of derived types with allocatable objects. */
17526 :
17527 : static void
17528 136746 : resolve_cyclic_derived_type (gfc_symbol *derived)
17529 : {
17530 136746 : hash_set<gfc_symbol *> seen, to_examin;
17531 136746 : gfc_component *c;
17532 136746 : seen.add (derived);
17533 136746 : to_examin.add (derived);
17534 458351 : while (!to_examin.is_empty ())
17535 : {
17536 187051 : gfc_symbol *cand = *to_examin.begin ();
17537 187051 : to_examin.remove (cand);
17538 503922 : for (c = cand->components; c; c = c->next)
17539 319063 : if (c->ts.type == BT_DERIVED)
17540 : {
17541 70172 : if (c->ts.u.derived == derived)
17542 : {
17543 1168 : derived->attr.recursive = 1;
17544 2192 : return;
17545 : }
17546 69004 : else if (!seen.contains (c->ts.u.derived))
17547 : {
17548 45774 : seen.add (c->ts.u.derived);
17549 45774 : to_examin.add (c->ts.u.derived);
17550 : }
17551 : }
17552 248891 : else if (c->ts.type == BT_CLASS)
17553 : {
17554 9560 : if (!c->attr.class_ok)
17555 7 : continue;
17556 9553 : if (CLASS_DATA (c)->ts.u.derived == derived)
17557 : {
17558 1024 : derived->attr.recursive = 1;
17559 1024 : return;
17560 : }
17561 8529 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
17562 : {
17563 4767 : seen.add (CLASS_DATA (c)->ts.u.derived);
17564 4767 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
17565 : }
17566 : }
17567 : }
17568 136746 : }
17569 :
17570 : /* Resolve the components of a derived type. This does not have to wait until
17571 : resolution stage, but can be done as soon as the dt declaration has been
17572 : parsed. */
17573 :
17574 : static bool
17575 168489 : resolve_fl_derived0 (gfc_symbol *sym)
17576 : {
17577 168489 : gfc_symbol* super_type;
17578 168489 : gfc_component *c;
17579 168489 : gfc_formal_arglist *f;
17580 168489 : bool success;
17581 :
17582 168489 : if (sym->attr.unlimited_polymorphic)
17583 : return true;
17584 :
17585 168489 : super_type = gfc_get_derived_super_type (sym);
17586 :
17587 : /* F2008, C432. */
17588 168489 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
17589 : {
17590 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
17591 : "parent type %qs shall also have one", sym->name,
17592 : &sym->declared_at, super_type->name);
17593 2 : return false;
17594 : }
17595 :
17596 : /* Ensure the extended type gets resolved before we do. */
17597 17275 : if (super_type && !resolve_fl_derived0 (super_type))
17598 : return false;
17599 :
17600 : /* An ABSTRACT type must be extensible. */
17601 168481 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
17602 : {
17603 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
17604 : sym->name, &sym->declared_at);
17605 2 : return false;
17606 : }
17607 :
17608 : /* Resolving components below, may create vtabs for which the cyclic type
17609 : information needs to be present. */
17610 168479 : if (!sym->attr.vtype)
17611 136746 : resolve_cyclic_derived_type (sym);
17612 :
17613 168479 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
17614 : : sym->components;
17615 :
17616 : success = true;
17617 571740 : for ( ; c != NULL; c = c->next)
17618 403261 : if (!resolve_component (c, sym))
17619 96 : success = false;
17620 :
17621 168479 : if (!success)
17622 : return false;
17623 :
17624 : /* Now add the caf token field, where needed. */
17625 168393 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
17626 990 : && !sym->attr.vtype)
17627 : {
17628 2222 : for (c = sym->components; c; c = c->next)
17629 1431 : if (!c->attr.dimension && !c->attr.codimension
17630 795 : && (c->attr.allocatable || c->attr.pointer))
17631 : {
17632 146 : char name[GFC_MAX_SYMBOL_LEN+9];
17633 146 : gfc_component *token;
17634 146 : sprintf (name, "_caf_%s", c->name);
17635 146 : token = gfc_find_component (sym, name, true, true, NULL);
17636 146 : if (token == NULL)
17637 : {
17638 82 : if (!gfc_add_component (sym, name, &token))
17639 0 : return false;
17640 82 : token->ts.type = BT_VOID;
17641 82 : token->ts.kind = gfc_default_integer_kind;
17642 82 : token->attr.access = ACCESS_PRIVATE;
17643 82 : token->attr.artificial = 1;
17644 82 : token->attr.caf_token = 1;
17645 : }
17646 146 : c->caf_token = token;
17647 : }
17648 : }
17649 :
17650 168393 : check_defined_assignments (sym);
17651 :
17652 168393 : if (!sym->attr.defined_assign_comp && super_type)
17653 16268 : sym->attr.defined_assign_comp
17654 16268 : = super_type->attr.defined_assign_comp;
17655 :
17656 : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
17657 : all DEFERRED bindings are overridden. */
17658 17268 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
17659 1397 : && !sym->attr.is_class
17660 3147 : && !ensure_not_abstract (sym, super_type))
17661 : return false;
17662 :
17663 : /* Check that there is a component for every PDT parameter. */
17664 168387 : if (sym->attr.pdt_template)
17665 : {
17666 2336 : for (f = sym->formal; f; f = f->next)
17667 : {
17668 1360 : if (!f->sym)
17669 1 : continue;
17670 1359 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
17671 1359 : if (c == NULL)
17672 : {
17673 9 : gfc_error ("Parameterized type %qs does not have a component "
17674 : "corresponding to parameter %qs at %L", sym->name,
17675 9 : f->sym->name, &sym->declared_at);
17676 9 : break;
17677 : }
17678 : }
17679 : }
17680 :
17681 : /* Add derived type to the derived type list. */
17682 168387 : add_dt_to_dt_list (sym);
17683 :
17684 168387 : return true;
17685 : }
17686 :
17687 : /* The following procedure does the full resolution of a derived type,
17688 : including resolution of all type-bound procedures (if present). In contrast
17689 : to 'resolve_fl_derived0' this can only be done after the module has been
17690 : parsed completely. */
17691 :
17692 : static bool
17693 87626 : resolve_fl_derived (gfc_symbol *sym)
17694 : {
17695 87626 : gfc_symbol *gen_dt = NULL;
17696 :
17697 87626 : if (sym->attr.unlimited_polymorphic)
17698 : return true;
17699 :
17700 87626 : if (!sym->attr.is_class)
17701 75104 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
17702 56130 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
17703 2289 : && (!gen_dt->generic->sym->attr.use_assoc
17704 2146 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
17705 87802 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
17706 : "%qs at %L being the same name as derived "
17707 : "type at %L", sym->name,
17708 : gen_dt->generic->sym == sym
17709 11 : ? gen_dt->generic->next->sym->name
17710 : : gen_dt->generic->sym->name,
17711 : gen_dt->generic->sym == sym
17712 11 : ? &gen_dt->generic->next->sym->declared_at
17713 : : &gen_dt->generic->sym->declared_at,
17714 : &sym->declared_at))
17715 : return false;
17716 :
17717 87622 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
17718 : {
17719 13 : gfc_error ("Derived type %qs at %L has not been declared",
17720 : sym->name, &sym->declared_at);
17721 13 : return false;
17722 : }
17723 :
17724 : /* Resolve the finalizer procedures. */
17725 87609 : if (!gfc_resolve_finalizers (sym, NULL))
17726 : return false;
17727 :
17728 87606 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
17729 : {
17730 : /* Fix up incomplete CLASS symbols. */
17731 12522 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
17732 12522 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
17733 :
17734 12522 : if (data->ts.u.derived->attr.pdt_template)
17735 : {
17736 6 : match m;
17737 6 : m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
17738 : &data->param_list);
17739 6 : if (m != MATCH_YES
17740 6 : || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
17741 : {
17742 0 : gfc_error ("Failed to build PDT class component at %L",
17743 : &sym->declared_at);
17744 0 : return false;
17745 : }
17746 6 : data = gfc_find_component (sym, "_data", true, true, NULL);
17747 6 : vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
17748 : }
17749 :
17750 : /* Nothing more to do for unlimited polymorphic entities. */
17751 12522 : if (data->ts.u.derived->attr.unlimited_polymorphic)
17752 : {
17753 2005 : add_dt_to_dt_list (sym);
17754 2005 : return true;
17755 : }
17756 10517 : else if (vptr->ts.u.derived == NULL)
17757 : {
17758 6208 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
17759 6208 : gcc_assert (vtab);
17760 6208 : vptr->ts.u.derived = vtab->ts.u.derived;
17761 6208 : if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
17762 : return false;
17763 : }
17764 : }
17765 :
17766 85601 : if (!resolve_fl_derived0 (sym))
17767 : return false;
17768 :
17769 : /* Resolve the type-bound procedures. */
17770 85517 : if (!resolve_typebound_procedures (sym))
17771 : return false;
17772 :
17773 : /* Generate module vtables subject to their accessibility and their not
17774 : being vtables or pdt templates. If this is not done class declarations
17775 : in external procedures wind up with their own version and so SELECT TYPE
17776 : fails because the vptrs do not have the same address. */
17777 85476 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
17778 85415 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
17779 64106 : || (sym->attr.recursive && sym->attr.alloc_comp))
17780 21463 : && sym->attr.access != ACCESS_PRIVATE
17781 21430 : && !(sym->attr.vtype || sym->attr.pdt_template))
17782 : {
17783 19266 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
17784 19266 : gfc_set_sym_referenced (vtab);
17785 : }
17786 :
17787 : return true;
17788 : }
17789 :
17790 :
17791 : static bool
17792 835 : resolve_fl_namelist (gfc_symbol *sym)
17793 : {
17794 835 : gfc_namelist *nl;
17795 835 : gfc_symbol *nlsym;
17796 :
17797 2984 : for (nl = sym->namelist; nl; nl = nl->next)
17798 : {
17799 : /* Check again, the check in match only works if NAMELIST comes
17800 : after the decl. */
17801 2154 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
17802 : {
17803 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
17804 : "allowed", nl->sym->name, sym->name, &sym->declared_at);
17805 1 : return false;
17806 : }
17807 :
17808 652 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
17809 2161 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17810 : "with assumed shape in namelist %qs at %L",
17811 : nl->sym->name, sym->name, &sym->declared_at))
17812 : return false;
17813 :
17814 2152 : if (is_non_constant_shape_array (nl->sym)
17815 2202 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17816 : "with nonconstant shape in namelist %qs at %L",
17817 50 : nl->sym->name, sym->name, &sym->declared_at))
17818 : return false;
17819 :
17820 2151 : if (nl->sym->ts.type == BT_CHARACTER
17821 589 : && (nl->sym->ts.u.cl->length == NULL
17822 550 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
17823 2233 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
17824 : "nonconstant character length in "
17825 82 : "namelist %qs at %L", nl->sym->name,
17826 : sym->name, &sym->declared_at))
17827 : return false;
17828 :
17829 : }
17830 :
17831 : /* Reject PRIVATE objects in a PUBLIC namelist. */
17832 830 : if (gfc_check_symbol_access (sym))
17833 : {
17834 2965 : for (nl = sym->namelist; nl; nl = nl->next)
17835 : {
17836 2148 : if (!nl->sym->attr.use_assoc
17837 4000 : && !is_sym_host_assoc (nl->sym, sym->ns)
17838 4126 : && !gfc_check_symbol_access (nl->sym))
17839 : {
17840 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
17841 : "cannot be member of PUBLIC namelist %qs at %L",
17842 2 : nl->sym->name, sym->name, &sym->declared_at);
17843 2 : return false;
17844 : }
17845 :
17846 2146 : if (nl->sym->ts.type == BT_DERIVED
17847 466 : && (nl->sym->ts.u.derived->attr.alloc_comp
17848 464 : || nl->sym->ts.u.derived->attr.pointer_comp))
17849 : {
17850 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
17851 : "namelist %qs at %L with ALLOCATABLE "
17852 : "or POINTER components", nl->sym->name,
17853 : sym->name, &sym->declared_at))
17854 : return false;
17855 : return true;
17856 : }
17857 :
17858 : /* Types with private components that came here by USE-association. */
17859 2141 : if (nl->sym->ts.type == BT_DERIVED
17860 2141 : && derived_inaccessible (nl->sym->ts.u.derived))
17861 : {
17862 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
17863 : "components and cannot be member of namelist %qs at %L",
17864 : nl->sym->name, sym->name, &sym->declared_at);
17865 6 : return false;
17866 : }
17867 :
17868 : /* Types with private components that are defined in the same module. */
17869 2135 : if (nl->sym->ts.type == BT_DERIVED
17870 910 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
17871 2413 : && nl->sym->ts.u.derived->attr.private_comp)
17872 : {
17873 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
17874 : "cannot be a member of PUBLIC namelist %qs at %L",
17875 : nl->sym->name, sym->name, &sym->declared_at);
17876 0 : return false;
17877 : }
17878 : }
17879 : }
17880 :
17881 :
17882 : /* 14.1.2 A module or internal procedure represent local entities
17883 : of the same type as a namelist member and so are not allowed. */
17884 2949 : for (nl = sym->namelist; nl; nl = nl->next)
17885 : {
17886 2135 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
17887 1576 : continue;
17888 :
17889 559 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
17890 7 : if ((nl->sym == sym->ns->proc_name)
17891 1 : ||
17892 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
17893 6 : continue;
17894 :
17895 553 : nlsym = NULL;
17896 553 : if (nl->sym->name)
17897 553 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
17898 553 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
17899 : {
17900 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
17901 : "attribute in %qs at %L", nlsym->name,
17902 : &sym->declared_at);
17903 3 : return false;
17904 : }
17905 : }
17906 :
17907 : return true;
17908 : }
17909 :
17910 :
17911 : static bool
17912 380841 : resolve_fl_parameter (gfc_symbol *sym)
17913 : {
17914 : /* A parameter array's shape needs to be constant. */
17915 380841 : if (sym->as != NULL
17916 380841 : && (sym->as->type == AS_DEFERRED
17917 6251 : || is_non_constant_shape_array (sym)))
17918 : {
17919 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
17920 : "or of deferred shape", sym->name, &sym->declared_at);
17921 17 : return false;
17922 : }
17923 :
17924 : /* Constraints on deferred type parameter. */
17925 380824 : if (!deferred_requirements (sym))
17926 : return false;
17927 :
17928 : /* Make sure a parameter that has been implicitly typed still
17929 : matches the implicit type, since PARAMETER statements can precede
17930 : IMPLICIT statements. */
17931 380823 : if (sym->attr.implicit_type
17932 381536 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
17933 713 : sym->ns)))
17934 : {
17935 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
17936 : "later IMPLICIT type", sym->name, &sym->declared_at);
17937 0 : return false;
17938 : }
17939 :
17940 : /* Make sure the types of derived parameters are consistent. This
17941 : type checking is deferred until resolution because the type may
17942 : refer to a derived type from the host. */
17943 380823 : if (sym->ts.type == BT_DERIVED
17944 380823 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
17945 : {
17946 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
17947 0 : &sym->value->where);
17948 0 : return false;
17949 : }
17950 :
17951 : /* F03:C509,C514. */
17952 380823 : if (sym->ts.type == BT_CLASS)
17953 : {
17954 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
17955 : sym->name, &sym->declared_at);
17956 0 : return false;
17957 : }
17958 :
17959 : /* Some programmers can have a typo when using an implied-do loop to
17960 : initialize an array constant. For example,
17961 : INTEGER I,J
17962 : INTEGER, PARAMETER :: A(3) = [(I, I = 1, 3)] ! OK
17963 : INTEGER, PARAMETER :: B(3) = [(A(J), I = 1, 3)] ! Not OK, J undefined
17964 : This check catches the typo. */
17965 380823 : if (sym->attr.dimension
17966 6244 : && sym->value && sym->value->expr_type == EXPR_ARRAY
17967 387063 : && !gfc_is_constant_expr (sym->value))
17968 : {
17969 : /* PR fortran/117070 argues a nonconstant proc pointer can appear in
17970 : the array constructor of a paramater. This seems inconsistant with
17971 : the concept of a parameter. TODO: Needs an interpretation. */
17972 20 : if (sym->value->ts.type == BT_DERIVED
17973 18 : && sym->value->ts.u.derived
17974 18 : && sym->value->ts.u.derived->attr.proc_pointer_comp)
17975 : return true;
17976 2 : gfc_error ("Expecting constant expression near %L", &sym->value->where);
17977 2 : return false;
17978 : }
17979 :
17980 : return true;
17981 : }
17982 :
17983 :
17984 : /* Called by resolve_symbol to check PDTs. */
17985 :
17986 : static void
17987 1376 : resolve_pdt (gfc_symbol* sym)
17988 : {
17989 1376 : gfc_symbol *derived = NULL;
17990 1376 : gfc_actual_arglist *param;
17991 1376 : gfc_component *c;
17992 1376 : bool const_len_exprs = true;
17993 1376 : bool assumed_len_exprs = false;
17994 1376 : symbol_attribute *attr;
17995 :
17996 1376 : if (sym->ts.type == BT_DERIVED)
17997 : {
17998 1149 : derived = sym->ts.u.derived;
17999 1149 : attr = &(sym->attr);
18000 : }
18001 227 : else if (sym->ts.type == BT_CLASS)
18002 : {
18003 227 : derived = CLASS_DATA (sym)->ts.u.derived;
18004 227 : attr = &(CLASS_DATA (sym)->attr);
18005 : }
18006 : else
18007 0 : gcc_unreachable ();
18008 :
18009 1376 : gcc_assert (derived->attr.pdt_type);
18010 :
18011 3274 : for (param = sym->param_list; param; param = param->next)
18012 : {
18013 1898 : c = gfc_find_component (derived, param->name, false, true, NULL);
18014 1898 : gcc_assert (c);
18015 1898 : if (c->attr.pdt_kind)
18016 1016 : continue;
18017 :
18018 613 : if (param->expr && !gfc_is_constant_expr (param->expr)
18019 966 : && c->attr.pdt_len)
18020 : const_len_exprs = false;
18021 798 : else if (param->spec_type == SPEC_ASSUMED)
18022 291 : assumed_len_exprs = true;
18023 :
18024 882 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
18025 18 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
18026 16 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
18027 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
18028 : "parameter %qs and requires either the POINTER "
18029 : "or ALLOCATABLE attribute",
18030 : sym->name, &sym->declared_at,
18031 : param->name);
18032 :
18033 : }
18034 :
18035 1376 : if (!const_len_exprs
18036 84 : && (sym->ns->proc_name->attr.is_main_program
18037 83 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18038 82 : || sym->attr.save != SAVE_NONE))
18039 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
18040 : "SAVE attribute or be a variable declared in the "
18041 : "main program, a module or a submodule(F08/C513)",
18042 : sym->name, &sym->declared_at);
18043 :
18044 1376 : if (assumed_len_exprs && !(sym->attr.dummy
18045 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
18046 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
18047 : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
18048 : sym->name, &sym->declared_at);
18049 1376 : }
18050 :
18051 :
18052 : /* Resolve the symbol's array spec. */
18053 :
18054 : static bool
18055 1686987 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
18056 : {
18057 1686987 : gfc_namespace *orig_current_ns = gfc_current_ns;
18058 1686987 : gfc_current_ns = gfc_get_spec_ns (sym);
18059 :
18060 1686987 : bool saved_specification_expr = specification_expr;
18061 1686987 : specification_expr = true;
18062 :
18063 1686987 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
18064 :
18065 1686987 : specification_expr = saved_specification_expr;
18066 1686987 : gfc_current_ns = orig_current_ns;
18067 :
18068 1686987 : return result;
18069 : }
18070 :
18071 :
18072 : /* Do anything necessary to resolve a symbol. Right now, we just
18073 : assume that an otherwise unknown symbol is a variable. This sort
18074 : of thing commonly happens for symbols in module. */
18075 :
18076 : static void
18077 1827126 : resolve_symbol (gfc_symbol *sym)
18078 : {
18079 1827126 : int check_constant, mp_flag;
18080 1827126 : gfc_symtree *symtree;
18081 1827126 : gfc_symtree *this_symtree;
18082 1827126 : gfc_namespace *ns;
18083 1827126 : gfc_component *c;
18084 1827126 : symbol_attribute class_attr;
18085 1827126 : gfc_array_spec *as;
18086 :
18087 1827126 : if (sym->resolve_symbol_called >= 1)
18088 171442 : return;
18089 1753460 : sym->resolve_symbol_called = 1;
18090 :
18091 : /* No symbol will ever have union type; only components can be unions.
18092 : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
18093 : (just like derived type declaration symbols have flavor FL_DERIVED). */
18094 1753460 : gcc_assert (sym->ts.type != BT_UNION);
18095 :
18096 : /* Coarrayed polymorphic objects with allocatable or pointer components are
18097 : yet unsupported for -fcoarray=lib. */
18098 1753460 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
18099 112 : && sym->ts.u.derived && CLASS_DATA (sym)
18100 112 : && CLASS_DATA (sym)->attr.codimension
18101 94 : && CLASS_DATA (sym)->ts.u.derived
18102 93 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
18103 90 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
18104 : {
18105 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
18106 : "type coarrays at %L are unsupported", &sym->declared_at);
18107 6 : return;
18108 : }
18109 :
18110 1753454 : if (sym->attr.artificial)
18111 : return;
18112 :
18113 1658351 : if (sym->attr.unlimited_polymorphic)
18114 : return;
18115 :
18116 1656894 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
18117 : {
18118 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
18119 : "the OpenMP DEPEND clause", &sym->declared_at);
18120 4 : return;
18121 : }
18122 :
18123 1656890 : if (sym->attr.flavor == FL_UNKNOWN
18124 1635765 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
18125 441381 : && !sym->attr.generic && !sym->attr.external
18126 179258 : && sym->attr.if_source == IFSRC_UNKNOWN
18127 80670 : && sym->ts.type == BT_UNKNOWN))
18128 : {
18129 : /* A symbol in a common block might not have been resolved yet properly.
18130 : Do not try to find an interface with the same name. */
18131 93412 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
18132 21121 : && !sym->attr.generic && !sym->attr.external
18133 21070 : && sym->attr.in_common)
18134 2594 : goto skip_interfaces;
18135 :
18136 : /* If we find that a flavorless symbol is an interface in one of the
18137 : parent namespaces, find its symtree in this namespace, free the
18138 : symbol and set the symtree to point to the interface symbol. */
18139 129648 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
18140 : {
18141 39508 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
18142 39508 : if (symtree && (symtree->n.sym->generic ||
18143 724 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
18144 634 : && sym->ns->construct_entities)))
18145 : {
18146 686 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
18147 : sym->name);
18148 686 : if (this_symtree->n.sym == sym)
18149 : {
18150 678 : symtree->n.sym->refs++;
18151 678 : gfc_release_symbol (sym);
18152 678 : this_symtree->n.sym = symtree->n.sym;
18153 678 : return;
18154 : }
18155 : }
18156 : }
18157 :
18158 90140 : skip_interfaces:
18159 : /* Otherwise give it a flavor according to such attributes as
18160 : it has. */
18161 92734 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
18162 20940 : && sym->attr.intrinsic == 0)
18163 20936 : sym->attr.flavor = FL_VARIABLE;
18164 71798 : else if (sym->attr.flavor == FL_UNKNOWN)
18165 : {
18166 55 : sym->attr.flavor = FL_PROCEDURE;
18167 55 : if (sym->attr.dimension)
18168 0 : sym->attr.function = 1;
18169 : }
18170 : }
18171 :
18172 1656212 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
18173 2304 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
18174 :
18175 1452 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
18176 1657664 : && !resolve_procedure_interface (sym))
18177 : return;
18178 :
18179 1656201 : if (sym->attr.is_protected && !sym->attr.proc_pointer
18180 130 : && (sym->attr.procedure || sym->attr.external))
18181 : {
18182 0 : if (sym->attr.external)
18183 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18184 : "at %L", &sym->declared_at);
18185 : else
18186 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18187 : "at %L", &sym->declared_at);
18188 :
18189 0 : return;
18190 : }
18191 :
18192 : /* Ensure that variables of derived or class type having a finalizer are
18193 : marked used even when the variable is not used anything else in the scope.
18194 : This fixes PR118730. */
18195 646415 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18196 442168 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18197 1705479 : && gfc_may_be_finalized (sym->ts))
18198 8398 : gfc_set_sym_referenced (sym);
18199 :
18200 1656201 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18201 : return;
18202 :
18203 1655425 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18204 1656188 : && !resolve_fl_struct (sym))
18205 : return;
18206 :
18207 : /* Symbols that are module procedures with results (functions) have
18208 : the types and array specification copied for type checking in
18209 : procedures that call them, as well as for saving to a module
18210 : file. These symbols can't stand the scrutiny that their results
18211 : can. */
18212 1656056 : mp_flag = (sym->result != NULL && sym->result != sym);
18213 :
18214 : /* Make sure that the intrinsic is consistent with its internal
18215 : representation. This needs to be done before assigning a default
18216 : type to avoid spurious warnings. */
18217 1622142 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18218 1688404 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18219 : return;
18220 :
18221 : /* Resolve associate names. */
18222 1656020 : if (sym->assoc)
18223 6735 : resolve_assoc_var (sym, true);
18224 :
18225 : /* Assign default type to symbols that need one and don't have one. */
18226 1656020 : if (sym->ts.type == BT_UNKNOWN)
18227 : {
18228 399098 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18229 : {
18230 11758 : gfc_set_default_type (sym, 1, NULL);
18231 : }
18232 :
18233 257753 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18234 60993 : && !sym->attr.function && !sym->attr.subroutine
18235 400713 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18236 564 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18237 :
18238 399098 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18239 : {
18240 : /* The specific case of an external procedure should emit an error
18241 : in the case that there is no implicit type. */
18242 101744 : if (!mp_flag)
18243 : {
18244 95777 : if (!sym->attr.mixed_entry_master)
18245 95669 : gfc_set_default_type (sym, sym->attr.external, NULL);
18246 : }
18247 : else
18248 : {
18249 : /* Result may be in another namespace. */
18250 5967 : resolve_symbol (sym->result);
18251 :
18252 5967 : if (!sym->result->attr.proc_pointer)
18253 : {
18254 5788 : sym->ts = sym->result->ts;
18255 5788 : sym->as = gfc_copy_array_spec (sym->result->as);
18256 5788 : sym->attr.dimension = sym->result->attr.dimension;
18257 5788 : sym->attr.codimension = sym->result->attr.codimension;
18258 5788 : sym->attr.pointer = sym->result->attr.pointer;
18259 5788 : sym->attr.allocatable = sym->result->attr.allocatable;
18260 5788 : sym->attr.contiguous = sym->result->attr.contiguous;
18261 : }
18262 : }
18263 : }
18264 : }
18265 1256922 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18266 31300 : resolve_symbol_array_spec (sym->result, false);
18267 :
18268 : /* For a CLASS-valued function with a result variable, affirm that it has
18269 : been resolved also when looking at the symbol 'sym'. */
18270 430398 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18271 720 : sym->attr.class_ok = sym->result->attr.class_ok;
18272 :
18273 1656020 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18274 19172 : && CLASS_DATA (sym))
18275 : {
18276 19171 : as = CLASS_DATA (sym)->as;
18277 19171 : class_attr = CLASS_DATA (sym)->attr;
18278 19171 : class_attr.pointer = class_attr.class_pointer;
18279 : }
18280 : else
18281 : {
18282 1636849 : class_attr = sym->attr;
18283 1636849 : as = sym->as;
18284 : }
18285 :
18286 : /* F2008, C530. */
18287 1656020 : if (sym->attr.contiguous
18288 7687 : && !sym->attr.associate_var
18289 7686 : && (!class_attr.dimension
18290 7683 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18291 128 : && !class_attr.pointer)))
18292 : {
18293 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18294 : "array pointer or an assumed-shape or assumed-rank array",
18295 : sym->name, &sym->declared_at);
18296 7 : return;
18297 : }
18298 :
18299 : /* Assumed size arrays and assumed shape arrays must be dummy
18300 : arguments. Array-spec's of implied-shape should have been resolved to
18301 : AS_EXPLICIT already. */
18302 :
18303 1648458 : if (as)
18304 : {
18305 : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18306 : specification expression. */
18307 145147 : if (as->type == AS_IMPLIED_SHAPE)
18308 : {
18309 : int i;
18310 1 : for (i=0; i<as->rank; i++)
18311 : {
18312 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18313 : {
18314 1 : gfc_error ("Bad specification for assumed size array at %L",
18315 : &as->lower[i]->where);
18316 1 : return;
18317 : }
18318 : }
18319 0 : gcc_unreachable();
18320 : }
18321 :
18322 145146 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18323 112245 : || as->type == AS_ASSUMED_SHAPE)
18324 44454 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18325 8 : && !sym->attr.associate_var)
18326 : {
18327 7 : if (as->type == AS_ASSUMED_SIZE)
18328 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18329 : &sym->declared_at);
18330 : else
18331 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18332 : &sym->declared_at);
18333 7 : return;
18334 : }
18335 : /* TS 29113, C535a. */
18336 145139 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18337 60 : && !sym->attr.select_type_temporary
18338 60 : && !(cs_base && cs_base->current
18339 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18340 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18341 0 : && cs_base->current->op == EXEC_BLOCK))))
18342 : {
18343 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18344 : &sym->declared_at);
18345 18 : return;
18346 : }
18347 145121 : if (as->type == AS_ASSUMED_RANK
18348 26202 : && (sym->attr.codimension || sym->attr.value))
18349 : {
18350 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18351 : "CODIMENSION attribute", &sym->declared_at);
18352 2 : return;
18353 : }
18354 : }
18355 :
18356 : /* Make sure symbols with known intent or optional are really dummy
18357 : variable. Because of ENTRY statement, this has to be deferred
18358 : until resolution time. */
18359 :
18360 1655985 : if (!sym->attr.dummy
18361 1190749 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
18362 : {
18363 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
18364 2 : return;
18365 : }
18366 :
18367 1655983 : if (sym->attr.value && !sym->attr.dummy)
18368 : {
18369 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
18370 : "it is not a dummy argument", sym->name, &sym->declared_at);
18371 2 : return;
18372 : }
18373 :
18374 1655981 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
18375 : {
18376 616 : gfc_charlen *cl = sym->ts.u.cl;
18377 616 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
18378 : {
18379 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
18380 : "attribute must have constant length",
18381 : sym->name, &sym->declared_at);
18382 2 : return;
18383 : }
18384 :
18385 614 : if (sym->ts.is_c_interop
18386 381 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
18387 : {
18388 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
18389 : "with VALUE attribute must have length one",
18390 : sym->name, &sym->declared_at);
18391 1 : return;
18392 : }
18393 : }
18394 :
18395 1655978 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18396 122701 : && sym->ts.u.derived->attr.generic)
18397 : {
18398 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
18399 20 : if (!sym->ts.u.derived)
18400 : {
18401 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
18402 : "which has not been defined", sym->name,
18403 : &sym->declared_at, sym->ts.u.derived->name);
18404 0 : sym->ts.type = BT_UNKNOWN;
18405 0 : return;
18406 : }
18407 : }
18408 :
18409 : /* Use the same constraints as TYPE(*), except for the type check
18410 : and that only scalars and assumed-size arrays are permitted. */
18411 1655978 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
18412 : {
18413 12960 : if (!sym->attr.dummy)
18414 : {
18415 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18416 : "a dummy argument", sym->name, &sym->declared_at);
18417 1 : return;
18418 : }
18419 :
18420 12959 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
18421 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
18422 0 : && sym->ts.type != BT_COMPLEX)
18423 : {
18424 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18425 : "of type TYPE(*) or of an numeric intrinsic type",
18426 : sym->name, &sym->declared_at);
18427 0 : return;
18428 : }
18429 :
18430 12959 : if (sym->attr.allocatable || sym->attr.codimension
18431 12957 : || sym->attr.pointer || sym->attr.value)
18432 : {
18433 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18434 : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
18435 : "attribute", sym->name, &sym->declared_at);
18436 4 : return;
18437 : }
18438 :
18439 12955 : if (sym->attr.intent == INTENT_OUT)
18440 : {
18441 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18442 : "have the INTENT(OUT) attribute",
18443 : sym->name, &sym->declared_at);
18444 0 : return;
18445 : }
18446 12955 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
18447 : {
18448 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
18449 : "either be a scalar or an assumed-size array",
18450 : sym->name, &sym->declared_at);
18451 1 : return;
18452 : }
18453 :
18454 : /* Set the type to TYPE(*) and add a dimension(*) to ensure
18455 : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
18456 : packing. */
18457 12954 : sym->ts.type = BT_ASSUMED;
18458 12954 : sym->as = gfc_get_array_spec ();
18459 12954 : sym->as->type = AS_ASSUMED_SIZE;
18460 12954 : sym->as->rank = 1;
18461 12954 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
18462 : }
18463 1643018 : else if (sym->ts.type == BT_ASSUMED)
18464 : {
18465 : /* TS 29113, C407a. */
18466 11006 : if (!sym->attr.dummy)
18467 : {
18468 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
18469 : "for dummy variables", sym->name, &sym->declared_at);
18470 7 : return;
18471 : }
18472 10999 : if (sym->attr.allocatable || sym->attr.codimension
18473 10995 : || sym->attr.pointer || sym->attr.value)
18474 : {
18475 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
18476 : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
18477 : sym->name, &sym->declared_at);
18478 8 : return;
18479 : }
18480 10991 : if (sym->attr.intent == INTENT_OUT)
18481 : {
18482 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
18483 : "INTENT(OUT) attribute",
18484 : sym->name, &sym->declared_at);
18485 2 : return;
18486 : }
18487 10989 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
18488 : {
18489 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
18490 : "explicit-shape array", sym->name, &sym->declared_at);
18491 3 : return;
18492 : }
18493 : }
18494 :
18495 : /* If the symbol is marked as bind(c), that it is declared at module level
18496 : scope and verify its type and kind. Do not do the latter for symbols
18497 : that are implicitly typed because that is handled in
18498 : gfc_set_default_type. Handle dummy arguments and procedure definitions
18499 : separately. Also, anything that is use associated is not handled here
18500 : but instead is handled in the module it is declared in. Finally, derived
18501 : type definitions are allowed to be BIND(C) since that only implies that
18502 : they're interoperable, and they are checked fully for interoperability
18503 : when a variable is declared of that type. */
18504 1655952 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
18505 7160 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
18506 567 : && sym->attr.flavor != FL_DERIVED)
18507 : {
18508 167 : bool t = true;
18509 :
18510 : /* First, make sure the variable is declared at the
18511 : module-level scope (J3/04-007, Section 15.3). */
18512 167 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
18513 7 : && !sym->attr.in_common)
18514 : {
18515 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
18516 : "is neither a COMMON block nor declared at the "
18517 : "module level scope", sym->name, &(sym->declared_at));
18518 6 : t = false;
18519 : }
18520 161 : else if (sym->ts.type == BT_CHARACTER
18521 161 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
18522 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
18523 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
18524 : {
18525 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
18526 1 : sym->name, &sym->declared_at);
18527 1 : t = false;
18528 : }
18529 160 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
18530 : {
18531 1 : t = verify_com_block_vars_c_interop (sym->common_head);
18532 : }
18533 159 : else if (sym->attr.implicit_type == 0)
18534 : {
18535 : /* If type() declaration, we need to verify that the components
18536 : of the given type are all C interoperable, etc. */
18537 157 : if (sym->ts.type == BT_DERIVED &&
18538 24 : sym->ts.u.derived->attr.is_c_interop != 1)
18539 : {
18540 : /* Make sure the user marked the derived type as BIND(C). If
18541 : not, call the verify routine. This could print an error
18542 : for the derived type more than once if multiple variables
18543 : of that type are declared. */
18544 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
18545 1 : verify_bind_c_derived_type (sym->ts.u.derived);
18546 157 : t = false;
18547 : }
18548 :
18549 : /* Verify the variable itself as C interoperable if it
18550 : is BIND(C). It is not possible for this to succeed if
18551 : the verify_bind_c_derived_type failed, so don't have to handle
18552 : any error returned by verify_bind_c_derived_type. */
18553 157 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
18554 157 : sym->common_block);
18555 : }
18556 :
18557 165 : if (!t)
18558 : {
18559 : /* clear the is_bind_c flag to prevent reporting errors more than
18560 : once if something failed. */
18561 10 : sym->attr.is_bind_c = 0;
18562 10 : return;
18563 : }
18564 : }
18565 :
18566 : /* If a derived type symbol has reached this point, without its
18567 : type being declared, we have an error. Notice that most
18568 : conditions that produce undefined derived types have already
18569 : been dealt with. However, the likes of:
18570 : implicit type(t) (t) ..... call foo (t) will get us here if
18571 : the type is not declared in the scope of the implicit
18572 : statement. Change the type to BT_UNKNOWN, both because it is so
18573 : and to prevent an ICE. */
18574 1655942 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18575 122699 : && sym->ts.u.derived->components == NULL
18576 1138 : && !sym->ts.u.derived->attr.zero_comp)
18577 : {
18578 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
18579 : "which has not been defined", sym->name,
18580 : &sym->declared_at, sym->ts.u.derived->name);
18581 3 : sym->ts.type = BT_UNKNOWN;
18582 3 : return;
18583 : }
18584 :
18585 : /* Make sure that the derived type has been resolved and that the
18586 : derived type is visible in the symbol's namespace, if it is a
18587 : module function and is not PRIVATE. */
18588 1655939 : if (sym->ts.type == BT_DERIVED
18589 129606 : && sym->ts.u.derived->attr.use_assoc
18590 112344 : && sym->ns->proc_name
18591 112336 : && sym->ns->proc_name->attr.flavor == FL_MODULE
18592 1661800 : && !resolve_fl_derived (sym->ts.u.derived))
18593 : return;
18594 :
18595 : /* Unless the derived-type declaration is use associated, Fortran 95
18596 : does not allow public entries of private derived types.
18597 : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
18598 : 161 in 95-006r3. */
18599 1655939 : if (sym->ts.type == BT_DERIVED
18600 129606 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
18601 7923 : && !sym->ts.u.derived->attr.use_assoc
18602 2062 : && gfc_check_symbol_access (sym)
18603 1855 : && !gfc_check_symbol_access (sym->ts.u.derived)
18604 1655953 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
18605 : "derived type %qs",
18606 14 : (sym->attr.flavor == FL_PARAMETER)
18607 : ? "parameter" : "variable",
18608 : sym->name, &sym->declared_at,
18609 14 : sym->ts.u.derived->name))
18610 : return;
18611 :
18612 : /* F2008, C1302. */
18613 1655932 : if (sym->ts.type == BT_DERIVED
18614 129599 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18615 154 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
18616 129568 : || sym->ts.u.derived->attr.lock_comp)
18617 44 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18618 : {
18619 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
18620 : "type LOCK_TYPE must be a coarray", sym->name,
18621 : &sym->declared_at);
18622 4 : return;
18623 : }
18624 :
18625 : /* TS18508, C702/C703. */
18626 1655928 : if (sym->ts.type == BT_DERIVED
18627 129595 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18628 153 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
18629 129578 : || sym->ts.u.derived->attr.event_comp)
18630 17 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18631 : {
18632 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
18633 : "type EVENT_TYPE must be a coarray", sym->name,
18634 : &sym->declared_at);
18635 1 : return;
18636 : }
18637 :
18638 : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
18639 : default initialization is defined (5.1.2.4.4). */
18640 1655927 : if (sym->ts.type == BT_DERIVED
18641 129594 : && sym->attr.dummy
18642 44714 : && sym->attr.intent == INTENT_OUT
18643 2356 : && sym->as
18644 381 : && sym->as->type == AS_ASSUMED_SIZE)
18645 : {
18646 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
18647 : {
18648 1 : if (c->initializer)
18649 : {
18650 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
18651 : "ASSUMED SIZE and so cannot have a default initializer",
18652 : sym->name, &sym->declared_at);
18653 1 : return;
18654 : }
18655 : }
18656 : }
18657 :
18658 : /* F2008, C542. */
18659 1655926 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18660 44713 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
18661 : {
18662 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
18663 : "INTENT(OUT)", sym->name, &sym->declared_at);
18664 0 : return;
18665 : }
18666 :
18667 : /* TS18508. */
18668 1655926 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18669 44713 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
18670 : {
18671 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
18672 : "INTENT(OUT)", sym->name, &sym->declared_at);
18673 0 : return;
18674 : }
18675 :
18676 : /* F2008, C525. */
18677 1655926 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18678 1655826 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18679 19175 : && sym->ts.u.derived && CLASS_DATA (sym)
18680 19169 : && CLASS_DATA (sym)->attr.coarray_comp))
18681 1655826 : || class_attr.codimension)
18682 1773 : && (sym->attr.result || sym->result == sym))
18683 : {
18684 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
18685 : "a coarray component", sym->name, &sym->declared_at);
18686 8 : return;
18687 : }
18688 :
18689 : /* F2008, C524. */
18690 1655918 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
18691 411 : && sym->ts.u.derived->ts.is_iso_c)
18692 : {
18693 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
18694 : "shall not be a coarray", sym->name, &sym->declared_at);
18695 3 : return;
18696 : }
18697 :
18698 : /* F2008, C525. */
18699 1655915 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18700 1655818 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18701 19174 : && sym->ts.u.derived && CLASS_DATA (sym)
18702 19168 : && CLASS_DATA (sym)->attr.coarray_comp))
18703 97 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
18704 93 : || class_attr.allocatable))
18705 : {
18706 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
18707 : "nonpointer, nonallocatable scalar, which is not a coarray",
18708 : sym->name, &sym->declared_at);
18709 4 : return;
18710 : }
18711 :
18712 : /* F2008, C526. The function-result case was handled above. */
18713 1655911 : if (class_attr.codimension
18714 1665 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
18715 348 : || sym->attr.select_type_temporary
18716 272 : || sym->attr.associate_var
18717 254 : || (sym->ns->save_all && !sym->attr.automatic)
18718 254 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18719 254 : || sym->ns->proc_name->attr.is_main_program
18720 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
18721 : {
18722 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
18723 : "nor a dummy argument", sym->name, &sym->declared_at);
18724 4 : return;
18725 : }
18726 : /* F2008, C528. */
18727 1655907 : else if (class_attr.codimension && !sym->attr.select_type_temporary
18728 1585 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
18729 : {
18730 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
18731 : "deferred shape without allocatable", sym->name,
18732 : &sym->declared_at);
18733 6 : return;
18734 : }
18735 1655901 : else if (class_attr.codimension && class_attr.allocatable && as
18736 611 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
18737 : {
18738 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
18739 : "deferred shape", sym->name, &sym->declared_at);
18740 9 : return;
18741 : }
18742 :
18743 : /* F2008, C541. */
18744 1655892 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18745 1655799 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18746 19169 : && sym->ts.u.derived && CLASS_DATA (sym)
18747 19163 : && CLASS_DATA (sym)->attr.coarray_comp))
18748 1655799 : || (class_attr.codimension && class_attr.allocatable))
18749 695 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
18750 : {
18751 3 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
18752 : "allocatable coarray or have coarray components",
18753 : sym->name, &sym->declared_at);
18754 3 : return;
18755 : }
18756 :
18757 1655889 : if (class_attr.codimension && sym->attr.dummy
18758 469 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
18759 : {
18760 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
18761 : "procedure %qs", sym->name, &sym->declared_at,
18762 : sym->ns->proc_name->name);
18763 2 : return;
18764 : }
18765 :
18766 1655887 : if (sym->ts.type == BT_LOGICAL
18767 112018 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
18768 112015 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
18769 30954 : && sym->ns->proc_name->attr.is_bind_c)))
18770 : {
18771 : int i;
18772 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
18773 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
18774 : break;
18775 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
18776 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
18777 : "%L with non-C_Bool kind in BIND(C) procedure "
18778 : "%qs", sym->name, &sym->declared_at,
18779 13 : sym->ns->proc_name->name))
18780 : return;
18781 167 : else if (!gfc_logical_kinds[i].c_bool
18782 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
18783 : "%qs at %L with non-C_Bool kind in "
18784 : "BIND(C) procedure %qs", sym->name,
18785 : &sym->declared_at,
18786 15 : sym->attr.function ? sym->name
18787 13 : : sym->ns->proc_name->name))
18788 : return;
18789 : }
18790 :
18791 1655884 : switch (sym->attr.flavor)
18792 : {
18793 646298 : case FL_VARIABLE:
18794 646298 : if (!resolve_fl_variable (sym, mp_flag))
18795 : return;
18796 : break;
18797 :
18798 473175 : case FL_PROCEDURE:
18799 473175 : if (sym->formal && !sym->formal_ns)
18800 : {
18801 : /* Check that none of the arguments are a namelist. */
18802 : gfc_formal_arglist *formal = sym->formal;
18803 :
18804 104812 : for (; formal; formal = formal->next)
18805 71189 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
18806 : {
18807 1 : gfc_error ("Namelist %qs cannot be an argument to "
18808 : "subroutine or function at %L",
18809 : formal->sym->name, &sym->declared_at);
18810 1 : return;
18811 : }
18812 : }
18813 :
18814 473174 : if (!resolve_fl_procedure (sym, mp_flag))
18815 : return;
18816 : break;
18817 :
18818 835 : case FL_NAMELIST:
18819 835 : if (!resolve_fl_namelist (sym))
18820 : return;
18821 : break;
18822 :
18823 380841 : case FL_PARAMETER:
18824 380841 : if (!resolve_fl_parameter (sym))
18825 : return;
18826 : break;
18827 :
18828 : default:
18829 : break;
18830 : }
18831 :
18832 : /* Resolve array specifier. Check as well some constraints
18833 : on COMMON blocks. */
18834 :
18835 1655687 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
18836 :
18837 1655687 : resolve_symbol_array_spec (sym, check_constant);
18838 :
18839 : /* Resolve formal namespaces. */
18840 1655687 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
18841 258969 : && !sym->attr.contained && !sym->attr.intrinsic)
18842 233900 : gfc_resolve (sym->formal_ns);
18843 :
18844 : /* Make sure the formal namespace is present. */
18845 1655687 : if (sym->formal && !sym->formal_ns)
18846 : {
18847 : gfc_formal_arglist *formal = sym->formal;
18848 34065 : while (formal && !formal->sym)
18849 11 : formal = formal->next;
18850 :
18851 34054 : if (formal)
18852 : {
18853 34043 : sym->formal_ns = formal->sym->ns;
18854 34043 : if (sym->formal_ns && sym->ns != formal->sym->ns)
18855 25767 : sym->formal_ns->refs++;
18856 : }
18857 : }
18858 :
18859 : /* Check threadprivate restrictions. */
18860 1655687 : if ((sym->attr.threadprivate || sym->attr.omp_groupprivate)
18861 384 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
18862 33 : && !(sym->ns->save_all && !sym->attr.automatic)
18863 32 : && sym->module == NULL
18864 17 : && (sym->ns->proc_name == NULL
18865 17 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18866 4 : && !sym->ns->proc_name->attr.is_main_program)))
18867 : {
18868 2 : if (sym->attr.threadprivate)
18869 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
18870 : else
18871 1 : gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE "
18872 : "attribute", sym->name, &sym->declared_at);
18873 : }
18874 :
18875 1655687 : if (sym->attr.omp_groupprivate && sym->value)
18876 2 : gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an "
18877 : "initializer", sym->name, &sym->declared_at);
18878 :
18879 : /* Check omp declare target restrictions. */
18880 1655687 : if ((sym->attr.omp_declare_target
18881 1654275 : || sym->attr.omp_declare_target_link
18882 1654227 : || sym->attr.omp_declare_target_local)
18883 1500 : && !sym->attr.omp_groupprivate /* already warned. */
18884 1453 : && sym->attr.flavor == FL_VARIABLE
18885 612 : && !sym->attr.save
18886 199 : && !(sym->ns->save_all && !sym->attr.automatic)
18887 199 : && (!sym->attr.in_common
18888 186 : && sym->module == NULL
18889 96 : && (sym->ns->proc_name == NULL
18890 96 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18891 6 : && !sym->ns->proc_name->attr.is_main_program))))
18892 4 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
18893 : sym->name, &sym->declared_at);
18894 :
18895 : /* If we have come this far we can apply default-initializers, as
18896 : described in 14.7.5, to those variables that have not already
18897 : been assigned one. */
18898 1655687 : if (sym->ts.type == BT_DERIVED
18899 129564 : && !sym->value
18900 104740 : && !sym->attr.allocatable
18901 101794 : && !sym->attr.alloc_comp)
18902 : {
18903 101736 : symbol_attribute *a = &sym->attr;
18904 :
18905 101736 : if ((!a->save && !a->dummy && !a->pointer
18906 55721 : && !a->in_common && !a->use_assoc
18907 10234 : && a->referenced
18908 8008 : && !((a->function || a->result)
18909 1572 : && (!a->dimension
18910 136 : || sym->ts.u.derived->attr.alloc_comp
18911 95 : || sym->ts.u.derived->attr.pointer_comp))
18912 6517 : && !(a->function && sym != sym->result))
18913 95239 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
18914 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
18915 7926 : apply_default_init (sym);
18916 93810 : else if (a->function && !a->pointer && !a->allocatable
18917 20325 : && !a->use_assoc && !a->used_in_submodule && sym->result)
18918 : /* Default initialization for function results. */
18919 2638 : apply_default_init (sym->result);
18920 91172 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
18921 11637 : && (sym->ts.u.derived->attr.alloc_comp
18922 11126 : || sym->ts.u.derived->attr.pointer_comp))
18923 : /* Mark the result symbol to be referenced, when it has allocatable
18924 : components. */
18925 570 : sym->result->attr.referenced = 1;
18926 : }
18927 :
18928 1655687 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
18929 18670 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
18930 1226 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
18931 1151 : && !CLASS_DATA (sym)->attr.class_pointer
18932 1125 : && !CLASS_DATA (sym)->attr.allocatable)
18933 853 : apply_default_init (sym);
18934 :
18935 : /* If this symbol has a type-spec, check it. */
18936 1655687 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
18937 628658 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
18938 1344134 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
18939 : return;
18940 :
18941 1655684 : if (sym->param_list)
18942 1376 : resolve_pdt (sym);
18943 : }
18944 :
18945 :
18946 3939 : void gfc_resolve_symbol (gfc_symbol *sym)
18947 : {
18948 3939 : resolve_symbol (sym);
18949 3939 : return;
18950 : }
18951 :
18952 :
18953 : /************* Resolve DATA statements *************/
18954 :
18955 : static struct
18956 : {
18957 : gfc_data_value *vnode;
18958 : mpz_t left;
18959 : }
18960 : values;
18961 :
18962 :
18963 : /* Advance the values structure to point to the next value in the data list. */
18964 :
18965 : static bool
18966 10892 : next_data_value (void)
18967 : {
18968 16660 : while (mpz_cmp_ui (values.left, 0) == 0)
18969 : {
18970 :
18971 8198 : if (values.vnode->next == NULL)
18972 : return false;
18973 :
18974 5768 : values.vnode = values.vnode->next;
18975 5768 : mpz_set (values.left, values.vnode->repeat);
18976 : }
18977 :
18978 : return true;
18979 : }
18980 :
18981 :
18982 : static bool
18983 3557 : check_data_variable (gfc_data_variable *var, locus *where)
18984 : {
18985 3557 : gfc_expr *e;
18986 3557 : mpz_t size;
18987 3557 : mpz_t offset;
18988 3557 : bool t;
18989 3557 : ar_type mark = AR_UNKNOWN;
18990 3557 : int i;
18991 3557 : mpz_t section_index[GFC_MAX_DIMENSIONS];
18992 3557 : int vector_offset[GFC_MAX_DIMENSIONS];
18993 3557 : gfc_ref *ref;
18994 3557 : gfc_array_ref *ar;
18995 3557 : gfc_symbol *sym;
18996 3557 : int has_pointer;
18997 :
18998 3557 : if (!gfc_resolve_expr (var->expr))
18999 : return false;
19000 :
19001 3557 : ar = NULL;
19002 3557 : e = var->expr;
19003 :
19004 3557 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
19005 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
19006 0 : e = e->value.function.actual->expr;
19007 :
19008 3557 : if (e->expr_type != EXPR_VARIABLE)
19009 : {
19010 0 : gfc_error ("Expecting definable entity near %L", where);
19011 0 : return false;
19012 : }
19013 :
19014 3557 : sym = e->symtree->n.sym;
19015 :
19016 3557 : if (sym->ns->is_block_data && !sym->attr.in_common)
19017 : {
19018 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
19019 : sym->name, &sym->declared_at);
19020 2 : return false;
19021 : }
19022 :
19023 3555 : if (e->ref == NULL && sym->as)
19024 : {
19025 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
19026 : " declaration", sym->name, where);
19027 1 : return false;
19028 : }
19029 :
19030 3554 : if (gfc_is_coindexed (e))
19031 : {
19032 7 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
19033 : where);
19034 7 : return false;
19035 : }
19036 :
19037 3547 : has_pointer = sym->attr.pointer;
19038 :
19039 5988 : for (ref = e->ref; ref; ref = ref->next)
19040 : {
19041 2445 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
19042 : has_pointer = 1;
19043 :
19044 2419 : if (has_pointer)
19045 : {
19046 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
19047 : {
19048 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
19049 : "be a full array", sym->name, where);
19050 1 : return false;
19051 : }
19052 :
19053 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
19054 : {
19055 1 : gfc_error ("DATA object near %L has the pointer attribute "
19056 : "and the corresponding DATA value is not a valid "
19057 : "initial-data-target", where);
19058 1 : return false;
19059 : }
19060 : }
19061 :
19062 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
19063 : {
19064 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
19065 : "attribute", ref->u.c.component->name, &e->where);
19066 1 : return false;
19067 : }
19068 :
19069 : /* Reject substrings of strings of non-constant length. */
19070 2442 : if (ref->type == REF_SUBSTRING
19071 73 : && ref->u.ss.length
19072 73 : && ref->u.ss.length->length
19073 2515 : && !gfc_is_constant_expr (ref->u.ss.length->length))
19074 1 : goto bad_charlen;
19075 : }
19076 :
19077 : /* Reject strings with deferred length or non-constant length. */
19078 3543 : if (e->ts.type == BT_CHARACTER
19079 3543 : && (e->ts.deferred
19080 374 : || (e->ts.u.cl->length
19081 323 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
19082 5 : goto bad_charlen;
19083 :
19084 3538 : mpz_init_set_si (offset, 0);
19085 :
19086 3538 : if (e->rank == 0 || has_pointer)
19087 : {
19088 2691 : mpz_init_set_ui (size, 1);
19089 2691 : ref = NULL;
19090 : }
19091 : else
19092 : {
19093 847 : ref = e->ref;
19094 :
19095 : /* Find the array section reference. */
19096 1030 : for (ref = e->ref; ref; ref = ref->next)
19097 : {
19098 1030 : if (ref->type != REF_ARRAY)
19099 92 : continue;
19100 938 : if (ref->u.ar.type == AR_ELEMENT)
19101 91 : continue;
19102 : break;
19103 : }
19104 847 : gcc_assert (ref);
19105 :
19106 : /* Set marks according to the reference pattern. */
19107 847 : switch (ref->u.ar.type)
19108 : {
19109 : case AR_FULL:
19110 : mark = AR_FULL;
19111 : break;
19112 :
19113 151 : case AR_SECTION:
19114 151 : ar = &ref->u.ar;
19115 : /* Get the start position of array section. */
19116 151 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
19117 151 : mark = AR_SECTION;
19118 151 : break;
19119 :
19120 0 : default:
19121 0 : gcc_unreachable ();
19122 : }
19123 :
19124 847 : if (!gfc_array_size (e, &size))
19125 : {
19126 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
19127 : where);
19128 1 : mpz_clear (offset);
19129 1 : return false;
19130 : }
19131 : }
19132 :
19133 3537 : t = true;
19134 :
19135 11937 : while (mpz_cmp_ui (size, 0) > 0)
19136 : {
19137 8463 : if (!next_data_value ())
19138 : {
19139 1 : gfc_error ("DATA statement at %L has more variables than values",
19140 : where);
19141 1 : t = false;
19142 1 : break;
19143 : }
19144 :
19145 8462 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
19146 8462 : if (!t)
19147 : break;
19148 :
19149 : /* If we have more than one element left in the repeat count,
19150 : and we have more than one element left in the target variable,
19151 : then create a range assignment. */
19152 : /* FIXME: Only done for full arrays for now, since array sections
19153 : seem tricky. */
19154 8443 : if (mark == AR_FULL && ref && ref->next == NULL
19155 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
19156 : {
19157 137 : mpz_t range;
19158 :
19159 137 : if (mpz_cmp (size, values.left) >= 0)
19160 : {
19161 126 : mpz_init_set (range, values.left);
19162 126 : mpz_sub (size, size, values.left);
19163 126 : mpz_set_ui (values.left, 0);
19164 : }
19165 : else
19166 : {
19167 11 : mpz_init_set (range, size);
19168 11 : mpz_sub (values.left, values.left, size);
19169 11 : mpz_set_ui (size, 0);
19170 : }
19171 :
19172 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19173 : offset, &range);
19174 :
19175 137 : mpz_add (offset, offset, range);
19176 137 : mpz_clear (range);
19177 :
19178 137 : if (!t)
19179 : break;
19180 129 : }
19181 :
19182 : /* Assign initial value to symbol. */
19183 : else
19184 : {
19185 8306 : mpz_sub_ui (values.left, values.left, 1);
19186 8306 : mpz_sub_ui (size, size, 1);
19187 :
19188 8306 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19189 : offset, NULL);
19190 8306 : if (!t)
19191 : break;
19192 :
19193 8271 : if (mark == AR_FULL)
19194 5259 : mpz_add_ui (offset, offset, 1);
19195 :
19196 : /* Modify the array section indexes and recalculate the offset
19197 : for next element. */
19198 3012 : else if (mark == AR_SECTION)
19199 366 : gfc_advance_section (section_index, ar, &offset, vector_offset);
19200 : }
19201 : }
19202 :
19203 3537 : if (mark == AR_SECTION)
19204 : {
19205 344 : for (i = 0; i < ar->dimen; i++)
19206 194 : mpz_clear (section_index[i]);
19207 : }
19208 :
19209 3537 : mpz_clear (size);
19210 3537 : mpz_clear (offset);
19211 :
19212 3537 : return t;
19213 :
19214 6 : bad_charlen:
19215 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19216 : &e->where);
19217 6 : return false;
19218 : }
19219 :
19220 :
19221 : static bool traverse_data_var (gfc_data_variable *, locus *);
19222 :
19223 : /* Iterate over a list of elements in a DATA statement. */
19224 :
19225 : static bool
19226 237 : traverse_data_list (gfc_data_variable *var, locus *where)
19227 : {
19228 237 : mpz_t trip;
19229 237 : iterator_stack frame;
19230 237 : gfc_expr *e, *start, *end, *step;
19231 237 : bool retval = true;
19232 :
19233 237 : mpz_init (frame.value);
19234 237 : mpz_init (trip);
19235 :
19236 237 : start = gfc_copy_expr (var->iter.start);
19237 237 : end = gfc_copy_expr (var->iter.end);
19238 237 : step = gfc_copy_expr (var->iter.step);
19239 :
19240 237 : if (!gfc_simplify_expr (start, 1)
19241 237 : || start->expr_type != EXPR_CONSTANT)
19242 : {
19243 0 : gfc_error ("start of implied-do loop at %L could not be "
19244 : "simplified to a constant value", &start->where);
19245 0 : retval = false;
19246 0 : goto cleanup;
19247 : }
19248 237 : if (!gfc_simplify_expr (end, 1)
19249 237 : || end->expr_type != EXPR_CONSTANT)
19250 : {
19251 0 : gfc_error ("end of implied-do loop at %L could not be "
19252 : "simplified to a constant value", &end->where);
19253 0 : retval = false;
19254 0 : goto cleanup;
19255 : }
19256 237 : if (!gfc_simplify_expr (step, 1)
19257 237 : || step->expr_type != EXPR_CONSTANT)
19258 : {
19259 0 : gfc_error ("step of implied-do loop at %L could not be "
19260 : "simplified to a constant value", &step->where);
19261 0 : retval = false;
19262 0 : goto cleanup;
19263 : }
19264 237 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19265 : {
19266 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19267 : &step->where);
19268 1 : retval = false;
19269 1 : goto cleanup;
19270 : }
19271 :
19272 236 : mpz_set (trip, end->value.integer);
19273 236 : mpz_sub (trip, trip, start->value.integer);
19274 236 : mpz_add (trip, trip, step->value.integer);
19275 :
19276 236 : mpz_div (trip, trip, step->value.integer);
19277 :
19278 236 : mpz_set (frame.value, start->value.integer);
19279 :
19280 236 : frame.prev = iter_stack;
19281 236 : frame.variable = var->iter.var->symtree;
19282 236 : iter_stack = &frame;
19283 :
19284 1127 : while (mpz_cmp_ui (trip, 0) > 0)
19285 : {
19286 905 : if (!traverse_data_var (var->list, where))
19287 : {
19288 14 : retval = false;
19289 14 : goto cleanup;
19290 : }
19291 :
19292 891 : e = gfc_copy_expr (var->expr);
19293 891 : if (!gfc_simplify_expr (e, 1))
19294 : {
19295 0 : gfc_free_expr (e);
19296 0 : retval = false;
19297 0 : goto cleanup;
19298 : }
19299 :
19300 891 : mpz_add (frame.value, frame.value, step->value.integer);
19301 :
19302 891 : mpz_sub_ui (trip, trip, 1);
19303 : }
19304 :
19305 222 : cleanup:
19306 237 : mpz_clear (frame.value);
19307 237 : mpz_clear (trip);
19308 :
19309 237 : gfc_free_expr (start);
19310 237 : gfc_free_expr (end);
19311 237 : gfc_free_expr (step);
19312 :
19313 237 : iter_stack = frame.prev;
19314 237 : return retval;
19315 : }
19316 :
19317 :
19318 : /* Type resolve variables in the variable list of a DATA statement. */
19319 :
19320 : static bool
19321 3418 : traverse_data_var (gfc_data_variable *var, locus *where)
19322 : {
19323 3418 : bool t;
19324 :
19325 7114 : for (; var; var = var->next)
19326 : {
19327 3794 : if (var->expr == NULL)
19328 237 : t = traverse_data_list (var, where);
19329 : else
19330 3557 : t = check_data_variable (var, where);
19331 :
19332 3794 : if (!t)
19333 : return false;
19334 : }
19335 :
19336 : return true;
19337 : }
19338 :
19339 :
19340 : /* Resolve the expressions and iterators associated with a data statement.
19341 : This is separate from the assignment checking because data lists should
19342 : only be resolved once. */
19343 :
19344 : static bool
19345 2668 : resolve_data_variables (gfc_data_variable *d)
19346 : {
19347 5707 : for (; d; d = d->next)
19348 : {
19349 3044 : if (d->list == NULL)
19350 : {
19351 2891 : if (!gfc_resolve_expr (d->expr))
19352 : return false;
19353 : }
19354 : else
19355 : {
19356 153 : if (!gfc_resolve_iterator (&d->iter, false, true))
19357 : return false;
19358 :
19359 150 : if (!resolve_data_variables (d->list))
19360 : return false;
19361 : }
19362 : }
19363 :
19364 : return true;
19365 : }
19366 :
19367 :
19368 : /* Resolve a single DATA statement. We implement this by storing a pointer to
19369 : the value list into static variables, and then recursively traversing the
19370 : variables list, expanding iterators and such. */
19371 :
19372 : static void
19373 2518 : resolve_data (gfc_data *d)
19374 : {
19375 :
19376 2518 : if (!resolve_data_variables (d->var))
19377 : return;
19378 :
19379 2513 : values.vnode = d->value;
19380 2513 : if (d->value == NULL)
19381 0 : mpz_set_ui (values.left, 0);
19382 : else
19383 2513 : mpz_set (values.left, d->value->repeat);
19384 :
19385 2513 : if (!traverse_data_var (d->var, &d->where))
19386 : return;
19387 :
19388 : /* At this point, we better not have any values left. */
19389 :
19390 2429 : if (next_data_value ())
19391 0 : gfc_error ("DATA statement at %L has more values than variables",
19392 : &d->where);
19393 : }
19394 :
19395 :
19396 : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
19397 : accessed by host or use association, is a dummy argument to a pure function,
19398 : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
19399 : is storage associated with any such variable, shall not be used in the
19400 : following contexts: (clients of this function). */
19401 :
19402 : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
19403 : procedure. Returns zero if assignment is OK, nonzero if there is a
19404 : problem. */
19405 : bool
19406 55093 : gfc_impure_variable (gfc_symbol *sym)
19407 : {
19408 55093 : gfc_symbol *proc;
19409 55093 : gfc_namespace *ns;
19410 :
19411 55093 : if (sym->attr.use_assoc || sym->attr.in_common)
19412 : return 1;
19413 :
19414 : /* The namespace of a module procedure interface holds the arguments and
19415 : symbols, and so the symbol namespace can be different to that of the
19416 : procedure. */
19417 54475 : if (sym->ns != gfc_current_ns
19418 5847 : && gfc_current_ns->proc_name->abr_modproc_decl
19419 48 : && sym->ns->proc_name->attr.function
19420 12 : && sym->attr.result
19421 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
19422 : return 0;
19423 :
19424 : /* Check if the symbol's ns is inside the pure procedure. */
19425 59116 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19426 : {
19427 58825 : if (ns == sym->ns)
19428 : break;
19429 6153 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
19430 5091 : && !(sym->attr.function || sym->attr.result))
19431 : return 1;
19432 : }
19433 :
19434 52963 : proc = sym->ns->proc_name;
19435 52963 : if (sym->attr.dummy
19436 5846 : && !sym->attr.value
19437 5724 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
19438 5521 : || proc->attr.function))
19439 691 : return 1;
19440 :
19441 : /* TODO: Sort out what can be storage associated, if anything, and include
19442 : it here. In principle equivalences should be scanned but it does not
19443 : seem to be possible to storage associate an impure variable this way. */
19444 : return 0;
19445 : }
19446 :
19447 :
19448 : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
19449 : current namespace is inside a pure procedure. */
19450 :
19451 : bool
19452 2299872 : gfc_pure (gfc_symbol *sym)
19453 : {
19454 2299872 : symbol_attribute attr;
19455 2299872 : gfc_namespace *ns;
19456 :
19457 2299872 : if (sym == NULL)
19458 : {
19459 : /* Check if the current namespace or one of its parents
19460 : belongs to a pure procedure. */
19461 3154321 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19462 : {
19463 1862624 : sym = ns->proc_name;
19464 1862624 : if (sym == NULL)
19465 : return 0;
19466 1861486 : attr = sym->attr;
19467 1861486 : if (attr.flavor == FL_PROCEDURE && attr.pure)
19468 : return 1;
19469 : }
19470 : return 0;
19471 : }
19472 :
19473 999868 : attr = sym->attr;
19474 :
19475 999868 : return attr.flavor == FL_PROCEDURE && attr.pure;
19476 : }
19477 :
19478 :
19479 : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
19480 : checks if the current namespace is implicitly pure. Note that this
19481 : function returns false for a PURE procedure. */
19482 :
19483 : bool
19484 719915 : gfc_implicit_pure (gfc_symbol *sym)
19485 : {
19486 719915 : gfc_namespace *ns;
19487 :
19488 719915 : if (sym == NULL)
19489 : {
19490 : /* Check if the current procedure is implicit_pure. Walk up
19491 : the procedure list until we find a procedure. */
19492 991950 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19493 : {
19494 708002 : sym = ns->proc_name;
19495 708002 : if (sym == NULL)
19496 : return 0;
19497 :
19498 707929 : if (sym->attr.flavor == FL_PROCEDURE)
19499 : break;
19500 : }
19501 : }
19502 :
19503 435891 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
19504 746806 : && !sym->attr.pure;
19505 : }
19506 :
19507 :
19508 : void
19509 421391 : gfc_unset_implicit_pure (gfc_symbol *sym)
19510 : {
19511 421391 : gfc_namespace *ns;
19512 :
19513 421391 : if (sym == NULL)
19514 : {
19515 : /* Check if the current procedure is implicit_pure. Walk up
19516 : the procedure list until we find a procedure. */
19517 688820 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19518 : {
19519 425940 : sym = ns->proc_name;
19520 425940 : if (sym == NULL)
19521 : return;
19522 :
19523 425110 : if (sym->attr.flavor == FL_PROCEDURE)
19524 : break;
19525 : }
19526 : }
19527 :
19528 420561 : if (sym->attr.flavor == FL_PROCEDURE)
19529 149525 : sym->attr.implicit_pure = 0;
19530 : else
19531 271036 : sym->attr.pure = 0;
19532 : }
19533 :
19534 :
19535 : /* Test whether the current procedure is elemental or not. */
19536 :
19537 : bool
19538 1341022 : gfc_elemental (gfc_symbol *sym)
19539 : {
19540 1341022 : symbol_attribute attr;
19541 :
19542 1341022 : if (sym == NULL)
19543 0 : sym = gfc_current_ns->proc_name;
19544 0 : if (sym == NULL)
19545 : return 0;
19546 1341022 : attr = sym->attr;
19547 :
19548 1341022 : return attr.flavor == FL_PROCEDURE && attr.elemental;
19549 : }
19550 :
19551 :
19552 : /* Warn about unused labels. */
19553 :
19554 : static void
19555 4656 : warn_unused_fortran_label (gfc_st_label *label)
19556 : {
19557 4682 : if (label == NULL)
19558 : return;
19559 :
19560 27 : warn_unused_fortran_label (label->left);
19561 :
19562 27 : if (label->defined == ST_LABEL_UNKNOWN)
19563 : return;
19564 :
19565 26 : switch (label->referenced)
19566 : {
19567 2 : case ST_LABEL_UNKNOWN:
19568 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
19569 : label->value, &label->where);
19570 2 : break;
19571 :
19572 1 : case ST_LABEL_BAD_TARGET:
19573 1 : gfc_warning (OPT_Wunused_label,
19574 : "Label %d at %L defined but cannot be used",
19575 : label->value, &label->where);
19576 1 : break;
19577 :
19578 : default:
19579 : break;
19580 : }
19581 :
19582 26 : warn_unused_fortran_label (label->right);
19583 : }
19584 :
19585 :
19586 : /* Returns the sequence type of a symbol or sequence. */
19587 :
19588 : static seq_type
19589 1076 : sequence_type (gfc_typespec ts)
19590 : {
19591 1076 : seq_type result;
19592 1076 : gfc_component *c;
19593 :
19594 1076 : switch (ts.type)
19595 : {
19596 49 : case BT_DERIVED:
19597 :
19598 49 : if (ts.u.derived->components == NULL)
19599 : return SEQ_NONDEFAULT;
19600 :
19601 49 : result = sequence_type (ts.u.derived->components->ts);
19602 103 : for (c = ts.u.derived->components->next; c; c = c->next)
19603 67 : if (sequence_type (c->ts) != result)
19604 : return SEQ_MIXED;
19605 :
19606 : return result;
19607 :
19608 129 : case BT_CHARACTER:
19609 129 : if (ts.kind != gfc_default_character_kind)
19610 0 : return SEQ_NONDEFAULT;
19611 :
19612 : return SEQ_CHARACTER;
19613 :
19614 240 : case BT_INTEGER:
19615 240 : if (ts.kind != gfc_default_integer_kind)
19616 25 : return SEQ_NONDEFAULT;
19617 :
19618 : return SEQ_NUMERIC;
19619 :
19620 559 : case BT_REAL:
19621 559 : if (!(ts.kind == gfc_default_real_kind
19622 269 : || ts.kind == gfc_default_double_kind))
19623 0 : return SEQ_NONDEFAULT;
19624 :
19625 : return SEQ_NUMERIC;
19626 :
19627 81 : case BT_COMPLEX:
19628 81 : if (ts.kind != gfc_default_complex_kind)
19629 48 : return SEQ_NONDEFAULT;
19630 :
19631 : return SEQ_NUMERIC;
19632 :
19633 17 : case BT_LOGICAL:
19634 17 : if (ts.kind != gfc_default_logical_kind)
19635 0 : return SEQ_NONDEFAULT;
19636 :
19637 : return SEQ_NUMERIC;
19638 :
19639 : default:
19640 : return SEQ_NONDEFAULT;
19641 : }
19642 : }
19643 :
19644 :
19645 : /* Resolve derived type EQUIVALENCE object. */
19646 :
19647 : static bool
19648 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
19649 : {
19650 80 : gfc_component *c = derived->components;
19651 :
19652 80 : if (!derived)
19653 : return true;
19654 :
19655 : /* Shall not be an object of nonsequence derived type. */
19656 80 : if (!derived->attr.sequence)
19657 : {
19658 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
19659 : "attribute to be an EQUIVALENCE object", sym->name,
19660 : &e->where);
19661 0 : return false;
19662 : }
19663 :
19664 : /* Shall not have allocatable components. */
19665 80 : if (derived->attr.alloc_comp)
19666 : {
19667 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
19668 : "components to be an EQUIVALENCE object",sym->name,
19669 : &e->where);
19670 1 : return false;
19671 : }
19672 :
19673 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
19674 : {
19675 1 : gfc_error ("Derived type variable %qs at %L with default "
19676 : "initialization cannot be in EQUIVALENCE with a variable "
19677 : "in COMMON", sym->name, &e->where);
19678 1 : return false;
19679 : }
19680 :
19681 245 : for (; c ; c = c->next)
19682 : {
19683 167 : if (gfc_bt_struct (c->ts.type)
19684 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
19685 : return false;
19686 :
19687 : /* Shall not be an object of sequence derived type containing a pointer
19688 : in the structure. */
19689 167 : if (c->attr.pointer)
19690 : {
19691 0 : gfc_error ("Derived type variable %qs at %L with pointer "
19692 : "component(s) cannot be an EQUIVALENCE object",
19693 : sym->name, &e->where);
19694 0 : return false;
19695 : }
19696 : }
19697 : return true;
19698 : }
19699 :
19700 :
19701 : /* Resolve equivalence object.
19702 : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
19703 : an allocatable array, an object of nonsequence derived type, an object of
19704 : sequence derived type containing a pointer at any level of component
19705 : selection, an automatic object, a function name, an entry name, a result
19706 : name, a named constant, a structure component, or a subobject of any of
19707 : the preceding objects. A substring shall not have length zero. A
19708 : derived type shall not have components with default initialization nor
19709 : shall two objects of an equivalence group be initialized.
19710 : Either all or none of the objects shall have an protected attribute.
19711 : The simple constraints are done in symbol.cc(check_conflict) and the rest
19712 : are implemented here. */
19713 :
19714 : static void
19715 1565 : resolve_equivalence (gfc_equiv *eq)
19716 : {
19717 1565 : gfc_symbol *sym;
19718 1565 : gfc_symbol *first_sym;
19719 1565 : gfc_expr *e;
19720 1565 : gfc_ref *r;
19721 1565 : locus *last_where = NULL;
19722 1565 : seq_type eq_type, last_eq_type;
19723 1565 : gfc_typespec *last_ts;
19724 1565 : int object, cnt_protected;
19725 1565 : const char *msg;
19726 :
19727 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
19728 :
19729 1565 : first_sym = eq->expr->symtree->n.sym;
19730 :
19731 1565 : cnt_protected = 0;
19732 :
19733 4727 : for (object = 1; eq; eq = eq->eq, object++)
19734 : {
19735 3171 : e = eq->expr;
19736 :
19737 3171 : e->ts = e->symtree->n.sym->ts;
19738 : /* match_varspec might not know yet if it is seeing
19739 : array reference or substring reference, as it doesn't
19740 : know the types. */
19741 3171 : if (e->ref && e->ref->type == REF_ARRAY)
19742 : {
19743 2152 : gfc_ref *ref = e->ref;
19744 2152 : sym = e->symtree->n.sym;
19745 :
19746 2152 : if (sym->attr.dimension)
19747 : {
19748 1855 : ref->u.ar.as = sym->as;
19749 1855 : ref = ref->next;
19750 : }
19751 :
19752 : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
19753 2152 : if (e->ts.type == BT_CHARACTER
19754 592 : && ref
19755 371 : && ref->type == REF_ARRAY
19756 371 : && ref->u.ar.dimen == 1
19757 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
19758 371 : && ref->u.ar.stride[0] == NULL)
19759 : {
19760 370 : gfc_expr *start = ref->u.ar.start[0];
19761 370 : gfc_expr *end = ref->u.ar.end[0];
19762 370 : void *mem = NULL;
19763 :
19764 : /* Optimize away the (:) reference. */
19765 370 : if (start == NULL && end == NULL)
19766 : {
19767 9 : if (e->ref == ref)
19768 0 : e->ref = ref->next;
19769 : else
19770 9 : e->ref->next = ref->next;
19771 : mem = ref;
19772 : }
19773 : else
19774 : {
19775 361 : ref->type = REF_SUBSTRING;
19776 361 : if (start == NULL)
19777 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
19778 : NULL, 1);
19779 361 : ref->u.ss.start = start;
19780 361 : if (end == NULL && e->ts.u.cl)
19781 27 : end = gfc_copy_expr (e->ts.u.cl->length);
19782 361 : ref->u.ss.end = end;
19783 361 : ref->u.ss.length = e->ts.u.cl;
19784 361 : e->ts.u.cl = NULL;
19785 : }
19786 370 : ref = ref->next;
19787 370 : free (mem);
19788 : }
19789 :
19790 : /* Any further ref is an error. */
19791 1930 : if (ref)
19792 : {
19793 1 : gcc_assert (ref->type == REF_ARRAY);
19794 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
19795 : &ref->u.ar.where);
19796 1 : continue;
19797 : }
19798 : }
19799 :
19800 3170 : if (!gfc_resolve_expr (e))
19801 2 : continue;
19802 :
19803 3168 : sym = e->symtree->n.sym;
19804 :
19805 3168 : if (sym->attr.is_protected)
19806 2 : cnt_protected++;
19807 3168 : if (cnt_protected > 0 && cnt_protected != object)
19808 : {
19809 2 : gfc_error ("Either all or none of the objects in the "
19810 : "EQUIVALENCE set at %L shall have the "
19811 : "PROTECTED attribute",
19812 : &e->where);
19813 2 : break;
19814 : }
19815 :
19816 : /* Shall not equivalence common block variables in a PURE procedure. */
19817 3166 : if (sym->ns->proc_name
19818 3150 : && sym->ns->proc_name->attr.pure
19819 7 : && sym->attr.in_common)
19820 : {
19821 : /* Need to check for symbols that may have entered the pure
19822 : procedure via a USE statement. */
19823 7 : bool saw_sym = false;
19824 7 : if (sym->ns->use_stmts)
19825 : {
19826 6 : gfc_use_rename *r;
19827 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
19828 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
19829 : }
19830 : else
19831 : saw_sym = true;
19832 :
19833 6 : if (saw_sym)
19834 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
19835 : "EQUIVALENCE object in the pure procedure %qs",
19836 : sym->name, &e->where, sym->ns->proc_name->name);
19837 : break;
19838 : }
19839 :
19840 : /* Shall not be a named constant. */
19841 3159 : if (e->expr_type == EXPR_CONSTANT)
19842 : {
19843 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
19844 : "object", sym->name, &e->where);
19845 0 : continue;
19846 : }
19847 :
19848 3161 : if (e->ts.type == BT_DERIVED
19849 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
19850 2 : continue;
19851 :
19852 : /* Check that the types correspond correctly:
19853 : Note 5.28:
19854 : A numeric sequence structure may be equivalenced to another sequence
19855 : structure, an object of default integer type, default real type, double
19856 : precision real type, default logical type such that components of the
19857 : structure ultimately only become associated to objects of the same
19858 : kind. A character sequence structure may be equivalenced to an object
19859 : of default character kind or another character sequence structure.
19860 : Other objects may be equivalenced only to objects of the same type and
19861 : kind parameters. */
19862 :
19863 : /* Identical types are unconditionally OK. */
19864 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
19865 2677 : goto identical_types;
19866 :
19867 480 : last_eq_type = sequence_type (*last_ts);
19868 480 : eq_type = sequence_type (sym->ts);
19869 :
19870 : /* Since the pair of objects is not of the same type, mixed or
19871 : non-default sequences can be rejected. */
19872 :
19873 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
19874 : "statement at %L with different type objects");
19875 481 : if ((object ==2
19876 480 : && last_eq_type == SEQ_MIXED
19877 7 : && last_where
19878 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19879 486 : || (eq_type == SEQ_MIXED
19880 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19881 1 : continue;
19882 :
19883 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
19884 : "statement at %L with objects of different type");
19885 483 : if ((object ==2
19886 479 : && last_eq_type == SEQ_NONDEFAULT
19887 50 : && last_where
19888 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19889 525 : || (eq_type == SEQ_NONDEFAULT
19890 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19891 4 : continue;
19892 :
19893 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
19894 : "EQUIVALENCE statement at %L");
19895 479 : if (last_eq_type == SEQ_CHARACTER
19896 475 : && eq_type != SEQ_CHARACTER
19897 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19898 4 : continue;
19899 :
19900 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
19901 : "EQUIVALENCE statement at %L");
19902 473 : if (last_eq_type == SEQ_NUMERIC
19903 471 : && eq_type != SEQ_NUMERIC
19904 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19905 2 : continue;
19906 :
19907 3146 : identical_types:
19908 :
19909 3146 : last_ts =&sym->ts;
19910 3146 : last_where = &e->where;
19911 :
19912 3146 : if (!e->ref)
19913 1003 : continue;
19914 :
19915 : /* Shall not be an automatic array. */
19916 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
19917 : {
19918 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
19919 : "an EQUIVALENCE object", sym->name, &e->where);
19920 3 : continue;
19921 : }
19922 :
19923 2140 : r = e->ref;
19924 4326 : while (r)
19925 : {
19926 : /* Shall not be a structure component. */
19927 2187 : if (r->type == REF_COMPONENT)
19928 : {
19929 0 : gfc_error ("Structure component %qs at %L cannot be an "
19930 : "EQUIVALENCE object",
19931 0 : r->u.c.component->name, &e->where);
19932 0 : break;
19933 : }
19934 :
19935 : /* A substring shall not have length zero. */
19936 2187 : if (r->type == REF_SUBSTRING)
19937 : {
19938 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
19939 : {
19940 1 : gfc_error ("Substring at %L has length zero",
19941 : &r->u.ss.start->where);
19942 1 : break;
19943 : }
19944 : }
19945 2186 : r = r->next;
19946 : }
19947 : }
19948 1565 : }
19949 :
19950 :
19951 : /* Function called by resolve_fntype to flag other symbols used in the
19952 : length type parameter specification of function results. */
19953 :
19954 : static bool
19955 4136 : flag_fn_result_spec (gfc_expr *expr,
19956 : gfc_symbol *sym,
19957 : int *f ATTRIBUTE_UNUSED)
19958 : {
19959 4136 : gfc_namespace *ns;
19960 4136 : gfc_symbol *s;
19961 :
19962 4136 : if (expr->expr_type == EXPR_VARIABLE)
19963 : {
19964 1378 : s = expr->symtree->n.sym;
19965 2153 : for (ns = s->ns; ns; ns = ns->parent)
19966 2153 : if (!ns->parent)
19967 : break;
19968 :
19969 1378 : if (sym == s)
19970 : {
19971 1 : gfc_error ("Self reference in character length expression "
19972 : "for %qs at %L", sym->name, &expr->where);
19973 1 : return true;
19974 : }
19975 :
19976 1377 : if (!s->fn_result_spec
19977 1377 : && s->attr.flavor == FL_PARAMETER)
19978 : {
19979 : /* Function contained in a module.... */
19980 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
19981 : {
19982 32 : gfc_symtree *st;
19983 32 : s->fn_result_spec = 1;
19984 : /* Make sure that this symbol is translated as a module
19985 : variable. */
19986 32 : st = gfc_get_unique_symtree (ns);
19987 32 : st->n.sym = s;
19988 32 : s->refs++;
19989 32 : }
19990 : /* ... which is use associated and called. */
19991 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
19992 0 : ||
19993 : /* External function matched with an interface. */
19994 0 : (s->ns->proc_name
19995 0 : && ((s->ns == ns
19996 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
19997 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
19998 0 : && s->ns->proc_name->attr.function))
19999 31 : s->fn_result_spec = 1;
20000 : }
20001 : }
20002 : return false;
20003 : }
20004 :
20005 :
20006 : /* Resolve function and ENTRY types, issue diagnostics if needed. */
20007 :
20008 : static void
20009 342255 : resolve_fntype (gfc_namespace *ns)
20010 : {
20011 342255 : gfc_entry_list *el;
20012 342255 : gfc_symbol *sym;
20013 :
20014 342255 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
20015 : return;
20016 :
20017 : /* If there are any entries, ns->proc_name is the entry master
20018 : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
20019 178331 : if (ns->entries)
20020 566 : sym = ns->entries->sym;
20021 : else
20022 : sym = ns->proc_name;
20023 178331 : if (sym->result == sym
20024 143303 : && sym->ts.type == BT_UNKNOWN
20025 6 : && !gfc_set_default_type (sym, 0, NULL)
20026 178335 : && !sym->attr.untyped)
20027 : {
20028 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
20029 : sym->name, &sym->declared_at);
20030 3 : sym->attr.untyped = 1;
20031 : }
20032 :
20033 13564 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
20034 1789 : && !sym->attr.contained
20035 299 : && !gfc_check_symbol_access (sym->ts.u.derived)
20036 178331 : && gfc_check_symbol_access (sym))
20037 : {
20038 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
20039 : "%L of PRIVATE type %qs", sym->name,
20040 0 : &sym->declared_at, sym->ts.u.derived->name);
20041 : }
20042 :
20043 178331 : if (ns->entries)
20044 1193 : for (el = ns->entries->next; el; el = el->next)
20045 : {
20046 627 : if (el->sym->result == el->sym
20047 415 : && el->sym->ts.type == BT_UNKNOWN
20048 2 : && !gfc_set_default_type (el->sym, 0, NULL)
20049 629 : && !el->sym->attr.untyped)
20050 : {
20051 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
20052 : el->sym->name, &el->sym->declared_at);
20053 2 : el->sym->attr.untyped = 1;
20054 : }
20055 : }
20056 :
20057 178331 : if (sym->ts.type == BT_CHARACTER
20058 6876 : && sym->ts.u.cl->length
20059 1788 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
20060 1783 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
20061 : }
20062 :
20063 :
20064 : /* 12.3.2.1.1 Defined operators. */
20065 :
20066 : static bool
20067 452 : check_uop_procedure (gfc_symbol *sym, locus where)
20068 : {
20069 452 : gfc_formal_arglist *formal;
20070 :
20071 452 : if (!sym->attr.function)
20072 : {
20073 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
20074 : sym->name, &where);
20075 4 : return false;
20076 : }
20077 :
20078 448 : if (sym->ts.type == BT_CHARACTER
20079 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
20080 2 : && !(sym->result && ((sym->result->ts.u.cl
20081 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
20082 : {
20083 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
20084 : "character length", sym->name, &where);
20085 2 : return false;
20086 : }
20087 :
20088 446 : formal = gfc_sym_get_dummy_args (sym);
20089 446 : if (!formal || !formal->sym)
20090 : {
20091 1 : gfc_error ("User operator procedure %qs at %L must have at least "
20092 : "one argument", sym->name, &where);
20093 1 : return false;
20094 : }
20095 :
20096 445 : if (formal->sym->attr.intent != INTENT_IN)
20097 : {
20098 0 : gfc_error ("First argument of operator interface at %L must be "
20099 : "INTENT(IN)", &where);
20100 0 : return false;
20101 : }
20102 :
20103 445 : if (formal->sym->attr.optional)
20104 : {
20105 0 : gfc_error ("First argument of operator interface at %L cannot be "
20106 : "optional", &where);
20107 0 : return false;
20108 : }
20109 :
20110 445 : formal = formal->next;
20111 445 : if (!formal || !formal->sym)
20112 : return true;
20113 :
20114 295 : if (formal->sym->attr.intent != INTENT_IN)
20115 : {
20116 0 : gfc_error ("Second argument of operator interface at %L must be "
20117 : "INTENT(IN)", &where);
20118 0 : return false;
20119 : }
20120 :
20121 295 : if (formal->sym->attr.optional)
20122 : {
20123 1 : gfc_error ("Second argument of operator interface at %L cannot be "
20124 : "optional", &where);
20125 1 : return false;
20126 : }
20127 :
20128 294 : if (formal->next)
20129 : {
20130 2 : gfc_error ("Operator interface at %L must have, at most, two "
20131 : "arguments", &where);
20132 2 : return false;
20133 : }
20134 :
20135 : return true;
20136 : }
20137 :
20138 : static void
20139 343015 : gfc_resolve_uops (gfc_symtree *symtree)
20140 : {
20141 343015 : gfc_interface *itr;
20142 :
20143 343015 : if (symtree == NULL)
20144 : return;
20145 :
20146 380 : gfc_resolve_uops (symtree->left);
20147 380 : gfc_resolve_uops (symtree->right);
20148 :
20149 773 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
20150 393 : check_uop_procedure (itr->sym, itr->sym->declared_at);
20151 : }
20152 :
20153 :
20154 : /* Examine all of the expressions associated with a program unit,
20155 : assign types to all intermediate expressions, make sure that all
20156 : assignments are to compatible types and figure out which names
20157 : refer to which functions or subroutines. It doesn't check code
20158 : block, which is handled by gfc_resolve_code. */
20159 :
20160 : static void
20161 344737 : resolve_types (gfc_namespace *ns)
20162 : {
20163 344737 : gfc_namespace *n;
20164 344737 : gfc_charlen *cl;
20165 344737 : gfc_data *d;
20166 344737 : gfc_equiv *eq;
20167 344737 : gfc_namespace* old_ns = gfc_current_ns;
20168 344737 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
20169 :
20170 344737 : if (ns->types_resolved)
20171 : return;
20172 :
20173 : /* Check that all IMPLICIT types are ok. */
20174 342256 : if (!ns->seen_implicit_none)
20175 : {
20176 : unsigned letter;
20177 8611084 : for (letter = 0; letter != GFC_LETTERS; ++letter)
20178 8292155 : if (ns->set_flag[letter]
20179 8292155 : && !resolve_typespec_used (&ns->default_type[letter],
20180 : &ns->implicit_loc[letter], NULL))
20181 : return;
20182 : }
20183 :
20184 342255 : gfc_current_ns = ns;
20185 :
20186 342255 : resolve_entries (ns);
20187 :
20188 342255 : resolve_common_vars (&ns->blank_common, false);
20189 342255 : resolve_common_blocks (ns->common_root);
20190 :
20191 342255 : resolve_contained_functions (ns);
20192 :
20193 342255 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
20194 292564 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
20195 191285 : gfc_resolve_formal_arglist (ns->proc_name);
20196 :
20197 342255 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
20198 :
20199 436946 : for (cl = ns->cl_list; cl; cl = cl->next)
20200 94691 : resolve_charlen (cl);
20201 :
20202 342255 : gfc_traverse_ns (ns, resolve_symbol);
20203 :
20204 342255 : resolve_fntype (ns);
20205 :
20206 389836 : for (n = ns->contained; n; n = n->sibling)
20207 : {
20208 : /* Exclude final wrappers with the test for the artificial attribute. */
20209 47581 : if (gfc_pure (ns->proc_name)
20210 5 : && !gfc_pure (n->proc_name)
20211 47581 : && !n->proc_name->attr.artificial)
20212 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20213 : "also be PURE", n->proc_name->name,
20214 : &n->proc_name->declared_at);
20215 :
20216 47581 : resolve_types (n);
20217 : }
20218 :
20219 342255 : forall_flag = 0;
20220 342255 : gfc_do_concurrent_flag = 0;
20221 342255 : gfc_check_interfaces (ns);
20222 :
20223 342255 : gfc_traverse_ns (ns, resolve_values);
20224 :
20225 342255 : if (ns->save_all || (!flag_automatic && !recursive))
20226 313 : gfc_save_all (ns);
20227 :
20228 342255 : iter_stack = NULL;
20229 344773 : for (d = ns->data; d; d = d->next)
20230 2518 : resolve_data (d);
20231 :
20232 342255 : iter_stack = NULL;
20233 342255 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20234 :
20235 342255 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20236 :
20237 343820 : for (eq = ns->equiv; eq; eq = eq->next)
20238 1565 : resolve_equivalence (eq);
20239 :
20240 : /* Warn about unused labels. */
20241 342255 : if (warn_unused_label)
20242 4629 : warn_unused_fortran_label (ns->st_labels);
20243 :
20244 342255 : gfc_resolve_uops (ns->uop_root);
20245 :
20246 342255 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20247 :
20248 342255 : gfc_resolve_omp_declare (ns);
20249 :
20250 342255 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20251 :
20252 342255 : ns->types_resolved = 1;
20253 :
20254 342255 : gfc_current_ns = old_ns;
20255 : }
20256 :
20257 :
20258 : /* Call gfc_resolve_code recursively. */
20259 :
20260 : static void
20261 344793 : resolve_codes (gfc_namespace *ns)
20262 : {
20263 344793 : gfc_namespace *n;
20264 344793 : bitmap_obstack old_obstack;
20265 :
20266 344793 : if (ns->resolved == 1)
20267 13854 : return;
20268 :
20269 378576 : for (n = ns->contained; n; n = n->sibling)
20270 47637 : resolve_codes (n);
20271 :
20272 330939 : gfc_current_ns = ns;
20273 :
20274 : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20275 330939 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20276 318906 : cs_base = NULL;
20277 :
20278 : /* Set to an out of range value. */
20279 330939 : current_entry_id = -1;
20280 :
20281 330939 : old_obstack = labels_obstack;
20282 330939 : bitmap_obstack_initialize (&labels_obstack);
20283 :
20284 330939 : gfc_resolve_oacc_declare (ns);
20285 330939 : gfc_resolve_oacc_routines (ns);
20286 330939 : gfc_resolve_omp_local_vars (ns);
20287 330939 : if (ns->omp_allocate)
20288 62 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20289 330939 : gfc_resolve_code (ns->code, ns);
20290 :
20291 330938 : bitmap_obstack_release (&labels_obstack);
20292 330938 : labels_obstack = old_obstack;
20293 : }
20294 :
20295 :
20296 : /* This function is called after a complete program unit has been compiled.
20297 : Its purpose is to examine all of the expressions associated with a program
20298 : unit, assign types to all intermediate expressions, make sure that all
20299 : assignments are to compatible types and figure out which names refer to
20300 : which functions or subroutines. */
20301 :
20302 : void
20303 301706 : gfc_resolve (gfc_namespace *ns)
20304 : {
20305 301706 : gfc_namespace *old_ns;
20306 301706 : code_stack *old_cs_base;
20307 301706 : struct gfc_omp_saved_state old_omp_state;
20308 :
20309 301706 : if (ns->resolved)
20310 4550 : return;
20311 :
20312 297156 : ns->resolved = -1;
20313 297156 : old_ns = gfc_current_ns;
20314 297156 : old_cs_base = cs_base;
20315 :
20316 : /* As gfc_resolve can be called during resolution of an OpenMP construct
20317 : body, we should clear any state associated to it, so that say NS's
20318 : DO loops are not interpreted as OpenMP loops. */
20319 297156 : if (!ns->construct_entities)
20320 285123 : gfc_omp_save_and_clear_state (&old_omp_state);
20321 :
20322 297156 : resolve_types (ns);
20323 297156 : component_assignment_level = 0;
20324 297156 : resolve_codes (ns);
20325 :
20326 297155 : if (ns->omp_assumes)
20327 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
20328 :
20329 297155 : gfc_current_ns = old_ns;
20330 297155 : cs_base = old_cs_base;
20331 297155 : ns->resolved = 1;
20332 :
20333 297155 : gfc_run_passes (ns);
20334 :
20335 297155 : if (!ns->construct_entities)
20336 285122 : gfc_omp_restore_state (&old_omp_state);
20337 : }
|
