Line data Source code
1 : /* Perform type resolution on the various structures.
2 : Copyright (C) 2001-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : #include "config.h"
22 : #include "system.h"
23 : #include "coretypes.h"
24 : #include "options.h"
25 : #include "bitmap.h"
26 : #include "gfortran.h"
27 : #include "arith.h" /* For gfc_compare_expr(). */
28 : #include "dependency.h"
29 : #include "data.h"
30 : #include "target-memory.h" /* for gfc_simplify_transfer */
31 : #include "constructor.h"
32 :
33 : /* Types used in equivalence statements. */
34 :
35 : enum seq_type
36 : {
37 : SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 : };
39 :
40 : /* Stack to keep track of the nesting of blocks as we move through the
41 : code. See resolve_branch() and gfc_resolve_code(). */
42 :
43 : typedef struct code_stack
44 : {
45 : struct gfc_code *head, *current;
46 : struct code_stack *prev;
47 :
48 : /* This bitmap keeps track of the targets valid for a branch from
49 : inside this block except for END {IF|SELECT}s of enclosing
50 : blocks. */
51 : bitmap reachable_labels;
52 : }
53 : code_stack;
54 :
55 : static code_stack *cs_base = NULL;
56 :
57 : struct check_default_none_data
58 : {
59 : gfc_code *code;
60 : hash_set<gfc_symbol *> *sym_hash;
61 : gfc_namespace *ns;
62 : bool default_none;
63 : };
64 :
65 : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
66 :
67 : static int forall_flag;
68 : int gfc_do_concurrent_flag;
69 :
70 : /* True when we are resolving an expression that is an actual argument to
71 : a procedure. */
72 : static bool actual_arg = false;
73 : /* True when we are resolving an expression that is the first actual argument
74 : to a procedure. */
75 : static bool first_actual_arg = false;
76 :
77 :
78 : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
79 :
80 : static int omp_workshare_flag;
81 :
82 :
83 : /* True if we are resolving a specification expression. */
84 : static bool specification_expr = false;
85 : /* The dummy whose character length or array bounds are currently being
86 : resolved as a specification expression. */
87 : static gfc_symbol *specification_expr_symbol = NULL;
88 :
89 : /* The id of the last entry seen. */
90 : static int current_entry_id;
91 :
92 : /* We use bitmaps to determine if a branch target is valid. */
93 : static bitmap_obstack labels_obstack;
94 :
95 : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
96 : static bool inquiry_argument = false;
97 :
98 : static bool
99 464 : entry_dummy_seen_p (gfc_symbol *sym)
100 : {
101 464 : gfc_entry_list *entry;
102 464 : gfc_formal_arglist *formal;
103 :
104 464 : gcc_checking_assert (sym->attr.dummy && sym->ns == gfc_current_ns);
105 :
106 464 : for (entry = gfc_current_ns->entries;
107 471 : entry && entry->id <= current_entry_id;
108 7 : entry = entry->next)
109 765 : for (formal = entry->sym->formal; formal; formal = formal->next)
110 758 : if (formal->sym && sym->name == formal->sym->name)
111 : return true;
112 :
113 : return false;
114 : }
115 :
116 :
117 : /* Is the symbol host associated? */
118 : static bool
119 56032 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
120 : {
121 61291 : for (ns = ns->parent; ns; ns = ns->parent)
122 : {
123 5517 : if (sym->ns == ns)
124 : return true;
125 : }
126 :
127 : return false;
128 : }
129 :
130 : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
131 : an ABSTRACT derived-type. If where is not NULL, an error message with that
132 : locus is printed, optionally using name. */
133 :
134 : static bool
135 1606690 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
136 : {
137 1606690 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
138 : {
139 5 : if (where)
140 : {
141 5 : if (name)
142 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
143 : name, where, ts->u.derived->name);
144 : else
145 1 : gfc_error ("ABSTRACT type %qs used at %L",
146 : ts->u.derived->name, where);
147 : }
148 :
149 : return false;
150 : }
151 :
152 : return true;
153 : }
154 :
155 :
156 : static bool
157 5721 : check_proc_interface (gfc_symbol *ifc, locus *where)
158 : {
159 : /* Several checks for F08:C1216. */
160 5721 : if (ifc->attr.procedure)
161 : {
162 2 : gfc_error ("Interface %qs at %L is declared "
163 : "in a later PROCEDURE statement", ifc->name, where);
164 2 : return false;
165 : }
166 5719 : if (ifc->generic)
167 : {
168 : /* For generic interfaces, check if there is
169 : a specific procedure with the same name. */
170 : gfc_interface *gen = ifc->generic;
171 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
172 5 : gen = gen->next;
173 7 : if (!gen)
174 : {
175 4 : gfc_error ("Interface %qs at %L may not be generic",
176 : ifc->name, where);
177 4 : return false;
178 : }
179 : }
180 5715 : if (ifc->attr.proc == PROC_ST_FUNCTION)
181 : {
182 4 : gfc_error ("Interface %qs at %L may not be a statement function",
183 : ifc->name, where);
184 4 : return false;
185 : }
186 5711 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
187 5711 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
188 17 : ifc->attr.intrinsic = 1;
189 5711 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
190 : {
191 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
192 : "PROCEDURE statement at %L", ifc->name, where);
193 3 : return false;
194 : }
195 5708 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
196 : {
197 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
198 7 : return false;
199 : }
200 : return true;
201 : }
202 :
203 :
204 : static void resolve_symbol (gfc_symbol *sym);
205 :
206 :
207 : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
208 :
209 : static bool
210 2143 : resolve_procedure_interface (gfc_symbol *sym)
211 : {
212 2143 : gfc_symbol *ifc = sym->ts.interface;
213 :
214 2143 : if (!ifc)
215 : return true;
216 :
217 1983 : if (ifc == sym)
218 : {
219 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
220 : sym->name, &sym->declared_at);
221 2 : return false;
222 : }
223 1981 : if (!check_proc_interface (ifc, &sym->declared_at))
224 : return false;
225 :
226 1972 : if (ifc->attr.if_source || ifc->attr.intrinsic)
227 : {
228 : /* Resolve interface and copy attributes. */
229 1693 : resolve_symbol (ifc);
230 1693 : if (ifc->attr.intrinsic)
231 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
232 :
233 1693 : if (ifc->result)
234 : {
235 782 : sym->ts = ifc->result->ts;
236 782 : sym->attr.allocatable = ifc->result->attr.allocatable;
237 782 : sym->attr.pointer = ifc->result->attr.pointer;
238 782 : sym->attr.dimension = ifc->result->attr.dimension;
239 782 : sym->attr.class_ok = ifc->result->attr.class_ok;
240 782 : sym->as = gfc_copy_array_spec (ifc->result->as);
241 782 : sym->result = sym;
242 : }
243 : else
244 : {
245 911 : sym->ts = ifc->ts;
246 911 : sym->attr.allocatable = ifc->attr.allocatable;
247 911 : sym->attr.pointer = ifc->attr.pointer;
248 911 : sym->attr.dimension = ifc->attr.dimension;
249 911 : sym->attr.class_ok = ifc->attr.class_ok;
250 911 : sym->as = gfc_copy_array_spec (ifc->as);
251 : }
252 1693 : sym->ts.interface = ifc;
253 1693 : sym->attr.function = ifc->attr.function;
254 1693 : sym->attr.subroutine = ifc->attr.subroutine;
255 :
256 1693 : sym->attr.pure = ifc->attr.pure;
257 1693 : sym->attr.elemental = ifc->attr.elemental;
258 1693 : sym->attr.contiguous = ifc->attr.contiguous;
259 1693 : sym->attr.recursive = ifc->attr.recursive;
260 1693 : sym->attr.always_explicit = ifc->attr.always_explicit;
261 1693 : sym->attr.ext_attr |= ifc->attr.ext_attr;
262 1693 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
263 : /* Copy char length. */
264 1693 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
265 : {
266 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
267 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
268 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
269 : return false;
270 : }
271 : }
272 :
273 : return true;
274 : }
275 :
276 :
277 : /* Resolve types of formal argument lists. These have to be done early so that
278 : the formal argument lists of module procedures can be copied to the
279 : containing module before the individual procedures are resolved
280 : individually. We also resolve argument lists of procedures in interface
281 : blocks because they are self-contained scoping units.
282 :
283 : Since a dummy argument cannot be a non-dummy procedure, the only
284 : resort left for untyped names are the IMPLICIT types. */
285 :
286 : void
287 554704 : gfc_resolve_formal_arglist (gfc_symbol *proc)
288 : {
289 554704 : gfc_formal_arglist *f;
290 554704 : gfc_symbol *sym;
291 554704 : bool saved_specification_expr;
292 554704 : int i;
293 :
294 554704 : if (proc->result != NULL)
295 345359 : sym = proc->result;
296 : else
297 : sym = proc;
298 :
299 554704 : if (gfc_elemental (proc)
300 391753 : || sym->attr.pointer || sym->attr.allocatable
301 933979 : || (sym->as && sym->as->rank != 0))
302 : {
303 177759 : proc->attr.always_explicit = 1;
304 177759 : sym->attr.always_explicit = 1;
305 : }
306 :
307 554704 : gfc_namespace *orig_current_ns = gfc_current_ns;
308 554704 : gfc_current_ns = gfc_get_procedure_ns (proc);
309 :
310 1435065 : for (f = proc->formal; f; f = f->next)
311 : {
312 880363 : gfc_array_spec *as;
313 880363 : gfc_symbol *saved_specification_expr_symbol;
314 :
315 880363 : sym = f->sym;
316 :
317 880363 : if (sym == NULL)
318 : {
319 : /* Alternate return placeholder. */
320 171 : if (gfc_elemental (proc))
321 1 : gfc_error ("Alternate return specifier in elemental subroutine "
322 : "%qs at %L is not allowed", proc->name,
323 : &proc->declared_at);
324 171 : if (proc->attr.function)
325 1 : gfc_error ("Alternate return specifier in function "
326 : "%qs at %L is not allowed", proc->name,
327 : &proc->declared_at);
328 171 : continue;
329 : }
330 :
331 611 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
332 880803 : && !resolve_procedure_interface (sym))
333 : break;
334 :
335 880192 : if (strcmp (proc->name, sym->name) == 0)
336 : {
337 2 : gfc_error ("Self-referential argument "
338 : "%qs at %L is not allowed", sym->name,
339 : &proc->declared_at);
340 2 : break;
341 : }
342 :
343 880190 : if (sym->attr.if_source != IFSRC_UNKNOWN)
344 903 : gfc_resolve_formal_arglist (sym);
345 :
346 880190 : if (sym->attr.subroutine || sym->attr.external)
347 : {
348 913 : if (sym->attr.flavor == FL_UNKNOWN)
349 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
350 : }
351 : else
352 : {
353 879277 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
354 3688 : && (!sym->attr.function || sym->result == sym))
355 3650 : gfc_set_default_type (sym, 1, sym->ns);
356 : }
357 :
358 880190 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
359 894575 : ? CLASS_DATA (sym)->as : sym->as;
360 :
361 880190 : saved_specification_expr = specification_expr;
362 880190 : saved_specification_expr_symbol = specification_expr_symbol;
363 880190 : specification_expr = true;
364 880190 : specification_expr_symbol = sym;
365 880190 : gfc_resolve_array_spec (as, 0);
366 880190 : specification_expr = saved_specification_expr;
367 880190 : specification_expr_symbol = saved_specification_expr_symbol;
368 :
369 : /* We can't tell if an array with dimension (:) is assumed or deferred
370 : shape until we know if it has the pointer or allocatable attributes.
371 : */
372 880190 : if (as && as->rank > 0 && as->type == AS_DEFERRED
373 12890 : && ((sym->ts.type != BT_CLASS
374 11702 : && !(sym->attr.pointer || sym->attr.allocatable))
375 5481 : || (sym->ts.type == BT_CLASS
376 1188 : && !(CLASS_DATA (sym)->attr.class_pointer
377 982 : || CLASS_DATA (sym)->attr.allocatable)))
378 7952 : && sym->attr.flavor != FL_PROCEDURE)
379 : {
380 7951 : as->type = AS_ASSUMED_SHAPE;
381 18416 : for (i = 0; i < as->rank; i++)
382 10465 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
383 : }
384 :
385 139324 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
386 124711 : || (as && as->type == AS_ASSUMED_RANK)
387 825706 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
388 815439 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
389 11997 : && (CLASS_DATA (sym)->attr.class_pointer
390 11508 : || CLASS_DATA (sym)->attr.allocatable
391 10561 : || CLASS_DATA (sym)->attr.target))
392 814003 : || sym->attr.optional)
393 : {
394 81805 : proc->attr.always_explicit = 1;
395 81805 : if (proc->result)
396 37169 : proc->result->attr.always_explicit = 1;
397 : }
398 :
399 : /* If the flavor is unknown at this point, it has to be a variable.
400 : A procedure specification would have already set the type. */
401 :
402 880190 : if (sym->attr.flavor == FL_UNKNOWN)
403 52414 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
404 :
405 880190 : if (gfc_pure (proc))
406 : {
407 328981 : if (sym->attr.flavor == FL_PROCEDURE)
408 : {
409 : /* F08:C1279. */
410 29 : if (!gfc_pure (sym))
411 : {
412 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
413 : "also be PURE", sym->name, &sym->declared_at);
414 1 : continue;
415 : }
416 : }
417 328952 : else if (!sym->attr.pointer)
418 : {
419 328938 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
420 : {
421 111 : if (sym->attr.value)
422 110 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
423 : " of pure function %qs at %L with VALUE "
424 : "attribute but without INTENT(IN)",
425 : sym->name, proc->name, &sym->declared_at);
426 : else
427 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
428 : "be INTENT(IN) or VALUE", sym->name, proc->name,
429 : &sym->declared_at);
430 : }
431 :
432 328938 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
433 : {
434 159 : if (sym->attr.value)
435 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
436 : " of pure subroutine %qs at %L with VALUE "
437 : "attribute but without INTENT", sym->name,
438 : proc->name, &sym->declared_at);
439 : else
440 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
441 : "must have its INTENT specified or have the "
442 : "VALUE attribute", sym->name, proc->name,
443 : &sym->declared_at);
444 : }
445 : }
446 :
447 : /* F08:C1278a. */
448 328980 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
449 : {
450 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
451 : " may not be polymorphic", sym->name, proc->name,
452 : &sym->declared_at);
453 1 : continue;
454 : }
455 : }
456 :
457 880188 : if (proc->attr.implicit_pure)
458 : {
459 26227 : if (sym->attr.flavor == FL_PROCEDURE)
460 : {
461 337 : if (!gfc_pure (sym))
462 305 : proc->attr.implicit_pure = 0;
463 : }
464 25890 : else if (!sym->attr.pointer)
465 : {
466 25088 : if (proc->attr.function && sym->attr.intent != INTENT_IN
467 2754 : && !sym->value)
468 2754 : proc->attr.implicit_pure = 0;
469 :
470 25088 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
471 4323 : && !sym->value)
472 4323 : proc->attr.implicit_pure = 0;
473 : }
474 : }
475 :
476 880188 : if (gfc_elemental (proc))
477 : {
478 : /* F08:C1289. */
479 303098 : if (sym->attr.codimension
480 303097 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
481 965 : && CLASS_DATA (sym)->attr.codimension))
482 : {
483 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
484 : "procedure", sym->name, &sym->declared_at);
485 3 : continue;
486 : }
487 :
488 303095 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
489 963 : && CLASS_DATA (sym)->as))
490 : {
491 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
492 : "be scalar", sym->name, &sym->declared_at);
493 2 : continue;
494 : }
495 :
496 303093 : if (sym->attr.allocatable
497 303092 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
498 962 : && CLASS_DATA (sym)->attr.allocatable))
499 : {
500 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
501 : "have the ALLOCATABLE attribute", sym->name,
502 : &sym->declared_at);
503 2 : continue;
504 : }
505 :
506 303091 : if (sym->attr.pointer
507 303090 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
508 961 : && CLASS_DATA (sym)->attr.class_pointer))
509 : {
510 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
511 : "have the POINTER attribute", sym->name,
512 : &sym->declared_at);
513 2 : continue;
514 : }
515 :
516 303089 : if (sym->attr.flavor == FL_PROCEDURE)
517 : {
518 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
519 : "procedure %qs at %L", sym->name, proc->name,
520 : &sym->declared_at);
521 2 : continue;
522 : }
523 :
524 : /* Fortran 2008 Corrigendum 1, C1290a. */
525 303087 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
526 : {
527 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
528 : "have its INTENT specified or have the VALUE "
529 : "attribute", sym->name, proc->name,
530 : &sym->declared_at);
531 2 : continue;
532 : }
533 : }
534 :
535 : /* Each dummy shall be specified to be scalar. */
536 880175 : if (proc->attr.proc == PROC_ST_FUNCTION)
537 : {
538 307 : if (sym->as != NULL)
539 : {
540 : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
541 : shall be specified, explicitly or implicitly, to be scalar. */
542 1 : gfc_error ("Argument %qs of statement function %qs at %L "
543 : "must be scalar", sym->name, proc->name,
544 : &proc->declared_at);
545 1 : continue;
546 : }
547 :
548 306 : if (sym->ts.type == BT_CHARACTER)
549 : {
550 48 : gfc_charlen *cl = sym->ts.u.cl;
551 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
552 : {
553 0 : gfc_error ("Character-valued argument %qs of statement "
554 : "function at %L must have constant length",
555 : sym->name, &sym->declared_at);
556 0 : continue;
557 : }
558 : }
559 : }
560 : }
561 554704 : if (sym)
562 554612 : sym->formal_resolved = 1;
563 554704 : gfc_current_ns = orig_current_ns;
564 554704 : }
565 :
566 :
567 : /* Work function called when searching for symbols that have argument lists
568 : associated with them. */
569 :
570 : static void
571 1929835 : find_arglists (gfc_symbol *sym)
572 : {
573 1929835 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
574 350064 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
575 : return;
576 :
577 347343 : gfc_resolve_formal_arglist (sym);
578 : }
579 :
580 :
581 : /* Given a namespace, resolve all formal argument lists within the namespace.
582 : */
583 :
584 : static void
585 364147 : resolve_formal_arglists (gfc_namespace *ns)
586 : {
587 0 : if (ns == NULL)
588 : return;
589 :
590 364147 : gfc_traverse_ns (ns, find_arglists);
591 : }
592 :
593 :
594 : static void
595 38615 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
596 : {
597 38615 : bool t;
598 :
599 38615 : if (sym && sym->attr.flavor == FL_PROCEDURE
600 38615 : && sym->ns->parent
601 1458 : && sym->ns->parent->proc_name
602 1458 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
603 0 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
604 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
605 : "encompassing procedure", sym->name, &sym->declared_at);
606 :
607 : /* If this namespace is not a function or an entry master function,
608 : ignore it. */
609 38615 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
610 11296 : || sym->attr.entry_master)
611 : return;
612 :
613 11107 : if (!sym->result)
614 : return;
615 :
616 : /* Try to find out of what the return type is. */
617 11107 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
618 : {
619 58 : t = gfc_set_default_type (sym->result, 0, ns);
620 :
621 58 : if (!t && !sym->result->attr.untyped)
622 : {
623 19 : if (sym->result == sym)
624 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
625 : sym->name, &sym->declared_at);
626 18 : else if (!sym->result->attr.proc_pointer)
627 0 : gfc_error ("Result %qs of contained function %qs at %L has "
628 : "no IMPLICIT type", sym->result->name, sym->name,
629 : &sym->result->declared_at);
630 19 : sym->result->attr.untyped = 1;
631 : }
632 : }
633 :
634 : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
635 : type, lists the only ways a character length value of * can be used:
636 : dummy arguments of procedures, named constants, function results and
637 : in allocate statements if the allocate_object is an assumed length dummy
638 : in external functions. Internal function results and results of module
639 : procedures are not on this list, ergo, not permitted. */
640 :
641 11107 : if (sym->result->ts.type == BT_CHARACTER)
642 : {
643 1247 : gfc_charlen *cl = sym->result->ts.u.cl;
644 1247 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
645 : {
646 : /* See if this is a module-procedure and adapt error message
647 : accordingly. */
648 4 : bool module_proc;
649 4 : gcc_assert (ns->parent && ns->parent->proc_name);
650 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
651 :
652 7 : gfc_error (module_proc
653 : ? G_("Character-valued module procedure %qs at %L"
654 : " must not be assumed length")
655 : : G_("Character-valued internal function %qs at %L"
656 : " must not be assumed length"),
657 : sym->name, &sym->declared_at);
658 : }
659 : }
660 : }
661 :
662 :
663 : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
664 : introduce duplicates. */
665 :
666 : static void
667 1491 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
668 : {
669 1491 : gfc_formal_arglist *f, *new_arglist;
670 1491 : gfc_symbol *new_sym;
671 :
672 2644 : for (; new_args != NULL; new_args = new_args->next)
673 : {
674 1153 : new_sym = new_args->sym;
675 : /* See if this arg is already in the formal argument list. */
676 2186 : for (f = proc->formal; f; f = f->next)
677 : {
678 1481 : if (new_sym == f->sym)
679 : break;
680 : }
681 :
682 1153 : if (f)
683 448 : continue;
684 :
685 : /* Add a new argument. Argument order is not important. */
686 705 : new_arglist = gfc_get_formal_arglist ();
687 705 : new_arglist->sym = new_sym;
688 705 : new_arglist->next = proc->formal;
689 705 : proc->formal = new_arglist;
690 : }
691 1491 : }
692 :
693 :
694 : /* Flag the arguments that are not present in all entries. */
695 :
696 : static void
697 1491 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
698 : {
699 1491 : gfc_formal_arglist *f, *head;
700 1491 : head = new_args;
701 :
702 3086 : for (f = proc->formal; f; f = f->next)
703 : {
704 1595 : if (f->sym == NULL)
705 36 : continue;
706 :
707 2738 : for (new_args = head; new_args; new_args = new_args->next)
708 : {
709 2287 : if (new_args->sym == f->sym)
710 : break;
711 : }
712 :
713 1559 : if (new_args)
714 1108 : continue;
715 :
716 451 : f->sym->attr.not_always_present = 1;
717 : }
718 1491 : }
719 :
720 :
721 : /* Resolve alternate entry points. If a symbol has multiple entry points we
722 : create a new master symbol for the main routine, and turn the existing
723 : symbol into an entry point. */
724 :
725 : static void
726 402255 : resolve_entries (gfc_namespace *ns)
727 : {
728 402255 : gfc_namespace *old_ns;
729 402255 : gfc_code *c;
730 402255 : gfc_symbol *proc;
731 402255 : gfc_entry_list *el;
732 : /* Provide sufficient space to hold "master.%d.%s". */
733 402255 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
734 402255 : static int master_count = 0;
735 :
736 402255 : if (ns->proc_name == NULL)
737 401552 : return;
738 :
739 : /* No need to do anything if this procedure doesn't have alternate entry
740 : points. */
741 402206 : if (!ns->entries)
742 : return;
743 :
744 : /* We may already have resolved alternate entry points. */
745 954 : if (ns->proc_name->attr.entry_master)
746 : return;
747 :
748 : /* If this isn't a procedure something has gone horribly wrong. */
749 703 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
750 :
751 : /* Remember the current namespace. */
752 703 : old_ns = gfc_current_ns;
753 :
754 703 : gfc_current_ns = ns;
755 :
756 : /* Add the main entry point to the list of entry points. */
757 703 : el = gfc_get_entry_list ();
758 703 : el->sym = ns->proc_name;
759 703 : el->id = 0;
760 703 : el->next = ns->entries;
761 703 : ns->entries = el;
762 703 : ns->proc_name->attr.entry = 1;
763 :
764 : /* If it is a module function, it needs to be in the right namespace
765 : so that gfc_get_fake_result_decl can gather up the results. The
766 : need for this arose in get_proc_name, where these beasts were
767 : left in their own namespace, to keep prior references linked to
768 : the entry declaration.*/
769 703 : if (ns->proc_name->attr.function
770 596 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
771 189 : el->sym->ns = ns;
772 :
773 : /* Do the same for entries where the master is not a module
774 : procedure. These are retained in the module namespace because
775 : of the module procedure declaration. */
776 1491 : for (el = el->next; el; el = el->next)
777 788 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
778 0 : && el->sym->attr.mod_proc)
779 0 : el->sym->ns = ns;
780 703 : el = ns->entries;
781 :
782 : /* Add an entry statement for it. */
783 703 : c = gfc_get_code (EXEC_ENTRY);
784 703 : c->ext.entry = el;
785 703 : c->next = ns->code;
786 703 : ns->code = c;
787 :
788 : /* Create a new symbol for the master function. */
789 : /* Give the internal function a unique name (within this file).
790 : Also include the function name so the user has some hope of figuring
791 : out what is going on. */
792 703 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
793 703 : master_count++, ns->proc_name->name);
794 703 : gfc_get_ha_symbol (name, &proc);
795 703 : gcc_assert (proc != NULL);
796 :
797 703 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
798 703 : if (ns->proc_name->attr.subroutine)
799 107 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
800 : else
801 : {
802 596 : gfc_symbol *sym;
803 596 : gfc_typespec *ts, *fts;
804 596 : gfc_array_spec *as, *fas;
805 596 : gfc_add_function (&proc->attr, proc->name, NULL);
806 596 : proc->result = proc;
807 596 : fas = ns->entries->sym->as;
808 596 : fas = fas ? fas : ns->entries->sym->result->as;
809 596 : fts = &ns->entries->sym->result->ts;
810 596 : if (fts->type == BT_UNKNOWN)
811 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
812 1120 : for (el = ns->entries->next; el; el = el->next)
813 : {
814 635 : ts = &el->sym->result->ts;
815 635 : as = el->sym->as;
816 635 : as = as ? as : el->sym->result->as;
817 635 : if (ts->type == BT_UNKNOWN)
818 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
819 :
820 635 : if (! gfc_compare_types (ts, fts)
821 527 : || (el->sym->result->attr.dimension
822 527 : != ns->entries->sym->result->attr.dimension)
823 635 : || (el->sym->result->attr.pointer
824 527 : != ns->entries->sym->result->attr.pointer))
825 : break;
826 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
827 589 : && gfc_compare_array_spec (as, fas) == 0)
828 5 : gfc_error ("Function %s at %L has entries with mismatched "
829 : "array specifications", ns->entries->sym->name,
830 5 : &ns->entries->sym->declared_at);
831 : /* The characteristics need to match and thus both need to have
832 : the same string length, i.e. both len=*, or both len=4.
833 : Having both len=<variable> is also possible, but difficult to
834 : check at compile time. */
835 522 : else if (ts->type == BT_CHARACTER
836 113 : && (el->sym->result->attr.allocatable
837 113 : != ns->entries->sym->result->attr.allocatable))
838 : {
839 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
840 : "characteristics", ns->entries->sym->name,
841 : &ns->entries->sym->declared_at, el->sym->name);
842 3 : goto cleanup;
843 : }
844 519 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
845 110 : && (((ts->u.cl->length && !fts->u.cl->length)
846 109 : ||(!ts->u.cl->length && fts->u.cl->length))
847 90 : || (ts->u.cl->length
848 53 : && ts->u.cl->length->expr_type
849 53 : != fts->u.cl->length->expr_type)
850 90 : || (ts->u.cl->length
851 53 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
852 52 : && mpz_cmp (ts->u.cl->length->value.integer,
853 52 : fts->u.cl->length->value.integer) != 0)))
854 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
855 : "entries returning variables of different "
856 : "string lengths", ns->entries->sym->name,
857 21 : &ns->entries->sym->declared_at);
858 498 : else if (el->sym->result->attr.allocatable
859 498 : != ns->entries->sym->result->attr.allocatable)
860 : break;
861 : }
862 :
863 593 : if (el == NULL)
864 : {
865 485 : sym = ns->entries->sym->result;
866 : /* All result types the same. */
867 485 : proc->ts = *fts;
868 485 : if (sym->attr.dimension)
869 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
870 485 : if (sym->attr.pointer)
871 78 : gfc_add_pointer (&proc->attr, NULL);
872 485 : if (sym->attr.allocatable)
873 24 : gfc_add_allocatable (&proc->attr, NULL);
874 : }
875 : else
876 : {
877 : /* Otherwise the result will be passed through a union by
878 : reference. */
879 108 : proc->attr.mixed_entry_master = 1;
880 346 : for (el = ns->entries; el; el = el->next)
881 : {
882 238 : sym = el->sym->result;
883 238 : if (sym->attr.dimension)
884 : {
885 1 : if (el == ns->entries)
886 0 : gfc_error ("FUNCTION result %s cannot be an array in "
887 : "FUNCTION %s at %L", sym->name,
888 0 : ns->entries->sym->name, &sym->declared_at);
889 : else
890 1 : gfc_error ("ENTRY result %s cannot be an array in "
891 : "FUNCTION %s at %L", sym->name,
892 1 : ns->entries->sym->name, &sym->declared_at);
893 : }
894 237 : else if (sym->attr.pointer)
895 : {
896 1 : if (el == ns->entries)
897 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
898 : "FUNCTION %s at %L", sym->name,
899 1 : ns->entries->sym->name, &sym->declared_at);
900 : else
901 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
902 : "FUNCTION %s at %L", sym->name,
903 0 : ns->entries->sym->name, &sym->declared_at);
904 : }
905 236 : else if (sym->attr.allocatable)
906 : {
907 0 : if (el == ns->entries)
908 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
909 : "FUNCTION %s at %L", sym->name,
910 0 : ns->entries->sym->name, &sym->declared_at);
911 : else
912 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
913 : "FUNCTION %s at %L", sym->name,
914 0 : ns->entries->sym->name, &sym->declared_at);
915 : }
916 : else
917 : {
918 236 : ts = &sym->ts;
919 236 : if (ts->type == BT_UNKNOWN)
920 9 : ts = gfc_get_default_type (sym->name, NULL);
921 236 : switch (ts->type)
922 : {
923 85 : case BT_INTEGER:
924 85 : if (ts->kind == gfc_default_integer_kind)
925 : sym = NULL;
926 : break;
927 100 : case BT_REAL:
928 100 : if (ts->kind == gfc_default_real_kind
929 18 : || ts->kind == gfc_default_double_kind)
930 : sym = NULL;
931 : break;
932 20 : case BT_COMPLEX:
933 20 : if (ts->kind == gfc_default_complex_kind)
934 : sym = NULL;
935 : break;
936 28 : case BT_LOGICAL:
937 28 : if (ts->kind == gfc_default_logical_kind)
938 : sym = NULL;
939 : break;
940 : case BT_UNKNOWN:
941 : /* We will issue error elsewhere. */
942 : sym = NULL;
943 : break;
944 : default:
945 : break;
946 : }
947 3 : if (sym)
948 : {
949 3 : if (el == ns->entries)
950 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
951 : "in FUNCTION %s at %L", sym->name,
952 1 : gfc_typename (ts), ns->entries->sym->name,
953 : &sym->declared_at);
954 : else
955 2 : gfc_error ("ENTRY result %s cannot be of type %s "
956 : "in FUNCTION %s at %L", sym->name,
957 2 : gfc_typename (ts), ns->entries->sym->name,
958 : &sym->declared_at);
959 : }
960 : }
961 : }
962 : }
963 : }
964 :
965 108 : cleanup:
966 703 : proc->attr.access = ACCESS_PRIVATE;
967 703 : proc->attr.entry_master = 1;
968 :
969 : /* Merge all the entry point arguments. */
970 2194 : for (el = ns->entries; el; el = el->next)
971 1491 : merge_argument_lists (proc, el->sym->formal);
972 :
973 : /* Check the master formal arguments for any that are not
974 : present in all entry points. */
975 2194 : for (el = ns->entries; el; el = el->next)
976 1491 : check_argument_lists (proc, el->sym->formal);
977 :
978 : /* Use the master function for the function body. */
979 703 : ns->proc_name = proc;
980 :
981 : /* Finalize the new symbols. */
982 703 : gfc_commit_symbols ();
983 :
984 : /* Restore the original namespace. */
985 703 : gfc_current_ns = old_ns;
986 : }
987 :
988 :
989 : /* Forward declaration. */
990 : static bool is_non_constant_shape_array (gfc_symbol *sym);
991 :
992 :
993 : /* Resolve common variables. */
994 : static void
995 366125 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
996 : {
997 366125 : gfc_symbol *csym = common_block->head;
998 366125 : gfc_gsymbol *gsym;
999 :
1000 372178 : for (; csym; csym = csym->common_next)
1001 : {
1002 6053 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
1003 6053 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
1004 : {
1005 3 : if (csym->common_block)
1006 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1007 : "COMMON block at %L", gsym->name,
1008 : &gsym->where, &csym->common_block->where);
1009 : else
1010 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1011 : "COMMON block", gsym->name, &gsym->where);
1012 : }
1013 :
1014 : /* gfc_add_in_common may have been called before, but the reported errors
1015 : have been ignored to continue parsing.
1016 : We do the checks again here, unless the symbol is USE associated. */
1017 6053 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
1018 : {
1019 5780 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
1020 5780 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
1021 : &common_block->where);
1022 : }
1023 :
1024 6053 : if (csym->value || csym->attr.data)
1025 : {
1026 149 : if (!csym->ns->is_block_data)
1027 33 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1028 : "but only in BLOCK DATA initialization is "
1029 : "allowed", csym->name, &csym->declared_at);
1030 116 : else if (!named_common)
1031 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1032 : "in a blank COMMON but initialization is only "
1033 : "allowed in named common blocks", csym->name,
1034 : &csym->declared_at);
1035 : }
1036 :
1037 6053 : if (UNLIMITED_POLY (csym))
1038 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1039 : "[F2008:C5100]", csym->name, &csym->declared_at);
1040 :
1041 6053 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1042 : {
1043 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1044 : "COMMON at %L", csym->name, &csym->declared_at,
1045 : &common_block->where);
1046 : /* Avoid confusing follow-on error. */
1047 1 : csym->error = 1;
1048 : }
1049 :
1050 6053 : if (csym->ts.type != BT_DERIVED)
1051 6006 : continue;
1052 :
1053 47 : if (!(csym->ts.u.derived->attr.sequence
1054 3 : || csym->ts.u.derived->attr.is_bind_c))
1055 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1056 : "has neither the SEQUENCE nor the BIND(C) "
1057 : "attribute", csym->name, &csym->declared_at);
1058 47 : if (csym->ts.u.derived->attr.alloc_comp)
1059 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1060 : "has an ultimate component that is "
1061 : "allocatable", csym->name, &csym->declared_at);
1062 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1063 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1064 : "may not have default initializer", csym->name,
1065 : &csym->declared_at);
1066 :
1067 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1068 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1069 : }
1070 366125 : }
1071 :
1072 : /* Resolve common blocks. */
1073 : static void
1074 364678 : resolve_common_blocks (gfc_symtree *common_root)
1075 : {
1076 364678 : gfc_symbol *sym = NULL;
1077 364678 : gfc_gsymbol * gsym;
1078 :
1079 364678 : if (common_root == NULL)
1080 364556 : return;
1081 :
1082 1978 : if (common_root->left)
1083 257 : resolve_common_blocks (common_root->left);
1084 1978 : if (common_root->right)
1085 274 : resolve_common_blocks (common_root->right);
1086 :
1087 1978 : resolve_common_vars (common_root->n.common, true);
1088 :
1089 : /* The common name is a global name - in Fortran 2003 also if it has a
1090 : C binding name, since Fortran 2008 only the C binding name is a global
1091 : identifier. */
1092 1978 : if (!common_root->n.common->binding_label
1093 1978 : || gfc_notification_std (GFC_STD_F2008))
1094 : {
1095 3812 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1096 1906 : common_root->n.common->name);
1097 :
1098 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1099 14 : && gsym->type == GSYM_COMMON
1100 1919 : && ((common_root->n.common->binding_label
1101 6 : && (!gsym->binding_label
1102 0 : || strcmp (common_root->n.common->binding_label,
1103 : gsym->binding_label) != 0))
1104 7 : || (!common_root->n.common->binding_label
1105 7 : && gsym->binding_label)))
1106 : {
1107 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1108 : "identifier and must thus have the same binding name "
1109 : "as the same-named COMMON block at %L: %s vs %s",
1110 6 : common_root->n.common->name, &common_root->n.common->where,
1111 : &gsym->where,
1112 : common_root->n.common->binding_label
1113 : ? common_root->n.common->binding_label : "(blank)",
1114 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1115 6 : return;
1116 : }
1117 :
1118 1900 : if (gsym && gsym->type != GSYM_COMMON
1119 1 : && !common_root->n.common->binding_label)
1120 : {
1121 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1122 : "as entity at %L",
1123 0 : common_root->n.common->name, &common_root->n.common->where,
1124 : &gsym->where);
1125 0 : return;
1126 : }
1127 814 : if (gsym && gsym->type != GSYM_COMMON)
1128 : {
1129 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1130 : "%L sharing the identifier with global non-COMMON-block "
1131 1 : "entity at %L", common_root->n.common->name,
1132 1 : &common_root->n.common->where, &gsym->where);
1133 1 : return;
1134 : }
1135 1086 : if (!gsym)
1136 : {
1137 1086 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1138 1086 : gsym->type = GSYM_COMMON;
1139 1086 : gsym->where = common_root->n.common->where;
1140 1086 : gsym->defined = 1;
1141 : }
1142 1899 : gsym->used = 1;
1143 : }
1144 :
1145 1971 : if (common_root->n.common->binding_label)
1146 : {
1147 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1148 : common_root->n.common->binding_label);
1149 76 : if (gsym && gsym->type != GSYM_COMMON)
1150 : {
1151 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1152 : "global identifier as entity at %L",
1153 : &common_root->n.common->where,
1154 1 : common_root->n.common->binding_label, &gsym->where);
1155 1 : return;
1156 : }
1157 57 : if (!gsym)
1158 : {
1159 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1160 57 : gsym->type = GSYM_COMMON;
1161 57 : gsym->where = common_root->n.common->where;
1162 57 : gsym->defined = 1;
1163 : }
1164 75 : gsym->used = 1;
1165 : }
1166 :
1167 1970 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1168 1970 : if (sym == NULL)
1169 : return;
1170 :
1171 122 : if (sym->attr.flavor == FL_PARAMETER)
1172 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1173 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1174 :
1175 122 : if (sym->attr.external)
1176 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1177 1 : sym->name, &common_root->n.common->where);
1178 :
1179 122 : if (sym->attr.intrinsic)
1180 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1181 2 : sym->name, &common_root->n.common->where);
1182 120 : else if (sym->attr.result
1183 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1184 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1185 : "that is also a function result", sym->name,
1186 1 : &common_root->n.common->where);
1187 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1188 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1189 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1190 : "that is also a global procedure", sym->name,
1191 3 : &common_root->n.common->where);
1192 : }
1193 :
1194 :
1195 : /* Resolve contained function types. Because contained functions can call one
1196 : another, they have to be worked out before any of the contained procedures
1197 : can be resolved.
1198 :
1199 : The good news is that if a function doesn't already have a type, the only
1200 : way it can get one is through an IMPLICIT type or a RESULT variable, because
1201 : by definition contained functions are contained namespace they're contained
1202 : in, not in a sibling or parent namespace. */
1203 :
1204 : static void
1205 364147 : resolve_contained_functions (gfc_namespace *ns)
1206 : {
1207 364147 : gfc_namespace *child;
1208 364147 : gfc_entry_list *el;
1209 :
1210 364147 : resolve_formal_arglists (ns);
1211 :
1212 402255 : for (child = ns->contained; child; child = child->sibling)
1213 : {
1214 : /* Resolve alternate entry points first. */
1215 38108 : resolve_entries (child);
1216 :
1217 : /* Then check function return types. */
1218 38108 : resolve_contained_fntype (child->proc_name, child);
1219 38615 : for (el = child->entries; el; el = el->next)
1220 507 : resolve_contained_fntype (el->sym, child);
1221 : }
1222 364147 : }
1223 :
1224 :
1225 :
1226 : /* A Parameterized Derived Type constructor must contain values for
1227 : the PDT KIND parameters or they must have a default initializer.
1228 : Go through the constructor picking out the KIND expressions,
1229 : storing them in 'param_list' and then call gfc_get_pdt_instance
1230 : to obtain the PDT instance. */
1231 :
1232 : static gfc_actual_arglist *param_list, *param_tail, *param;
1233 :
1234 : static bool
1235 440 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1236 : {
1237 440 : param = gfc_get_actual_arglist ();
1238 440 : if (!param_list)
1239 330 : param_list = param_tail = param;
1240 : else
1241 : {
1242 110 : param_tail->next = param;
1243 110 : param_tail = param_tail->next;
1244 : }
1245 :
1246 440 : param_tail->name = c->name;
1247 440 : if (expr)
1248 440 : param_tail->expr = gfc_copy_expr (expr);
1249 0 : else if (c->initializer)
1250 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1251 : else
1252 : {
1253 0 : param_tail->spec_type = SPEC_ASSUMED;
1254 0 : if (c->attr.pdt_kind)
1255 : {
1256 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1257 : "at %C has no value", param->name);
1258 0 : return false;
1259 : }
1260 : }
1261 :
1262 : return true;
1263 : }
1264 :
1265 : static bool
1266 378 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1267 : gfc_symbol *derived)
1268 : {
1269 378 : gfc_constructor *cons = NULL;
1270 378 : gfc_component *comp;
1271 378 : bool t = true;
1272 :
1273 378 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1274 342 : cons = gfc_constructor_first (expr->value.constructor);
1275 36 : else if (constr)
1276 36 : cons = *constr;
1277 378 : gcc_assert (cons);
1278 :
1279 378 : comp = derived->components;
1280 :
1281 1204 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1282 : {
1283 826 : if (cons->expr
1284 826 : && cons->expr->expr_type == EXPR_STRUCTURE
1285 12 : && comp->ts.type == BT_DERIVED)
1286 : {
1287 12 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1288 12 : if (!t)
1289 : return t;
1290 : }
1291 814 : else if (comp->ts.type == BT_DERIVED)
1292 : {
1293 36 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1294 36 : if (!t)
1295 : return t;
1296 : }
1297 778 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1298 440 : && derived->attr.pdt_template)
1299 : {
1300 440 : t = get_pdt_spec_expr (comp, cons->expr);
1301 440 : if (!t)
1302 : return t;
1303 : }
1304 : }
1305 : return t;
1306 : }
1307 :
1308 :
1309 : static bool resolve_fl_derived0 (gfc_symbol *sym);
1310 : static bool resolve_fl_struct (gfc_symbol *sym);
1311 :
1312 :
1313 : /* Resolve all of the elements of a structure constructor and make sure that
1314 : the types are correct. The 'init' flag indicates that the given
1315 : constructor is an initializer. */
1316 :
1317 : static bool
1318 65662 : resolve_structure_cons (gfc_expr *expr, int init)
1319 : {
1320 65662 : gfc_constructor *cons;
1321 65662 : gfc_component *comp;
1322 65662 : bool t;
1323 65662 : symbol_attribute a;
1324 :
1325 65662 : t = true;
1326 :
1327 65662 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1328 : {
1329 62598 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1330 62448 : resolve_fl_derived0 (expr->ts.u.derived);
1331 : else
1332 150 : resolve_fl_struct (expr->ts.u.derived);
1333 :
1334 : /* If this is a Parameterized Derived Type template, find the
1335 : instance corresponding to the PDT kind parameters. */
1336 62598 : if (expr->ts.u.derived->attr.pdt_template)
1337 : {
1338 330 : param_list = NULL;
1339 330 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1340 330 : if (!t)
1341 : return t;
1342 330 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1343 :
1344 330 : expr->param_list = gfc_copy_actual_arglist (param_list);
1345 :
1346 330 : if (param_list)
1347 330 : gfc_free_actual_arglist (param_list);
1348 :
1349 330 : if (!expr->ts.u.derived->attr.pdt_type)
1350 : return false;
1351 : }
1352 : }
1353 :
1354 : /* A constructor may have references if it is the result of substituting a
1355 : parameter variable. In this case we just pull out the component we
1356 : want. */
1357 65662 : if (expr->ref)
1358 160 : comp = expr->ref->u.c.sym->components;
1359 65502 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1360 : || expr->ts.type == BT_UNION)
1361 65500 : && expr->ts.u.derived)
1362 65500 : comp = expr->ts.u.derived->components;
1363 : else
1364 : return false;
1365 :
1366 65660 : cons = gfc_constructor_first (expr->value.constructor);
1367 :
1368 286660 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1369 : {
1370 155342 : int rank;
1371 :
1372 155342 : if (!cons->expr)
1373 10672 : continue;
1374 :
1375 : /* Unions use an EXPR_NULL contrived expression to tell the translation
1376 : phase to generate an initializer of the appropriate length.
1377 : Ignore it here. */
1378 144670 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1379 15 : continue;
1380 :
1381 144655 : if (!gfc_resolve_expr (cons->expr))
1382 : {
1383 0 : t = false;
1384 0 : continue;
1385 : }
1386 :
1387 144655 : rank = comp->as ? comp->as->rank : 0;
1388 144655 : if (comp->ts.type == BT_CLASS
1389 1915 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1390 1914 : && CLASS_DATA (comp)->as)
1391 579 : rank = CLASS_DATA (comp)->as->rank;
1392 :
1393 144655 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1394 276 : gfc_find_vtab (&cons->expr->ts);
1395 :
1396 144655 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1397 567 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1398 : {
1399 4 : gfc_error ("The rank of the element in the structure "
1400 : "constructor at %L does not match that of the "
1401 : "component (%d/%d)", &cons->expr->where,
1402 : cons->expr->rank, rank);
1403 4 : t = false;
1404 : }
1405 :
1406 : /* If we don't have the right type, try to convert it. */
1407 :
1408 252803 : if (!comp->attr.proc_pointer &&
1409 108148 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1410 : {
1411 13249 : if (strcmp (comp->name, "_extends") == 0)
1412 : {
1413 : /* Can afford to be brutal with the _extends initializer.
1414 : The derived type can get lost because it is PRIVATE
1415 : but it is not usage constrained by the standard. */
1416 9704 : cons->expr->ts = comp->ts;
1417 : }
1418 3545 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1419 : {
1420 2 : gfc_error ("The element in the structure constructor at %L, "
1421 : "for pointer component %qs, is %s but should be %s",
1422 2 : &cons->expr->where, comp->name,
1423 2 : gfc_basic_typename (cons->expr->ts.type),
1424 : gfc_basic_typename (comp->ts.type));
1425 2 : t = false;
1426 : }
1427 3543 : else if (!UNLIMITED_POLY (comp))
1428 : {
1429 3462 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1430 3462 : if (t)
1431 144655 : t = t2;
1432 : }
1433 : }
1434 :
1435 : /* For strings, the length of the constructor should be the same as
1436 : the one of the structure, ensure this if the lengths are known at
1437 : compile time and when we are dealing with PARAMETER or structure
1438 : constructors. Skip for PDT types which have type parameters. */
1439 144655 : if (!IS_PDT (expr) && cons->expr->ts.type == BT_CHARACTER
1440 3975 : && comp->ts.type == BT_CHARACTER
1441 3937 : && comp->ts.u.cl && comp->ts.u.cl->length
1442 2548 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1443 2531 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1444 957 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1445 957 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1446 957 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1447 957 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1448 957 : comp->ts.u.cl->length->value.integer) != 0)
1449 : {
1450 11 : if (comp->attr.pointer)
1451 : {
1452 3 : HOST_WIDE_INT la, lb;
1453 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1454 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1455 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1456 : "component %qs in constructor at %L",
1457 3 : la, lb, comp->name, &cons->expr->where);
1458 3 : t = false;
1459 : }
1460 :
1461 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1462 4 : && cons->expr->rank != 0
1463 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1464 : {
1465 : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1466 : to make use of the gfc_resolve_character_array_constructor
1467 : machinery. The expression is later simplified away to
1468 : an array of string literals. */
1469 1 : gfc_expr *para = cons->expr;
1470 1 : cons->expr = gfc_get_expr ();
1471 1 : cons->expr->ts = para->ts;
1472 1 : cons->expr->where = para->where;
1473 1 : cons->expr->expr_type = EXPR_ARRAY;
1474 1 : cons->expr->rank = para->rank;
1475 1 : cons->expr->corank = para->corank;
1476 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1477 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1478 1 : para, &cons->expr->where);
1479 : }
1480 :
1481 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1482 : {
1483 : /* Rely on the cleanup of the namespace to deal correctly with
1484 : the old charlen. (There was a block here that attempted to
1485 : remove the charlen but broke the chain in so doing.) */
1486 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1487 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1488 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1489 5 : gfc_resolve_character_array_constructor (cons->expr);
1490 : }
1491 : }
1492 :
1493 144655 : if (cons->expr->expr_type == EXPR_NULL
1494 43495 : && !(comp->attr.pointer || comp->attr.allocatable
1495 21709 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1496 1208 : || (comp->ts.type == BT_CLASS
1497 1206 : && (CLASS_DATA (comp)->attr.class_pointer
1498 989 : || CLASS_DATA (comp)->attr.allocatable))))
1499 : {
1500 2 : t = false;
1501 2 : gfc_error ("The NULL in the structure constructor at %L is "
1502 : "being applied to component %qs, which is neither "
1503 : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1504 : comp->name);
1505 : }
1506 :
1507 144655 : if (comp->attr.proc_pointer && comp->ts.interface)
1508 : {
1509 : /* Check procedure pointer interface. */
1510 16352 : gfc_symbol *s2 = NULL;
1511 16352 : gfc_component *c2;
1512 16352 : const char *name;
1513 16352 : char err[200];
1514 :
1515 16352 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1516 16352 : if (c2)
1517 : {
1518 12 : s2 = c2->ts.interface;
1519 12 : name = c2->name;
1520 : }
1521 16340 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1522 : {
1523 0 : s2 = cons->expr->symtree->n.sym->result;
1524 0 : name = cons->expr->symtree->n.sym->result->name;
1525 : }
1526 16340 : else if (cons->expr->expr_type != EXPR_NULL)
1527 : {
1528 15901 : s2 = cons->expr->symtree->n.sym;
1529 15901 : name = cons->expr->symtree->n.sym->name;
1530 : }
1531 :
1532 15913 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1533 : err, sizeof (err), NULL, NULL))
1534 : {
1535 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1536 : "component %qs in structure constructor at %L:"
1537 2 : " %s", comp->name, &cons->expr->where, err);
1538 2 : return false;
1539 : }
1540 : }
1541 :
1542 : /* Validate shape, except for dynamic or PDT arrays. */
1543 144653 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1544 2421 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1545 1677 : && !comp->attr.pdt_array)
1546 : {
1547 1388 : mpz_t len;
1548 1388 : mpz_init (len);
1549 4257 : for (int n = 0; n < rank; n++)
1550 : {
1551 1486 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1552 1481 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1553 : {
1554 5 : gfc_error ("Bad array spec of component %qs referenced in "
1555 : "structure constructor at %L",
1556 5 : comp->name, &cons->expr->where);
1557 5 : t = false;
1558 5 : break;
1559 1481 : };
1560 1481 : if (cons->expr->shape == NULL)
1561 12 : continue;
1562 1469 : mpz_set_ui (len, 1);
1563 1469 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1564 1469 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1565 1469 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1566 : {
1567 9 : gfc_error ("The shape of component %qs in the structure "
1568 : "constructor at %L differs from the shape of the "
1569 : "declared component for dimension %d (%ld/%ld)",
1570 : comp->name, &cons->expr->where, n+1,
1571 : mpz_get_si (cons->expr->shape[n]),
1572 : mpz_get_si (len));
1573 9 : t = false;
1574 : }
1575 : }
1576 1388 : mpz_clear (len);
1577 : }
1578 :
1579 144653 : if (!comp->attr.pointer || comp->attr.proc_pointer
1580 23323 : || cons->expr->expr_type == EXPR_NULL)
1581 133890 : continue;
1582 :
1583 10763 : a = gfc_expr_attr (cons->expr);
1584 :
1585 10763 : if (!a.pointer && !a.target)
1586 : {
1587 1 : t = false;
1588 1 : gfc_error ("The element in the structure constructor at %L, "
1589 : "for pointer component %qs should be a POINTER or "
1590 1 : "a TARGET", &cons->expr->where, comp->name);
1591 : }
1592 :
1593 10763 : if (init)
1594 : {
1595 : /* F08:C461. Additional checks for pointer initialization. */
1596 10692 : if (a.allocatable)
1597 : {
1598 0 : t = false;
1599 0 : gfc_error ("Pointer initialization target at %L "
1600 0 : "must not be ALLOCATABLE", &cons->expr->where);
1601 : }
1602 10692 : if (!a.save)
1603 : {
1604 0 : t = false;
1605 0 : gfc_error ("Pointer initialization target at %L "
1606 0 : "must have the SAVE attribute", &cons->expr->where);
1607 : }
1608 : }
1609 :
1610 : /* F2023:C770: A designator that is an initial-data-target shall ...
1611 : not have a vector subscript. */
1612 10763 : if (comp->attr.pointer && (a.pointer || a.target)
1613 21525 : && gfc_has_vector_index (cons->expr))
1614 : {
1615 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1616 1 : &cons->expr->where);
1617 1 : t = false;
1618 : }
1619 :
1620 : /* F2003, C1272 (3). */
1621 10763 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1622 10763 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1623 10726 : || gfc_is_coindexed (cons->expr));
1624 34 : if (impure && gfc_pure (NULL))
1625 : {
1626 1 : t = false;
1627 1 : gfc_error ("Invalid expression in the structure constructor for "
1628 : "pointer component %qs at %L in PURE procedure",
1629 1 : comp->name, &cons->expr->where);
1630 : }
1631 :
1632 10763 : if (impure)
1633 34 : gfc_unset_implicit_pure (NULL);
1634 : }
1635 :
1636 : return t;
1637 : }
1638 :
1639 :
1640 : /****************** Expression name resolution ******************/
1641 :
1642 : /* Returns 0 if a symbol was not declared with a type or
1643 : attribute declaration statement, nonzero otherwise. */
1644 :
1645 : static bool
1646 758642 : was_declared (gfc_symbol *sym)
1647 : {
1648 758642 : symbol_attribute a;
1649 :
1650 758642 : a = sym->attr;
1651 :
1652 758642 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1653 : return 1;
1654 :
1655 642533 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1656 633662 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1657 633660 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1658 633606 : || a.asynchronous || a.codimension
1659 633606 : || (a.subroutine && a.proc != PROC_UNKNOWN) || a.result)
1660 67476 : return 1;
1661 :
1662 : return 0;
1663 : }
1664 :
1665 :
1666 : /* Determine if a symbol is generic or not. */
1667 :
1668 : static int
1669 421770 : generic_sym (gfc_symbol *sym)
1670 : {
1671 421770 : gfc_symbol *s;
1672 :
1673 421770 : if (sym->attr.generic ||
1674 391642 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1675 : return 1;
1676 :
1677 390520 : if (was_declared (sym) || sym->ns->parent == NULL)
1678 : return 0;
1679 :
1680 80300 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1681 :
1682 80300 : if (s != NULL)
1683 : {
1684 163 : if (s == sym)
1685 : return 0;
1686 : else
1687 162 : return generic_sym (s);
1688 : }
1689 :
1690 : return 0;
1691 : }
1692 :
1693 :
1694 : /* Determine if a symbol is specific or not. */
1695 :
1696 : static int
1697 390432 : specific_sym (gfc_symbol *sym)
1698 : {
1699 390432 : gfc_symbol *s;
1700 :
1701 390432 : if (sym->attr.if_source == IFSRC_IFBODY
1702 378941 : || sym->attr.proc == PROC_MODULE
1703 349653 : || sym->attr.proc == PROC_INTERNAL
1704 300790 : || sym->attr.proc == PROC_ST_FUNCTION
1705 300500 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1706 690201 : || sym->attr.external)
1707 : return 1;
1708 :
1709 297357 : if (was_declared (sym) || sym->ns->parent == NULL)
1710 : return 0;
1711 :
1712 80198 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1713 :
1714 80198 : return (s == NULL) ? 0 : specific_sym (s);
1715 : }
1716 :
1717 :
1718 : /* Figure out if the procedure is specific, generic or unknown. */
1719 :
1720 : enum proc_type
1721 : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1722 :
1723 : static proc_type
1724 421459 : procedure_kind (gfc_symbol *sym)
1725 : {
1726 421459 : if (generic_sym (sym))
1727 : return PTYPE_GENERIC;
1728 :
1729 390355 : if (specific_sym (sym))
1730 93075 : return PTYPE_SPECIFIC;
1731 :
1732 : return PTYPE_UNKNOWN;
1733 : }
1734 :
1735 : /* Check references to assumed size arrays. The flag need_full_assumed_size
1736 : is nonzero when matching actual arguments. */
1737 :
1738 : static int need_full_assumed_size = 0;
1739 :
1740 : static bool
1741 1453286 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1742 : {
1743 1453286 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1744 : return false;
1745 :
1746 : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1747 : What should it be? */
1748 3832 : if (e->ref
1749 3830 : && e->ref->u.ar.as
1750 3829 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1751 3316 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1752 3316 : && (e->ref->u.ar.type == AR_FULL))
1753 : {
1754 25 : gfc_error ("The upper bound in the last dimension must "
1755 : "appear in the reference to the assumed size "
1756 : "array %qs at %L", sym->name, &e->where);
1757 25 : return true;
1758 : }
1759 : return false;
1760 : }
1761 :
1762 :
1763 : /* Look for bad assumed size array references in argument expressions
1764 : of elemental and array valued intrinsic procedures. Since this is
1765 : called from procedure resolution functions, it only recurses at
1766 : operators. */
1767 :
1768 : static bool
1769 234476 : resolve_assumed_size_actual (gfc_expr *e)
1770 : {
1771 234476 : if (e == NULL)
1772 : return false;
1773 :
1774 233907 : switch (e->expr_type)
1775 : {
1776 112586 : case EXPR_VARIABLE:
1777 112586 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1778 : return true;
1779 : break;
1780 :
1781 49841 : case EXPR_OP:
1782 49841 : if (resolve_assumed_size_actual (e->value.op.op1)
1783 49841 : || resolve_assumed_size_actual (e->value.op.op2))
1784 0 : return true;
1785 : break;
1786 :
1787 : default:
1788 : break;
1789 : }
1790 : return false;
1791 : }
1792 :
1793 :
1794 : /* Check a generic procedure, passed as an actual argument, to see if
1795 : there is a matching specific name. If none, it is an error, and if
1796 : more than one, the reference is ambiguous. */
1797 : static int
1798 8 : count_specific_procs (gfc_expr *e)
1799 : {
1800 8 : int n;
1801 8 : gfc_interface *p;
1802 8 : gfc_symbol *sym;
1803 :
1804 8 : n = 0;
1805 8 : sym = e->symtree->n.sym;
1806 :
1807 22 : for (p = sym->generic; p; p = p->next)
1808 14 : if (strcmp (sym->name, p->sym->name) == 0)
1809 : {
1810 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1811 : sym->name);
1812 8 : n++;
1813 : }
1814 :
1815 8 : if (n > 1)
1816 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1817 : &e->where);
1818 :
1819 8 : if (n == 0)
1820 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1821 : "argument at %L", sym->name, &e->where);
1822 :
1823 8 : return n;
1824 : }
1825 :
1826 :
1827 : /* See if a call to sym could possibly be a not allowed RECURSION because of
1828 : a missing RECURSIVE declaration. This means that either sym is the current
1829 : context itself, or sym is the parent of a contained procedure calling its
1830 : non-RECURSIVE containing procedure.
1831 : This also works if sym is an ENTRY. */
1832 :
1833 : static bool
1834 155651 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1835 : {
1836 155651 : gfc_symbol* proc_sym;
1837 155651 : gfc_symbol* context_proc;
1838 155651 : gfc_namespace* real_context;
1839 :
1840 155651 : if (sym->attr.flavor == FL_PROGRAM
1841 : || gfc_fl_struct (sym->attr.flavor))
1842 : return false;
1843 :
1844 : /* If we've got an ENTRY, find real procedure. */
1845 155650 : if (sym->attr.entry && sym->ns->entries)
1846 45 : proc_sym = sym->ns->entries->sym;
1847 : else
1848 : proc_sym = sym;
1849 :
1850 : /* If sym is RECURSIVE, all is well of course. */
1851 155650 : if (proc_sym->attr.recursive || flag_recursive)
1852 : return false;
1853 :
1854 : /* Find the context procedure's "real" symbol if it has entries.
1855 : We look for a procedure symbol, so recurse on the parents if we don't
1856 : find one (like in case of a BLOCK construct). */
1857 2027 : for (real_context = context; ; real_context = real_context->parent)
1858 : {
1859 : /* We should find something, eventually! */
1860 131957 : gcc_assert (real_context);
1861 :
1862 131957 : context_proc = (real_context->entries ? real_context->entries->sym
1863 : : real_context->proc_name);
1864 :
1865 : /* In some special cases, there may not be a proc_name, like for this
1866 : invalid code:
1867 : real(bad_kind()) function foo () ...
1868 : when checking the call to bad_kind ().
1869 : In these cases, we simply return here and assume that the
1870 : call is ok. */
1871 131957 : if (!context_proc)
1872 : return false;
1873 :
1874 131693 : if (context_proc->attr.flavor != FL_LABEL)
1875 : break;
1876 : }
1877 :
1878 : /* A call from sym's body to itself is recursion, of course. */
1879 129666 : if (context_proc == proc_sym)
1880 : return true;
1881 :
1882 : /* The same is true if context is a contained procedure and sym the
1883 : containing one. */
1884 129651 : if (context_proc->attr.contained)
1885 : {
1886 21865 : gfc_symbol* parent_proc;
1887 :
1888 21865 : gcc_assert (context->parent);
1889 21865 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1890 : : context->parent->proc_name);
1891 :
1892 21865 : if (parent_proc == proc_sym)
1893 9 : return true;
1894 : }
1895 :
1896 : return false;
1897 : }
1898 :
1899 :
1900 : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1901 : its typespec and formal argument list. */
1902 :
1903 : bool
1904 47605 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1905 : {
1906 47605 : gfc_intrinsic_sym* isym = NULL;
1907 47605 : const char* symstd;
1908 :
1909 47605 : if (sym->resolve_symbol_called >= 2)
1910 : return true;
1911 :
1912 37532 : sym->resolve_symbol_called = 2;
1913 :
1914 : /* Already resolved. */
1915 37532 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1916 : return true;
1917 :
1918 : /* We already know this one is an intrinsic, so we don't call
1919 : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1920 : gfc_find_subroutine directly to check whether it is a function or
1921 : subroutine. */
1922 :
1923 29458 : if (sym->intmod_sym_id && sym->attr.subroutine)
1924 : {
1925 12811 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1926 12811 : isym = gfc_intrinsic_subroutine_by_id (id);
1927 12811 : }
1928 16647 : else if (sym->intmod_sym_id)
1929 : {
1930 12754 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1931 12754 : isym = gfc_intrinsic_function_by_id (id);
1932 : }
1933 3893 : else if (!sym->attr.subroutine)
1934 3806 : isym = gfc_find_function (sym->name);
1935 :
1936 29371 : if (isym && !sym->attr.subroutine)
1937 : {
1938 16515 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1939 24 : && !sym->attr.implicit_type)
1940 10 : gfc_warning (OPT_Wsurprising,
1941 : "Type specified for intrinsic function %qs at %L is"
1942 : " ignored", sym->name, &sym->declared_at);
1943 :
1944 21098 : if (!sym->attr.function &&
1945 4583 : !gfc_add_function(&sym->attr, sym->name, loc))
1946 : return false;
1947 :
1948 16515 : sym->ts = isym->ts;
1949 : }
1950 12943 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1951 : {
1952 12940 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1953 : {
1954 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1955 : " specifier", sym->name, &sym->declared_at);
1956 1 : return false;
1957 : }
1958 :
1959 12980 : if (!sym->attr.subroutine &&
1960 41 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1961 : return false;
1962 : }
1963 : else
1964 : {
1965 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1966 : &sym->declared_at);
1967 3 : return false;
1968 : }
1969 :
1970 29453 : gfc_copy_formal_args_intr (sym, isym, NULL);
1971 :
1972 29453 : sym->attr.pure = isym->pure;
1973 29453 : sym->attr.elemental = isym->elemental;
1974 :
1975 : /* Check it is actually available in the standard settings. */
1976 29453 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1977 : {
1978 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1979 : "available in the current standard settings but %s. Use "
1980 : "an appropriate %<-std=*%> option or enable "
1981 : "%<-fall-intrinsics%> in order to use it.",
1982 : sym->name, &sym->declared_at, symstd);
1983 31 : return false;
1984 : }
1985 :
1986 : return true;
1987 : }
1988 :
1989 :
1990 : /* Resolve a procedure expression, like passing it to a called procedure or as
1991 : RHS for a procedure pointer assignment. */
1992 :
1993 : static bool
1994 1354436 : resolve_procedure_expression (gfc_expr* expr)
1995 : {
1996 1354436 : gfc_symbol* sym;
1997 :
1998 1354436 : if (expr->expr_type != EXPR_VARIABLE)
1999 : return true;
2000 1354419 : gcc_assert (expr->symtree);
2001 :
2002 1354419 : sym = expr->symtree->n.sym;
2003 :
2004 1354419 : if (sym->attr.intrinsic)
2005 1360 : gfc_resolve_intrinsic (sym, &expr->where);
2006 :
2007 1354419 : if (sym->attr.flavor != FL_PROCEDURE
2008 32953 : || (sym->attr.function && sym->result == sym))
2009 : return true;
2010 :
2011 : /* A non-RECURSIVE procedure that is used as procedure expression within its
2012 : own body is in danger of being called recursively. */
2013 18089 : if (is_illegal_recursion (sym, gfc_current_ns))
2014 : {
2015 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
2016 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
2017 : " possibly calling itself recursively in procedure %qs. "
2018 : " Declare it RECURSIVE or use %<-frecursive%>",
2019 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
2020 : else
2021 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
2022 : " itself recursively. Declare it RECURSIVE or use"
2023 : " %<-frecursive%>", sym->name, &expr->where);
2024 : }
2025 :
2026 : return true;
2027 : }
2028 :
2029 :
2030 : /* Check that name is not a derived type. */
2031 :
2032 : static bool
2033 3435 : is_dt_name (const char *name)
2034 : {
2035 3435 : gfc_symbol *dt_list, *dt_first;
2036 :
2037 3435 : dt_list = dt_first = gfc_derived_types;
2038 5889 : for (; dt_list; dt_list = dt_list->dt_next)
2039 : {
2040 3577 : if (strcmp(dt_list->name, name) == 0)
2041 : return true;
2042 3574 : if (dt_first == dt_list->dt_next)
2043 : break;
2044 : }
2045 : return false;
2046 : }
2047 :
2048 :
2049 : /* Resolve an actual argument list. Most of the time, this is just
2050 : resolving the expressions in the list.
2051 : The exception is that we sometimes have to decide whether arguments
2052 : that look like procedure arguments are really simple variable
2053 : references. */
2054 :
2055 : static bool
2056 436659 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2057 : bool no_formal_args)
2058 : {
2059 436659 : gfc_symbol *sym = NULL;
2060 436659 : gfc_symtree *parent_st;
2061 436659 : gfc_expr *e;
2062 436659 : gfc_component *comp;
2063 436659 : int save_need_full_assumed_size;
2064 436659 : bool return_value = false;
2065 436659 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2066 :
2067 436659 : actual_arg = true;
2068 436659 : first_actual_arg = true;
2069 :
2070 1117690 : for (; arg; arg = arg->next)
2071 : {
2072 681132 : e = arg->expr;
2073 681132 : if (e == NULL)
2074 : {
2075 : /* Check the label is a valid branching target. */
2076 2617 : if (arg->label)
2077 : {
2078 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2079 : {
2080 0 : gfc_error ("Label %d referenced at %L is never defined",
2081 : arg->label->value, &arg->label->where);
2082 0 : goto cleanup;
2083 : }
2084 : }
2085 2617 : first_actual_arg = false;
2086 2617 : continue;
2087 : }
2088 :
2089 678515 : if (e->expr_type == EXPR_VARIABLE
2090 299804 : && e->symtree->n.sym->attr.generic
2091 8 : && no_formal_args
2092 678520 : && count_specific_procs (e) != 1)
2093 2 : goto cleanup;
2094 :
2095 678513 : if (e->ts.type != BT_PROCEDURE)
2096 : {
2097 604313 : save_need_full_assumed_size = need_full_assumed_size;
2098 604313 : if (e->expr_type != EXPR_VARIABLE)
2099 378711 : need_full_assumed_size = 0;
2100 604313 : if (!gfc_resolve_expr (e))
2101 60 : goto cleanup;
2102 604253 : need_full_assumed_size = save_need_full_assumed_size;
2103 604253 : goto argument_list;
2104 : }
2105 :
2106 : /* See if the expression node should really be a variable reference. */
2107 :
2108 74200 : sym = e->symtree->n.sym;
2109 :
2110 74200 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2111 : {
2112 3 : gfc_error ("Derived type %qs is used as an actual "
2113 : "argument at %L", sym->name, &e->where);
2114 3 : goto cleanup;
2115 : }
2116 :
2117 74197 : if (sym->attr.flavor == FL_PROCEDURE
2118 70765 : || sym->attr.intrinsic
2119 70765 : || sym->attr.external)
2120 : {
2121 3432 : int actual_ok;
2122 :
2123 : /* If a procedure is not already determined to be something else
2124 : check if it is intrinsic. */
2125 3432 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2126 1254 : sym->attr.intrinsic = 1;
2127 :
2128 3432 : if (sym->attr.proc == PROC_ST_FUNCTION)
2129 : {
2130 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2131 : "actual argument", sym->name, &e->where);
2132 : }
2133 :
2134 6864 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2135 3432 : sym->attr.subroutine);
2136 3432 : if (sym->attr.intrinsic && actual_ok == 0)
2137 : {
2138 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2139 : "actual argument", sym->name, &e->where);
2140 : }
2141 :
2142 3432 : if (sym->attr.contained && !sym->attr.use_assoc
2143 444 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2144 : {
2145 256 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2146 : " used as actual argument at %L",
2147 : sym->name, &e->where))
2148 3 : goto cleanup;
2149 : }
2150 :
2151 3429 : if (sym->attr.elemental && !sym->attr.intrinsic)
2152 : {
2153 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2154 : "allowed as an actual argument at %L", sym->name,
2155 : &e->where);
2156 : }
2157 :
2158 : /* Check if a generic interface has a specific procedure
2159 : with the same name before emitting an error. */
2160 3429 : if (sym->attr.generic && count_specific_procs (e) != 1)
2161 0 : goto cleanup;
2162 :
2163 : /* Just in case a specific was found for the expression. */
2164 3429 : sym = e->symtree->n.sym;
2165 :
2166 : /* If the symbol is the function that names the current (or
2167 : parent) scope, then we really have a variable reference. */
2168 :
2169 3429 : if (gfc_is_function_return_value (sym, sym->ns))
2170 0 : goto got_variable;
2171 :
2172 : /* If all else fails, see if we have a specific intrinsic. */
2173 3429 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2174 : {
2175 0 : gfc_intrinsic_sym *isym;
2176 :
2177 0 : isym = gfc_find_function (sym->name);
2178 0 : if (isym == NULL || !isym->specific)
2179 : {
2180 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2181 : "for the reference %qs at %L", sym->name,
2182 : &e->where);
2183 0 : goto cleanup;
2184 : }
2185 0 : sym->ts = isym->ts;
2186 0 : sym->attr.intrinsic = 1;
2187 0 : sym->attr.function = 1;
2188 : }
2189 :
2190 3429 : if (!gfc_resolve_expr (e))
2191 0 : goto cleanup;
2192 3429 : goto argument_list;
2193 : }
2194 :
2195 : /* See if the name is a module procedure in a parent unit. */
2196 :
2197 70765 : if (was_declared (sym) || sym->ns->parent == NULL)
2198 70671 : goto got_variable;
2199 :
2200 94 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2201 : {
2202 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2203 0 : goto cleanup;
2204 : }
2205 :
2206 94 : if (parent_st == NULL)
2207 94 : goto got_variable;
2208 :
2209 0 : sym = parent_st->n.sym;
2210 0 : e->symtree = parent_st; /* Point to the right thing. */
2211 :
2212 0 : if (sym->attr.flavor == FL_PROCEDURE
2213 0 : || sym->attr.intrinsic
2214 0 : || sym->attr.external)
2215 : {
2216 0 : if (!gfc_resolve_expr (e))
2217 0 : goto cleanup;
2218 0 : goto argument_list;
2219 : }
2220 :
2221 0 : got_variable:
2222 70765 : e->expr_type = EXPR_VARIABLE;
2223 70765 : e->ts = sym->ts;
2224 70765 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2225 36569 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2226 3948 : && CLASS_DATA (sym)->as))
2227 : {
2228 39880 : gfc_array_spec *as
2229 37038 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2230 37038 : e->rank = as->rank;
2231 37038 : e->corank = as->corank;
2232 37038 : e->ref = gfc_get_ref ();
2233 37038 : e->ref->type = REF_ARRAY;
2234 37038 : e->ref->u.ar.type = AR_FULL;
2235 37038 : e->ref->u.ar.as = as;
2236 : }
2237 :
2238 : /* These symbols are set untyped by calls to gfc_set_default_type
2239 : with 'error_flag' = false. Reset the untyped attribute so that
2240 : the error will be generated in gfc_resolve_expr. */
2241 70765 : if (e->expr_type == EXPR_VARIABLE
2242 70765 : && sym->ts.type == BT_UNKNOWN
2243 36 : && sym->attr.untyped)
2244 5 : sym->attr.untyped = 0;
2245 :
2246 : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2247 : primary.cc (match_actual_arg). If above code determines that it
2248 : is a variable instead, it needs to be resolved as it was not
2249 : done at the beginning of this function. */
2250 70765 : save_need_full_assumed_size = need_full_assumed_size;
2251 70765 : if (e->expr_type != EXPR_VARIABLE)
2252 0 : need_full_assumed_size = 0;
2253 70765 : if (!gfc_resolve_expr (e))
2254 22 : goto cleanup;
2255 70743 : need_full_assumed_size = save_need_full_assumed_size;
2256 :
2257 678425 : argument_list:
2258 : /* Check argument list functions %VAL, %LOC and %REF. There is
2259 : nothing to do for %REF. */
2260 678425 : if (arg->name && arg->name[0] == '%')
2261 : {
2262 42 : if (strcmp ("%VAL", arg->name) == 0)
2263 : {
2264 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2265 : {
2266 2 : gfc_error ("By-value argument at %L is not of numeric "
2267 : "type", &e->where);
2268 2 : goto cleanup;
2269 : }
2270 :
2271 26 : if (e->rank)
2272 : {
2273 1 : gfc_error ("By-value argument at %L cannot be an array or "
2274 : "an array section", &e->where);
2275 1 : goto cleanup;
2276 : }
2277 :
2278 : /* Intrinsics are still PROC_UNKNOWN here. However,
2279 : since same file external procedures are not resolvable
2280 : in gfortran, it is a good deal easier to leave them to
2281 : intrinsic.cc. */
2282 25 : if (ptype != PROC_UNKNOWN
2283 25 : && ptype != PROC_DUMMY
2284 9 : && ptype != PROC_EXTERNAL
2285 9 : && ptype != PROC_MODULE)
2286 : {
2287 3 : gfc_error ("By-value argument at %L is not allowed "
2288 : "in this context", &e->where);
2289 3 : goto cleanup;
2290 : }
2291 : }
2292 :
2293 : /* Statement functions have already been excluded above. */
2294 14 : else if (strcmp ("%LOC", arg->name) == 0
2295 8 : && e->ts.type == BT_PROCEDURE)
2296 : {
2297 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2298 : {
2299 0 : gfc_error ("Passing internal procedure at %L by location "
2300 : "not allowed", &e->where);
2301 0 : goto cleanup;
2302 : }
2303 : }
2304 : }
2305 :
2306 678419 : comp = gfc_get_proc_ptr_comp(e);
2307 678419 : if (e->expr_type == EXPR_VARIABLE
2308 298426 : && comp && comp->attr.elemental)
2309 : {
2310 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2311 : "allowed as an actual argument at %L", comp->name,
2312 : &e->where);
2313 : }
2314 :
2315 : /* Fortran 2008, C1237. */
2316 298426 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2317 678870 : && gfc_has_ultimate_pointer (e))
2318 : {
2319 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2320 : "component", &e->where);
2321 3 : goto cleanup;
2322 : }
2323 :
2324 678416 : if (e->expr_type == EXPR_VARIABLE
2325 298423 : && e->ts.type == BT_PROCEDURE
2326 3429 : && no_formal_args
2327 1505 : && sym->attr.flavor == FL_PROCEDURE
2328 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2329 142 : && !sym->attr.external
2330 2 : && !sym->attr.intrinsic
2331 2 : && !sym->attr.artificial
2332 2 : && !sym->ts.interface)
2333 : {
2334 : /* Emit a warning for -std=legacy and an error otherwise. */
2335 2 : if (gfc_option.warn_std == 0)
2336 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2337 : "does neither have an explicit interface nor the "
2338 : "EXTERNAL attribute", sym->name, &e->where);
2339 : else
2340 : {
2341 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2342 : "does neither have an explicit interface nor the "
2343 : "EXTERNAL attribute", sym->name, &e->where);
2344 2 : goto cleanup;
2345 : }
2346 : }
2347 :
2348 678414 : first_actual_arg = false;
2349 : }
2350 :
2351 : return_value = true;
2352 :
2353 436659 : cleanup:
2354 436659 : actual_arg = actual_arg_sav;
2355 436659 : first_actual_arg = first_actual_arg_sav;
2356 :
2357 436659 : return return_value;
2358 : }
2359 :
2360 :
2361 : /* Do the checks of the actual argument list that are specific to elemental
2362 : procedures. If called with c == NULL, we have a function, otherwise if
2363 : expr == NULL, we have a subroutine. */
2364 :
2365 : static bool
2366 332672 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2367 : {
2368 332672 : gfc_actual_arglist *arg0;
2369 332672 : gfc_actual_arglist *arg;
2370 332672 : gfc_symbol *esym = NULL;
2371 332672 : gfc_intrinsic_sym *isym = NULL;
2372 332672 : gfc_expr *e = NULL;
2373 332672 : gfc_intrinsic_arg *iformal = NULL;
2374 332672 : gfc_formal_arglist *eformal = NULL;
2375 332672 : bool formal_optional = false;
2376 332672 : bool set_by_optional = false;
2377 332672 : int i;
2378 332672 : int rank = 0;
2379 :
2380 : /* Is this an elemental procedure? */
2381 332672 : if (expr && expr->value.function.actual != NULL)
2382 : {
2383 241043 : if (expr->value.function.esym != NULL
2384 44685 : && expr->value.function.esym->attr.elemental)
2385 : {
2386 : arg0 = expr->value.function.actual;
2387 : esym = expr->value.function.esym;
2388 : }
2389 224729 : else if (expr->value.function.isym != NULL
2390 195291 : && expr->value.function.isym->elemental)
2391 : {
2392 : arg0 = expr->value.function.actual;
2393 : isym = expr->value.function.isym;
2394 : }
2395 : else
2396 : return true;
2397 : }
2398 91629 : else if (c && c->ext.actual != NULL)
2399 : {
2400 72279 : arg0 = c->ext.actual;
2401 :
2402 72279 : if (c->resolved_sym)
2403 : esym = c->resolved_sym;
2404 : else
2405 323 : esym = c->symtree->n.sym;
2406 72279 : gcc_assert (esym);
2407 :
2408 72279 : if (!esym->attr.elemental)
2409 : return true;
2410 : }
2411 : else
2412 : return true;
2413 :
2414 : /* The rank of an elemental is the rank of its array argument(s). */
2415 176959 : for (arg = arg0; arg; arg = arg->next)
2416 : {
2417 114490 : if (arg->expr != NULL && arg->expr->rank != 0)
2418 : {
2419 10788 : rank = arg->expr->rank;
2420 10788 : if (arg->expr->expr_type == EXPR_VARIABLE
2421 5508 : && arg->expr->symtree->n.sym->attr.optional)
2422 10788 : set_by_optional = true;
2423 :
2424 : /* Function specific; set the result rank and shape. */
2425 10788 : if (expr)
2426 : {
2427 8380 : expr->rank = rank;
2428 8380 : expr->corank = arg->expr->corank;
2429 8380 : if (!expr->shape && arg->expr->shape)
2430 : {
2431 3986 : expr->shape = gfc_get_shape (rank);
2432 8767 : for (i = 0; i < rank; i++)
2433 4781 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2434 : }
2435 : }
2436 : break;
2437 : }
2438 : }
2439 :
2440 : /* If it is an array, it shall not be supplied as an actual argument
2441 : to an elemental procedure unless an array of the same rank is supplied
2442 : as an actual argument corresponding to a nonoptional dummy argument of
2443 : that elemental procedure(12.4.1.5). */
2444 73257 : formal_optional = false;
2445 73257 : if (isym)
2446 50730 : iformal = isym->formal;
2447 : else
2448 22527 : eformal = esym->formal;
2449 :
2450 193269 : for (arg = arg0; arg; arg = arg->next)
2451 : {
2452 120012 : if (eformal)
2453 : {
2454 40423 : if (eformal->sym && eformal->sym->attr.optional)
2455 40423 : formal_optional = true;
2456 40423 : eformal = eformal->next;
2457 : }
2458 79589 : else if (isym && iformal)
2459 : {
2460 68664 : if (iformal->optional)
2461 13657 : formal_optional = true;
2462 68664 : iformal = iformal->next;
2463 : }
2464 10925 : else if (isym)
2465 10917 : formal_optional = true;
2466 :
2467 120012 : if (pedantic && arg->expr != NULL
2468 68407 : && arg->expr->expr_type == EXPR_VARIABLE
2469 32185 : && arg->expr->symtree->n.sym->attr.optional
2470 578 : && formal_optional
2471 485 : && arg->expr->rank
2472 159 : && (set_by_optional || arg->expr->rank != rank)
2473 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2474 : {
2475 114 : bool t = false;
2476 : gfc_actual_arglist *a;
2477 :
2478 : /* Scan the argument list for a non-optional argument with the
2479 : same rank as arg. */
2480 114 : for (a = arg0; a; a = a->next)
2481 87 : if (a != arg
2482 45 : && a->expr->rank == arg->expr->rank
2483 39 : && (a->expr->expr_type != EXPR_VARIABLE
2484 37 : || (a->expr->expr_type == EXPR_VARIABLE
2485 37 : && !a->expr->symtree->n.sym->attr.optional)))
2486 : {
2487 : t = true;
2488 : break;
2489 : }
2490 :
2491 42 : if (!t)
2492 27 : gfc_warning (OPT_Wpedantic,
2493 : "%qs at %L is an array and OPTIONAL; If it is not "
2494 : "present, then it cannot be the actual argument of "
2495 : "an ELEMENTAL procedure unless there is a non-optional"
2496 : " argument with the same rank "
2497 : "(Fortran 2018, 15.5.2.12)",
2498 : arg->expr->symtree->n.sym->name, &arg->expr->where);
2499 : }
2500 : }
2501 :
2502 193258 : for (arg = arg0; arg; arg = arg->next)
2503 : {
2504 120010 : if (arg->expr == NULL || arg->expr->rank == 0)
2505 106328 : continue;
2506 :
2507 : /* Being elemental, the last upper bound of an assumed size array
2508 : argument must be present. */
2509 13682 : if (resolve_assumed_size_actual (arg->expr))
2510 : return false;
2511 :
2512 : /* Elemental procedure's array actual arguments must conform. */
2513 13679 : if (e != NULL)
2514 : {
2515 2894 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2516 : return false;
2517 : }
2518 : else
2519 10785 : e = arg->expr;
2520 : }
2521 :
2522 : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2523 : is an array, the intent inout/out variable needs to be also an array. */
2524 73248 : if (rank > 0 && esym && expr == NULL)
2525 7333 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2526 4931 : arg = arg->next, eformal = eformal->next)
2527 4933 : if (eformal->sym
2528 4932 : && (eformal->sym->attr.intent == INTENT_OUT
2529 3850 : || eformal->sym->attr.intent == INTENT_INOUT)
2530 1716 : && arg->expr && arg->expr->rank == 0)
2531 : {
2532 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2533 : "ELEMENTAL subroutine %qs is a scalar, but another "
2534 : "actual argument is an array", &arg->expr->where,
2535 : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2536 : : "INOUT", eformal->sym->name, esym->name);
2537 2 : return false;
2538 : }
2539 : return true;
2540 : }
2541 :
2542 :
2543 : /* This function does the checking of references to global procedures
2544 : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2545 : 77 and 95 standards. It checks for a gsymbol for the name, making
2546 : one if it does not already exist. If it already exists, then the
2547 : reference being resolved must correspond to the type of gsymbol.
2548 : Otherwise, the new symbol is equipped with the attributes of the
2549 : reference. The corresponding code that is called in creating
2550 : global entities is parse.cc.
2551 :
2552 : In addition, for all but -std=legacy, the gsymbols are used to
2553 : check the interfaces of external procedures from the same file.
2554 : The namespace of the gsymbol is resolved and then, once this is
2555 : done the interface is checked. */
2556 :
2557 :
2558 : static bool
2559 15015 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2560 : {
2561 15015 : if (!gsym_ns->proc_name->attr.recursive)
2562 : return true;
2563 :
2564 151 : if (sym->ns == gsym_ns)
2565 : return false;
2566 :
2567 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2568 0 : return false;
2569 :
2570 : return true;
2571 : }
2572 :
2573 : static bool
2574 15015 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2575 : {
2576 15015 : if (gsym_ns->entries)
2577 : {
2578 : gfc_entry_list *entry = gsym_ns->entries;
2579 :
2580 3312 : for (; entry; entry = entry->next)
2581 : {
2582 2333 : if (strcmp (sym->name, entry->sym->name) == 0)
2583 : {
2584 971 : if (strcmp (gsym_ns->proc_name->name,
2585 971 : sym->ns->proc_name->name) == 0)
2586 : return false;
2587 :
2588 971 : if (sym->ns->parent
2589 0 : && strcmp (gsym_ns->proc_name->name,
2590 0 : sym->ns->parent->proc_name->name) == 0)
2591 : return false;
2592 : }
2593 : }
2594 : }
2595 : return true;
2596 : }
2597 :
2598 :
2599 : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2600 :
2601 : bool
2602 15869 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2603 : {
2604 15869 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2605 :
2606 59191 : for ( ; arg; arg = arg->next)
2607 : {
2608 27873 : if (!arg->sym)
2609 157 : continue;
2610 :
2611 27716 : if (arg->sym->attr.allocatable) /* (2a) */
2612 : {
2613 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2614 0 : return true;
2615 : }
2616 27716 : else if (arg->sym->attr.asynchronous)
2617 : {
2618 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2619 0 : return true;
2620 : }
2621 27716 : else if (arg->sym->attr.optional)
2622 : {
2623 75 : strncpy (errmsg, _("optional argument"), err_len);
2624 75 : return true;
2625 : }
2626 27641 : else if (arg->sym->attr.pointer)
2627 : {
2628 12 : strncpy (errmsg, _("pointer argument"), err_len);
2629 12 : return true;
2630 : }
2631 27629 : else if (arg->sym->attr.target)
2632 : {
2633 72 : strncpy (errmsg, _("target argument"), err_len);
2634 72 : return true;
2635 : }
2636 27557 : else if (arg->sym->attr.value)
2637 : {
2638 12 : strncpy (errmsg, _("value argument"), err_len);
2639 12 : return true;
2640 : }
2641 27545 : else if (arg->sym->attr.volatile_)
2642 : {
2643 1 : strncpy (errmsg, _("volatile argument"), err_len);
2644 1 : return true;
2645 : }
2646 27544 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2647 : {
2648 81 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2649 81 : return true;
2650 : }
2651 27463 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2652 : {
2653 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2654 1 : return true;
2655 : }
2656 27462 : else if (arg->sym->attr.codimension) /* (2c) */
2657 : {
2658 1 : strncpy (errmsg, _("coarray argument"), err_len);
2659 1 : return true;
2660 : }
2661 27461 : else if (false) /* (2d) TODO: parametrized derived type */
2662 : {
2663 : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2664 : return true;
2665 : }
2666 27461 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2667 : {
2668 164 : strncpy (errmsg, _("polymorphic argument"), err_len);
2669 164 : return true;
2670 : }
2671 27297 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2672 : {
2673 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2674 0 : return true;
2675 : }
2676 27297 : else if (arg->sym->ts.type == BT_ASSUMED)
2677 : {
2678 : /* As assumed-type is unlimited polymorphic (cf. above).
2679 : See also TS 29113, Note 6.1. */
2680 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2681 1 : return true;
2682 : }
2683 : }
2684 :
2685 15449 : if (sym->attr.function)
2686 : {
2687 3499 : gfc_symbol *res = sym->result ? sym->result : sym;
2688 :
2689 3499 : if (res->attr.dimension) /* (3a) */
2690 : {
2691 93 : strncpy (errmsg, _("array result"), err_len);
2692 93 : return true;
2693 : }
2694 3406 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2695 : {
2696 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2697 38 : return true;
2698 : }
2699 3368 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2700 347 : && res->ts.u.cl->length
2701 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2702 : {
2703 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2704 12 : return true;
2705 : }
2706 : }
2707 :
2708 15306 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2709 : {
2710 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2711 7 : return true;
2712 : }
2713 15299 : else if (sym->attr.is_bind_c) /* (5) */
2714 : {
2715 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2716 0 : return true;
2717 : }
2718 :
2719 : return false;
2720 : }
2721 :
2722 :
2723 : static void
2724 29913 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2725 : {
2726 29913 : gfc_gsymbol * gsym;
2727 29913 : gfc_namespace *ns;
2728 29913 : enum gfc_symbol_type type;
2729 29913 : char reason[200];
2730 :
2731 29913 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2732 :
2733 29913 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2734 29913 : sym->binding_label != NULL);
2735 :
2736 29913 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2737 9 : gfc_global_used (gsym, where);
2738 :
2739 29913 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2740 9660 : || sym->attr.if_source == IFSRC_IFBODY)
2741 25228 : && gsym->type != GSYM_UNKNOWN
2742 23034 : && !gsym->binding_label
2743 20681 : && gsym->ns
2744 15015 : && gsym->ns->proc_name
2745 15015 : && not_in_recursive (sym, gsym->ns)
2746 44928 : && not_entry_self_reference (sym, gsym->ns))
2747 : {
2748 15015 : gfc_symbol *def_sym;
2749 15015 : def_sym = gsym->ns->proc_name;
2750 :
2751 15015 : if (gsym->ns->resolved != -1)
2752 : {
2753 :
2754 : /* Resolve the gsymbol namespace if needed. */
2755 14993 : if (!gsym->ns->resolved)
2756 : {
2757 2794 : gfc_symbol *old_dt_list;
2758 :
2759 : /* Stash away derived types so that the backend_decls
2760 : do not get mixed up. */
2761 2794 : old_dt_list = gfc_derived_types;
2762 2794 : gfc_derived_types = NULL;
2763 :
2764 2794 : gfc_resolve (gsym->ns);
2765 :
2766 : /* Store the new derived types with the global namespace. */
2767 2794 : if (gfc_derived_types)
2768 306 : gsym->ns->derived_types = gfc_derived_types;
2769 :
2770 : /* Restore the derived types of this namespace. */
2771 2794 : gfc_derived_types = old_dt_list;
2772 : }
2773 :
2774 : /* Make sure that translation for the gsymbol occurs before
2775 : the procedure currently being resolved. */
2776 14993 : ns = gfc_global_ns_list;
2777 25466 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2778 : {
2779 17051 : if (ns->sibling == gsym->ns)
2780 : {
2781 6578 : ns->sibling = gsym->ns->sibling;
2782 6578 : gsym->ns->sibling = gfc_global_ns_list;
2783 6578 : gfc_global_ns_list = gsym->ns;
2784 6578 : break;
2785 : }
2786 : }
2787 :
2788 : /* This can happen if a binding name has been specified. */
2789 14993 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2790 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2791 : }
2792 :
2793 : /* Look up the specific entry symbol so that interface checks use
2794 : the entry's own formal argument list, not the entry master's.
2795 : This must run even when resolved == -1 (recursive resolution in
2796 : progress), because def_sym starts as the namespace proc_name
2797 : which is the entry master with the combined formals. */
2798 15015 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2799 : {
2800 979 : gfc_entry_list *entry;
2801 1699 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2802 1699 : if (strcmp (entry->sym->name, sym->name) == 0)
2803 : {
2804 979 : def_sym = entry->sym;
2805 979 : break;
2806 : }
2807 : }
2808 :
2809 15015 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2810 : {
2811 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2812 : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2813 6 : gfc_typename (&def_sym->ts));
2814 28 : goto done;
2815 : }
2816 :
2817 15009 : if (sym->attr.if_source == IFSRC_UNKNOWN
2818 15009 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2819 : {
2820 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2821 : sym->name, &sym->declared_at, reason);
2822 8 : goto done;
2823 : }
2824 :
2825 15001 : bool bad_result_characteristics;
2826 15001 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2827 : reason, sizeof(reason), NULL, NULL,
2828 : &bad_result_characteristics))
2829 : {
2830 : /* Turn errors into warnings with -std=gnu and -std=legacy,
2831 : unless a function returns a wrong type, which can lead
2832 : to all kinds of ICEs and wrong code. */
2833 :
2834 14 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2835 2 : && !bad_result_characteristics)
2836 2 : gfc_errors_to_warnings (true);
2837 :
2838 14 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2839 : sym->name, &sym->declared_at, reason);
2840 14 : sym->error = 1;
2841 14 : gfc_errors_to_warnings (false);
2842 14 : goto done;
2843 : }
2844 : }
2845 :
2846 29913 : done:
2847 :
2848 29913 : if (gsym->type == GSYM_UNKNOWN)
2849 : {
2850 4165 : gsym->type = type;
2851 4165 : gsym->where = *where;
2852 : }
2853 :
2854 29913 : gsym->used = 1;
2855 29913 : }
2856 :
2857 :
2858 : /************* Function resolution *************/
2859 :
2860 : /* Resolve a function call known to be generic.
2861 : Section 14.1.2.4.1. */
2862 :
2863 : static match
2864 28367 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2865 : {
2866 28367 : gfc_symbol *s;
2867 :
2868 28367 : if (sym->attr.generic)
2869 : {
2870 27203 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2871 27203 : if (s != NULL)
2872 : {
2873 20203 : expr->value.function.name = s->name;
2874 20203 : expr->value.function.esym = s;
2875 :
2876 20203 : if (s->ts.type != BT_UNKNOWN)
2877 20186 : expr->ts = s->ts;
2878 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2879 15 : expr->ts = s->result->ts;
2880 :
2881 20203 : if (s->as != NULL)
2882 : {
2883 55 : expr->rank = s->as->rank;
2884 55 : expr->corank = s->as->corank;
2885 : }
2886 20148 : else if (s->result != NULL && s->result->as != NULL)
2887 : {
2888 0 : expr->rank = s->result->as->rank;
2889 0 : expr->corank = s->result->as->corank;
2890 : }
2891 :
2892 20203 : gfc_set_sym_referenced (expr->value.function.esym);
2893 :
2894 20203 : return MATCH_YES;
2895 : }
2896 :
2897 : /* TODO: Need to search for elemental references in generic
2898 : interface. */
2899 : }
2900 :
2901 8164 : if (sym->attr.intrinsic)
2902 1121 : return gfc_intrinsic_func_interface (expr, 0);
2903 :
2904 : return MATCH_NO;
2905 : }
2906 :
2907 :
2908 : static bool
2909 28223 : resolve_generic_f (gfc_expr *expr)
2910 : {
2911 28223 : gfc_symbol *sym;
2912 28223 : match m;
2913 28223 : gfc_interface *intr = NULL;
2914 :
2915 28223 : sym = expr->symtree->n.sym;
2916 :
2917 28367 : for (;;)
2918 : {
2919 28367 : m = resolve_generic_f0 (expr, sym);
2920 28367 : if (m == MATCH_YES)
2921 : return true;
2922 7045 : else if (m == MATCH_ERROR)
2923 : return false;
2924 :
2925 7045 : generic:
2926 7048 : if (!intr)
2927 7016 : for (intr = sym->generic; intr; intr = intr->next)
2928 6932 : if (gfc_fl_struct (intr->sym->attr.flavor))
2929 : break;
2930 :
2931 7048 : if (sym->ns->parent == NULL)
2932 : break;
2933 316 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2934 :
2935 316 : if (sym == NULL)
2936 : break;
2937 147 : if (!generic_sym (sym))
2938 3 : goto generic;
2939 : }
2940 :
2941 : /* Last ditch attempt. See if the reference is to an intrinsic
2942 : that possesses a matching interface. 14.1.2.4 */
2943 6901 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2944 : {
2945 5 : if (gfc_init_expr_flag)
2946 1 : gfc_error ("Function %qs in initialization expression at %L "
2947 : "must be an intrinsic function",
2948 1 : expr->symtree->n.sym->name, &expr->where);
2949 : else
2950 4 : gfc_error ("There is no specific function for the generic %qs "
2951 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2952 : return false;
2953 : }
2954 :
2955 6896 : if (intr)
2956 : {
2957 6861 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2958 : NULL, false))
2959 : return false;
2960 6834 : if (!gfc_use_derived (expr->ts.u.derived))
2961 : return false;
2962 6834 : return resolve_structure_cons (expr, 0);
2963 : }
2964 :
2965 35 : m = gfc_intrinsic_func_interface (expr, 0);
2966 35 : if (m == MATCH_YES)
2967 : return true;
2968 :
2969 3 : if (m == MATCH_NO)
2970 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2971 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2972 : &expr->where);
2973 :
2974 : return false;
2975 : }
2976 :
2977 :
2978 : /* Resolve a function call known to be specific. */
2979 :
2980 : static match
2981 28884 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2982 : {
2983 28884 : match m;
2984 :
2985 28884 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2986 : {
2987 8257 : if (sym->attr.dummy)
2988 : {
2989 282 : sym->attr.proc = PROC_DUMMY;
2990 282 : goto found;
2991 : }
2992 :
2993 7975 : sym->attr.proc = PROC_EXTERNAL;
2994 7975 : goto found;
2995 : }
2996 :
2997 20627 : if (sym->attr.proc == PROC_MODULE
2998 11334 : || sym->attr.proc == PROC_ST_FUNCTION
2999 11044 : || sym->attr.proc == PROC_INTERNAL)
3000 19889 : goto found;
3001 :
3002 738 : if (sym->attr.intrinsic)
3003 : {
3004 731 : m = gfc_intrinsic_func_interface (expr, 1);
3005 731 : if (m == MATCH_YES)
3006 : return MATCH_YES;
3007 0 : if (m == MATCH_NO)
3008 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
3009 : "with an intrinsic", sym->name, &expr->where);
3010 :
3011 : return MATCH_ERROR;
3012 : }
3013 :
3014 : return MATCH_NO;
3015 :
3016 28146 : found:
3017 28146 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3018 :
3019 28146 : if (sym->result)
3020 28146 : expr->ts = sym->result->ts;
3021 : else
3022 0 : expr->ts = sym->ts;
3023 28146 : expr->value.function.name = sym->name;
3024 28146 : expr->value.function.esym = sym;
3025 : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
3026 : error(s). */
3027 28146 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
3028 : return MATCH_ERROR;
3029 28145 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
3030 : {
3031 334 : expr->rank = CLASS_DATA (sym)->as->rank;
3032 334 : expr->corank = CLASS_DATA (sym)->as->corank;
3033 : }
3034 27811 : else if (sym->as != NULL)
3035 : {
3036 2545 : expr->rank = sym->as->rank;
3037 2545 : expr->corank = sym->as->corank;
3038 : }
3039 :
3040 : return MATCH_YES;
3041 : }
3042 :
3043 :
3044 : static bool
3045 28877 : resolve_specific_f (gfc_expr *expr)
3046 : {
3047 28877 : gfc_symbol *sym;
3048 28877 : match m;
3049 :
3050 28877 : sym = expr->symtree->n.sym;
3051 :
3052 28884 : for (;;)
3053 : {
3054 28884 : m = resolve_specific_f0 (sym, expr);
3055 28884 : if (m == MATCH_YES)
3056 : return true;
3057 8 : if (m == MATCH_ERROR)
3058 : return false;
3059 :
3060 7 : if (sym->ns->parent == NULL)
3061 : break;
3062 :
3063 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3064 :
3065 7 : if (sym == NULL)
3066 : break;
3067 : }
3068 :
3069 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3070 0 : expr->symtree->n.sym->name, &expr->where);
3071 :
3072 0 : return true;
3073 : }
3074 :
3075 : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3076 : candidates in CANDIDATES_LEN. */
3077 :
3078 : static void
3079 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3080 : char **&candidates,
3081 : size_t &candidates_len)
3082 : {
3083 388 : gfc_symtree *p;
3084 :
3085 388 : if (sym == NULL)
3086 : return;
3087 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3088 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3089 51 : vec_push (candidates, candidates_len, sym->name);
3090 :
3091 388 : p = sym->left;
3092 388 : if (p)
3093 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3094 :
3095 388 : p = sym->right;
3096 388 : if (p)
3097 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3098 : }
3099 :
3100 :
3101 : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3102 :
3103 : const char*
3104 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3105 : {
3106 57 : char **candidates = NULL;
3107 57 : size_t candidates_len = 0;
3108 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3109 57 : return gfc_closest_fuzzy_match (fn, candidates);
3110 : }
3111 :
3112 :
3113 : /* Resolve a procedure call not known to be generic nor specific. */
3114 :
3115 : static bool
3116 281293 : resolve_unknown_f (gfc_expr *expr)
3117 : {
3118 281293 : gfc_symbol *sym;
3119 281293 : gfc_typespec *ts;
3120 :
3121 281293 : sym = expr->symtree->n.sym;
3122 :
3123 281293 : if (sym->attr.dummy)
3124 : {
3125 293 : sym->attr.proc = PROC_DUMMY;
3126 293 : expr->value.function.name = sym->name;
3127 293 : goto set_type;
3128 : }
3129 :
3130 : /* See if we have an intrinsic function reference. */
3131 :
3132 281000 : if (gfc_is_intrinsic (sym, 0, expr->where))
3133 : {
3134 278738 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3135 : return true;
3136 819 : return false;
3137 : }
3138 :
3139 : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3140 : /* Intrinsics were handled above, only non-intrinsics left here. */
3141 2262 : if (sym->attr.flavor == FL_PROCEDURE
3142 2259 : && sym->attr.implicit_type
3143 376 : && sym->ns
3144 376 : && sym->ns->has_implicit_none_export)
3145 : {
3146 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3147 : "for symbol %qs at %L", sym->name, &sym->declared_at);
3148 3 : sym->error = 1;
3149 3 : return false;
3150 : }
3151 :
3152 : /* The reference is to an external name. */
3153 :
3154 2259 : sym->attr.proc = PROC_EXTERNAL;
3155 2259 : expr->value.function.name = sym->name;
3156 2259 : expr->value.function.esym = expr->symtree->n.sym;
3157 :
3158 2259 : if (sym->as != NULL)
3159 : {
3160 1 : expr->rank = sym->as->rank;
3161 1 : expr->corank = sym->as->corank;
3162 : }
3163 :
3164 : /* Type of the expression is either the type of the symbol or the
3165 : default type of the symbol. */
3166 :
3167 2258 : set_type:
3168 2552 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3169 :
3170 2552 : if (sym->ts.type != BT_UNKNOWN)
3171 2501 : expr->ts = sym->ts;
3172 : else
3173 : {
3174 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3175 :
3176 51 : if (ts->type == BT_UNKNOWN)
3177 : {
3178 41 : const char *guessed
3179 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3180 41 : if (guessed)
3181 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3182 : "; did you mean %qs?",
3183 : sym->name, &expr->where, guessed);
3184 : else
3185 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3186 : sym->name, &expr->where);
3187 : return false;
3188 : }
3189 : else
3190 10 : expr->ts = *ts;
3191 : }
3192 :
3193 : return true;
3194 : }
3195 :
3196 :
3197 : /* Return true, if the symbol is an external procedure. */
3198 : static bool
3199 870603 : is_external_proc (gfc_symbol *sym)
3200 : {
3201 868880 : if (!sym->attr.dummy && !sym->attr.contained
3202 758558 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3203 165998 : && sym->attr.proc != PROC_ST_FUNCTION
3204 165401 : && !sym->attr.proc_pointer
3205 164195 : && !sym->attr.use_assoc
3206 930460 : && sym->name)
3207 59857 : return true;
3208 :
3209 : return false;
3210 : }
3211 :
3212 :
3213 : /* Figure out if a function reference is pure or not. Also set the name
3214 : of the function for a potential error message. Return nonzero if the
3215 : function is PURE, zero if not. */
3216 : static bool
3217 : pure_stmt_function (gfc_expr *, gfc_symbol *);
3218 :
3219 : bool
3220 262049 : gfc_pure_function (gfc_expr *e, const char **name)
3221 : {
3222 262049 : bool pure;
3223 262049 : gfc_component *comp;
3224 :
3225 262049 : *name = NULL;
3226 :
3227 262049 : if (e->symtree != NULL
3228 261675 : && e->symtree->n.sym != NULL
3229 261675 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3230 306 : return pure_stmt_function (e, e->symtree->n.sym);
3231 :
3232 261743 : comp = gfc_get_proc_ptr_comp (e);
3233 261743 : if (comp)
3234 : {
3235 491 : pure = gfc_pure (comp->ts.interface);
3236 491 : *name = comp->name;
3237 : }
3238 261252 : else if (e->value.function.esym)
3239 : {
3240 53962 : pure = gfc_pure (e->value.function.esym);
3241 53962 : *name = e->value.function.esym->name;
3242 : }
3243 207290 : else if (e->value.function.isym)
3244 : {
3245 412416 : pure = e->value.function.isym->pure
3246 206208 : || e->value.function.isym->elemental;
3247 206208 : *name = e->value.function.isym->name;
3248 : }
3249 1082 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3250 : {
3251 : /* The function has been resolved, but esym is not yet set.
3252 : This can happen with functions as dummy argument. */
3253 291 : pure = e->symtree->n.sym->attr.pure;
3254 291 : *name = e->symtree->n.sym->name;
3255 : }
3256 : else
3257 : {
3258 : /* Implicit functions are not pure. */
3259 791 : pure = 0;
3260 791 : *name = e->value.function.name;
3261 : }
3262 :
3263 : return pure;
3264 : }
3265 :
3266 :
3267 : /* Check if the expression is a reference to an implicitly pure function. */
3268 :
3269 : bool
3270 39276 : gfc_implicit_pure_function (gfc_expr *e)
3271 : {
3272 39276 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3273 39276 : if (comp)
3274 469 : return gfc_implicit_pure (comp->ts.interface);
3275 38807 : else if (e->value.function.esym)
3276 33385 : return gfc_implicit_pure (e->value.function.esym);
3277 : else
3278 : return 0;
3279 : }
3280 :
3281 :
3282 : static bool
3283 983 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3284 : int *f ATTRIBUTE_UNUSED)
3285 : {
3286 983 : const char *name;
3287 :
3288 : /* Don't bother recursing into other statement functions
3289 : since they will be checked individually for purity. */
3290 983 : if (e->expr_type != EXPR_FUNCTION
3291 344 : || !e->symtree
3292 344 : || e->symtree->n.sym == sym
3293 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3294 : return false;
3295 :
3296 19 : return !gfc_pure_function (e, &name);
3297 : }
3298 :
3299 :
3300 : static bool
3301 306 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3302 : {
3303 306 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3304 : }
3305 :
3306 :
3307 : /* Check if an impure function is allowed in the current context. */
3308 :
3309 249967 : static bool check_pure_function (gfc_expr *e)
3310 : {
3311 249967 : const char *name = NULL;
3312 249967 : code_stack *stack;
3313 249967 : bool saw_block = false;
3314 :
3315 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3316 : gfc_do_concurrent_flag = 0 when the check for an impure function
3317 : occurs. Check the stack to see if the source code has a nested
3318 : BLOCK construct. */
3319 :
3320 578888 : for (stack = cs_base; stack; stack = stack->prev)
3321 : {
3322 328923 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3323 : {
3324 7849 : saw_block = true;
3325 7849 : continue;
3326 : }
3327 :
3328 5537 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3329 : {
3330 16 : bool is_pure;
3331 328921 : is_pure = (e->value.function.isym
3332 15 : && (e->value.function.isym->pure
3333 1 : || e->value.function.isym->elemental))
3334 17 : || (e->value.function.esym
3335 1 : && (e->value.function.esym->attr.pure
3336 1 : || e->value.function.esym->attr.elemental));
3337 2 : if (!is_pure)
3338 : {
3339 2 : gfc_error ("Reference to impure function at %L inside a "
3340 : "DO CONCURRENT", &e->where);
3341 2 : return false;
3342 : }
3343 : }
3344 : }
3345 :
3346 249965 : if (!gfc_pure_function (e, &name) && name)
3347 : {
3348 37979 : if (forall_flag)
3349 : {
3350 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3351 : "FORALL %s", name, &e->where,
3352 : forall_flag == 2 ? "mask" : "block");
3353 4 : return false;
3354 : }
3355 37975 : else if (gfc_do_concurrent_flag)
3356 : {
3357 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3358 : "DO CONCURRENT %s", name, &e->where,
3359 : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3360 2 : return false;
3361 : }
3362 37973 : else if (gfc_pure (NULL))
3363 : {
3364 5 : gfc_error ("Reference to impure function %qs at %L "
3365 : "within a PURE procedure", name, &e->where);
3366 5 : return false;
3367 : }
3368 37968 : if (!gfc_implicit_pure_function (e))
3369 31195 : gfc_unset_implicit_pure (NULL);
3370 : }
3371 : return true;
3372 : }
3373 :
3374 :
3375 : /* Update current procedure's array_outer_dependency flag, considering
3376 : a call to procedure SYM. */
3377 :
3378 : static void
3379 135494 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3380 : {
3381 : /* Check to see if this is a sibling function that has not yet
3382 : been resolved. */
3383 135494 : gfc_namespace *sibling = gfc_current_ns->sibling;
3384 253897 : for (; sibling; sibling = sibling->sibling)
3385 : {
3386 125685 : if (sibling->proc_name == sym)
3387 : {
3388 7282 : gfc_resolve (sibling);
3389 7282 : break;
3390 : }
3391 : }
3392 :
3393 : /* If SYM has references to outer arrays, so has the procedure calling
3394 : SYM. If SYM is a procedure pointer, we can assume the worst. */
3395 135494 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3396 69240 : && gfc_current_ns->proc_name)
3397 69196 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3398 135494 : }
3399 :
3400 :
3401 : /* Resolve a function call, which means resolving the arguments, then figuring
3402 : out which entity the name refers to. */
3403 :
3404 : static bool
3405 352607 : resolve_function (gfc_expr *expr)
3406 : {
3407 352607 : gfc_actual_arglist *arg;
3408 352607 : gfc_symbol *sym;
3409 352607 : bool t;
3410 352607 : int temp;
3411 352607 : procedure_type p = PROC_INTRINSIC;
3412 352607 : bool no_formal_args;
3413 :
3414 352607 : sym = NULL;
3415 352607 : if (expr->symtree)
3416 352233 : sym = expr->symtree->n.sym;
3417 :
3418 : /* If this is a procedure pointer component, it has already been resolved. */
3419 352607 : if (gfc_is_proc_ptr_comp (expr))
3420 : return true;
3421 :
3422 : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3423 : another caf_get. */
3424 352191 : if (sym && sym->attr.intrinsic
3425 8786 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3426 8786 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3427 : return true;
3428 :
3429 352191 : if (expr->ref)
3430 : {
3431 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3432 : &expr->where);
3433 1 : return false;
3434 : }
3435 :
3436 351816 : if (sym && sym->attr.intrinsic
3437 360976 : && !gfc_resolve_intrinsic (sym, &expr->where))
3438 : return false;
3439 :
3440 352190 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3441 : {
3442 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3443 4 : return false;
3444 : }
3445 :
3446 : /* If this is a deferred TBP with an abstract interface (which may
3447 : of course be referenced), expr->value.function.esym will be set. */
3448 351812 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3449 : {
3450 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3451 : sym->name, &expr->where);
3452 1 : return false;
3453 : }
3454 :
3455 : /* If this is a deferred TBP with an abstract interface, its result
3456 : cannot be an assumed length character (F2003: C418). */
3457 351811 : if (sym && sym->attr.abstract && sym->attr.function
3458 192 : && sym->result->ts.u.cl
3459 158 : && sym->result->ts.u.cl->length == NULL
3460 2 : && !sym->result->ts.deferred)
3461 : {
3462 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3463 : "character length result (F2008: C418)", sym->name,
3464 : &sym->declared_at);
3465 1 : return false;
3466 : }
3467 :
3468 : /* Switch off assumed size checking and do this again for certain kinds
3469 : of procedure, once the procedure itself is resolved. */
3470 352184 : need_full_assumed_size++;
3471 :
3472 352184 : if (expr->symtree && expr->symtree->n.sym)
3473 351810 : p = expr->symtree->n.sym->attr.proc;
3474 :
3475 352184 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3476 1260 : inquiry_argument = true;
3477 351810 : no_formal_args = sym && is_external_proc (sym)
3478 366381 : && gfc_sym_get_dummy_args (sym) == NULL;
3479 :
3480 352184 : if (!resolve_actual_arglist (expr->value.function.actual,
3481 : p, no_formal_args))
3482 : {
3483 67 : inquiry_argument = false;
3484 67 : return false;
3485 : }
3486 :
3487 352117 : inquiry_argument = false;
3488 :
3489 : /* Resume assumed_size checking. */
3490 352117 : need_full_assumed_size--;
3491 :
3492 : /* If the procedure is external, check for usage. */
3493 352117 : if (sym && is_external_proc (sym))
3494 14177 : resolve_global_procedure (sym, &expr->where, 0);
3495 :
3496 352117 : if (sym && sym->ts.type == BT_CHARACTER
3497 3437 : && sym->ts.u.cl
3498 3343 : && sym->ts.u.cl->length == NULL
3499 701 : && !sym->attr.dummy
3500 694 : && !sym->ts.deferred
3501 2 : && expr->value.function.esym == NULL
3502 2 : && !sym->attr.contained)
3503 : {
3504 : /* Internal procedures are taken care of in resolve_contained_fntype. */
3505 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3506 : "be used at %L since it is not a dummy argument",
3507 : sym->name, &expr->where);
3508 1 : return false;
3509 : }
3510 :
3511 : /* Add and check formal interface when -fc-prototypes-external is in
3512 : force, see comment in resolve_call(). */
3513 :
3514 352116 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3515 18 : && sym->attr.external)
3516 : {
3517 18 : if (sym->formal)
3518 : {
3519 6 : bool conflict;
3520 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3521 : sym->formal, 0, 0, 0, NULL);
3522 6 : if (conflict)
3523 : {
3524 6 : sym->ext_dummy_arglist_mismatch = 1;
3525 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3526 : "Different argument lists in external dummy "
3527 : "function %s at %L and %L", sym->name,
3528 : &expr->where, &sym->other_loc);
3529 : }
3530 : }
3531 12 : else if (!sym->formal_resolved)
3532 : {
3533 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3534 6 : sym->other_loc = expr->where;
3535 : }
3536 : }
3537 : /* See if function is already resolved. */
3538 :
3539 352116 : if (expr->value.function.name != NULL
3540 339251 : || expr->value.function.isym != NULL)
3541 : {
3542 13723 : if (expr->ts.type == BT_UNKNOWN)
3543 3 : expr->ts = sym->ts;
3544 : t = true;
3545 : }
3546 : else
3547 : {
3548 : /* Apply the rules of section 14.1.2. */
3549 :
3550 338393 : switch (procedure_kind (sym))
3551 : {
3552 28223 : case PTYPE_GENERIC:
3553 28223 : t = resolve_generic_f (expr);
3554 28223 : break;
3555 :
3556 28877 : case PTYPE_SPECIFIC:
3557 28877 : t = resolve_specific_f (expr);
3558 28877 : break;
3559 :
3560 281293 : case PTYPE_UNKNOWN:
3561 281293 : t = resolve_unknown_f (expr);
3562 281293 : break;
3563 :
3564 : default:
3565 : gfc_internal_error ("resolve_function(): bad function type");
3566 : }
3567 : }
3568 :
3569 : /* If the expression is still a function (it might have simplified),
3570 : then we check to see if we are calling an elemental function. */
3571 :
3572 352116 : if (expr->expr_type != EXPR_FUNCTION)
3573 : return t;
3574 :
3575 : /* Walk the argument list looking for invalid BOZ. */
3576 755738 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3577 506239 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3578 : {
3579 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3580 : "actual argument in a function reference",
3581 : &arg->expr->where);
3582 5 : return false;
3583 : }
3584 :
3585 249499 : temp = need_full_assumed_size;
3586 249499 : need_full_assumed_size = 0;
3587 :
3588 249499 : if (!resolve_elemental_actual (expr, NULL))
3589 : return false;
3590 :
3591 249496 : if (omp_workshare_flag
3592 32 : && expr->value.function.esym
3593 249501 : && ! gfc_elemental (expr->value.function.esym))
3594 : {
3595 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3596 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3597 : &expr->where);
3598 4 : t = false;
3599 : }
3600 :
3601 : #define GENERIC_ID expr->value.function.isym->id
3602 249492 : else if (expr->value.function.actual != NULL
3603 241040 : && expr->value.function.isym != NULL
3604 195290 : && GENERIC_ID != GFC_ISYM_LBOUND
3605 : && GENERIC_ID != GFC_ISYM_LCOBOUND
3606 : && GENERIC_ID != GFC_ISYM_UCOBOUND
3607 : && GENERIC_ID != GFC_ISYM_LEN
3608 : && GENERIC_ID != GFC_ISYM_LOC
3609 : && GENERIC_ID != GFC_ISYM_C_LOC
3610 : && GENERIC_ID != GFC_ISYM_PRESENT)
3611 : {
3612 : /* Array intrinsics must also have the last upper bound of an
3613 : assumed size array argument. UBOUND and SIZE have to be
3614 : excluded from the check if the second argument is anything
3615 : than a constant. */
3616 :
3617 549831 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3618 : {
3619 380846 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3620 46553 : && arg == expr->value.function.actual
3621 17145 : && arg->next != NULL && arg->next->expr)
3622 : {
3623 8429 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3624 : break;
3625 :
3626 8205 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3627 : break;
3628 :
3629 8205 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3630 8205 : < arg->expr->rank)
3631 : break;
3632 : }
3633 :
3634 378407 : if (arg->expr != NULL
3635 251201 : && arg->expr->rank > 0
3636 499519 : && resolve_assumed_size_actual (arg->expr))
3637 : return false;
3638 : }
3639 : }
3640 : #undef GENERIC_ID
3641 :
3642 249493 : need_full_assumed_size = temp;
3643 :
3644 249493 : if (!check_pure_function(expr))
3645 12 : t = false;
3646 :
3647 : /* Functions without the RECURSIVE attribution are not allowed to
3648 : * call themselves. */
3649 249493 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3650 : {
3651 52688 : gfc_symbol *esym;
3652 52688 : esym = expr->value.function.esym;
3653 :
3654 52688 : if (is_illegal_recursion (esym, gfc_current_ns))
3655 : {
3656 5 : if (esym->attr.entry && esym->ns->entries)
3657 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3658 : " function %qs is not RECURSIVE",
3659 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3660 : else
3661 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3662 : " is not RECURSIVE", esym->name, &expr->where);
3663 :
3664 : t = false;
3665 : }
3666 : }
3667 :
3668 : /* Character lengths of use associated functions may contains references to
3669 : symbols not referenced from the current program unit otherwise. Make sure
3670 : those symbols are marked as referenced. */
3671 :
3672 249493 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3673 3541 : && expr->value.function.esym->attr.use_assoc)
3674 : {
3675 1328 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3676 : }
3677 :
3678 : /* Make sure that the expression has a typespec that works. */
3679 249493 : if (expr->ts.type == BT_UNKNOWN)
3680 : {
3681 930 : if (expr->symtree->n.sym->result
3682 921 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3683 561 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3684 561 : expr->ts = expr->symtree->n.sym->result->ts;
3685 : }
3686 :
3687 : /* These derived types with an incomplete namespace, arising from use
3688 : association, cause gfc_get_derived_vtab to segfault. If the function
3689 : namespace does not suffice, something is badly wrong. */
3690 249493 : if (expr->ts.type == BT_DERIVED
3691 9646 : && !expr->ts.u.derived->ns->proc_name)
3692 : {
3693 3 : gfc_symbol *der;
3694 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3695 3 : if (der)
3696 : {
3697 3 : expr->ts.u.derived->refs--;
3698 3 : expr->ts.u.derived = der;
3699 3 : der->refs++;
3700 : }
3701 : else
3702 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3703 : }
3704 :
3705 249493 : if (!expr->ref && !expr->value.function.isym)
3706 : {
3707 54082 : if (expr->value.function.esym)
3708 53000 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3709 : else
3710 1082 : update_current_proc_array_outer_dependency (sym);
3711 : }
3712 195411 : else if (expr->ref)
3713 : /* typebound procedure: Assume the worst. */
3714 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3715 :
3716 249493 : if (expr->value.function.esym
3717 53000 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3718 26 : gfc_warning (OPT_Wdeprecated_declarations,
3719 : "Using function %qs at %L is deprecated",
3720 : sym->name, &expr->where);
3721 :
3722 : /* Check an external function supplied as a dummy argument has an external
3723 : attribute when a program unit uses 'implicit none (external)'. */
3724 249493 : if (expr->expr_type == EXPR_FUNCTION
3725 249493 : && expr->symtree
3726 249119 : && expr->symtree->n.sym->attr.dummy
3727 574 : && expr->symtree->n.sym->ns->has_implicit_none_export
3728 249494 : && !gfc_is_intrinsic(expr->symtree->n.sym, 0, expr->where))
3729 : {
3730 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
3731 : sym->name, &expr->where);
3732 1 : return false;
3733 : }
3734 :
3735 : return t;
3736 : }
3737 :
3738 :
3739 : /************* Subroutine resolution *************/
3740 :
3741 : static bool
3742 78830 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3743 : {
3744 78830 : code_stack *stack;
3745 78830 : bool saw_block = false;
3746 :
3747 78830 : if (gfc_pure (sym))
3748 : return true;
3749 :
3750 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3751 : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3752 : occurs. Walk up the stack to see if the source code has a nested
3753 : construct. */
3754 :
3755 162633 : for (stack = cs_base; stack; stack = stack->prev)
3756 : {
3757 89460 : if (stack->current->op == EXEC_BLOCK)
3758 : {
3759 1932 : saw_block = true;
3760 1932 : continue;
3761 : }
3762 :
3763 87528 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3764 : {
3765 :
3766 2 : bool is_pure = true;
3767 89460 : is_pure = sym->attr.pure || sym->attr.elemental;
3768 :
3769 2 : if (!is_pure)
3770 : {
3771 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3772 : "is not PURE", loc);
3773 2 : return false;
3774 : }
3775 : }
3776 : }
3777 :
3778 73173 : if (forall_flag)
3779 : {
3780 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3781 : name, loc);
3782 0 : return false;
3783 : }
3784 73173 : else if (gfc_do_concurrent_flag)
3785 : {
3786 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3787 : "PURE", name, loc);
3788 6 : return false;
3789 : }
3790 73167 : else if (gfc_pure (NULL))
3791 : {
3792 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3793 4 : return false;
3794 : }
3795 :
3796 73163 : gfc_unset_implicit_pure (NULL);
3797 73163 : return true;
3798 : }
3799 :
3800 :
3801 : static match
3802 2883 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3803 : {
3804 2883 : gfc_symbol *s;
3805 :
3806 2883 : if (sym->attr.generic)
3807 : {
3808 2882 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3809 2882 : if (s != NULL)
3810 : {
3811 2873 : c->resolved_sym = s;
3812 2873 : if (!pure_subroutine (s, s->name, &c->loc))
3813 : return MATCH_ERROR;
3814 2873 : return MATCH_YES;
3815 : }
3816 :
3817 : /* TODO: Need to search for elemental references in generic interface. */
3818 : }
3819 :
3820 10 : if (sym->attr.intrinsic)
3821 1 : return gfc_intrinsic_sub_interface (c, 0);
3822 :
3823 : return MATCH_NO;
3824 : }
3825 :
3826 :
3827 : static bool
3828 2881 : resolve_generic_s (gfc_code *c)
3829 : {
3830 2881 : gfc_symbol *sym;
3831 2881 : match m;
3832 :
3833 2881 : sym = c->symtree->n.sym;
3834 :
3835 2883 : for (;;)
3836 : {
3837 2883 : m = resolve_generic_s0 (c, sym);
3838 2883 : if (m == MATCH_YES)
3839 : return true;
3840 9 : else if (m == MATCH_ERROR)
3841 : return false;
3842 :
3843 9 : generic:
3844 9 : if (sym->ns->parent == NULL)
3845 : break;
3846 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3847 :
3848 3 : if (sym == NULL)
3849 : break;
3850 2 : if (!generic_sym (sym))
3851 0 : goto generic;
3852 : }
3853 :
3854 : /* Last ditch attempt. See if the reference is to an intrinsic
3855 : that possesses a matching interface. 14.1.2.4 */
3856 7 : sym = c->symtree->n.sym;
3857 :
3858 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3859 : {
3860 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3861 : sym->name, &c->loc);
3862 4 : return false;
3863 : }
3864 :
3865 3 : m = gfc_intrinsic_sub_interface (c, 0);
3866 3 : if (m == MATCH_YES)
3867 : return true;
3868 1 : if (m == MATCH_NO)
3869 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3870 : "intrinsic subroutine interface", sym->name, &c->loc);
3871 :
3872 : return false;
3873 : }
3874 :
3875 :
3876 : /* Resolve a subroutine call known to be specific. */
3877 :
3878 : static match
3879 64204 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3880 : {
3881 64204 : match m;
3882 :
3883 64204 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3884 : {
3885 5732 : if (sym->attr.dummy)
3886 : {
3887 263 : sym->attr.proc = PROC_DUMMY;
3888 263 : goto found;
3889 : }
3890 :
3891 5469 : sym->attr.proc = PROC_EXTERNAL;
3892 5469 : goto found;
3893 : }
3894 :
3895 58472 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3896 58466 : goto found;
3897 :
3898 6 : if (sym->attr.intrinsic)
3899 : {
3900 0 : m = gfc_intrinsic_sub_interface (c, 1);
3901 0 : if (m == MATCH_YES)
3902 : return MATCH_YES;
3903 0 : if (m == MATCH_NO)
3904 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3905 : "with an intrinsic", sym->name, &c->loc);
3906 :
3907 : return MATCH_ERROR;
3908 : }
3909 :
3910 : return MATCH_NO;
3911 :
3912 64198 : found:
3913 64198 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3914 :
3915 64198 : c->resolved_sym = sym;
3916 64198 : if (!pure_subroutine (sym, sym->name, &c->loc))
3917 7 : return MATCH_ERROR;
3918 :
3919 : return MATCH_YES;
3920 : }
3921 :
3922 :
3923 : static bool
3924 64198 : resolve_specific_s (gfc_code *c)
3925 : {
3926 64198 : gfc_symbol *sym;
3927 64198 : match m;
3928 :
3929 64198 : sym = c->symtree->n.sym;
3930 :
3931 64204 : for (;;)
3932 : {
3933 64204 : m = resolve_specific_s0 (c, sym);
3934 64204 : if (m == MATCH_YES)
3935 : return true;
3936 13 : if (m == MATCH_ERROR)
3937 : return false;
3938 :
3939 6 : if (sym->ns->parent == NULL)
3940 : break;
3941 :
3942 6 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3943 :
3944 6 : if (sym == NULL)
3945 : break;
3946 : }
3947 :
3948 0 : sym = c->symtree->n.sym;
3949 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3950 : sym->name, &c->loc);
3951 :
3952 0 : return false;
3953 : }
3954 :
3955 :
3956 : /* Resolve a subroutine call not known to be generic nor specific. */
3957 :
3958 : static bool
3959 15987 : resolve_unknown_s (gfc_code *c)
3960 : {
3961 15987 : gfc_symbol *sym;
3962 :
3963 15987 : sym = c->symtree->n.sym;
3964 :
3965 15987 : if (sym->attr.dummy)
3966 : {
3967 26 : sym->attr.proc = PROC_DUMMY;
3968 26 : goto found;
3969 : }
3970 :
3971 : /* See if we have an intrinsic function reference. */
3972 :
3973 15961 : if (gfc_is_intrinsic (sym, 1, c->loc))
3974 : {
3975 4351 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3976 : return true;
3977 319 : return false;
3978 : }
3979 :
3980 : /* The reference is to an external name. */
3981 :
3982 11610 : found:
3983 11636 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3984 :
3985 11636 : c->resolved_sym = sym;
3986 :
3987 11636 : return pure_subroutine (sym, sym->name, &c->loc);
3988 : }
3989 :
3990 :
3991 :
3992 : static bool
3993 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3994 : gfc_code *c, gfc_namespace *ns)
3995 : {
3996 805 : locus *here;
3997 :
3998 : /* If the type has been imported then its vtype functions are OK. */
3999 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
4000 : return true;
4001 :
4002 : if (e)
4003 791 : here = &e->where;
4004 : else
4005 7 : here = &c->loc;
4006 :
4007 798 : if (s && !s->import_only)
4008 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
4009 :
4010 798 : if (ns->import_state == IMPORT_ONLY
4011 75 : && sym->ns != ns
4012 58 : && (!s || !s->import_only))
4013 : {
4014 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
4015 : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
4016 21 : return false;
4017 : }
4018 777 : else if (ns->import_state == IMPORT_NONE
4019 27 : && sym->ns != ns)
4020 : {
4021 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
4022 : "has IMPORT, NONE", sym->name, here);
4023 12 : return false;
4024 : }
4025 : return true;
4026 : }
4027 :
4028 :
4029 : static bool
4030 7384 : check_import_status (gfc_expr *e)
4031 : {
4032 7384 : gfc_symtree *st;
4033 7384 : gfc_ref *ref;
4034 7384 : gfc_symbol *sym, *der;
4035 7384 : gfc_namespace *ns = gfc_current_ns;
4036 :
4037 7384 : switch (e->expr_type)
4038 : {
4039 727 : case EXPR_VARIABLE:
4040 727 : case EXPR_FUNCTION:
4041 727 : case EXPR_SUBSTRING:
4042 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
4043 :
4044 : /* Check the symbol itself. */
4045 727 : if (sym
4046 727 : && !(ns->proc_name
4047 : && (sym == ns->proc_name))
4048 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4049 : return false;
4050 :
4051 : /* Check the declared derived type. */
4052 717 : if (sym->ts.type == BT_DERIVED)
4053 : {
4054 16 : der = sym->ts.u.derived;
4055 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4056 :
4057 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4058 : return false;
4059 : }
4060 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4061 : {
4062 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4063 : : sym->ts.u.derived;
4064 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4065 :
4066 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4067 : return false;
4068 : }
4069 :
4070 : /* Check the declared derived types of component references. */
4071 724 : for (ref = e->ref; ref; ref = ref->next)
4072 20 : if (ref->type == REF_COMPONENT)
4073 : {
4074 19 : gfc_component *c = ref->u.c.component;
4075 19 : if (c->ts.type == BT_DERIVED)
4076 : {
4077 7 : der = c->ts.u.derived;
4078 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4079 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4080 : return false;
4081 : }
4082 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4083 : {
4084 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4085 : : c->ts.u.derived;
4086 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4087 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4088 : return false;
4089 : }
4090 : }
4091 :
4092 : break;
4093 :
4094 8 : case EXPR_ARRAY:
4095 8 : case EXPR_STRUCTURE:
4096 : /* Check the declared derived type. */
4097 8 : if (e->ts.type == BT_DERIVED)
4098 : {
4099 8 : der = e->ts.u.derived;
4100 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4101 :
4102 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4103 : return false;
4104 : }
4105 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4106 : {
4107 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4108 : : e->ts.u.derived;
4109 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4110 :
4111 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4112 : return false;
4113 : }
4114 :
4115 : break;
4116 :
4117 : /* Either not applicable or resolved away
4118 : case EXPR_OP:
4119 : case EXPR_UNKNOWN:
4120 : case EXPR_CONSTANT:
4121 : case EXPR_NULL:
4122 : case EXPR_COMPCALL:
4123 : case EXPR_PPC: */
4124 :
4125 : default:
4126 : break;
4127 : }
4128 :
4129 : return true;
4130 : }
4131 :
4132 :
4133 : /* If an elemental call has an INTENT_IN argument that has a dependency on an
4134 : argument which is not INTENT_IN and requires a temporary, build a temporary
4135 : for the INTENT_IN actual argument as well. */
4136 :
4137 : static void
4138 : add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **);
4139 :
4140 : static void
4141 5257 : resolve_elemental_dependencies (gfc_code *c)
4142 : {
4143 5257 : gfc_actual_arglist *arg1 = c->ext.actual;
4144 5257 : gfc_actual_arglist *arg2 = NULL;
4145 5257 : gfc_formal_arglist *formal1 = c->resolved_sym->formal;
4146 5257 : gfc_formal_arglist *formal2 = NULL;
4147 5257 : gfc_expr *expr1;
4148 5257 : gfc_expr **expr2;
4149 :
4150 16645 : for (; arg1 && formal1; arg1 = arg1->next, formal1 = formal1->next)
4151 : {
4152 11388 : if (formal1->sym
4153 11388 : && (formal1->sym->attr.intent == INTENT_IN
4154 3536 : || formal1->sym->attr.value))
4155 8110 : continue;
4156 :
4157 3278 : if (!arg1->expr || arg1->expr->expr_type != EXPR_VARIABLE)
4158 0 : continue;
4159 :
4160 3278 : arg2 = c->ext.actual;
4161 3278 : formal2 = c->resolved_sym->formal;
4162 10696 : for (; arg2 && formal2; arg2 = arg2->next, formal2 = formal2->next)
4163 : {
4164 7418 : if (arg2 == arg1 || !arg2->expr
4165 4128 : || !(formal2->sym && formal2->sym->attr.intent == INTENT_IN))
4166 3304 : continue;
4167 :
4168 4114 : expr1 = arg1->expr;
4169 4114 : expr2 = &arg2->expr;
4170 :
4171 : /* If the arg1 has something horrible like a vector index and
4172 : there is a dependency between arg1 and arg2, build a
4173 : temporary from arg2, assign the arg2 to it and use the
4174 : temporary in the call expression. */
4175 2009 : if (expr1->rank && gfc_ref_needs_temporary_p (expr1->ref)
4176 4234 : && gfc_check_dependency (expr1, *expr2, false))
4177 36 : add_temp_assign_before_call (c, gfc_current_ns, expr2);
4178 : }
4179 : }
4180 5257 : }
4181 :
4182 : /* Resolve a subroutine call. Although it was tempting to use the same code
4183 : for functions, subroutines and functions are stored differently and this
4184 : makes things awkward. */
4185 :
4186 :
4187 : static bool
4188 83214 : resolve_call (gfc_code *c)
4189 : {
4190 83214 : bool t;
4191 83214 : procedure_type ptype = PROC_INTRINSIC;
4192 83214 : gfc_symbol *csym, *sym;
4193 83214 : bool no_formal_args;
4194 :
4195 83214 : csym = c->symtree ? c->symtree->n.sym : NULL;
4196 :
4197 83214 : if (csym && csym->ts.type != BT_UNKNOWN)
4198 : {
4199 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4200 : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4201 4 : return false;
4202 : }
4203 :
4204 83210 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4205 : {
4206 17643 : gfc_symtree *st;
4207 17643 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4208 17643 : sym = st ? st->n.sym : NULL;
4209 17643 : if (sym && csym != sym
4210 3 : && sym->ns == gfc_current_ns
4211 3 : && sym->attr.flavor == FL_PROCEDURE
4212 3 : && sym->attr.contained)
4213 : {
4214 3 : sym->refs++;
4215 3 : if (csym->attr.generic)
4216 2 : c->symtree->n.sym = sym;
4217 : else
4218 1 : c->symtree = st;
4219 3 : csym = c->symtree->n.sym;
4220 : }
4221 : }
4222 :
4223 : /* If this ia a deferred TBP, c->expr1 will be set. */
4224 83210 : if (!c->expr1 && csym)
4225 : {
4226 81457 : if (csym->attr.abstract)
4227 : {
4228 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4229 : csym->name, &c->loc);
4230 1 : return false;
4231 : }
4232 :
4233 : /* Subroutines without the RECURSIVE attribution are not allowed to
4234 : call themselves. */
4235 81456 : if (is_illegal_recursion (csym, gfc_current_ns))
4236 : {
4237 4 : if (csym->attr.entry && csym->ns->entries)
4238 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4239 : "as subroutine %qs is not RECURSIVE",
4240 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4241 : else
4242 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4243 : "as it is not RECURSIVE", csym->name, &c->loc);
4244 :
4245 83209 : t = false;
4246 : }
4247 : }
4248 :
4249 : /* Switch off assumed size checking and do this again for certain kinds
4250 : of procedure, once the procedure itself is resolved. */
4251 83209 : need_full_assumed_size++;
4252 :
4253 83209 : if (csym)
4254 83209 : ptype = csym->attr.proc;
4255 :
4256 83209 : no_formal_args = csym && is_external_proc (csym)
4257 15742 : && gfc_sym_get_dummy_args (csym) == NULL;
4258 83209 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4259 : return false;
4260 :
4261 : /* Resume assumed_size checking. */
4262 83175 : need_full_assumed_size--;
4263 :
4264 : /* If 'implicit none (external)' and the symbol is a dummy argument,
4265 : check for an 'external' attribute. */
4266 83175 : if (csym->ns->has_implicit_none_export
4267 4486 : && csym->attr.external == 0 && csym->attr.dummy == 1)
4268 : {
4269 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
4270 : csym->name, &c->loc);
4271 1 : return false;
4272 : }
4273 :
4274 : /* If external, check for usage. */
4275 83174 : if (csym && is_external_proc (csym))
4276 15736 : resolve_global_procedure (csym, &c->loc, 1);
4277 :
4278 : /* If we have an external dummy argument, we want to write out its arguments
4279 : with -fc-prototypes-external. Code like
4280 :
4281 : subroutine foo(a,n)
4282 : external a
4283 : if (n == 1) call a(1)
4284 : if (n == 2) call a(2,3)
4285 : end subroutine foo
4286 :
4287 : is actually legal Fortran, but it is not possible to generate a C23-
4288 : compliant prototype for this, so we just record the fact here and
4289 : handle that during -fc-prototypes-external processing. */
4290 :
4291 83174 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4292 14 : && csym->attr.external)
4293 : {
4294 14 : if (csym->formal)
4295 : {
4296 6 : bool conflict;
4297 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4298 : 0, 0, 0, NULL);
4299 6 : if (conflict)
4300 : {
4301 6 : csym->ext_dummy_arglist_mismatch = 1;
4302 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4303 : "Different argument lists in external dummy "
4304 : "subroutine %s at %L and %L", csym->name,
4305 : &c->loc, &csym->other_loc);
4306 : }
4307 : }
4308 8 : else if (!csym->formal_resolved)
4309 : {
4310 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4311 7 : csym->other_loc = c->loc;
4312 : }
4313 : }
4314 :
4315 83174 : t = true;
4316 83174 : if (c->resolved_sym == NULL)
4317 : {
4318 83066 : c->resolved_isym = NULL;
4319 83066 : switch (procedure_kind (csym))
4320 : {
4321 2881 : case PTYPE_GENERIC:
4322 2881 : t = resolve_generic_s (c);
4323 2881 : break;
4324 :
4325 64198 : case PTYPE_SPECIFIC:
4326 64198 : t = resolve_specific_s (c);
4327 64198 : break;
4328 :
4329 15987 : case PTYPE_UNKNOWN:
4330 15987 : t = resolve_unknown_s (c);
4331 15987 : break;
4332 :
4333 : default:
4334 : gfc_internal_error ("resolve_subroutine(): bad function type");
4335 : }
4336 : }
4337 :
4338 : /* Some checks of elemental subroutine actual arguments. */
4339 83173 : if (!resolve_elemental_actual (NULL, c))
4340 : return false;
4341 :
4342 : /* Deal with complicated dependencies that the scalarizer cannot handle. */
4343 83165 : if (c->resolved_sym && c->resolved_sym->attr.elemental && !no_formal_args
4344 6206 : && c->ext.actual && c->ext.actual->next)
4345 5257 : resolve_elemental_dependencies (c);
4346 :
4347 83165 : if (!c->expr1)
4348 81412 : update_current_proc_array_outer_dependency (csym);
4349 : else
4350 : /* Typebound procedure: Assume the worst. */
4351 1753 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4352 :
4353 83165 : if (c->resolved_sym
4354 82842 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4355 34 : gfc_warning (OPT_Wdeprecated_declarations,
4356 : "Using subroutine %qs at %L is deprecated",
4357 : c->resolved_sym->name, &c->loc);
4358 :
4359 83165 : csym = c->resolved_sym ? c->resolved_sym : csym;
4360 83165 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4361 2 : && csym != gfc_current_ns->proc_name)
4362 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4363 :
4364 : return t;
4365 : }
4366 :
4367 :
4368 : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4369 : op1->shape and op2->shape are non-NULL return true if their shapes
4370 : match. If both op1->shape and op2->shape are non-NULL return false
4371 : if their shapes do not match. If either op1->shape or op2->shape is
4372 : NULL, return true. */
4373 :
4374 : static bool
4375 33494 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4376 : {
4377 33494 : bool t;
4378 33494 : int i;
4379 :
4380 33494 : t = true;
4381 :
4382 33494 : if (op1->shape != NULL && op2->shape != NULL)
4383 : {
4384 43914 : for (i = 0; i < op1->rank; i++)
4385 : {
4386 23403 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4387 : {
4388 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4389 : &op1->where, &op2->where);
4390 3 : t = false;
4391 3 : break;
4392 : }
4393 : }
4394 : }
4395 :
4396 33494 : return t;
4397 : }
4398 :
4399 : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4400 : For example A .AND. B becomes IAND(A, B). */
4401 : static gfc_expr *
4402 668 : logical_to_bitwise (gfc_expr *e)
4403 : {
4404 668 : gfc_expr *tmp, *op1, *op2;
4405 668 : gfc_isym_id isym;
4406 668 : gfc_actual_arglist *args = NULL;
4407 :
4408 668 : gcc_assert (e->expr_type == EXPR_OP);
4409 :
4410 668 : isym = GFC_ISYM_NONE;
4411 668 : op1 = e->value.op.op1;
4412 668 : op2 = e->value.op.op2;
4413 :
4414 668 : switch (e->value.op.op)
4415 : {
4416 : case INTRINSIC_NOT:
4417 : isym = GFC_ISYM_NOT;
4418 : break;
4419 126 : case INTRINSIC_AND:
4420 126 : isym = GFC_ISYM_IAND;
4421 126 : break;
4422 127 : case INTRINSIC_OR:
4423 127 : isym = GFC_ISYM_IOR;
4424 127 : break;
4425 270 : case INTRINSIC_NEQV:
4426 270 : isym = GFC_ISYM_IEOR;
4427 270 : break;
4428 126 : case INTRINSIC_EQV:
4429 : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4430 : Change the old expression to NEQV, which will get replaced by IEOR,
4431 : and wrap it in NOT. */
4432 126 : tmp = gfc_copy_expr (e);
4433 126 : tmp->value.op.op = INTRINSIC_NEQV;
4434 126 : tmp = logical_to_bitwise (tmp);
4435 126 : isym = GFC_ISYM_NOT;
4436 126 : op1 = tmp;
4437 126 : op2 = NULL;
4438 126 : break;
4439 0 : default:
4440 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4441 : }
4442 :
4443 : /* Inherit the original operation's operands as arguments. */
4444 668 : args = gfc_get_actual_arglist ();
4445 668 : args->expr = op1;
4446 668 : if (op2)
4447 : {
4448 523 : args->next = gfc_get_actual_arglist ();
4449 523 : args->next->expr = op2;
4450 : }
4451 :
4452 : /* Convert the expression to a function call. */
4453 668 : e->expr_type = EXPR_FUNCTION;
4454 668 : e->value.function.actual = args;
4455 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4456 668 : e->value.function.name = e->value.function.isym->name;
4457 668 : e->value.function.esym = NULL;
4458 :
4459 : /* Make up a pre-resolved function call symtree if we need to. */
4460 668 : if (!e->symtree || !e->symtree->n.sym)
4461 : {
4462 668 : gfc_symbol *sym;
4463 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4464 668 : sym = e->symtree->n.sym;
4465 668 : sym->result = sym;
4466 668 : sym->attr.flavor = FL_PROCEDURE;
4467 668 : sym->attr.function = 1;
4468 668 : sym->attr.elemental = 1;
4469 668 : sym->attr.pure = 1;
4470 668 : sym->attr.referenced = 1;
4471 668 : gfc_intrinsic_symbol (sym);
4472 668 : gfc_commit_symbol (sym);
4473 : }
4474 :
4475 668 : args->name = e->value.function.isym->formal->name;
4476 668 : if (e->value.function.isym->formal->next)
4477 523 : args->next->name = e->value.function.isym->formal->next->name;
4478 :
4479 668 : return e;
4480 : }
4481 :
4482 : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4483 : candidates in CANDIDATES_LEN. */
4484 : static void
4485 114 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4486 : char **&candidates,
4487 : size_t &candidates_len)
4488 : {
4489 116 : gfc_symtree *p;
4490 :
4491 116 : if (uop == NULL)
4492 : return;
4493 :
4494 : /* Not sure how to properly filter here. Use all for a start.
4495 : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4496 : these as i suppose they don't make terribly sense. */
4497 :
4498 116 : if (uop->n.uop->op != NULL)
4499 2 : vec_push (candidates, candidates_len, uop->name);
4500 :
4501 116 : p = uop->left;
4502 116 : if (p)
4503 36 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4504 :
4505 116 : p = uop->right;
4506 116 : if (p)
4507 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4508 : }
4509 :
4510 : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4511 :
4512 : static const char*
4513 78 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4514 : {
4515 78 : char **candidates = NULL;
4516 78 : size_t candidates_len = 0;
4517 78 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4518 78 : return gfc_closest_fuzzy_match (op, candidates);
4519 : }
4520 :
4521 :
4522 : /* Callback finding an impure function as an operand to an .and. or
4523 : .or. expression. Remember the last function warned about to
4524 : avoid double warnings when recursing. */
4525 :
4526 : static int
4527 194416 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4528 : void *data)
4529 : {
4530 194416 : gfc_expr *f = *e;
4531 194416 : const char *name;
4532 194416 : static gfc_expr *last = NULL;
4533 194416 : bool *found = (bool *) data;
4534 :
4535 194416 : if (f->expr_type == EXPR_FUNCTION)
4536 : {
4537 12053 : *found = 1;
4538 12053 : if (f != last && !gfc_pure_function (f, &name)
4539 13356 : && !gfc_implicit_pure_function (f))
4540 : {
4541 1164 : if (name)
4542 1164 : gfc_warning (OPT_Wfunction_elimination,
4543 : "Impure function %qs at %L might not be evaluated",
4544 : name, &f->where);
4545 : else
4546 0 : gfc_warning (OPT_Wfunction_elimination,
4547 : "Impure function at %L might not be evaluated",
4548 : &f->where);
4549 : }
4550 12053 : last = f;
4551 : }
4552 :
4553 194416 : return 0;
4554 : }
4555 :
4556 : /* Return true if TYPE is character based, false otherwise. */
4557 :
4558 : static int
4559 1373 : is_character_based (bt type)
4560 : {
4561 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4562 : }
4563 :
4564 :
4565 : /* If expression is a hollerith, convert it to character and issue a warning
4566 : for the conversion. */
4567 :
4568 : static void
4569 408 : convert_hollerith_to_character (gfc_expr *e)
4570 : {
4571 408 : if (e->ts.type == BT_HOLLERITH)
4572 : {
4573 108 : gfc_typespec t;
4574 108 : gfc_clear_ts (&t);
4575 108 : t.type = BT_CHARACTER;
4576 108 : t.kind = e->ts.kind;
4577 108 : gfc_convert_type_warn (e, &t, 2, 1);
4578 : }
4579 408 : }
4580 :
4581 : /* Convert to numeric and issue a warning for the conversion. */
4582 :
4583 : static void
4584 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4585 : {
4586 240 : gfc_typespec t;
4587 240 : gfc_clear_ts (&t);
4588 240 : t.type = b->ts.type;
4589 240 : t.kind = b->ts.kind;
4590 240 : gfc_convert_type_warn (a, &t, 2, 1);
4591 240 : }
4592 :
4593 : /* Resolve an operator expression node. This can involve replacing the
4594 : operation with a user defined function call. CHECK_INTERFACES is a
4595 : helper macro. */
4596 :
4597 : #define CHECK_INTERFACES \
4598 : { \
4599 : match m = gfc_extend_expr (e); \
4600 : if (m == MATCH_YES) \
4601 : return true; \
4602 : if (m == MATCH_ERROR) \
4603 : return false; \
4604 : }
4605 :
4606 : static bool
4607 541590 : resolve_operator (gfc_expr *e)
4608 : {
4609 541590 : gfc_expr *op1, *op2;
4610 : /* One error uses 3 names; additional space for wording (also via gettext). */
4611 541590 : bool t = true;
4612 :
4613 : /* Reduce stacked parentheses to single pair */
4614 541590 : while (e->expr_type == EXPR_OP
4615 541748 : && e->value.op.op == INTRINSIC_PARENTHESES
4616 23690 : && e->value.op.op1->expr_type == EXPR_OP
4617 558616 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4618 : {
4619 158 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4620 158 : gfc_replace_expr (e, tmp);
4621 : }
4622 :
4623 : /* Resolve all subnodes-- give them types. */
4624 :
4625 541590 : switch (e->value.op.op)
4626 : {
4627 489082 : default:
4628 489082 : if (!gfc_resolve_expr (e->value.op.op2))
4629 541590 : t = false;
4630 :
4631 : /* Fall through. */
4632 :
4633 541590 : case INTRINSIC_NOT:
4634 541590 : case INTRINSIC_UPLUS:
4635 541590 : case INTRINSIC_UMINUS:
4636 541590 : case INTRINSIC_PARENTHESES:
4637 541590 : if (!gfc_resolve_expr (e->value.op.op1))
4638 : return false;
4639 541429 : if (e->value.op.op1
4640 541420 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4641 : {
4642 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4643 0 : "unary operator %qs", &e->value.op.op1->where,
4644 : gfc_op2string (e->value.op.op));
4645 0 : return false;
4646 : }
4647 541429 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4648 6 : && e->value.op.op == INTRINSIC_UMINUS)
4649 : {
4650 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4651 : &e->value.op.op1->where);
4652 2 : return false;
4653 : }
4654 541427 : break;
4655 : }
4656 :
4657 : /* Typecheck the new node. */
4658 :
4659 541427 : op1 = e->value.op.op1;
4660 541427 : op2 = e->value.op.op2;
4661 541427 : if (op1 == NULL && op2 == NULL)
4662 : return false;
4663 : /* Error out if op2 did not resolve. We already diagnosed op1. */
4664 541418 : if (t == false)
4665 : return false;
4666 :
4667 : /* op1 and op2 cannot both be BOZ. */
4668 541352 : if (op1 && op1->ts.type == BT_BOZ
4669 0 : && op2 && op2->ts.type == BT_BOZ)
4670 : {
4671 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4672 0 : "binary operator %qs", &op1->where, &op2->where,
4673 : gfc_op2string (e->value.op.op));
4674 0 : return false;
4675 : }
4676 :
4677 541352 : if ((op1 && op1->expr_type == EXPR_NULL)
4678 541350 : || (op2 && op2->expr_type == EXPR_NULL))
4679 : {
4680 3 : CHECK_INTERFACES
4681 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4682 3 : return false;
4683 : }
4684 :
4685 541349 : switch (e->value.op.op)
4686 : {
4687 8295 : case INTRINSIC_UPLUS:
4688 8295 : case INTRINSIC_UMINUS:
4689 8295 : if (op1->ts.type == BT_INTEGER
4690 : || op1->ts.type == BT_REAL
4691 : || op1->ts.type == BT_COMPLEX
4692 : || op1->ts.type == BT_UNSIGNED)
4693 : {
4694 8226 : e->ts = op1->ts;
4695 8226 : break;
4696 : }
4697 :
4698 69 : CHECK_INTERFACES
4699 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4700 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4701 43 : return false;
4702 :
4703 158273 : case INTRINSIC_POWER:
4704 158273 : case INTRINSIC_PLUS:
4705 158273 : case INTRINSIC_MINUS:
4706 158273 : case INTRINSIC_TIMES:
4707 158273 : case INTRINSIC_DIVIDE:
4708 :
4709 : /* UNSIGNED cannot appear in a mixed expression without explicit
4710 : conversion. */
4711 158273 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4712 : {
4713 3 : CHECK_INTERFACES
4714 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4715 : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4716 : gfc_typename (op1), gfc_typename (op2));
4717 3 : return false;
4718 : }
4719 :
4720 158270 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4721 : {
4722 : /* Do not perform conversions if operands are not conformable as
4723 : required for the binary intrinsic operators (F2018:10.1.5).
4724 : Defer to a possibly overloading user-defined operator. */
4725 157816 : if (!gfc_op_rank_conformable (op1, op2))
4726 : {
4727 36 : CHECK_INTERFACES
4728 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4729 0 : &op1->where, &op2->where);
4730 0 : return false;
4731 : }
4732 :
4733 157780 : gfc_type_convert_binary (e, 1);
4734 157780 : break;
4735 : }
4736 :
4737 454 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4738 : {
4739 225 : CHECK_INTERFACES
4740 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4741 : "numeric operator %qs at %L",
4742 : gfc_op2string (e->value.op.op), &e->where);
4743 2 : return false;
4744 : }
4745 : else
4746 : {
4747 229 : CHECK_INTERFACES
4748 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4749 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4750 : gfc_typename (op2));
4751 3 : return false;
4752 : }
4753 :
4754 2387 : case INTRINSIC_CONCAT:
4755 2387 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4756 2362 : && op1->ts.kind == op2->ts.kind)
4757 : {
4758 2353 : e->ts.type = BT_CHARACTER;
4759 2353 : e->ts.kind = op1->ts.kind;
4760 2353 : break;
4761 : }
4762 :
4763 34 : CHECK_INTERFACES
4764 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4765 : &e->where, gfc_typename (op1), gfc_typename (op2));
4766 10 : return false;
4767 :
4768 70059 : case INTRINSIC_AND:
4769 70059 : case INTRINSIC_OR:
4770 70059 : case INTRINSIC_EQV:
4771 70059 : case INTRINSIC_NEQV:
4772 70059 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4773 : {
4774 69508 : e->ts.type = BT_LOGICAL;
4775 69508 : e->ts.kind = gfc_kind_max (op1, op2);
4776 69508 : if (op1->ts.kind < e->ts.kind)
4777 140 : gfc_convert_type (op1, &e->ts, 2);
4778 69368 : else if (op2->ts.kind < e->ts.kind)
4779 117 : gfc_convert_type (op2, &e->ts, 2);
4780 :
4781 69508 : if (flag_frontend_optimize &&
4782 58408 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4783 : {
4784 : /* Warn about short-circuiting
4785 : with impure function as second operand. */
4786 52373 : bool op2_f = false;
4787 52373 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4788 : }
4789 : break;
4790 : }
4791 :
4792 : /* Logical ops on integers become bitwise ops with -fdec. */
4793 551 : else if (flag_dec
4794 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4795 : {
4796 523 : e->ts.type = BT_INTEGER;
4797 523 : e->ts.kind = gfc_kind_max (op1, op2);
4798 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4799 289 : gfc_convert_type (op1, &e->ts, 1);
4800 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4801 144 : gfc_convert_type (op2, &e->ts, 1);
4802 523 : e = logical_to_bitwise (e);
4803 523 : goto simplify_op;
4804 : }
4805 :
4806 28 : CHECK_INTERFACES
4807 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4808 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4809 : gfc_typename (op2));
4810 16 : return false;
4811 :
4812 20665 : case INTRINSIC_NOT:
4813 : /* Logical ops on integers become bitwise ops with -fdec. */
4814 20665 : if (flag_dec && op1->ts.type == BT_INTEGER)
4815 : {
4816 19 : e->ts.type = BT_INTEGER;
4817 19 : e->ts.kind = op1->ts.kind;
4818 19 : e = logical_to_bitwise (e);
4819 19 : goto simplify_op;
4820 : }
4821 :
4822 20646 : if (op1->ts.type == BT_LOGICAL)
4823 : {
4824 20640 : e->ts.type = BT_LOGICAL;
4825 20640 : e->ts.kind = op1->ts.kind;
4826 20640 : break;
4827 : }
4828 :
4829 6 : CHECK_INTERFACES
4830 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4831 : gfc_typename (op1));
4832 3 : return false;
4833 :
4834 21761 : case INTRINSIC_GT:
4835 21761 : case INTRINSIC_GT_OS:
4836 21761 : case INTRINSIC_GE:
4837 21761 : case INTRINSIC_GE_OS:
4838 21761 : case INTRINSIC_LT:
4839 21761 : case INTRINSIC_LT_OS:
4840 21761 : case INTRINSIC_LE:
4841 21761 : case INTRINSIC_LE_OS:
4842 21761 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4843 : {
4844 18 : CHECK_INTERFACES
4845 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4846 0 : return false;
4847 : }
4848 :
4849 : /* Fall through. */
4850 :
4851 257856 : case INTRINSIC_EQ:
4852 257856 : case INTRINSIC_EQ_OS:
4853 257856 : case INTRINSIC_NE:
4854 257856 : case INTRINSIC_NE_OS:
4855 :
4856 257856 : if (flag_dec
4857 1038 : && is_character_based (op1->ts.type)
4858 258191 : && is_character_based (op2->ts.type))
4859 : {
4860 204 : convert_hollerith_to_character (op1);
4861 204 : convert_hollerith_to_character (op2);
4862 : }
4863 :
4864 257856 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4865 39068 : && op1->ts.kind == op2->ts.kind)
4866 : {
4867 39031 : e->ts.type = BT_LOGICAL;
4868 39031 : e->ts.kind = gfc_default_logical_kind;
4869 39031 : break;
4870 : }
4871 :
4872 : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4873 218825 : if (op1->ts.type == BT_BOZ)
4874 : {
4875 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4876 : "as an operand of a relational operator"),
4877 : &op1->where))
4878 : return false;
4879 :
4880 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4881 : return false;
4882 :
4883 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4884 : return false;
4885 : }
4886 :
4887 : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4888 218825 : if (op2->ts.type == BT_BOZ)
4889 : {
4890 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4891 : " as an operand of a relational operator"),
4892 : &op2->where))
4893 : return false;
4894 :
4895 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4896 : return false;
4897 :
4898 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4899 : return false;
4900 : }
4901 218825 : if (flag_dec
4902 218825 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4903 120 : convert_to_numeric (op1, op2);
4904 :
4905 218825 : if (flag_dec
4906 218825 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4907 120 : convert_to_numeric (op2, op1);
4908 :
4909 218825 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4910 : {
4911 : /* Do not perform conversions if operands are not conformable as
4912 : required for the binary intrinsic operators (F2018:10.1.5).
4913 : Defer to a possibly overloading user-defined operator. */
4914 217696 : if (!gfc_op_rank_conformable (op1, op2))
4915 : {
4916 70 : CHECK_INTERFACES
4917 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4918 0 : &op1->where, &op2->where);
4919 0 : return false;
4920 : }
4921 :
4922 217626 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4923 : {
4924 1 : CHECK_INTERFACES
4925 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4926 1 : "%s and %s", &op1->where, &op2->where,
4927 : gfc_typename (op1), gfc_typename (op2));
4928 1 : return false;
4929 : }
4930 :
4931 217625 : gfc_type_convert_binary (e, 1);
4932 :
4933 217625 : e->ts.type = BT_LOGICAL;
4934 217625 : e->ts.kind = gfc_default_logical_kind;
4935 :
4936 217625 : if (warn_compare_reals)
4937 : {
4938 70 : gfc_intrinsic_op op = e->value.op.op;
4939 :
4940 : /* Type conversion has made sure that the types of op1 and op2
4941 : agree, so it is only necessary to check the first one. */
4942 70 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4943 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4944 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4945 : {
4946 13 : const char *msg;
4947 :
4948 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4949 : msg = G_("Equality comparison for %s at %L");
4950 : else
4951 6 : msg = G_("Inequality comparison for %s at %L");
4952 :
4953 13 : gfc_warning (OPT_Wcompare_reals, msg,
4954 : gfc_typename (op1), &op1->where);
4955 : }
4956 : }
4957 :
4958 : break;
4959 : }
4960 :
4961 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4962 : {
4963 2 : CHECK_INTERFACES
4964 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4965 : &e->where,
4966 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4967 : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4968 2 : }
4969 : else
4970 : {
4971 1127 : CHECK_INTERFACES
4972 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4973 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4974 : gfc_typename (op2));
4975 : }
4976 :
4977 : return false;
4978 :
4979 303 : case INTRINSIC_USER:
4980 303 : if (e->value.op.uop->op == NULL)
4981 : {
4982 78 : const char *name = e->value.op.uop->name;
4983 78 : const char *guessed;
4984 78 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4985 78 : CHECK_INTERFACES
4986 5 : if (guessed)
4987 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4988 : "%qs?", name, &e->where, guessed);
4989 : else
4990 4 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4991 : }
4992 225 : else if (op2 == NULL)
4993 : {
4994 48 : CHECK_INTERFACES
4995 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4996 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4997 : }
4998 : else
4999 : {
5000 177 : e->value.op.uop->op->sym->attr.referenced = 1;
5001 177 : CHECK_INTERFACES
5002 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
5003 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
5004 : gfc_typename (op2));
5005 : }
5006 :
5007 : return false;
5008 :
5009 23493 : case INTRINSIC_PARENTHESES:
5010 23493 : e->ts = op1->ts;
5011 23493 : if (e->ts.type == BT_CHARACTER)
5012 335 : e->ts.u.cl = op1->ts.u.cl;
5013 : break;
5014 :
5015 0 : default:
5016 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
5017 : }
5018 :
5019 : /* Deal with arrayness of an operand through an operator. */
5020 :
5021 538656 : switch (e->value.op.op)
5022 : {
5023 486297 : case INTRINSIC_PLUS:
5024 486297 : case INTRINSIC_MINUS:
5025 486297 : case INTRINSIC_TIMES:
5026 486297 : case INTRINSIC_DIVIDE:
5027 486297 : case INTRINSIC_POWER:
5028 486297 : case INTRINSIC_CONCAT:
5029 486297 : case INTRINSIC_AND:
5030 486297 : case INTRINSIC_OR:
5031 486297 : case INTRINSIC_EQV:
5032 486297 : case INTRINSIC_NEQV:
5033 486297 : case INTRINSIC_EQ:
5034 486297 : case INTRINSIC_EQ_OS:
5035 486297 : case INTRINSIC_NE:
5036 486297 : case INTRINSIC_NE_OS:
5037 486297 : case INTRINSIC_GT:
5038 486297 : case INTRINSIC_GT_OS:
5039 486297 : case INTRINSIC_GE:
5040 486297 : case INTRINSIC_GE_OS:
5041 486297 : case INTRINSIC_LT:
5042 486297 : case INTRINSIC_LT_OS:
5043 486297 : case INTRINSIC_LE:
5044 486297 : case INTRINSIC_LE_OS:
5045 :
5046 486297 : if (op1->rank == 0 && op2->rank == 0)
5047 432676 : e->rank = 0;
5048 :
5049 486297 : if (op1->rank == 0 && op2->rank != 0)
5050 : {
5051 2634 : e->rank = op2->rank;
5052 :
5053 2634 : if (e->shape == NULL)
5054 2603 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
5055 : }
5056 :
5057 486297 : if (op1->rank != 0 && op2->rank == 0)
5058 : {
5059 17432 : e->rank = op1->rank;
5060 :
5061 17432 : if (e->shape == NULL)
5062 17408 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5063 : }
5064 :
5065 486297 : if (op1->rank != 0 && op2->rank != 0)
5066 : {
5067 33555 : if (op1->rank == op2->rank)
5068 : {
5069 33555 : e->rank = op1->rank;
5070 33555 : if (e->shape == NULL)
5071 : {
5072 33494 : t = compare_shapes (op1, op2);
5073 33494 : if (!t)
5074 3 : e->shape = NULL;
5075 : else
5076 33491 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5077 : }
5078 : }
5079 : else
5080 : {
5081 : /* Allow higher level expressions to work. */
5082 0 : e->rank = 0;
5083 :
5084 : /* Try user-defined operators, and otherwise throw an error. */
5085 0 : CHECK_INTERFACES
5086 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
5087 0 : &op1->where, &op2->where);
5088 0 : return false;
5089 : }
5090 : }
5091 : break;
5092 :
5093 52359 : case INTRINSIC_PARENTHESES:
5094 52359 : case INTRINSIC_NOT:
5095 52359 : case INTRINSIC_UPLUS:
5096 52359 : case INTRINSIC_UMINUS:
5097 : /* Simply copy arrayness attribute */
5098 52359 : e->rank = op1->rank;
5099 52359 : e->corank = op1->corank;
5100 :
5101 52359 : if (e->shape == NULL)
5102 52349 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5103 :
5104 : break;
5105 :
5106 : default:
5107 : break;
5108 : }
5109 :
5110 539198 : simplify_op:
5111 :
5112 : /* Attempt to simplify the expression. */
5113 3 : if (t)
5114 : {
5115 539195 : t = gfc_simplify_expr (e, 0);
5116 : /* Some calls do not succeed in simplification and return false
5117 : even though there is no error; e.g. variable references to
5118 : PARAMETER arrays. */
5119 539195 : if (!gfc_is_constant_expr (e))
5120 492363 : t = true;
5121 : }
5122 : return t;
5123 : }
5124 :
5125 : static bool
5126 170 : resolve_conditional (gfc_expr *expr)
5127 : {
5128 170 : gfc_expr *condition, *true_expr, *false_expr;
5129 :
5130 170 : condition = expr->value.conditional.condition;
5131 170 : true_expr = expr->value.conditional.true_expr;
5132 170 : false_expr = expr->value.conditional.false_expr;
5133 :
5134 340 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5135 340 : || !gfc_resolve_expr (false_expr))
5136 : return false;
5137 :
5138 170 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5139 : {
5140 2 : gfc_error (
5141 : "Condition in conditional expression must be a scalar logical at %L",
5142 : &condition->where);
5143 2 : return false;
5144 : }
5145 :
5146 168 : if (true_expr->ts.type != false_expr->ts.type)
5147 : {
5148 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5149 : "must have the same declared type",
5150 : &true_expr->where, &false_expr->where);
5151 1 : return false;
5152 : }
5153 :
5154 167 : if (true_expr->ts.kind != false_expr->ts.kind)
5155 : {
5156 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5157 : "must have the same kind parameter",
5158 : &true_expr->where, &false_expr->where);
5159 1 : return false;
5160 : }
5161 :
5162 166 : if (true_expr->rank != false_expr->rank)
5163 : {
5164 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5165 : "must have the same rank",
5166 : &true_expr->where, &false_expr->where);
5167 1 : return false;
5168 : }
5169 :
5170 : /* TODO: support more data types for conditional expressions */
5171 165 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5172 165 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5173 67 : && true_expr->ts.type != BT_CHARACTER)
5174 : {
5175 1 : gfc_error (
5176 : "Sorry, only integer, logical, real, complex and character types are "
5177 : "currently supported for conditional expressions at %L",
5178 : &expr->where);
5179 1 : return false;
5180 : }
5181 :
5182 : /* TODO: support arrays in conditional expressions */
5183 164 : if (true_expr->rank > 0)
5184 : {
5185 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5186 : "expressions at %L",
5187 : &expr->where);
5188 1 : return false;
5189 : }
5190 :
5191 163 : expr->ts = true_expr->ts;
5192 163 : expr->rank = true_expr->rank;
5193 163 : return true;
5194 : }
5195 :
5196 : /************** Array resolution subroutines **************/
5197 :
5198 : enum compare_result
5199 : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5200 :
5201 : /* Compare two integer expressions. */
5202 :
5203 : static compare_result
5204 476795 : compare_bound (gfc_expr *a, gfc_expr *b)
5205 : {
5206 476795 : int i;
5207 :
5208 476795 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5209 313578 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5210 : return CMP_UNKNOWN;
5211 :
5212 : /* If either of the types isn't INTEGER, we must have
5213 : raised an error earlier. */
5214 :
5215 215866 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5216 : return CMP_UNKNOWN;
5217 :
5218 215862 : i = mpz_cmp (a->value.integer, b->value.integer);
5219 :
5220 215862 : if (i < 0)
5221 : return CMP_LT;
5222 101509 : if (i > 0)
5223 40318 : return CMP_GT;
5224 : return CMP_EQ;
5225 : }
5226 :
5227 :
5228 : /* Compare an integer expression with an integer. */
5229 :
5230 : static compare_result
5231 76243 : compare_bound_int (gfc_expr *a, int b)
5232 : {
5233 76243 : int i;
5234 :
5235 76243 : if (a == NULL
5236 33058 : || a->expr_type != EXPR_CONSTANT
5237 30105 : || a->ts.type != BT_INTEGER)
5238 : return CMP_UNKNOWN;
5239 :
5240 30105 : i = mpz_cmp_si (a->value.integer, b);
5241 :
5242 30105 : if (i < 0)
5243 : return CMP_LT;
5244 25631 : if (i > 0)
5245 22054 : return CMP_GT;
5246 : return CMP_EQ;
5247 : }
5248 :
5249 :
5250 : /* Compare an integer expression with a mpz_t. */
5251 :
5252 : static compare_result
5253 70885 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5254 : {
5255 70885 : int i;
5256 :
5257 70885 : if (a == NULL
5258 57794 : || a->expr_type != EXPR_CONSTANT
5259 55666 : || a->ts.type != BT_INTEGER)
5260 : return CMP_UNKNOWN;
5261 :
5262 55663 : i = mpz_cmp (a->value.integer, b);
5263 :
5264 55663 : if (i < 0)
5265 : return CMP_LT;
5266 25296 : if (i > 0)
5267 10776 : return CMP_GT;
5268 : return CMP_EQ;
5269 : }
5270 :
5271 :
5272 : /* Compute the last value of a sequence given by a triplet.
5273 : Return 0 if it wasn't able to compute the last value, or if the
5274 : sequence if empty, and 1 otherwise. */
5275 :
5276 : static int
5277 52802 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5278 : gfc_expr *stride, mpz_t last)
5279 : {
5280 52802 : mpz_t rem;
5281 :
5282 52802 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5283 37545 : || end == NULL || end->expr_type != EXPR_CONSTANT
5284 32787 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5285 : return 0;
5286 :
5287 32468 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5288 32467 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5289 : return 0;
5290 :
5291 6805 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5292 : {
5293 25788 : if (compare_bound (start, end) == CMP_GT)
5294 : return 0;
5295 24399 : mpz_set (last, end->value.integer);
5296 24399 : return 1;
5297 : }
5298 :
5299 6679 : if (compare_bound_int (stride, 0) == CMP_GT)
5300 : {
5301 : /* Stride is positive */
5302 5314 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5303 : return 0;
5304 : }
5305 : else
5306 : {
5307 : /* Stride is negative */
5308 1365 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5309 : return 0;
5310 : }
5311 :
5312 6659 : mpz_init (rem);
5313 6659 : mpz_sub (rem, end->value.integer, start->value.integer);
5314 6659 : mpz_tdiv_r (rem, rem, stride->value.integer);
5315 6659 : mpz_sub (last, end->value.integer, rem);
5316 6659 : mpz_clear (rem);
5317 :
5318 6659 : return 1;
5319 : }
5320 :
5321 :
5322 : /* Compare a single dimension of an array reference to the array
5323 : specification. */
5324 :
5325 : static bool
5326 221312 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5327 : {
5328 221312 : mpz_t last_value;
5329 :
5330 221312 : if (ar->dimen_type[i] == DIMEN_STAR)
5331 : {
5332 583 : gcc_assert (ar->stride[i] == NULL);
5333 : /* This implies [*] as [*:] and [*:3] are not possible. */
5334 583 : if (ar->start[i] == NULL)
5335 : {
5336 482 : gcc_assert (ar->end[i] == NULL);
5337 : return true;
5338 : }
5339 : }
5340 :
5341 : /* Given start, end and stride values, calculate the minimum and
5342 : maximum referenced indexes. */
5343 :
5344 220830 : switch (ar->dimen_type[i])
5345 : {
5346 : case DIMEN_VECTOR:
5347 : case DIMEN_THIS_IMAGE:
5348 : break;
5349 :
5350 159357 : case DIMEN_STAR:
5351 159357 : case DIMEN_ELEMENT:
5352 159357 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5353 : {
5354 2 : if (i < as->rank)
5355 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5356 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5357 2 : mpz_get_si (ar->start[i]->value.integer),
5358 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5359 : else
5360 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5361 : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5362 0 : mpz_get_si (ar->start[i]->value.integer),
5363 0 : mpz_get_si (as->lower[i]->value.integer),
5364 0 : i + 1 - as->rank);
5365 : return true;
5366 : }
5367 159355 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5368 : {
5369 39 : if (i < as->rank)
5370 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5371 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5372 39 : mpz_get_si (ar->start[i]->value.integer),
5373 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5374 : else
5375 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5376 : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5377 0 : mpz_get_si (ar->start[i]->value.integer),
5378 0 : mpz_get_si (as->upper[i]->value.integer),
5379 0 : i + 1 - as->rank);
5380 : return true;
5381 : }
5382 :
5383 : break;
5384 :
5385 52847 : case DIMEN_RANGE:
5386 52847 : {
5387 : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5388 : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5389 :
5390 52847 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5391 52847 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5392 :
5393 : /* Check for zero stride, which is not allowed. */
5394 52847 : if (comp_stride_zero == CMP_EQ)
5395 : {
5396 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5397 1 : return false;
5398 : }
5399 :
5400 : /* if start == end || (stride > 0 && start < end)
5401 : || (stride < 0 && start > end),
5402 : then the array section contains at least one element. In this
5403 : case, there is an out-of-bounds access if
5404 : (start < lower || start > upper). */
5405 52846 : if (comp_start_end == CMP_EQ
5406 52084 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5407 49295 : && comp_start_end == CMP_LT)
5408 23087 : || (comp_stride_zero == CMP_LT
5409 23087 : && comp_start_end == CMP_GT))
5410 : {
5411 31104 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5412 : {
5413 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5414 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5415 27 : mpz_get_si (AR_START->value.integer),
5416 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5417 27 : return true;
5418 : }
5419 31077 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5420 : {
5421 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5422 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5423 17 : mpz_get_si (AR_START->value.integer),
5424 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5425 17 : return true;
5426 : }
5427 : }
5428 :
5429 : /* If we can compute the highest index of the array section,
5430 : then it also has to be between lower and upper. */
5431 52802 : mpz_init (last_value);
5432 52802 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5433 : last_value))
5434 : {
5435 31058 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5436 : {
5437 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5438 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5439 : mpz_get_si (last_value),
5440 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5441 3 : mpz_clear (last_value);
5442 3 : return true;
5443 : }
5444 31055 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5445 : {
5446 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5447 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5448 : mpz_get_si (last_value),
5449 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5450 7 : mpz_clear (last_value);
5451 7 : return true;
5452 : }
5453 : }
5454 52792 : mpz_clear (last_value);
5455 :
5456 : #undef AR_START
5457 : #undef AR_END
5458 : }
5459 52792 : break;
5460 :
5461 0 : default:
5462 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5463 : }
5464 :
5465 : return true;
5466 : }
5467 :
5468 :
5469 : /* Compare an array reference with an array specification. */
5470 :
5471 : static bool
5472 436062 : compare_spec_to_ref (gfc_array_ref *ar)
5473 : {
5474 436062 : gfc_array_spec *as;
5475 436062 : int i;
5476 :
5477 436062 : as = ar->as;
5478 436062 : i = as->rank - 1;
5479 : /* TODO: Full array sections are only allowed as actual parameters. */
5480 436062 : if (as->type == AS_ASSUMED_SIZE
5481 5830 : && (/*ar->type == AR_FULL
5482 5830 : ||*/ (ar->type == AR_SECTION
5483 529 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5484 : {
5485 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5486 : "not specified at %L", &ar->where);
5487 5 : return false;
5488 : }
5489 :
5490 436057 : if (ar->type == AR_FULL)
5491 : return true;
5492 :
5493 168009 : if (as->rank != ar->dimen)
5494 : {
5495 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5496 : &ar->where, ar->dimen, as->rank);
5497 28 : return false;
5498 : }
5499 :
5500 : /* ar->codimen == 0 is a local array. */
5501 167981 : if (as->corank != ar->codimen && ar->codimen != 0)
5502 : {
5503 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5504 : &ar->where, ar->codimen, as->corank);
5505 0 : return false;
5506 : }
5507 :
5508 379001 : for (i = 0; i < as->rank; i++)
5509 211021 : if (!check_dimension (i, ar, as))
5510 : return false;
5511 :
5512 : /* Local access has no coarray spec. */
5513 167980 : if (ar->codimen != 0)
5514 19752 : for (i = as->rank; i < as->rank + as->corank; i++)
5515 : {
5516 10293 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5517 7202 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5518 : {
5519 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5520 2 : i + 1 - as->rank, &ar->where);
5521 2 : return false;
5522 : }
5523 10291 : if (!check_dimension (i, ar, as))
5524 : return false;
5525 : }
5526 :
5527 : return true;
5528 : }
5529 :
5530 :
5531 : /* Resolve one part of an array index. */
5532 :
5533 : static bool
5534 750532 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5535 : int force_index_integer_kind)
5536 : {
5537 750532 : gfc_typespec ts;
5538 :
5539 750532 : if (index == NULL)
5540 : return true;
5541 :
5542 222532 : if (!gfc_resolve_expr (index))
5543 : return false;
5544 :
5545 222521 : if (check_scalar && index->rank != 0)
5546 : {
5547 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5548 2 : return false;
5549 : }
5550 :
5551 222519 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5552 : {
5553 4 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5554 : &index->where, gfc_basic_typename (index->ts.type));
5555 4 : return false;
5556 : }
5557 :
5558 222515 : if (index->ts.type == BT_REAL)
5559 657 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5560 : &index->where))
5561 : return false;
5562 :
5563 222515 : if ((index->ts.kind != gfc_index_integer_kind
5564 217433 : && force_index_integer_kind)
5565 190703 : || (index->ts.type != BT_INTEGER
5566 : && index->ts.type != BT_UNKNOWN))
5567 : {
5568 32468 : gfc_clear_ts (&ts);
5569 32468 : ts.type = BT_INTEGER;
5570 32468 : ts.kind = gfc_index_integer_kind;
5571 :
5572 32468 : gfc_convert_type_warn (index, &ts, 2, 0);
5573 : }
5574 :
5575 : return true;
5576 : }
5577 :
5578 : /* Resolve one part of an array index. */
5579 :
5580 : bool
5581 500613 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5582 : {
5583 500613 : return gfc_resolve_index_1 (index, check_scalar, 1);
5584 : }
5585 :
5586 : /* Resolve a dim argument to an intrinsic function. */
5587 :
5588 : bool
5589 23921 : gfc_resolve_dim_arg (gfc_expr *dim)
5590 : {
5591 23921 : if (dim == NULL)
5592 : return true;
5593 :
5594 23921 : if (!gfc_resolve_expr (dim))
5595 : return false;
5596 :
5597 23921 : if (dim->rank != 0)
5598 : {
5599 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5600 0 : return false;
5601 :
5602 : }
5603 :
5604 23921 : if (dim->ts.type != BT_INTEGER)
5605 : {
5606 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5607 0 : return false;
5608 : }
5609 :
5610 23921 : if (dim->ts.kind != gfc_index_integer_kind)
5611 : {
5612 15312 : gfc_typespec ts;
5613 :
5614 15312 : gfc_clear_ts (&ts);
5615 15312 : ts.type = BT_INTEGER;
5616 15312 : ts.kind = gfc_index_integer_kind;
5617 :
5618 15312 : gfc_convert_type_warn (dim, &ts, 2, 0);
5619 : }
5620 :
5621 : return true;
5622 : }
5623 :
5624 : /* Given an expression that contains array references, update those array
5625 : references to point to the right array specifications. While this is
5626 : filled in during matching, this information is difficult to save and load
5627 : in a module, so we take care of it here.
5628 :
5629 : The idea here is that the original array reference comes from the
5630 : base symbol. We traverse the list of reference structures, setting
5631 : the stored reference to references. Component references can
5632 : provide an additional array specification. */
5633 : static void
5634 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5635 :
5636 : static bool
5637 918 : find_array_spec (gfc_expr *e)
5638 : {
5639 918 : gfc_array_spec *as;
5640 918 : gfc_component *c;
5641 918 : gfc_ref *ref;
5642 918 : bool class_as = false;
5643 :
5644 918 : if (e->symtree->n.sym->assoc)
5645 : {
5646 221 : if (e->symtree->n.sym->assoc->target)
5647 221 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5648 221 : resolve_assoc_var (e->symtree->n.sym, false);
5649 : }
5650 :
5651 918 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5652 : {
5653 124 : as = CLASS_DATA (e->symtree->n.sym)->as;
5654 124 : class_as = true;
5655 : }
5656 : else
5657 794 : as = e->symtree->n.sym->as;
5658 :
5659 2093 : for (ref = e->ref; ref; ref = ref->next)
5660 1182 : switch (ref->type)
5661 : {
5662 920 : case REF_ARRAY:
5663 920 : if (as == NULL)
5664 : {
5665 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5666 14 : ? ref->u.ar.where : e->where);
5667 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5668 : &loc);
5669 7 : return false;
5670 : }
5671 :
5672 913 : ref->u.ar.as = as;
5673 913 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5674 : as = NULL;
5675 : break;
5676 :
5677 238 : case REF_COMPONENT:
5678 238 : c = ref->u.c.component;
5679 238 : if (c->attr.dimension)
5680 : {
5681 107 : if (as != NULL && !(class_as && as == c->as))
5682 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5683 107 : as = c->as;
5684 : }
5685 :
5686 : break;
5687 :
5688 : case REF_SUBSTRING:
5689 : case REF_INQUIRY:
5690 : break;
5691 : }
5692 :
5693 911 : if (as != NULL)
5694 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5695 :
5696 : return true;
5697 : }
5698 :
5699 :
5700 : /* Resolve an array reference. */
5701 :
5702 : static bool
5703 436776 : resolve_array_ref (gfc_array_ref *ar)
5704 : {
5705 436776 : int i, check_scalar;
5706 436776 : gfc_expr *e;
5707 :
5708 686678 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5709 : {
5710 249919 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5711 :
5712 : /* Do not force gfc_index_integer_kind for the start. We can
5713 : do fine with any integer kind. This avoids temporary arrays
5714 : created for indexing with a vector. */
5715 249919 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5716 : return false;
5717 249904 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5718 : return false;
5719 249902 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5720 : return false;
5721 :
5722 249902 : e = ar->start[i];
5723 :
5724 249902 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5725 149266 : switch (e->rank)
5726 : {
5727 148168 : case 0:
5728 148168 : ar->dimen_type[i] = DIMEN_ELEMENT;
5729 148168 : break;
5730 :
5731 1098 : case 1:
5732 1098 : ar->dimen_type[i] = DIMEN_VECTOR;
5733 1098 : if (e->expr_type == EXPR_VARIABLE
5734 470 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5735 13 : ar->start[i] = gfc_get_parentheses (e);
5736 : break;
5737 :
5738 0 : default:
5739 0 : gfc_error ("Array index at %L is an array of rank %d",
5740 : &ar->c_where[i], e->rank);
5741 0 : return false;
5742 : }
5743 :
5744 : /* Fill in the upper bound, which may be lower than the
5745 : specified one for something like a(2:10:5), which is
5746 : identical to a(2:7:5). Only relevant for strides not equal
5747 : to one. Don't try a division by zero. */
5748 249902 : if (ar->dimen_type[i] == DIMEN_RANGE
5749 72829 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5750 8568 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5751 8421 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5752 : {
5753 8420 : mpz_t size, end;
5754 :
5755 8420 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5756 : {
5757 6689 : if (ar->end[i] == NULL)
5758 : {
5759 8062 : ar->end[i] =
5760 4031 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5761 : &ar->where);
5762 4031 : mpz_set (ar->end[i]->value.integer, end);
5763 : }
5764 2658 : else if (ar->end[i]->ts.type == BT_INTEGER
5765 2658 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5766 : {
5767 2658 : mpz_set (ar->end[i]->value.integer, end);
5768 : }
5769 : else
5770 0 : gcc_unreachable ();
5771 :
5772 6689 : mpz_clear (size);
5773 6689 : mpz_clear (end);
5774 : }
5775 : }
5776 : }
5777 :
5778 436759 : if (ar->type == AR_FULL)
5779 : {
5780 271753 : if (ar->as->rank == 0)
5781 3671 : ar->type = AR_ELEMENT;
5782 :
5783 : /* Make sure array is the same as array(:,:), this way
5784 : we don't need to special case all the time. */
5785 271753 : ar->dimen = ar->as->rank;
5786 646014 : for (i = 0; i < ar->dimen; i++)
5787 : {
5788 374261 : ar->dimen_type[i] = DIMEN_RANGE;
5789 :
5790 374261 : gcc_assert (ar->start[i] == NULL);
5791 374261 : gcc_assert (ar->end[i] == NULL);
5792 374261 : gcc_assert (ar->stride[i] == NULL);
5793 : }
5794 : }
5795 :
5796 : /* If the reference type is unknown, figure out what kind it is. */
5797 :
5798 436759 : if (ar->type == AR_UNKNOWN)
5799 : {
5800 151682 : ar->type = AR_ELEMENT;
5801 294065 : for (i = 0; i < ar->dimen; i++)
5802 181001 : if (ar->dimen_type[i] == DIMEN_RANGE
5803 181001 : || ar->dimen_type[i] == DIMEN_VECTOR)
5804 : {
5805 38618 : ar->type = AR_SECTION;
5806 38618 : break;
5807 : }
5808 : }
5809 :
5810 436759 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5811 : return false;
5812 :
5813 436723 : if (ar->as->corank && ar->codimen == 0)
5814 : {
5815 2149 : int n;
5816 2149 : ar->codimen = ar->as->corank;
5817 6064 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5818 3915 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5819 : }
5820 :
5821 436723 : if (ar->codimen)
5822 : {
5823 14202 : if (ar->team_type == TEAM_NUMBER)
5824 : {
5825 60 : if (!gfc_resolve_expr (ar->team))
5826 : return false;
5827 :
5828 60 : if (ar->team->rank != 0)
5829 : {
5830 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5831 : &ar->team->where);
5832 0 : return false;
5833 : }
5834 :
5835 60 : if (ar->team->ts.type != BT_INTEGER)
5836 : {
5837 6 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5838 : "type, found %s",
5839 6 : &ar->team->where,
5840 : gfc_basic_typename (ar->team->ts.type));
5841 6 : return false;
5842 : }
5843 : }
5844 14142 : else if (ar->team_type == TEAM_TEAM)
5845 : {
5846 42 : if (!gfc_resolve_expr (ar->team))
5847 : return false;
5848 :
5849 42 : if (ar->team->rank != 0)
5850 : {
5851 3 : gfc_error ("TEAM argument at %L must be scalar",
5852 : &ar->team->where);
5853 3 : return false;
5854 : }
5855 :
5856 39 : if (ar->team->ts.type != BT_DERIVED
5857 36 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5858 36 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5859 : {
5860 3 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5861 : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5862 3 : &ar->team->where,
5863 : gfc_basic_typename (ar->team->ts.type));
5864 3 : return false;
5865 : }
5866 : }
5867 14190 : if (ar->stat)
5868 : {
5869 62 : if (!gfc_resolve_expr (ar->stat))
5870 : return false;
5871 :
5872 62 : if (ar->stat->rank != 0)
5873 : {
5874 3 : gfc_error ("STAT argument at %L must be scalar",
5875 : &ar->stat->where);
5876 3 : return false;
5877 : }
5878 :
5879 59 : if (ar->stat->ts.type != BT_INTEGER)
5880 : {
5881 3 : gfc_error ("STAT argument at %L must be of INTEGER "
5882 : "type, found %s",
5883 3 : &ar->stat->where,
5884 : gfc_basic_typename (ar->stat->ts.type));
5885 3 : return false;
5886 : }
5887 :
5888 56 : if (ar->stat->expr_type != EXPR_VARIABLE)
5889 : {
5890 0 : gfc_error ("STAT's expression at %L must be a variable",
5891 : &ar->stat->where);
5892 0 : return false;
5893 : }
5894 : }
5895 : }
5896 : return true;
5897 : }
5898 :
5899 :
5900 : bool
5901 8973 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5902 : {
5903 8973 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5904 :
5905 8973 : if (ref->u.ss.start != NULL)
5906 : {
5907 8973 : if (!gfc_resolve_expr (ref->u.ss.start))
5908 : return false;
5909 :
5910 8973 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5911 : {
5912 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5913 : &ref->u.ss.start->where);
5914 1 : return false;
5915 : }
5916 :
5917 8972 : if (ref->u.ss.start->rank != 0)
5918 : {
5919 0 : gfc_error ("Substring start index at %L must be scalar",
5920 : &ref->u.ss.start->where);
5921 0 : return false;
5922 : }
5923 :
5924 8972 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5925 8972 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5926 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5927 : {
5928 1 : gfc_error ("Substring start index at %L is less than one",
5929 : &ref->u.ss.start->where);
5930 1 : return false;
5931 : }
5932 : }
5933 :
5934 8971 : if (ref->u.ss.end != NULL)
5935 : {
5936 8777 : if (!gfc_resolve_expr (ref->u.ss.end))
5937 : return false;
5938 :
5939 8777 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5940 : {
5941 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5942 : &ref->u.ss.end->where);
5943 1 : return false;
5944 : }
5945 :
5946 8776 : if (ref->u.ss.end->rank != 0)
5947 : {
5948 0 : gfc_error ("Substring end index at %L must be scalar",
5949 : &ref->u.ss.end->where);
5950 0 : return false;
5951 : }
5952 :
5953 8776 : if (ref->u.ss.length != NULL
5954 8439 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5955 8788 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5956 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5957 : {
5958 4 : gfc_error ("Substring end index at %L exceeds the string length",
5959 : &ref->u.ss.start->where);
5960 4 : return false;
5961 : }
5962 :
5963 8772 : if (compare_bound_mpz_t (ref->u.ss.end,
5964 8772 : gfc_integer_kinds[k].huge) == CMP_GT
5965 8772 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5966 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5967 : {
5968 4 : gfc_error ("Substring end index at %L is too large",
5969 : &ref->u.ss.end->where);
5970 4 : return false;
5971 : }
5972 : /* If the substring has the same length as the original
5973 : variable, the reference itself can be deleted. */
5974 :
5975 8768 : if (ref->u.ss.length != NULL
5976 8431 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5977 9708 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5978 236 : *equal_length = true;
5979 : }
5980 :
5981 : return true;
5982 : }
5983 :
5984 :
5985 : /* This function supplies missing substring charlens. */
5986 :
5987 : void
5988 9847 : gfc_resolve_substring_charlen (gfc_expr *e)
5989 : {
5990 9847 : gfc_ref *char_ref;
5991 9847 : gfc_expr *start, *end;
5992 9847 : gfc_typespec *ts = NULL;
5993 9847 : mpz_t diff;
5994 :
5995 14202 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5996 : {
5997 12355 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5998 : break;
5999 4355 : if (char_ref->type == REF_COMPONENT)
6000 334 : ts = &char_ref->u.c.component->ts;
6001 : }
6002 :
6003 9847 : if (!char_ref || char_ref->type == REF_INQUIRY)
6004 2019 : return;
6005 :
6006 8000 : gcc_assert (char_ref->next == NULL);
6007 :
6008 8000 : if (e->ts.u.cl)
6009 : {
6010 120 : if (e->ts.u.cl->length)
6011 120 : gfc_free_expr (e->ts.u.cl->length);
6012 0 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
6013 : return;
6014 : }
6015 :
6016 8000 : if (!e->ts.u.cl)
6017 7880 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6018 :
6019 8000 : if (char_ref->u.ss.start)
6020 8000 : start = gfc_copy_expr (char_ref->u.ss.start);
6021 : else
6022 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
6023 :
6024 8000 : if (char_ref->u.ss.end)
6025 7828 : end = gfc_copy_expr (char_ref->u.ss.end);
6026 172 : else if (e->expr_type == EXPR_VARIABLE)
6027 : {
6028 172 : if (!ts)
6029 154 : ts = &e->symtree->n.sym->ts;
6030 172 : end = gfc_copy_expr (ts->u.cl->length);
6031 : }
6032 : else
6033 : end = NULL;
6034 :
6035 8000 : if (!start || !end)
6036 : {
6037 172 : gfc_free_expr (start);
6038 172 : gfc_free_expr (end);
6039 172 : return;
6040 : }
6041 :
6042 : /* Length = (end - start + 1).
6043 : Check first whether it has a constant length. */
6044 7828 : if (gfc_dep_difference (end, start, &diff))
6045 : {
6046 7214 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
6047 : &e->where);
6048 :
6049 7214 : mpz_add_ui (len->value.integer, diff, 1);
6050 7214 : mpz_clear (diff);
6051 7214 : e->ts.u.cl->length = len;
6052 : /* The check for length < 0 is handled below */
6053 : }
6054 : else
6055 : {
6056 614 : e->ts.u.cl->length = gfc_subtract (end, start);
6057 614 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
6058 : gfc_get_int_expr (gfc_charlen_int_kind,
6059 : NULL, 1));
6060 : }
6061 :
6062 : /* F2008, 6.4.1: Both the starting point and the ending point shall
6063 : be within the range 1, 2, ..., n unless the starting point exceeds
6064 : the ending point, in which case the substring has length zero. */
6065 :
6066 7828 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
6067 52 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
6068 :
6069 7828 : e->ts.u.cl->length->ts.type = BT_INTEGER;
6070 7828 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6071 :
6072 : /* Make sure that the length is simplified. */
6073 7828 : gfc_simplify_expr (e->ts.u.cl->length, 1);
6074 7828 : gfc_resolve_expr (e->ts.u.cl->length);
6075 : }
6076 :
6077 :
6078 : /* Convert an array reference to an array element so that PDT KIND and LEN
6079 : or inquiry references are always scalar. */
6080 :
6081 : static void
6082 27 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
6083 : {
6084 27 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6085 27 : int dim;
6086 :
6087 27 : array_ref->u.ar.type = AR_ELEMENT;
6088 27 : expr->rank = 0;
6089 : /* Suppress the runtime bounds check. */
6090 27 : expr->no_bounds_check = 1;
6091 54 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
6092 : {
6093 27 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
6094 27 : if (array_ref->u.ar.start[dim])
6095 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
6096 :
6097 27 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
6098 9 : array_ref->u.ar.start[dim]
6099 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
6100 : else
6101 18 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
6102 :
6103 27 : if (array_ref->u.ar.end[dim])
6104 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
6105 27 : if (array_ref->u.ar.stride[dim])
6106 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
6107 : }
6108 27 : gfc_free_expr (unity);
6109 27 : }
6110 :
6111 :
6112 : /* Resolve subtype references. */
6113 :
6114 : bool
6115 557345 : gfc_resolve_ref (gfc_expr *expr)
6116 : {
6117 557345 : int current_part_dimension, n_components, seen_part_dimension;
6118 557345 : gfc_ref *ref, **prev, *array_ref;
6119 557345 : bool equal_length;
6120 557345 : gfc_symbol *last_pdt = NULL;
6121 :
6122 1096267 : for (ref = expr->ref; ref; ref = ref->next)
6123 539840 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6124 : {
6125 918 : if (!find_array_spec (expr))
6126 : return false;
6127 : break;
6128 : }
6129 :
6130 1636939 : for (prev = &expr->ref; *prev != NULL;
6131 539906 : prev = *prev == NULL ? prev : &(*prev)->next)
6132 539985 : switch ((*prev)->type)
6133 : {
6134 436776 : case REF_ARRAY:
6135 436776 : if (!resolve_array_ref (&(*prev)->u.ar))
6136 : return false;
6137 : break;
6138 :
6139 : case REF_COMPONENT:
6140 : case REF_INQUIRY:
6141 : break;
6142 :
6143 8692 : case REF_SUBSTRING:
6144 8692 : equal_length = false;
6145 8692 : if (!gfc_resolve_substring (*prev, &equal_length))
6146 : return false;
6147 :
6148 8684 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6149 : {
6150 : /* Remove the reference and move the charlen, if any. */
6151 211 : ref = *prev;
6152 211 : *prev = ref->next;
6153 211 : ref->next = NULL;
6154 211 : expr->ts.u.cl = ref->u.ss.length;
6155 211 : ref->u.ss.length = NULL;
6156 211 : gfc_free_ref_list (ref);
6157 : }
6158 : break;
6159 : }
6160 :
6161 : /* Check constraints on part references. */
6162 :
6163 557259 : current_part_dimension = 0;
6164 557259 : seen_part_dimension = 0;
6165 557259 : n_components = 0;
6166 557259 : array_ref = NULL;
6167 :
6168 : /* Use the declared type of the base symbol to initialize last_pdt when the
6169 : expression is not itself a PDT. This matters for ASSOCIATE variables whose
6170 : component reference may still point to a PDT template. */
6171 557259 : if (expr->expr_type == EXPR_VARIABLE
6172 461879 : && (IS_PDT (expr)
6173 461231 : || (expr->ref && expr->symtree && IS_PDT (expr->symtree->n.sym))))
6174 3641 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6175 :
6176 1096929 : for (ref = expr->ref; ref; ref = ref->next)
6177 : {
6178 539681 : switch (ref->type)
6179 : {
6180 436698 : case REF_ARRAY:
6181 436698 : array_ref = ref;
6182 436698 : switch (ref->u.ar.type)
6183 : {
6184 268080 : case AR_FULL:
6185 : /* Coarray scalar. */
6186 268080 : if (ref->u.ar.as->rank == 0)
6187 : {
6188 : current_part_dimension = 0;
6189 : break;
6190 : }
6191 : /* Fall through. */
6192 309822 : case AR_SECTION:
6193 309822 : current_part_dimension = 1;
6194 309822 : break;
6195 :
6196 126876 : case AR_ELEMENT:
6197 126876 : array_ref = NULL;
6198 126876 : current_part_dimension = 0;
6199 126876 : break;
6200 :
6201 0 : case AR_UNKNOWN:
6202 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6203 : }
6204 :
6205 : break;
6206 :
6207 93569 : case REF_COMPONENT:
6208 93569 : if (current_part_dimension || seen_part_dimension)
6209 : {
6210 : /* F03:C614. */
6211 7547 : if (ref->u.c.component->attr.pointer
6212 7544 : || ref->u.c.component->attr.proc_pointer
6213 7543 : || (ref->u.c.component->ts.type == BT_CLASS
6214 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6215 : {
6216 4 : gfc_error ("Component to the right of a part reference "
6217 : "with nonzero rank must not have the POINTER "
6218 : "attribute at %L", &expr->where);
6219 4 : return false;
6220 : }
6221 7543 : else if (ref->u.c.component->attr.allocatable
6222 7537 : || (ref->u.c.component->ts.type == BT_CLASS
6223 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6224 :
6225 : {
6226 7 : gfc_error ("Component to the right of a part reference "
6227 : "with nonzero rank must not have the ALLOCATABLE "
6228 : "attribute at %L", &expr->where);
6229 7 : return false;
6230 : }
6231 : }
6232 :
6233 : /* Sometimes the component in a component reference is that of the
6234 : pdt_template. Point to the component of pdt_type instead. This
6235 : ensures that the component gets a backend_decl in translation. */
6236 93558 : if (last_pdt)
6237 : {
6238 3512 : gfc_component *cmp = last_pdt->components;
6239 10491 : for (; cmp; cmp = cmp->next)
6240 10156 : if (!strcmp (cmp->name, ref->u.c.component->name))
6241 : {
6242 3177 : ref->u.c.component = cmp;
6243 3177 : break;
6244 : }
6245 3512 : ref->u.c.sym = last_pdt;
6246 : }
6247 :
6248 : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6249 93558 : if (ref->u.c.component->ts.type == BT_DERIVED)
6250 : {
6251 21528 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6252 : {
6253 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6254 : &ref->u.c.component->ts.u.derived,
6255 : NULL) != MATCH_YES)
6256 : return false;
6257 0 : last_pdt = ref->u.c.component->ts.u.derived;
6258 : }
6259 21528 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6260 539 : last_pdt = ref->u.c.component->ts.u.derived;
6261 : else
6262 : last_pdt = NULL;
6263 : }
6264 :
6265 : /* The F08 standard requires(See R425, R431, R435, and in particular
6266 : Note 6.7) that a PDT parameter reference be a scalar even if
6267 : the designator is an array." */
6268 93558 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6269 185 : && (ref->u.c.component->attr.pdt_kind
6270 185 : || ref->u.c.component->attr.pdt_len))
6271 7 : reset_array_ref_to_scalar (expr, array_ref);
6272 :
6273 93558 : n_components++;
6274 93558 : break;
6275 :
6276 : case REF_SUBSTRING:
6277 : break;
6278 :
6279 941 : case REF_INQUIRY:
6280 : /* Implement requirement in note 9.7 of F2018 that the result of the
6281 : LEN inquiry be a scalar. */
6282 941 : if (ref->u.i == INQUIRY_LEN && array_ref
6283 46 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6284 46 : || expr->ts.type == BT_INTEGER))
6285 20 : reset_array_ref_to_scalar (expr, array_ref);
6286 : break;
6287 : }
6288 :
6289 539670 : if (((ref->type == REF_COMPONENT && n_components > 1)
6290 525957 : || ref->next == NULL)
6291 : && current_part_dimension
6292 471371 : && seen_part_dimension)
6293 : {
6294 0 : gfc_error ("Two or more part references with nonzero rank must "
6295 : "not be specified at %L", &expr->where);
6296 0 : return false;
6297 : }
6298 :
6299 539670 : if (ref->type == REF_COMPONENT)
6300 : {
6301 93558 : if (current_part_dimension)
6302 7325 : seen_part_dimension = 1;
6303 :
6304 : /* reset to make sure */
6305 : current_part_dimension = 0;
6306 : }
6307 : }
6308 :
6309 : return true;
6310 : }
6311 :
6312 :
6313 : /* Given an expression, determine its shape. This is easier than it sounds.
6314 : Leaves the shape array NULL if it is not possible to determine the shape. */
6315 :
6316 : static void
6317 2646203 : expression_shape (gfc_expr *e)
6318 : {
6319 2646203 : mpz_t array[GFC_MAX_DIMENSIONS];
6320 2646203 : int i;
6321 :
6322 2646203 : if (e->rank <= 0 || e->shape != NULL)
6323 2464682 : return;
6324 :
6325 723141 : for (i = 0; i < e->rank; i++)
6326 488234 : if (!gfc_array_dimen_size (e, i, &array[i]))
6327 181521 : goto fail;
6328 :
6329 234907 : e->shape = gfc_get_shape (e->rank);
6330 :
6331 234907 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6332 :
6333 234907 : return;
6334 :
6335 181521 : fail:
6336 183216 : for (i--; i >= 0; i--)
6337 1695 : mpz_clear (array[i]);
6338 : }
6339 :
6340 :
6341 : /* Given a variable expression node, compute the rank of the expression by
6342 : examining the base symbol and any reference structures it may have. */
6343 :
6344 : void
6345 2646203 : gfc_expression_rank (gfc_expr *e)
6346 : {
6347 2646203 : gfc_ref *ref, *coarray_ref = nullptr;
6348 2646203 : int i, rank, corank;
6349 :
6350 : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6351 : could lead to serious confusion... */
6352 2646203 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6353 :
6354 2646203 : if (e->ref == NULL)
6355 : {
6356 1945426 : if (e->expr_type == EXPR_ARRAY)
6357 74478 : goto done;
6358 : /* Constructors can have a rank different from one via RESHAPE(). */
6359 :
6360 1870948 : if (e->symtree != NULL)
6361 : {
6362 : /* After errors the ts.u.derived of a CLASS might not be set. */
6363 1870936 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6364 14340 : && e->symtree->n.sym->ts.u.derived
6365 14335 : && CLASS_DATA (e->symtree->n.sym))
6366 1870936 : ? CLASS_DATA (e->symtree->n.sym)->as
6367 : : e->symtree->n.sym->as;
6368 1870936 : if (as)
6369 : {
6370 668 : e->rank = as->rank;
6371 668 : e->corank = as->corank;
6372 668 : goto done;
6373 : }
6374 : }
6375 1870280 : e->rank = 0;
6376 1870280 : e->corank = 0;
6377 1870280 : goto done;
6378 : }
6379 :
6380 : rank = 0;
6381 : corank = 0;
6382 :
6383 1110182 : for (ref = e->ref; ref; ref = ref->next)
6384 : {
6385 812832 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6386 604 : && ref->u.c.component->attr.function && !ref->next)
6387 : {
6388 408 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6389 408 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6390 : }
6391 :
6392 : /* F2018:5.4.7(5): an allocatable or pointer component selector ends the
6393 : codimensions inherited from an enclosing coarray. */
6394 812832 : if (ref->type == REF_COMPONENT)
6395 : {
6396 157937 : gfc_component *comp = ref->u.c.component;
6397 :
6398 157937 : if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
6399 : {
6400 7231 : if (CLASS_DATA (comp)->attr.class_pointer
6401 5674 : || CLASS_DATA (comp)->attr.allocatable)
6402 812832 : coarray_ref = nullptr;
6403 : }
6404 150706 : else if (comp->attr.pointer || comp->attr.allocatable)
6405 812832 : coarray_ref = nullptr;
6406 : }
6407 :
6408 812832 : if (ref->type != REF_ARRAY)
6409 165680 : continue;
6410 :
6411 647152 : if (!coarray_ref && ref->u.ar.as && ref->u.ar.as->corank > 0)
6412 647152 : coarray_ref = ref;
6413 647152 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6414 : {
6415 356935 : rank = ref->u.ar.as->rank;
6416 356935 : break;
6417 : }
6418 :
6419 290217 : if (ref->u.ar.type == AR_SECTION)
6420 : {
6421 : /* Figure out the rank of the section. */
6422 46492 : if (rank != 0)
6423 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6424 :
6425 115851 : for (i = 0; i < ref->u.ar.dimen; i++)
6426 69359 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6427 69359 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6428 60379 : rank++;
6429 :
6430 : break;
6431 : }
6432 : }
6433 : /* The codimensions come from the reference carrying them, which need not be
6434 : the last array reference: a subobject of a coarray is itself a coarray. */
6435 700777 : if (coarray_ref && coarray_ref->u.ar.as->rank != -1)
6436 : {
6437 19603 : for (i = coarray_ref->u.ar.as->rank;
6438 36333 : i < coarray_ref->u.ar.as->rank + coarray_ref->u.ar.as->corank; ++i)
6439 : {
6440 : /* For unknown dimen in non-resolved as assume full corank. */
6441 20698 : if (coarray_ref->u.ar.dimen_type[i] == DIMEN_STAR
6442 20046 : || (coarray_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6443 443 : && !coarray_ref->u.ar.as->resolved))
6444 : {
6445 : corank = coarray_ref->u.ar.as->corank;
6446 : break;
6447 : }
6448 19603 : else if (coarray_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6449 19603 : || coarray_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6450 19505 : || coarray_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6451 17059 : corank++;
6452 2544 : else if (coarray_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6453 0 : gfc_internal_error ("Illegal coarray index");
6454 : }
6455 : }
6456 :
6457 700777 : e->rank = rank;
6458 700777 : e->corank = corank;
6459 :
6460 2646203 : done:
6461 2646203 : expression_shape (e);
6462 2646203 : }
6463 :
6464 :
6465 : /* Given two expressions, check that their rank is conformable, i.e. either
6466 : both have the same rank or at least one is a scalar. */
6467 :
6468 : bool
6469 12261048 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6470 : {
6471 12261048 : if (op1->expr_type == EXPR_VARIABLE)
6472 747053 : gfc_expression_rank (op1);
6473 12261048 : if (op2->expr_type == EXPR_VARIABLE)
6474 450234 : gfc_expression_rank (op2);
6475 :
6476 79577 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6477 12340299 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6478 30 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6479 : }
6480 :
6481 :
6482 : /* Given an expression EXPR that is a variable, figure out what the ultimate
6483 : variable's type is and store it in TS, traversing the reference structures
6484 : if necessary.
6485 :
6486 : We start at the base symbol and store the type. Component references
6487 : overwrite a completely new type. */
6488 :
6489 : static void
6490 1340057 : get_data_ref_type (gfc_expr *expr, gfc_typespec *ts)
6491 : {
6492 1340057 : gfc_ref *ref;
6493 1340057 : gfc_symbol *sym;
6494 1340057 : gfc_component *comp;
6495 1340057 : bool has_inquiry_part;
6496 1340057 : bool has_substring_ref = false;
6497 :
6498 1340057 : if (expr->expr_type != EXPR_VARIABLE
6499 14 : && expr->expr_type != EXPR_FUNCTION
6500 0 : && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
6501 0 : gfc_internal_error ("get_data_ref_type(): Expression isn't a variable");
6502 :
6503 1340057 : sym = expr->symtree->n.sym;
6504 :
6505 1340057 : if (ts != NULL && expr->ts.type == BT_UNKNOWN)
6506 53297 : *ts = sym->ts;
6507 :
6508 : /* Catch left-overs from match_actual_arg, where an actual argument of a
6509 : procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
6510 : needed for structure constructors in DATA statements, where a pointer
6511 : is associated with a data target, and the argument has not been fully
6512 : resolved yet. Components references are dealt with further below. */
6513 53297 : if (ts != NULL
6514 1340057 : && expr->ts.type == BT_PROCEDURE
6515 3078 : && expr->ref == NULL
6516 3078 : && sym->attr.flavor != FL_PROCEDURE
6517 125 : && sym->attr.target)
6518 1 : *ts = sym->ts;
6519 :
6520 1340057 : has_inquiry_part = false;
6521 1859649 : for (ref = expr->ref; ref; ref = ref->next)
6522 520374 : if (ref->type == REF_SUBSTRING)
6523 : has_substring_ref = true;
6524 512694 : else if (ref->type == REF_INQUIRY)
6525 : {
6526 : has_inquiry_part = true;
6527 : break;
6528 : }
6529 :
6530 1860438 : for (ref = expr->ref; ref; ref = ref->next)
6531 520381 : switch (ref->type)
6532 : {
6533 91592 : case REF_COMPONENT:
6534 91592 : comp = ref->u.c.component;
6535 91592 : if (ts != NULL && !has_inquiry_part)
6536 : {
6537 91495 : *ts = comp->ts;
6538 : /* Don't set the string length if a substring reference
6539 : follows. */
6540 91495 : if (ts->type == BT_CHARACTER && has_substring_ref)
6541 300 : ts->u.cl = NULL;
6542 : }
6543 : break;
6544 :
6545 : case REF_ARRAY:
6546 : case REF_INQUIRY:
6547 : case REF_SUBSTRING:
6548 : break;
6549 : }
6550 1340057 : }
6551 :
6552 :
6553 : /* Resolve a variable expression. */
6554 :
6555 : static bool
6556 1355358 : resolve_variable (gfc_expr *e)
6557 : {
6558 1355358 : gfc_symbol *sym;
6559 1355358 : bool t;
6560 :
6561 1355358 : t = true;
6562 :
6563 1355358 : if (e->symtree == NULL)
6564 : return false;
6565 1354883 : sym = e->symtree->n.sym;
6566 :
6567 : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6568 : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6569 1354883 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6570 : {
6571 183 : if (!actual_arg || inquiry_argument)
6572 : {
6573 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6574 : "be used as actual argument", sym->name, &e->where);
6575 2 : return false;
6576 : }
6577 : }
6578 : /* TS 29113, 407b. */
6579 1354700 : else if (e->ts.type == BT_ASSUMED)
6580 : {
6581 571 : if (!actual_arg)
6582 : {
6583 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6584 : "as actual argument", sym->name, &e->where);
6585 20 : return false;
6586 : }
6587 551 : else if (inquiry_argument && !first_actual_arg)
6588 : {
6589 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6590 : for all inquiry functions in resolve_function; the reason is
6591 : that the function-name resolution happens too late in that
6592 : function. */
6593 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6594 : "an inquiry function shall be the first argument",
6595 : sym->name, &e->where);
6596 0 : return false;
6597 : }
6598 : }
6599 : /* TS 29113, C535b. */
6600 1354129 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6601 38894 : && sym->ts.u.derived && CLASS_DATA (sym)
6602 38889 : && CLASS_DATA (sym)->as
6603 15362 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6604 1353159 : || (sym->ts.type != BT_CLASS && sym->as
6605 370500 : && sym->as->type == AS_ASSUMED_RANK))
6606 8064 : && !sym->attr.select_rank_temporary
6607 8064 : && !(sym->assoc && sym->assoc->ar))
6608 : {
6609 8064 : if (!actual_arg
6610 1277 : && !(cs_base && cs_base->current
6611 1276 : && (cs_base->current->op == EXEC_SELECT_RANK
6612 188 : || sym->attr.target)))
6613 : {
6614 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6615 : "actual argument", sym->name, &e->where);
6616 144 : return false;
6617 : }
6618 7920 : else if (inquiry_argument && !first_actual_arg)
6619 : {
6620 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6621 : for all inquiry functions in resolve_function; the reason is
6622 : that the function-name resolution happens too late in that
6623 : function. */
6624 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6625 : "to an inquiry function shall be the first argument",
6626 : sym->name, &e->where);
6627 0 : return false;
6628 : }
6629 : }
6630 :
6631 1354717 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6632 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6633 180 : && e->ref->next == NULL))
6634 : {
6635 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6636 : "a subobject reference", sym->name, &e->ref->u.ar.where);
6637 1 : return false;
6638 : }
6639 : /* TS 29113, 407b. */
6640 1354716 : else if (e->ts.type == BT_ASSUMED && e->ref
6641 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6642 680 : && e->ref->next == NULL))
6643 : {
6644 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6645 : "reference", sym->name, &e->ref->u.ar.where);
6646 7 : return false;
6647 : }
6648 :
6649 : /* TS 29113, C535b. */
6650 1354709 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6651 38894 : && sym->ts.u.derived && CLASS_DATA (sym)
6652 38889 : && CLASS_DATA (sym)->as
6653 15362 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6654 1353739 : || (sym->ts.type != BT_CLASS && sym->as
6655 371036 : && sym->as->type == AS_ASSUMED_RANK))
6656 8204 : && !(sym->assoc && sym->assoc->ar)
6657 8204 : && e->ref
6658 8204 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6659 8200 : && e->ref->next == NULL))
6660 : {
6661 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6662 : "reference", sym->name, &e->ref->u.ar.where);
6663 4 : return false;
6664 : }
6665 :
6666 : /* Guessed type variables are associate_names whose selector had not been
6667 : parsed at the time that the construct was parsed. Now the namespace is
6668 : being resolved, the TKR of the selector will be available for fixup of
6669 : the associate_name. */
6670 1354705 : if (IS_INFERRED_TYPE (e) && e->ref)
6671 : {
6672 410 : gfc_fixup_inferred_type_refs (e);
6673 : /* KIND inquiry ref returns the kind of the target. */
6674 410 : if (e->expr_type == EXPR_CONSTANT)
6675 : return true;
6676 : }
6677 1354295 : else if (IS_INFERRED_TYPE (e)
6678 489 : && sym->ts.type != BT_UNKNOWN
6679 489 : && (sym->ts.type != e->ts.type || sym->ts.kind != e->ts.kind))
6680 : /* No subobject ref, but the expression's typespec was set at parse
6681 : time before the target's actual type/kind was known. Refresh from
6682 : the now-resolved associate-name symbol. */
6683 192 : e->ts = sym->ts;
6684 1354103 : else if (sym->attr.select_type_temporary
6685 9326 : && sym->ns->assoc_name_inferred)
6686 92 : gfc_fixup_inferred_type_refs (e);
6687 :
6688 : /* For variables that are used in an associate (target => object) where
6689 : the object's basetype is array valued while the target is scalar,
6690 : the ts' type of the component refs is still array valued, which
6691 : can't be translated that way. */
6692 1354693 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6693 635 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6694 635 : && sym->assoc->target->ts.u.derived
6695 635 : && CLASS_DATA (sym->assoc->target)
6696 635 : && CLASS_DATA (sym->assoc->target)->as)
6697 : {
6698 : gfc_ref *ref = e->ref;
6699 701 : while (ref)
6700 : {
6701 542 : switch (ref->type)
6702 : {
6703 237 : case REF_COMPONENT:
6704 237 : ref->u.c.sym = sym->ts.u.derived;
6705 : /* Stop the loop. */
6706 237 : ref = NULL;
6707 237 : break;
6708 305 : default:
6709 305 : ref = ref->next;
6710 305 : break;
6711 : }
6712 : }
6713 : }
6714 :
6715 : /* If this is an associate-name, it may be parsed with an array reference
6716 : in error even though the target is scalar. Fail directly in this case.
6717 : TODO Understand why class scalar expressions must be excluded. */
6718 1354693 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6719 : {
6720 12672 : if (sym->ts.type == BT_CLASS)
6721 245 : gfc_fix_class_refs (e);
6722 12672 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6723 2408 : && e->ref->type == REF_ARRAY)
6724 : {
6725 : /* Unambiguously scalar! */
6726 3 : if (sym->assoc->target
6727 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6728 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6729 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6730 : sym->name, &e->where);
6731 : return false;
6732 : }
6733 12669 : else if ((sym->attr.dimension || sym->attr.codimension)
6734 7291 : && (!e->ref || e->ref->type != REF_ARRAY))
6735 : {
6736 : /* This can happen because the parser did not detect that the
6737 : associate name is an array and the expression had no array
6738 : part_ref. */
6739 237 : gfc_ref *ref = gfc_get_ref ();
6740 237 : ref->type = REF_ARRAY;
6741 237 : ref->u.ar.type = AR_FULL;
6742 237 : if (sym->as)
6743 : {
6744 236 : ref->u.ar.as = sym->as;
6745 236 : ref->u.ar.dimen = sym->as->rank;
6746 : }
6747 237 : ref->next = e->ref;
6748 237 : e->ref = ref;
6749 : }
6750 : }
6751 :
6752 1354690 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6753 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6754 :
6755 : /* On the other hand, the parser may not have known this is an array;
6756 : in this case, we have to add a FULL reference. */
6757 1354690 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6758 : {
6759 0 : e->ref = gfc_get_ref ();
6760 0 : e->ref->type = REF_ARRAY;
6761 0 : e->ref->u.ar.type = AR_FULL;
6762 0 : e->ref->u.ar.dimen = 0;
6763 : }
6764 :
6765 : /* Like above, but for class types, where the checking whether an array
6766 : ref is present is more complicated. Furthermore make sure not to add
6767 : the full array ref to _vptr or _len refs. */
6768 1354690 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6769 1053 : && CLASS_DATA (sym)
6770 1053 : && (CLASS_DATA (sym)->attr.dimension
6771 479 : || CLASS_DATA (sym)->attr.codimension)
6772 580 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6773 : {
6774 555 : gfc_ref *ref, *newref;
6775 :
6776 555 : newref = gfc_get_ref ();
6777 555 : newref->type = REF_ARRAY;
6778 555 : newref->u.ar.type = AR_FULL;
6779 555 : newref->u.ar.dimen = 0;
6780 :
6781 : /* Because this is an associate var and the first ref either is a ref to
6782 : the _data component or not, no traversal of the ref chain is
6783 : needed. The array ref needs to be inserted after the _data ref,
6784 : or when that is not present, which may happened for polymorphic
6785 : types, then at the first position. */
6786 555 : ref = e->ref;
6787 555 : if (!ref)
6788 18 : e->ref = newref;
6789 537 : else if (ref->type == REF_COMPONENT
6790 232 : && strcmp ("_data", ref->u.c.component->name) == 0)
6791 : {
6792 232 : if (!ref->next || ref->next->type != REF_ARRAY)
6793 : {
6794 12 : newref->next = ref->next;
6795 12 : ref->next = newref;
6796 : }
6797 : else
6798 : /* Array ref present already. */
6799 220 : gfc_free_ref_list (newref);
6800 : }
6801 305 : else if (ref->type == REF_ARRAY)
6802 : /* Array ref present already. */
6803 305 : gfc_free_ref_list (newref);
6804 : else
6805 : {
6806 0 : newref->next = ref;
6807 0 : e->ref = newref;
6808 : }
6809 : }
6810 1354135 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6811 : {
6812 810 : gfc_ref *ref;
6813 1282 : for (ref = e->ref; ref; ref = ref->next)
6814 562 : if (ref->type == REF_SUBSTRING || ref->type == REF_INQUIRY)
6815 : break;
6816 810 : if (ref == NULL)
6817 720 : e->ts = sym->ts;
6818 : }
6819 :
6820 1354690 : if (e->ref && !gfc_resolve_ref (e))
6821 : return false;
6822 :
6823 1354597 : if (sym->attr.flavor == FL_PROCEDURE
6824 32971 : && (!sym->attr.function
6825 19209 : || (sym->attr.function && sym->result
6826 18754 : && sym->result->attr.proc_pointer
6827 728 : && !sym->result->attr.function)))
6828 : {
6829 13762 : e->ts.type = BT_PROCEDURE;
6830 13762 : goto resolve_procedure;
6831 : }
6832 :
6833 1340835 : if (sym->ts.type != BT_UNKNOWN)
6834 1340057 : get_data_ref_type (e, &e->ts);
6835 778 : else if (sym->attr.flavor == FL_PROCEDURE
6836 12 : && sym->attr.function && sym->result
6837 12 : && sym->result->ts.type != BT_UNKNOWN
6838 10 : && sym->result->attr.proc_pointer)
6839 10 : e->ts = sym->result->ts;
6840 : else
6841 : {
6842 : /* Must be a simple variable reference. */
6843 768 : if (!gfc_set_default_type (sym, 1, sym->ns))
6844 : return false;
6845 633 : e->ts = sym->ts;
6846 : }
6847 :
6848 1340700 : if (check_assumed_size_reference (sym, e))
6849 : return false;
6850 :
6851 : /* Deal with forward references to entries during gfc_resolve_code, to
6852 : satisfy, at least partially, 12.5.2.5. */
6853 1340681 : if (gfc_current_ns->entries
6854 3301 : && current_entry_id == sym->entry_id
6855 1050 : && cs_base
6856 964 : && cs_base->current
6857 964 : && cs_base->current->op != EXEC_ENTRY)
6858 : {
6859 964 : int n;
6860 964 : bool saved_specification_expr;
6861 964 : gfc_symbol *saved_specification_expr_symbol;
6862 :
6863 : /* If the symbol is a dummy... */
6864 964 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6865 : {
6866 : /* If it has not been seen as a dummy, this is an error. */
6867 462 : if (!entry_dummy_seen_p (sym))
6868 : {
6869 5 : if (specification_expr
6870 4 : && specification_expr_symbol
6871 4 : && specification_expr_symbol->attr.dummy
6872 2 : && specification_expr_symbol->ns == gfc_current_ns
6873 7 : && !entry_dummy_seen_p (specification_expr_symbol))
6874 : ;
6875 3 : else if (specification_expr)
6876 2 : gfc_error ("Variable %qs, used in a specification expression"
6877 : ", is referenced at %L before the ENTRY statement "
6878 : "in which it is a parameter",
6879 : sym->name, &cs_base->current->loc);
6880 : else
6881 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6882 : "statement in which it is a parameter",
6883 : sym->name, &cs_base->current->loc);
6884 : t = false;
6885 : }
6886 : }
6887 :
6888 : /* Now do the same check on the specification expressions. */
6889 964 : saved_specification_expr = specification_expr;
6890 964 : saved_specification_expr_symbol = specification_expr_symbol;
6891 964 : specification_expr = true;
6892 964 : specification_expr_symbol = sym;
6893 964 : if (sym->ts.type == BT_CHARACTER
6894 964 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6895 : t = false;
6896 :
6897 964 : if (sym->as)
6898 : {
6899 279 : for (n = 0; n < sym->as->rank; n++)
6900 : {
6901 164 : if (!gfc_resolve_expr (sym->as->lower[n]))
6902 0 : t = false;
6903 164 : if (!gfc_resolve_expr (sym->as->upper[n]))
6904 1 : t = false;
6905 : }
6906 : }
6907 964 : specification_expr = saved_specification_expr;
6908 964 : specification_expr_symbol = saved_specification_expr_symbol;
6909 :
6910 964 : if (t)
6911 : /* Update the symbol's entry level. */
6912 957 : sym->entry_id = current_entry_id + 1;
6913 : }
6914 :
6915 : /* If a symbol has been host_associated mark it. This is used latter,
6916 : to identify if aliasing is possible via host association. */
6917 1340681 : if (sym->attr.flavor == FL_VARIABLE
6918 1301630 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6919 6240 : || !sym->ns->code->ext.block.assoc)
6920 1299516 : && gfc_current_ns->parent
6921 619702 : && (gfc_current_ns->parent == sym->ns
6922 579494 : || (gfc_current_ns->parent->parent
6923 12523 : && gfc_current_ns->parent->parent == sym->ns)))
6924 47012 : sym->attr.host_assoc = 1;
6925 :
6926 1340681 : if (gfc_current_ns->proc_name
6927 1336285 : && sym->attr.dimension
6928 364120 : && (sym->ns != gfc_current_ns
6929 339517 : || sym->attr.use_assoc
6930 335326 : || sym->attr.in_common))
6931 33583 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6932 :
6933 1354443 : resolve_procedure:
6934 1354443 : if (t && !resolve_procedure_expression (e))
6935 : t = false;
6936 :
6937 : /* F2008, C617 and C1229. */
6938 1353286 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6939 1456834 : && gfc_is_coindexed (e))
6940 : {
6941 374 : gfc_ref *ref, *ref2 = NULL;
6942 :
6943 457 : for (ref = e->ref; ref; ref = ref->next)
6944 : {
6945 457 : if (ref->type == REF_COMPONENT)
6946 83 : ref2 = ref;
6947 457 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6948 : break;
6949 : }
6950 :
6951 748 : for ( ; ref; ref = ref->next)
6952 386 : if (ref->type == REF_COMPONENT)
6953 : break;
6954 :
6955 : /* Expression itself is not coindexed object. */
6956 374 : if (ref && e->ts.type == BT_CLASS)
6957 : {
6958 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6959 : &e->where);
6960 3 : t = false;
6961 : }
6962 :
6963 : /* Expression itself is coindexed object. */
6964 : if (ref == NULL)
6965 : {
6966 362 : gfc_component *c;
6967 362 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6968 482 : for ( ; c; c = c->next)
6969 120 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6970 : {
6971 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6972 : "subcomponent at %L", &e->where);
6973 0 : t = false;
6974 0 : break;
6975 : }
6976 : }
6977 : }
6978 :
6979 1354443 : if (t)
6980 1354433 : gfc_expression_rank (e);
6981 :
6982 1354443 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6983 3 : gfc_warning (OPT_Wdeprecated_declarations,
6984 : "Using variable %qs at %L is deprecated",
6985 : sym->name, &e->where);
6986 : /* Simplify cases where access to a parameter array results in a
6987 : single constant. Suppress errors since those will have been
6988 : issued before, as warnings. */
6989 1354443 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6990 : {
6991 2745 : gfc_push_suppress_errors ();
6992 2745 : gfc_simplify_expr (e, 1);
6993 2745 : gfc_pop_suppress_errors ();
6994 : }
6995 :
6996 : return t;
6997 : }
6998 :
6999 :
7000 : /* 'sym' was initially guessed to be derived type but has been corrected
7001 : in resolve_assoc_var to be a class entity or the derived type correcting.
7002 : If a class entity it will certainly need the _data reference or the
7003 : reference derived type symbol correcting in the first component ref if
7004 : a derived type. */
7005 :
7006 : void
7007 920 : gfc_fixup_inferred_type_refs (gfc_expr *e)
7008 : {
7009 920 : gfc_ref *ref, *new_ref;
7010 920 : gfc_symbol *sym, *derived;
7011 920 : gfc_expr *target;
7012 920 : sym = e->symtree->n.sym;
7013 :
7014 : /* An associate_name whose selector is (i) a component ref of a selector
7015 : that is a inferred type associate_name; or (ii) an intrinsic type that
7016 : has been inferred from an inquiry ref. */
7017 920 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7018 : {
7019 318 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
7020 318 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
7021 318 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
7022 : {
7023 60 : ref = e->ref;
7024 : /* A substring misidentified as an array section. */
7025 60 : if (sym->ts.type == BT_CHARACTER
7026 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
7027 6 : && !ref->u.ar.stride[0])
7028 : {
7029 6 : new_ref = gfc_get_ref ();
7030 6 : new_ref->type = REF_SUBSTRING;
7031 6 : new_ref->u.ss.start = ref->u.ar.start[0];
7032 6 : new_ref->u.ss.end = ref->u.ar.end[0];
7033 6 : new_ref->u.ss.length = sym->ts.u.cl;
7034 6 : *ref = *new_ref;
7035 6 : free (new_ref);
7036 : }
7037 : else
7038 : {
7039 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
7040 24 : gfc_error ("Invalid array reference at %L", &e->where);
7041 54 : e->ref = ref->next;
7042 54 : free (ref);
7043 : }
7044 : }
7045 :
7046 : /* It is possible for an inquiry reference to be mistaken for a
7047 : component reference. Correct this now. */
7048 318 : ref = e->ref;
7049 318 : if (ref && ref->type == REF_ARRAY)
7050 138 : ref = ref->next;
7051 186 : if (ref && ref->type == REF_COMPONENT
7052 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
7053 : {
7054 12 : e->symtree->n.sym = sym;
7055 12 : *ref = *new_ref;
7056 12 : gfc_free_ref_list (new_ref);
7057 : }
7058 :
7059 : /* The kind of the associate name is best evaluated directly from the
7060 : selector because of the guesses made in primary.cc, when the type
7061 : is still unknown. */
7062 318 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
7063 : {
7064 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
7065 12 : sym->assoc->target->ts.kind);
7066 12 : gfc_replace_expr (e, ne);
7067 12 : }
7068 174 : else if (ref && ref->type == REF_INQUIRY
7069 150 : && (ref->u.i == INQUIRY_RE || ref->u.i == INQUIRY_IM)
7070 114 : && sym->ts.type == BT_COMPLEX
7071 114 : && e->ts.type == BT_REAL
7072 114 : && e->ts.kind != sym->ts.kind)
7073 : /* primary.cc set the inquiry-result kind to the default real kind
7074 : when the associate-name's type was inferred from %re/%im before
7075 : the target was resolved. Now use the (resolved) selector kind. */
7076 24 : e->ts.kind = sym->ts.kind;
7077 :
7078 : /* Now that the references are all sorted out, set the expression rank
7079 : and return. */
7080 318 : gfc_expression_rank (e);
7081 318 : return;
7082 : }
7083 :
7084 602 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
7085 : : sym->ts.u.derived;
7086 :
7087 : /* Ensure that class symbols have an array spec and ensure that there
7088 : is a _data field reference following class type references. */
7089 602 : if (sym->ts.type == BT_CLASS
7090 196 : && sym->assoc->target->ts.type == BT_CLASS)
7091 : {
7092 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
7093 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
7094 196 : sym->attr.dimension = 0;
7095 196 : sym->attr.codimension = 0;
7096 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
7097 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
7098 196 : if (e->ref && (e->ref->type != REF_COMPONENT
7099 160 : || e->ref->u.c.component->name[0] != '_'))
7100 : {
7101 82 : ref = gfc_get_ref ();
7102 82 : ref->type = REF_COMPONENT;
7103 82 : ref->next = e->ref;
7104 82 : e->ref = ref;
7105 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
7106 : true, true, NULL);
7107 82 : ref->u.c.sym = sym->ts.u.derived;
7108 : }
7109 : }
7110 :
7111 : /* Proceed as far as the first component reference and ensure that the
7112 : correct derived type is being used. */
7113 865 : for (ref = e->ref; ref; ref = ref->next)
7114 829 : if (ref->type == REF_COMPONENT)
7115 : {
7116 566 : if (ref->u.c.component->name[0] != '_')
7117 370 : ref->u.c.sym = derived;
7118 : else
7119 196 : ref->u.c.sym = sym->ts.u.derived;
7120 : break;
7121 : }
7122 :
7123 : /* Verify that the type inference mechanism has not introduced a spurious
7124 : array reference. This can happen with an associate name, whose selector
7125 : is an element of another inferred type. */
7126 602 : target = e->symtree->n.sym->assoc->target;
7127 602 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
7128 190 : && e != target && !target->rank)
7129 : {
7130 : /* First case: array ref after the scalar class or derived
7131 : associate_name. */
7132 190 : if (e->ref && e->ref->type == REF_ARRAY
7133 7 : && e->ref->u.ar.type != AR_ELEMENT)
7134 : {
7135 7 : ref = e->ref;
7136 7 : if (ref->u.ar.type == AR_UNKNOWN)
7137 1 : gfc_error ("Invalid array reference at %L", &e->where);
7138 7 : e->ref = ref->next;
7139 7 : free (ref);
7140 :
7141 : /* If it hasn't a ref to the '_data' field supply one. */
7142 7 : if (sym->ts.type == BT_CLASS
7143 0 : && !(e->ref->type == REF_COMPONENT
7144 0 : && strcmp (e->ref->u.c.component->name, "_data")))
7145 : {
7146 0 : gfc_ref *new_ref;
7147 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
7148 : "_data", true, true, &new_ref);
7149 0 : new_ref->next = e->ref;
7150 0 : e->ref = new_ref;
7151 : }
7152 : }
7153 : /* 2nd case: a ref to the '_data' field followed by an array ref. */
7154 183 : else if (e->ref && e->ref->type == REF_COMPONENT
7155 183 : && strcmp (e->ref->u.c.component->name, "_data") == 0
7156 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
7157 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
7158 : {
7159 0 : ref = e->ref->next;
7160 0 : if (ref->u.ar.type == AR_UNKNOWN)
7161 0 : gfc_error ("Invalid array reference at %L", &e->where);
7162 0 : e->ref->next = e->ref->next->next;
7163 0 : free (ref);
7164 : }
7165 : }
7166 :
7167 : /* Now that all the references are OK, get the expression rank. */
7168 602 : gfc_expression_rank (e);
7169 : }
7170 :
7171 :
7172 : /* Checks to see that the correct symbol has been host associated.
7173 : The only situations where this arises are:
7174 : (i) That in which a twice contained function is parsed after
7175 : the host association is made. On detecting this, change
7176 : the symbol in the expression and convert the array reference
7177 : into an actual arglist if the old symbol is a variable; or
7178 : (ii) That in which an external function is typed but not declared
7179 : explicitly to be external. Here, the old symbol is changed
7180 : from a variable to an external function. */
7181 : static bool
7182 1707965 : check_host_association (gfc_expr *e)
7183 : {
7184 1707965 : gfc_symbol *sym, *old_sym;
7185 1707965 : gfc_symtree *st;
7186 1707965 : int n;
7187 1707965 : gfc_ref *ref;
7188 1707965 : gfc_actual_arglist *arg, *tail = NULL;
7189 1707965 : bool retval = e->expr_type == EXPR_FUNCTION;
7190 :
7191 : /* If the expression is the result of substitution in
7192 : interface.cc(gfc_extend_expr) because there is no way in
7193 : which the host association can be wrong. */
7194 1707965 : if (e->symtree == NULL
7195 1707116 : || e->symtree->n.sym == NULL
7196 1707116 : || e->user_operator)
7197 : return retval;
7198 :
7199 1705336 : old_sym = e->symtree->n.sym;
7200 :
7201 1705336 : if (gfc_current_ns->parent
7202 748952 : && old_sym->ns != gfc_current_ns)
7203 : {
7204 : /* Use the 'USE' name so that renamed module symbols are
7205 : correctly handled. */
7206 94886 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7207 :
7208 94886 : if (sym && old_sym != sym
7209 714 : && sym->attr.flavor == FL_PROCEDURE
7210 111 : && sym->attr.contained)
7211 : {
7212 : /* Clear the shape, since it might not be valid. */
7213 83 : gfc_free_shape (&e->shape, e->rank);
7214 :
7215 : /* Give the expression the right symtree! */
7216 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7217 83 : gcc_assert (st != NULL);
7218 :
7219 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7220 59 : || e->expr_type == EXPR_FUNCTION)
7221 : {
7222 : /* Original was function so point to the new symbol, since
7223 : the actual argument list is already attached to the
7224 : expression. */
7225 30 : e->value.function.esym = NULL;
7226 30 : e->symtree = st;
7227 : }
7228 : else
7229 : {
7230 : /* Original was variable so convert array references into
7231 : an actual arglist. This does not need any checking now
7232 : since resolve_function will take care of it. */
7233 53 : e->value.function.actual = NULL;
7234 53 : e->expr_type = EXPR_FUNCTION;
7235 53 : e->symtree = st;
7236 :
7237 : /* Ambiguity will not arise if the array reference is not
7238 : the last reference. */
7239 55 : for (ref = e->ref; ref; ref = ref->next)
7240 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7241 : break;
7242 :
7243 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7244 17 : && sym->attr.proc == PROC_INTERNAL)
7245 : {
7246 4 : gfc_error ("%qs at %L is host associated at %L into "
7247 : "a contained procedure with an internal "
7248 : "procedure of the same name", sym->name,
7249 : &old_sym->declared_at, &e->where);
7250 4 : return false;
7251 : }
7252 :
7253 13 : if (ref == NULL)
7254 : return false;
7255 :
7256 36 : gcc_assert (ref->type == REF_ARRAY);
7257 :
7258 : /* Grab the start expressions from the array ref and
7259 : copy them into actual arguments. */
7260 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7261 : {
7262 48 : arg = gfc_get_actual_arglist ();
7263 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7264 48 : if (e->value.function.actual == NULL)
7265 36 : tail = e->value.function.actual = arg;
7266 : else
7267 : {
7268 12 : tail->next = arg;
7269 12 : tail = arg;
7270 : }
7271 : }
7272 :
7273 : /* Dump the reference list and set the rank. */
7274 36 : gfc_free_ref_list (e->ref);
7275 36 : e->ref = NULL;
7276 36 : e->rank = sym->as ? sym->as->rank : 0;
7277 36 : e->corank = sym->as ? sym->as->corank : 0;
7278 : }
7279 :
7280 66 : gfc_resolve_expr (e);
7281 66 : sym->refs++;
7282 : }
7283 : /* This case corresponds to a call, from a block or a contained
7284 : procedure, to an external function, which has not been declared
7285 : as being external in the main program but has been typed. */
7286 94803 : else if (sym && old_sym != sym
7287 631 : && !e->ref
7288 359 : && sym->ts.type == BT_UNKNOWN
7289 27 : && old_sym->ts.type != BT_UNKNOWN
7290 19 : && sym->attr.flavor == FL_PROCEDURE
7291 19 : && old_sym->attr.flavor == FL_VARIABLE
7292 7 : && sym->ns->parent == old_sym->ns
7293 7 : && sym->ns->proc_name
7294 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7295 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7296 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7297 : {
7298 6 : old_sym->attr.flavor = FL_PROCEDURE;
7299 6 : old_sym->attr.external = 1;
7300 6 : old_sym->attr.function = 1;
7301 6 : old_sym->result = old_sym;
7302 6 : gfc_resolve_expr (e);
7303 : }
7304 : }
7305 : /* This might have changed! */
7306 1705319 : return e->expr_type == EXPR_FUNCTION;
7307 : }
7308 :
7309 :
7310 : static void
7311 1508 : gfc_resolve_character_operator (gfc_expr *e)
7312 : {
7313 1508 : gfc_expr *op1 = e->value.op.op1;
7314 1508 : gfc_expr *op2 = e->value.op.op2;
7315 1508 : gfc_expr *e1 = NULL;
7316 1508 : gfc_expr *e2 = NULL;
7317 :
7318 1508 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7319 :
7320 1508 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7321 844 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7322 664 : else if (op1->expr_type == EXPR_CONSTANT)
7323 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7324 268 : op1->value.character.length);
7325 :
7326 1508 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7327 801 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7328 707 : else if (op2->expr_type == EXPR_CONSTANT)
7329 474 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7330 474 : op2->value.character.length);
7331 :
7332 1508 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7333 :
7334 1508 : if (!e1 || !e2)
7335 : {
7336 521 : gfc_free_expr (e1);
7337 521 : gfc_free_expr (e2);
7338 :
7339 521 : return;
7340 : }
7341 :
7342 987 : e->ts.u.cl->length = gfc_add (e1, e2);
7343 987 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7344 987 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7345 987 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7346 987 : gfc_resolve_expr (e->ts.u.cl->length);
7347 :
7348 987 : return;
7349 : }
7350 :
7351 :
7352 : /* Ensure that an character expression has a charlen and, if possible, a
7353 : length expression. */
7354 :
7355 : static void
7356 182138 : fixup_charlen (gfc_expr *e)
7357 : {
7358 : /* The cases fall through so that changes in expression type and the need
7359 : for multiple fixes are picked up. In all circumstances, a charlen should
7360 : be available for the middle end to hang a backend_decl on. */
7361 182138 : switch (e->expr_type)
7362 : {
7363 1508 : case EXPR_OP:
7364 1508 : gfc_resolve_character_operator (e);
7365 : /* FALLTHRU */
7366 :
7367 1575 : case EXPR_ARRAY:
7368 1575 : if (e->expr_type == EXPR_ARRAY)
7369 67 : gfc_resolve_character_array_constructor (e);
7370 : /* FALLTHRU */
7371 :
7372 2032 : case EXPR_SUBSTRING:
7373 2032 : if (!e->ts.u.cl && e->ref)
7374 453 : gfc_resolve_substring_charlen (e);
7375 : /* FALLTHRU */
7376 :
7377 182138 : default:
7378 182138 : if (!e->ts.u.cl)
7379 180110 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7380 :
7381 182138 : break;
7382 : }
7383 182138 : }
7384 :
7385 :
7386 : /* Update an actual argument to include the passed-object for type-bound
7387 : procedures at the right position. */
7388 :
7389 : static gfc_actual_arglist*
7390 3038 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7391 : const char *name)
7392 : {
7393 3062 : gcc_assert (argpos > 0);
7394 :
7395 3062 : if (argpos == 1)
7396 : {
7397 2913 : gfc_actual_arglist* result;
7398 :
7399 2913 : result = gfc_get_actual_arglist ();
7400 2913 : result->expr = po;
7401 2913 : result->next = lst;
7402 2913 : if (name)
7403 514 : result->name = name;
7404 :
7405 : return result;
7406 : }
7407 :
7408 149 : if (lst)
7409 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7410 : else
7411 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7412 : return lst;
7413 : }
7414 :
7415 :
7416 : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7417 :
7418 : static gfc_expr*
7419 7431 : extract_compcall_passed_object (gfc_expr* e)
7420 : {
7421 7431 : gfc_expr* po;
7422 :
7423 7431 : if (e->expr_type == EXPR_UNKNOWN)
7424 : {
7425 0 : gfc_error ("Error in typebound call at %L",
7426 : &e->where);
7427 0 : return NULL;
7428 : }
7429 :
7430 7431 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7431 :
7432 7431 : if (e->value.compcall.base_object)
7433 1668 : po = gfc_copy_expr (e->value.compcall.base_object);
7434 : else
7435 : {
7436 5763 : po = gfc_get_expr ();
7437 5763 : po->expr_type = EXPR_VARIABLE;
7438 5763 : po->symtree = e->symtree;
7439 5763 : po->ref = gfc_copy_ref (e->ref);
7440 5763 : po->where = e->where;
7441 : }
7442 :
7443 7431 : if (!gfc_resolve_expr (po))
7444 3 : return NULL;
7445 :
7446 : return po;
7447 : }
7448 :
7449 :
7450 : /* Update the arglist of an EXPR_COMPCALL expression to include the
7451 : passed-object. */
7452 :
7453 : static bool
7454 3420 : update_compcall_arglist (gfc_expr* e)
7455 : {
7456 3420 : gfc_expr* po;
7457 3420 : gfc_typebound_proc* tbp;
7458 :
7459 3420 : tbp = e->value.compcall.tbp;
7460 :
7461 3420 : if (tbp->error)
7462 : return false;
7463 :
7464 3419 : po = extract_compcall_passed_object (e);
7465 3419 : if (!po)
7466 : return false;
7467 :
7468 3419 : if (tbp->nopass || e->value.compcall.ignore_pass)
7469 : {
7470 1170 : gfc_free_expr (po);
7471 1170 : return true;
7472 : }
7473 :
7474 2249 : if (tbp->pass_arg_num <= 0)
7475 : return false;
7476 :
7477 2248 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7478 : tbp->pass_arg_num,
7479 : tbp->pass_arg);
7480 :
7481 2248 : return true;
7482 : }
7483 :
7484 :
7485 : /* Extract the passed object from a PPC call (a copy of it). */
7486 :
7487 : static gfc_expr*
7488 85 : extract_ppc_passed_object (gfc_expr *e)
7489 : {
7490 85 : gfc_expr *po;
7491 85 : gfc_ref **ref;
7492 :
7493 85 : po = gfc_get_expr ();
7494 85 : po->expr_type = EXPR_VARIABLE;
7495 85 : po->symtree = e->symtree;
7496 85 : po->ref = gfc_copy_ref (e->ref);
7497 85 : po->where = e->where;
7498 :
7499 : /* Remove PPC reference. */
7500 85 : ref = &po->ref;
7501 91 : while ((*ref)->next)
7502 6 : ref = &(*ref)->next;
7503 85 : gfc_free_ref_list (*ref);
7504 85 : *ref = NULL;
7505 :
7506 85 : if (!gfc_resolve_expr (po))
7507 0 : return NULL;
7508 :
7509 : return po;
7510 : }
7511 :
7512 :
7513 : /* Update the actual arglist of a procedure pointer component to include the
7514 : passed-object. */
7515 :
7516 : static bool
7517 600 : update_ppc_arglist (gfc_expr* e)
7518 : {
7519 600 : gfc_expr* po;
7520 600 : gfc_component *ppc;
7521 600 : gfc_typebound_proc* tb;
7522 :
7523 600 : ppc = gfc_get_proc_ptr_comp (e);
7524 600 : if (!ppc)
7525 : return false;
7526 :
7527 600 : tb = ppc->tb;
7528 :
7529 600 : if (tb->error)
7530 : return false;
7531 598 : else if (tb->nopass)
7532 : return true;
7533 :
7534 85 : po = extract_ppc_passed_object (e);
7535 85 : if (!po)
7536 : return false;
7537 :
7538 : /* F08:R739. */
7539 85 : if (po->rank != 0)
7540 : {
7541 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7542 0 : return false;
7543 : }
7544 :
7545 : /* F08:C611. */
7546 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7547 : {
7548 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7549 : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7550 1 : return false;
7551 : }
7552 :
7553 84 : gcc_assert (tb->pass_arg_num > 0);
7554 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7555 : tb->pass_arg_num,
7556 : tb->pass_arg);
7557 :
7558 84 : return true;
7559 : }
7560 :
7561 :
7562 : /* Check that the object a TBP is called on is valid, i.e. it must not be
7563 : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7564 :
7565 : static bool
7566 3431 : check_typebound_baseobject (gfc_expr* e)
7567 : {
7568 3431 : gfc_expr* base;
7569 3431 : bool return_value = false;
7570 :
7571 3431 : base = extract_compcall_passed_object (e);
7572 3431 : if (!base)
7573 : return false;
7574 :
7575 3428 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7576 : {
7577 1 : gfc_error ("Error in typebound call at %L", &e->where);
7578 1 : goto cleanup;
7579 : }
7580 :
7581 3427 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7582 1 : return false;
7583 :
7584 : /* F08:C611. */
7585 3426 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7586 : {
7587 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7588 : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7589 3 : goto cleanup;
7590 : }
7591 :
7592 : /* F08:C1230. If the procedure called is NOPASS,
7593 : the base object must be scalar. */
7594 3423 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7595 : {
7596 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7597 : " be scalar", &e->where);
7598 1 : goto cleanup;
7599 : }
7600 :
7601 : return_value = true;
7602 :
7603 3427 : cleanup:
7604 3427 : gfc_free_expr (base);
7605 3427 : return return_value;
7606 : }
7607 :
7608 :
7609 : /* Resolve a call to a type-bound procedure, either function or subroutine,
7610 : statically from the data in an EXPR_COMPCALL expression. The adapted
7611 : arglist and the target-procedure symtree are returned. */
7612 :
7613 : static bool
7614 3420 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7615 : gfc_actual_arglist** actual)
7616 : {
7617 3420 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7618 3420 : gcc_assert (!e->value.compcall.tbp->is_generic);
7619 :
7620 : /* Update the actual arglist for PASS. */
7621 3420 : if (!update_compcall_arglist (e))
7622 : return false;
7623 :
7624 3418 : *actual = e->value.compcall.actual;
7625 3418 : *target = e->value.compcall.tbp->u.specific;
7626 :
7627 3418 : gfc_free_ref_list (e->ref);
7628 3418 : e->ref = NULL;
7629 3418 : e->value.compcall.actual = NULL;
7630 :
7631 : /* If we find a deferred typebound procedure, check for derived types
7632 : that an overriding typebound procedure has not been missed. */
7633 3418 : if (e->value.compcall.name
7634 3418 : && !e->value.compcall.tbp->non_overridable
7635 3400 : && e->value.compcall.base_object
7636 834 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7637 : {
7638 541 : gfc_symtree *st;
7639 541 : gfc_symbol *derived;
7640 :
7641 : /* Use the derived type of the base_object. */
7642 541 : derived = e->value.compcall.base_object->ts.u.derived;
7643 541 : st = NULL;
7644 :
7645 : /* If necessary, go through the inheritance chain. */
7646 1631 : while (!st && derived)
7647 : {
7648 : /* Look for the typebound procedure 'name'. */
7649 549 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7650 541 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7651 : e->value.compcall.name);
7652 549 : if (!st)
7653 8 : derived = gfc_get_derived_super_type (derived);
7654 : }
7655 :
7656 : /* Now find the specific name in the derived type namespace. */
7657 541 : if (st && st->n.tb && st->n.tb->u.specific)
7658 541 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7659 541 : derived->ns, 1, &st);
7660 541 : if (st)
7661 541 : *target = st;
7662 : }
7663 :
7664 3418 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7665 3418 : && !e->value.compcall.tbp->deferred)
7666 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7667 : " itself recursively. Declare it RECURSIVE or use"
7668 : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7669 :
7670 : return true;
7671 : }
7672 :
7673 :
7674 : /* Get the ultimate declared type from an expression. In addition,
7675 : return the last class/derived type reference and the copy of the
7676 : reference list. If check_types is set true, derived types are
7677 : identified as well as class references. */
7678 : static gfc_symbol*
7679 3333 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7680 : gfc_expr *e, bool check_types)
7681 : {
7682 3333 : gfc_symbol *declared;
7683 3333 : gfc_ref *ref;
7684 :
7685 3333 : declared = NULL;
7686 3333 : if (class_ref)
7687 2900 : *class_ref = NULL;
7688 3333 : if (new_ref)
7689 2607 : *new_ref = gfc_copy_ref (e->ref);
7690 :
7691 4128 : for (ref = e->ref; ref; ref = ref->next)
7692 : {
7693 795 : if (ref->type != REF_COMPONENT)
7694 292 : continue;
7695 :
7696 503 : if ((ref->u.c.component->ts.type == BT_CLASS
7697 256 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7698 428 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7699 : {
7700 354 : declared = ref->u.c.component->ts.u.derived;
7701 354 : if (class_ref)
7702 332 : *class_ref = ref;
7703 : }
7704 : }
7705 :
7706 3333 : if (declared == NULL)
7707 3005 : declared = e->symtree->n.sym->ts.u.derived;
7708 :
7709 3333 : return declared;
7710 : }
7711 :
7712 :
7713 : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7714 : which of the specific bindings (if any) matches the arglist and transform
7715 : the expression into a call of that binding. */
7716 :
7717 : static bool
7718 3422 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7719 : {
7720 3422 : gfc_typebound_proc* genproc;
7721 3422 : const char* genname;
7722 3422 : gfc_symtree *st;
7723 3422 : gfc_symbol *derived;
7724 :
7725 3422 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7726 3422 : genname = e->value.compcall.name;
7727 3422 : genproc = e->value.compcall.tbp;
7728 :
7729 3422 : if (!genproc->is_generic)
7730 : return true;
7731 :
7732 : /* Try the bindings on this type and in the inheritance hierarchy. */
7733 445 : for (; genproc; genproc = genproc->overridden)
7734 : {
7735 443 : gfc_tbp_generic* g;
7736 :
7737 443 : gcc_assert (genproc->is_generic);
7738 677 : for (g = genproc->u.generic; g; g = g->next)
7739 : {
7740 667 : gfc_symbol* target;
7741 667 : gfc_actual_arglist* args;
7742 667 : bool matches;
7743 :
7744 667 : gcc_assert (g->specific);
7745 :
7746 667 : if (g->specific->error)
7747 0 : continue;
7748 :
7749 667 : target = g->specific->u.specific->n.sym;
7750 :
7751 : /* Get the right arglist by handling PASS/NOPASS. */
7752 667 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7753 667 : if (!g->specific->nopass)
7754 : {
7755 581 : gfc_expr* po;
7756 581 : po = extract_compcall_passed_object (e);
7757 581 : if (!po)
7758 : {
7759 0 : gfc_free_actual_arglist (args);
7760 0 : return false;
7761 : }
7762 :
7763 581 : gcc_assert (g->specific->pass_arg_num > 0);
7764 581 : gcc_assert (!g->specific->error);
7765 581 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7766 : g->specific->pass_arg);
7767 : }
7768 1339 : resolve_actual_arglist (args, target->attr.proc,
7769 667 : is_external_proc (target)
7770 5 : && gfc_sym_get_dummy_args (target) == NULL);
7771 :
7772 : /* Check if this arglist matches the formal. */
7773 667 : matches = gfc_arglist_matches_symbol (&args, target);
7774 :
7775 : /* Clean up and break out of the loop if we've found it. */
7776 667 : gfc_free_actual_arglist (args);
7777 667 : if (matches)
7778 : {
7779 433 : e->value.compcall.tbp = g->specific;
7780 433 : genname = g->specific_st->name;
7781 : /* Pass along the name for CLASS methods, where the vtab
7782 : procedure pointer component has to be referenced. */
7783 433 : if (name)
7784 161 : *name = genname;
7785 433 : goto success;
7786 : }
7787 : }
7788 : }
7789 :
7790 : /* Nothing matching found! */
7791 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7792 : " %qs at %L", genname, &e->where);
7793 2 : return false;
7794 :
7795 433 : success:
7796 : /* Make sure that we have the right specific instance for the name. */
7797 433 : derived = get_declared_from_expr (NULL, NULL, e, true);
7798 :
7799 433 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7800 433 : if (st)
7801 433 : e->value.compcall.tbp = st->n.tb;
7802 :
7803 : return true;
7804 : }
7805 :
7806 :
7807 : /* Resolve a call to a type-bound subroutine. */
7808 :
7809 : static bool
7810 1768 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7811 : {
7812 1768 : gfc_actual_arglist* newactual;
7813 1768 : gfc_symtree* target;
7814 :
7815 : /* Check that's really a SUBROUTINE. */
7816 1768 : if (!c->expr1->value.compcall.tbp->subroutine)
7817 : {
7818 17 : if (!c->expr1->value.compcall.tbp->is_generic
7819 15 : && c->expr1->value.compcall.tbp->u.specific
7820 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7821 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7822 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7823 : else
7824 : {
7825 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7826 : c->expr1->value.compcall.name, &c->loc);
7827 5 : return false;
7828 : }
7829 : }
7830 :
7831 1763 : if (!check_typebound_baseobject (c->expr1))
7832 : return false;
7833 :
7834 : /* Pass along the name for CLASS methods, where the vtab
7835 : procedure pointer component has to be referenced. */
7836 1756 : if (name)
7837 480 : *name = c->expr1->value.compcall.name;
7838 :
7839 1756 : if (!resolve_typebound_generic_call (c->expr1, name))
7840 : return false;
7841 :
7842 : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7843 1755 : if (overridable)
7844 371 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7845 :
7846 : /* Transform into an ordinary EXEC_CALL for now. */
7847 :
7848 1755 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7849 : return false;
7850 :
7851 1753 : c->ext.actual = newactual;
7852 1753 : c->symtree = target;
7853 1753 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7854 :
7855 1753 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7856 :
7857 1753 : gfc_free_expr (c->expr1);
7858 1753 : c->expr1 = gfc_get_expr ();
7859 1753 : c->expr1->expr_type = EXPR_FUNCTION;
7860 1753 : c->expr1->symtree = target;
7861 1753 : c->expr1->where = c->loc;
7862 :
7863 1753 : return resolve_call (c);
7864 : }
7865 :
7866 :
7867 : /* Resolve a component-call expression. */
7868 : static bool
7869 1675 : resolve_compcall (gfc_expr* e, const char **name)
7870 : {
7871 1675 : gfc_actual_arglist* newactual;
7872 1675 : gfc_symtree* target;
7873 :
7874 : /* Check that's really a FUNCTION. */
7875 1675 : if (!e->value.compcall.tbp->function)
7876 : {
7877 7 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7878 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7879 : &e->where);
7880 : return false;
7881 : }
7882 :
7883 :
7884 : /* These must not be assign-calls! */
7885 1668 : gcc_assert (!e->value.compcall.assign);
7886 :
7887 1668 : if (!check_typebound_baseobject (e))
7888 : return false;
7889 :
7890 : /* Pass along the name for CLASS methods, where the vtab
7891 : procedure pointer component has to be referenced. */
7892 1666 : if (name)
7893 864 : *name = e->value.compcall.name;
7894 :
7895 1666 : if (!resolve_typebound_generic_call (e, name))
7896 : return false;
7897 1665 : gcc_assert (!e->value.compcall.tbp->is_generic);
7898 :
7899 : /* Take the rank from the function's symbol. */
7900 1665 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7901 : {
7902 155 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7903 155 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7904 : }
7905 :
7906 : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7907 : arglist to the TBP's binding target. */
7908 :
7909 1665 : if (!resolve_typebound_static (e, &target, &newactual))
7910 : return false;
7911 :
7912 1665 : e->value.function.actual = newactual;
7913 1665 : e->value.function.name = NULL;
7914 1665 : e->value.function.esym = target->n.sym;
7915 1665 : e->value.function.isym = NULL;
7916 1665 : e->symtree = target;
7917 1665 : e->ts = target->n.sym->ts;
7918 1665 : e->expr_type = EXPR_FUNCTION;
7919 :
7920 : /* Resolution is not necessary if this is a class subroutine; this
7921 : function only has to identify the specific proc. Resolution of
7922 : the call will be done next in resolve_typebound_call. */
7923 1665 : return gfc_resolve_expr (e);
7924 : }
7925 :
7926 :
7927 : static bool resolve_fl_derived (gfc_symbol *sym);
7928 :
7929 :
7930 : /* Resolve a typebound function, or 'method'. First separate all
7931 : the non-CLASS references by calling resolve_compcall directly. */
7932 :
7933 : static bool
7934 1675 : resolve_typebound_function (gfc_expr* e)
7935 : {
7936 1675 : gfc_symbol *declared;
7937 1675 : gfc_component *c;
7938 1675 : gfc_ref *new_ref;
7939 1675 : gfc_ref *class_ref;
7940 1675 : gfc_symtree *st;
7941 1675 : const char *name;
7942 1675 : gfc_typespec ts;
7943 1675 : gfc_expr *expr;
7944 1675 : bool overridable;
7945 :
7946 1675 : st = e->symtree;
7947 :
7948 : /* Deal with typebound operators for CLASS objects. */
7949 1675 : expr = e->value.compcall.base_object;
7950 1675 : overridable = !e->value.compcall.tbp->non_overridable;
7951 1675 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7952 : {
7953 : /* Since the typebound operators are generic, we have to ensure
7954 : that any delays in resolution are corrected and that the vtab
7955 : is present. */
7956 184 : ts = expr->ts;
7957 184 : declared = ts.u.derived;
7958 184 : if (!resolve_fl_derived (declared))
7959 : return false;
7960 :
7961 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7962 184 : if (c->ts.u.derived == NULL)
7963 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7964 :
7965 184 : if (!resolve_compcall (e, &name))
7966 : return false;
7967 :
7968 : /* Use the generic name if it is there. */
7969 184 : name = name ? name : e->value.function.esym->name;
7970 184 : e->symtree = expr->symtree;
7971 184 : e->ref = gfc_copy_ref (expr->ref);
7972 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7973 :
7974 : /* Trim away the extraneous references that emerge from nested
7975 : use of interface.cc (extend_expr). */
7976 184 : if (class_ref && class_ref->next)
7977 : {
7978 0 : gfc_free_ref_list (class_ref->next);
7979 0 : class_ref->next = NULL;
7980 : }
7981 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7982 : {
7983 0 : gfc_free_ref_list (e->ref);
7984 0 : e->ref = NULL;
7985 : }
7986 :
7987 184 : gfc_add_vptr_component (e);
7988 184 : gfc_add_component_ref (e, name);
7989 184 : e->value.function.esym = NULL;
7990 184 : if (expr->expr_type != EXPR_VARIABLE)
7991 80 : e->base_expr = expr;
7992 : return true;
7993 : }
7994 :
7995 1491 : if (st == NULL)
7996 195 : return resolve_compcall (e, NULL);
7997 :
7998 1296 : if (!gfc_resolve_ref (e))
7999 : return false;
8000 :
8001 : /* It can happen that a generic, typebound procedure is marked as overridable
8002 : with all of the specific procedures being non-overridable. If this is the
8003 : case, it is safe to resolve the compcall. */
8004 1296 : if (!expr && overridable
8005 1288 : && e->value.compcall.tbp->is_generic
8006 198 : && e->value.compcall.tbp->u.generic->specific
8007 197 : && e->value.compcall.tbp->u.generic->specific->non_overridable)
8008 : {
8009 : gfc_tbp_generic *g = e->value.compcall.tbp->u.generic;
8010 6 : for (; g; g = g->next)
8011 4 : if (!g->specific->non_overridable)
8012 : break;
8013 2 : if (g == NULL && resolve_compcall (e, &name))
8014 : return true;
8015 : }
8016 :
8017 : /* Get the CLASS declared type. */
8018 1294 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
8019 :
8020 1294 : if (!resolve_fl_derived (declared))
8021 : return false;
8022 :
8023 : /* Weed out cases of the ultimate component being a derived type. */
8024 1294 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8025 1200 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8026 : {
8027 614 : gfc_free_ref_list (new_ref);
8028 614 : return resolve_compcall (e, NULL);
8029 : }
8030 :
8031 680 : c = gfc_find_component (declared, "_data", true, true, NULL);
8032 :
8033 : /* Treat the call as if it is a typebound procedure, in order to roll
8034 : out the correct name for the specific function. */
8035 680 : if (!resolve_compcall (e, &name))
8036 : {
8037 3 : gfc_free_ref_list (new_ref);
8038 3 : return false;
8039 : }
8040 677 : ts = e->ts;
8041 :
8042 677 : if (overridable)
8043 : {
8044 : /* Convert the expression to a procedure pointer component call. */
8045 675 : e->value.function.esym = NULL;
8046 675 : e->symtree = st;
8047 :
8048 675 : if (new_ref)
8049 125 : e->ref = new_ref;
8050 :
8051 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8052 675 : gfc_add_vptr_component (e);
8053 675 : gfc_add_component_ref (e, name);
8054 :
8055 : /* Recover the typespec for the expression. This is really only
8056 : necessary for generic procedures, where the additional call
8057 : to gfc_add_component_ref seems to throw the collection of the
8058 : correct typespec. */
8059 675 : e->ts = ts;
8060 : }
8061 2 : else if (new_ref)
8062 0 : gfc_free_ref_list (new_ref);
8063 :
8064 : return true;
8065 : }
8066 :
8067 : /* Resolve a typebound subroutine, or 'method'. First separate all
8068 : the non-CLASS references by calling resolve_typebound_call
8069 : directly. */
8070 :
8071 : static bool
8072 1768 : resolve_typebound_subroutine (gfc_code *code)
8073 : {
8074 1768 : gfc_symbol *declared;
8075 1768 : gfc_component *c;
8076 1768 : gfc_ref *new_ref;
8077 1768 : gfc_ref *class_ref;
8078 1768 : gfc_symtree *st;
8079 1768 : const char *name;
8080 1768 : gfc_typespec ts;
8081 1768 : gfc_expr *expr;
8082 1768 : bool overridable;
8083 :
8084 1768 : st = code->expr1->symtree;
8085 :
8086 : /* Deal with typebound operators for CLASS objects. */
8087 1768 : expr = code->expr1->value.compcall.base_object;
8088 1768 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
8089 1768 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
8090 : {
8091 : /* If the base_object is not a variable, the corresponding actual
8092 : argument expression must be stored in e->base_expression so
8093 : that the corresponding tree temporary can be used as the base
8094 : object in gfc_conv_procedure_call. */
8095 109 : if (expr->expr_type != EXPR_VARIABLE)
8096 : {
8097 : gfc_actual_arglist *args;
8098 :
8099 : args= code->expr1->value.function.actual;
8100 : for (; args; args = args->next)
8101 : if (expr == args->expr)
8102 : expr = args->expr;
8103 : }
8104 :
8105 : /* Since the typebound operators are generic, we have to ensure
8106 : that any delays in resolution are corrected and that the vtab
8107 : is present. */
8108 109 : declared = expr->ts.u.derived;
8109 109 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
8110 109 : if (c->ts.u.derived == NULL)
8111 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
8112 :
8113 109 : if (!resolve_typebound_call (code, &name, NULL))
8114 : return false;
8115 :
8116 : /* Use the generic name if it is there. */
8117 109 : name = name ? name : code->expr1->value.function.esym->name;
8118 109 : code->expr1->symtree = expr->symtree;
8119 109 : code->expr1->ref = gfc_copy_ref (expr->ref);
8120 :
8121 : /* Trim away the extraneous references that emerge from nested
8122 : use of interface.cc (extend_expr). */
8123 109 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
8124 109 : if (class_ref && class_ref->next)
8125 : {
8126 0 : gfc_free_ref_list (class_ref->next);
8127 0 : class_ref->next = NULL;
8128 : }
8129 109 : else if (code->expr1->ref && !class_ref)
8130 : {
8131 18 : gfc_free_ref_list (code->expr1->ref);
8132 18 : code->expr1->ref = NULL;
8133 : }
8134 :
8135 : /* Now use the procedure in the vtable. */
8136 109 : gfc_add_vptr_component (code->expr1);
8137 109 : gfc_add_component_ref (code->expr1, name);
8138 109 : code->expr1->value.function.esym = NULL;
8139 109 : if (expr->expr_type != EXPR_VARIABLE)
8140 0 : code->expr1->base_expr = expr;
8141 : return true;
8142 : }
8143 :
8144 1659 : if (st == NULL)
8145 346 : return resolve_typebound_call (code, NULL, NULL);
8146 :
8147 1313 : if (!gfc_resolve_ref (code->expr1))
8148 : return false;
8149 :
8150 : /* Get the CLASS declared type. */
8151 1313 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
8152 :
8153 : /* Weed out cases of the ultimate component being a derived type. */
8154 1313 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8155 1248 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8156 : {
8157 937 : gfc_free_ref_list (new_ref);
8158 937 : return resolve_typebound_call (code, NULL, NULL);
8159 : }
8160 :
8161 376 : if (!resolve_typebound_call (code, &name, &overridable))
8162 : {
8163 5 : gfc_free_ref_list (new_ref);
8164 5 : return false;
8165 : }
8166 371 : ts = code->expr1->ts;
8167 :
8168 371 : if (overridable)
8169 : {
8170 : /* Convert the expression to a procedure pointer component call. */
8171 369 : code->expr1->value.function.esym = NULL;
8172 369 : code->expr1->symtree = st;
8173 :
8174 369 : if (new_ref)
8175 93 : code->expr1->ref = new_ref;
8176 :
8177 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8178 369 : gfc_add_vptr_component (code->expr1);
8179 369 : gfc_add_component_ref (code->expr1, name);
8180 :
8181 : /* Recover the typespec for the expression. This is really only
8182 : necessary for generic procedures, where the additional call
8183 : to gfc_add_component_ref seems to throw the collection of the
8184 : correct typespec. */
8185 369 : code->expr1->ts = ts;
8186 : }
8187 2 : else if (new_ref)
8188 0 : gfc_free_ref_list (new_ref);
8189 :
8190 : return true;
8191 : }
8192 :
8193 :
8194 : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8195 :
8196 : static bool
8197 124 : resolve_ppc_call (gfc_code* c)
8198 : {
8199 124 : gfc_component *comp;
8200 :
8201 124 : comp = gfc_get_proc_ptr_comp (c->expr1);
8202 124 : gcc_assert (comp != NULL);
8203 :
8204 124 : c->resolved_sym = c->expr1->symtree->n.sym;
8205 124 : c->expr1->expr_type = EXPR_VARIABLE;
8206 :
8207 124 : if (!comp->attr.subroutine)
8208 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8209 :
8210 124 : if (!gfc_resolve_ref (c->expr1))
8211 : return false;
8212 :
8213 124 : if (!update_ppc_arglist (c->expr1))
8214 : return false;
8215 :
8216 123 : c->ext.actual = c->expr1->value.compcall.actual;
8217 :
8218 123 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8219 123 : !(comp->ts.interface
8220 93 : && comp->ts.interface->formal)))
8221 : return false;
8222 :
8223 123 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8224 : return false;
8225 :
8226 122 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8227 :
8228 122 : return true;
8229 : }
8230 :
8231 :
8232 : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8233 :
8234 : static bool
8235 476 : resolve_expr_ppc (gfc_expr* e)
8236 : {
8237 476 : gfc_component *comp;
8238 :
8239 476 : comp = gfc_get_proc_ptr_comp (e);
8240 476 : gcc_assert (comp != NULL);
8241 :
8242 : /* Convert to EXPR_FUNCTION. */
8243 476 : e->expr_type = EXPR_FUNCTION;
8244 476 : e->value.function.isym = NULL;
8245 476 : e->value.function.actual = e->value.compcall.actual;
8246 476 : e->ts = comp->ts;
8247 476 : if (comp->as != NULL)
8248 : {
8249 28 : e->rank = comp->as->rank;
8250 28 : e->corank = comp->as->corank;
8251 : }
8252 :
8253 476 : if (!comp->attr.function)
8254 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8255 :
8256 476 : if (!gfc_resolve_ref (e))
8257 : return false;
8258 :
8259 476 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8260 476 : !(comp->ts.interface
8261 475 : && comp->ts.interface->formal)))
8262 : return false;
8263 :
8264 476 : if (!update_ppc_arglist (e))
8265 : return false;
8266 :
8267 474 : if (!check_pure_function(e))
8268 : return false;
8269 :
8270 473 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8271 :
8272 473 : return true;
8273 : }
8274 :
8275 :
8276 : static bool
8277 12384 : gfc_is_expandable_expr (gfc_expr *e)
8278 : {
8279 12384 : gfc_constructor *con;
8280 :
8281 12384 : if (e->expr_type == EXPR_ARRAY)
8282 : {
8283 : /* Traverse the constructor looking for variables that are flavor
8284 : parameter. Parameters must be expanded since they are fully used at
8285 : compile time. */
8286 12384 : con = gfc_constructor_first (e->value.constructor);
8287 32781 : for (; con; con = gfc_constructor_next (con))
8288 : {
8289 14331 : if (con->expr->expr_type == EXPR_VARIABLE
8290 5533 : && con->expr->symtree
8291 5533 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8292 5533 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8293 : return true;
8294 8798 : if (con->expr->expr_type == EXPR_ARRAY
8295 8798 : && gfc_is_expandable_expr (con->expr))
8296 : return true;
8297 : }
8298 : }
8299 :
8300 : return false;
8301 : }
8302 :
8303 :
8304 : /* Sometimes variables in specification expressions of the result
8305 : of module procedures in submodules wind up not being the 'real'
8306 : dummy. Find this, if possible, in the namespace of the first
8307 : formal argument. */
8308 :
8309 : static void
8310 4749 : fixup_unique_dummy (gfc_expr *e)
8311 : {
8312 4749 : gfc_symtree *st = NULL;
8313 4749 : gfc_symbol *s = NULL;
8314 :
8315 4749 : if (e->symtree->n.sym->ns->proc_name
8316 4749 : && e->symtree->n.sym->ns->proc_name->formal)
8317 4749 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8318 :
8319 4749 : if (s != NULL)
8320 4749 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8321 :
8322 4749 : if (st != NULL
8323 14 : && st->n.sym != NULL
8324 14 : && st->n.sym->attr.dummy)
8325 14 : e->symtree = st;
8326 4749 : }
8327 :
8328 :
8329 : /* Resolve an expression. That is, make sure that types of operands agree
8330 : with their operators, intrinsic operators are converted to function calls
8331 : for overloaded types and unresolved function references are resolved. */
8332 :
8333 : bool
8334 7138581 : gfc_resolve_expr (gfc_expr *e)
8335 : {
8336 7138581 : bool t;
8337 7138581 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8338 :
8339 7138581 : if (e == NULL || e->do_not_resolve_again)
8340 : return true;
8341 :
8342 : /* inquiry_argument only applies to variables. */
8343 5171652 : inquiry_save = inquiry_argument;
8344 5171652 : actual_arg_save = actual_arg;
8345 5171652 : first_actual_arg_save = first_actual_arg;
8346 :
8347 5171652 : if (e->expr_type != EXPR_VARIABLE)
8348 : {
8349 3816258 : inquiry_argument = false;
8350 3816258 : actual_arg = false;
8351 3816258 : first_actual_arg = false;
8352 : }
8353 1355394 : else if (e->symtree != NULL
8354 1354919 : && *e->symtree->name == '@'
8355 5483 : && e->symtree->n.sym->attr.dummy)
8356 : {
8357 : /* Deal with submodule specification expressions that are not
8358 : found to be referenced in module.cc(read_cleanup). */
8359 4749 : fixup_unique_dummy (e);
8360 : }
8361 :
8362 5171652 : switch (e->expr_type)
8363 : {
8364 541590 : case EXPR_OP:
8365 541590 : t = resolve_operator (e);
8366 541590 : break;
8367 :
8368 170 : case EXPR_CONDITIONAL:
8369 170 : t = resolve_conditional (e);
8370 170 : break;
8371 :
8372 1707965 : case EXPR_FUNCTION:
8373 1707965 : case EXPR_VARIABLE:
8374 :
8375 1707965 : if (check_host_association (e))
8376 352607 : t = resolve_function (e);
8377 : else
8378 1355358 : t = resolve_variable (e);
8379 :
8380 1707965 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref)
8381 7445 : gfc_resolve_substring_charlen (e);
8382 :
8383 : break;
8384 :
8385 1675 : case EXPR_COMPCALL:
8386 1675 : t = resolve_typebound_function (e);
8387 1675 : break;
8388 :
8389 508 : case EXPR_SUBSTRING:
8390 508 : t = gfc_resolve_ref (e);
8391 508 : break;
8392 :
8393 : case EXPR_CONSTANT:
8394 : case EXPR_NULL:
8395 : t = true;
8396 : break;
8397 :
8398 476 : case EXPR_PPC:
8399 476 : t = resolve_expr_ppc (e);
8400 476 : break;
8401 :
8402 74707 : case EXPR_ARRAY:
8403 74707 : t = false;
8404 74707 : if (!gfc_resolve_ref (e))
8405 : break;
8406 :
8407 74707 : t = gfc_resolve_array_constructor (e);
8408 : /* Also try to expand a constructor. */
8409 74707 : if (t)
8410 : {
8411 74605 : gfc_expression_rank (e);
8412 74605 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8413 69808 : gfc_expand_constructor (e, false);
8414 : }
8415 :
8416 : /* This provides the opportunity for the length of constructors with
8417 : character valued function elements to propagate the string length
8418 : to the expression. */
8419 74605 : if (t && e->ts.type == BT_CHARACTER)
8420 : {
8421 : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8422 : here rather then add a duplicate test for it above. */
8423 10922 : gfc_expand_constructor (e, false);
8424 10922 : t = gfc_resolve_character_array_constructor (e);
8425 : }
8426 :
8427 : break;
8428 :
8429 17077 : case EXPR_STRUCTURE:
8430 17077 : t = gfc_resolve_ref (e);
8431 17077 : if (!t)
8432 : break;
8433 :
8434 17077 : t = resolve_structure_cons (e, 0);
8435 17077 : if (!t)
8436 : break;
8437 :
8438 17065 : t = gfc_simplify_expr (e, 0);
8439 17065 : break;
8440 :
8441 0 : default:
8442 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8443 : }
8444 :
8445 5171652 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8446 182138 : fixup_charlen (e);
8447 :
8448 5171652 : inquiry_argument = inquiry_save;
8449 5171652 : actual_arg = actual_arg_save;
8450 5171652 : first_actual_arg = first_actual_arg_save;
8451 :
8452 : /* For some reason, resolving these expressions a second time mangles
8453 : the typespec of the expression itself. */
8454 5171652 : if (t && e->expr_type == EXPR_VARIABLE
8455 1352488 : && e->symtree->n.sym->attr.select_rank_temporary
8456 3470 : && UNLIMITED_POLY (e->symtree->n.sym))
8457 83 : e->do_not_resolve_again = 1;
8458 :
8459 5169076 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8460 7384 : t = check_import_status (e);
8461 :
8462 : return t;
8463 : }
8464 :
8465 :
8466 : /* Resolve an expression from an iterator. They must be scalar and have
8467 : INTEGER or (optionally) REAL type. */
8468 :
8469 : static bool
8470 156009 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8471 : const char *name_msgid)
8472 : {
8473 156009 : if (!gfc_resolve_expr (expr))
8474 : return false;
8475 :
8476 156004 : if (expr->rank != 0)
8477 : {
8478 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8479 0 : return false;
8480 : }
8481 :
8482 156004 : if (expr->ts.type != BT_INTEGER)
8483 : {
8484 317 : if (expr->ts.type == BT_REAL)
8485 : {
8486 317 : if (real_ok)
8487 314 : return gfc_notify_std (GFC_STD_F95_DEL,
8488 : "%s at %L must be integer",
8489 314 : _(name_msgid), &expr->where);
8490 : else
8491 : {
8492 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8493 : &expr->where);
8494 3 : return false;
8495 : }
8496 : }
8497 : else
8498 : {
8499 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8500 0 : return false;
8501 : }
8502 : }
8503 : return true;
8504 : }
8505 :
8506 :
8507 : /* Resolve the expressions in an iterator structure. If REAL_OK is
8508 : false allow only INTEGER type iterators, otherwise allow REAL types.
8509 : Set own_scope to true for ac-implied-do and data-implied-do as those
8510 : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8511 :
8512 : bool
8513 39011 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8514 : {
8515 39011 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8516 : return false;
8517 :
8518 39007 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8519 39007 : _("iterator variable")))
8520 : return false;
8521 :
8522 39001 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8523 : "Start expression in DO loop"))
8524 : return false;
8525 :
8526 39000 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8527 : "End expression in DO loop"))
8528 : return false;
8529 :
8530 38997 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8531 : "Step expression in DO loop"))
8532 : return false;
8533 :
8534 : /* Convert start, end, and step to the same type as var. */
8535 38996 : if (iter->start->ts.kind != iter->var->ts.kind
8536 38667 : || iter->start->ts.type != iter->var->ts.type)
8537 393 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8538 :
8539 38996 : if (iter->end->ts.kind != iter->var->ts.kind
8540 38694 : || iter->end->ts.type != iter->var->ts.type)
8541 345 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8542 :
8543 38996 : if (iter->step->ts.kind != iter->var->ts.kind
8544 38704 : || iter->step->ts.type != iter->var->ts.type)
8545 358 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8546 :
8547 38996 : if (iter->step->expr_type == EXPR_CONSTANT)
8548 : {
8549 37873 : if ((iter->step->ts.type == BT_INTEGER
8550 37760 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8551 75631 : || (iter->step->ts.type == BT_REAL
8552 113 : && mpfr_sgn (iter->step->value.real) == 0))
8553 : {
8554 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8555 3 : &iter->step->where);
8556 3 : return false;
8557 : }
8558 : }
8559 :
8560 38993 : if (iter->start->expr_type == EXPR_CONSTANT
8561 35849 : && iter->end->expr_type == EXPR_CONSTANT
8562 28031 : && iter->step->expr_type == EXPR_CONSTANT)
8563 : {
8564 27764 : int sgn, cmp;
8565 27764 : if (iter->start->ts.type == BT_INTEGER)
8566 : {
8567 27709 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8568 27709 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8569 : }
8570 : else
8571 : {
8572 55 : sgn = mpfr_sgn (iter->step->value.real);
8573 55 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8574 : }
8575 27764 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8576 146 : gfc_warning (OPT_Wzerotrip,
8577 : "DO loop at %L will be executed zero times",
8578 146 : &iter->step->where);
8579 : }
8580 :
8581 38993 : if (iter->end->expr_type == EXPR_CONSTANT
8582 28399 : && iter->end->ts.type == BT_INTEGER
8583 28344 : && iter->step->expr_type == EXPR_CONSTANT
8584 28034 : && iter->step->ts.type == BT_INTEGER
8585 28034 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8586 27663 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8587 : {
8588 26877 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8589 26877 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8590 :
8591 26877 : if (is_step_positive
8592 26506 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8593 7 : gfc_warning (OPT_Wundefined_do_loop,
8594 : "DO loop at %L is undefined as it overflows",
8595 7 : &iter->step->where);
8596 : else if (!is_step_positive
8597 371 : && mpz_cmp (iter->end->value.integer,
8598 371 : gfc_integer_kinds[k].min_int) == 0)
8599 7 : gfc_warning (OPT_Wundefined_do_loop,
8600 : "DO loop at %L is undefined as it underflows",
8601 7 : &iter->step->where);
8602 : }
8603 :
8604 38993 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
8605 : VALUE_USED);
8606 38993 : gfc_value_used_expr (iter->start, VALUE_USED);
8607 38993 : gfc_value_used_expr (iter->end, VALUE_USED);
8608 38993 : gfc_value_used_expr (iter->step, VALUE_USED);
8609 :
8610 38993 : return true;
8611 : }
8612 :
8613 :
8614 : /* Traversal function for find_forall_index. f == 2 signals that
8615 : that variable itself is not to be checked - only the references. */
8616 :
8617 : static bool
8618 43194 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8619 : {
8620 43194 : if (expr->expr_type != EXPR_VARIABLE)
8621 : return false;
8622 :
8623 : /* A scalar assignment */
8624 18323 : if (!expr->ref || *f == 1)
8625 : {
8626 12237 : if (expr->symtree->n.sym == sym)
8627 : return true;
8628 : else
8629 8197 : return false;
8630 : }
8631 :
8632 6086 : if (*f == 2)
8633 1731 : *f = 1;
8634 : return false;
8635 : }
8636 :
8637 :
8638 : /* Check whether the FORALL index appears in the expression or not.
8639 : Returns true if SYM is found in EXPR. */
8640 :
8641 : bool
8642 27548 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8643 : {
8644 27548 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8645 : return true;
8646 : else
8647 : return false;
8648 : }
8649 :
8650 : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8651 : This constraint specifies rules for variables in locality-specs. */
8652 :
8653 : static int
8654 1149 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8655 : {
8656 1149 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8657 :
8658 1149 : if ((*expr)->expr_type == EXPR_VARIABLE)
8659 : {
8660 22 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8661 22 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8662 24 : list; list = list->next)
8663 : {
8664 5 : if (list->expr->symtree->n.sym == sym)
8665 : {
8666 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8667 : "must not appear in LOCAL locality-spec at %L",
8668 : sym->name, &(*expr)->where, &list->expr->where);
8669 3 : *walk_subtrees = 0;
8670 3 : return 1;
8671 : }
8672 : }
8673 : }
8674 :
8675 1146 : *walk_subtrees = 1;
8676 1146 : return 0;
8677 : }
8678 :
8679 : static int
8680 5002 : check_default_none_expr (gfc_expr **e, int *, void *data)
8681 : {
8682 5002 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8683 :
8684 5002 : if ((*e)->expr_type == EXPR_VARIABLE)
8685 : {
8686 2428 : gfc_symbol *sym = (*e)->symtree->n.sym;
8687 :
8688 2428 : if (d->sym_hash->contains (sym))
8689 1471 : sym->mark = 1;
8690 :
8691 957 : else if (d->default_none)
8692 : {
8693 8 : gfc_namespace *ns2 = d->ns;
8694 13 : while (ns2)
8695 : {
8696 8 : if (ns2 == sym->ns)
8697 : break;
8698 5 : ns2 = ns2->parent;
8699 : }
8700 :
8701 : /* A DO CONCURRENT iterator cannot appear in a locality spec.
8702 : Use d->code (the DO CONCURRENT node) rather than sym->ns->code,
8703 : which may be a different code type (e.g. EXEC_ASSOCIATE) whose
8704 : ext union would be read incorrectly. */
8705 8 : for (gfc_forall_iterator *iter = d->code->ext.concur.forall_iterator;
8706 17 : iter; iter = iter->next)
8707 : {
8708 10 : if (!iter->var || !iter->var->symtree)
8709 0 : continue;
8710 10 : const char *iter_name = iter->var->symtree->name;
8711 : /* Use the user-visible name of a shadow iterator. */
8712 10 : if (iter->shadow)
8713 0 : iter_name = iter->shadow_outer_sym->name;
8714 10 : if (strcmp (sym->name, iter_name) == 0)
8715 1 : return 0;
8716 : }
8717 :
8718 : /* A named constant is not a variable, so skip test. */
8719 7 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8720 : {
8721 2 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8722 : "of DO CONCURRENT at %L but required due to "
8723 : "DEFAULT (NONE)",
8724 : sym->name, &(*e)->where, &d->code->loc);
8725 2 : d->sym_hash->add (sym);
8726 : }
8727 : }
8728 : }
8729 : return 0;
8730 : }
8731 :
8732 : static void
8733 352 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8734 : {
8735 352 : struct check_default_none_data data;
8736 352 : data.code = code;
8737 352 : data.sym_hash = new hash_set<gfc_symbol *>;
8738 352 : data.ns = ns;
8739 352 : data.default_none = code->ext.concur.default_none;
8740 :
8741 1760 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8742 : {
8743 1408 : const char *name;
8744 1408 : switch (locality)
8745 : {
8746 : case LOCALITY_LOCAL: name = "LOCAL"; break;
8747 352 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8748 352 : case LOCALITY_SHARED: name = "SHARED"; break;
8749 352 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8750 : default: gcc_unreachable ();
8751 : }
8752 :
8753 1947 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8754 539 : list = list->next)
8755 : {
8756 539 : gfc_expr *expr = list->expr;
8757 :
8758 539 : if (locality == LOCALITY_REDUCE
8759 294 : && (expr->expr_type == EXPR_FUNCTION
8760 196 : || expr->expr_type == EXPR_OP))
8761 109 : continue;
8762 :
8763 441 : if (!gfc_resolve_expr (expr))
8764 3 : continue;
8765 :
8766 438 : if (expr->expr_type != EXPR_VARIABLE
8767 438 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8768 438 : || (expr->ref
8769 151 : && (expr->ref->type != REF_ARRAY
8770 151 : || expr->ref->u.ar.type != AR_FULL
8771 147 : || expr->ref->next)))
8772 : {
8773 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8774 : name, &expr->where);
8775 4 : continue;
8776 : }
8777 :
8778 434 : gfc_symbol *sym = expr->symtree->n.sym;
8779 :
8780 434 : if (data.sym_hash->contains (sym))
8781 : {
8782 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8783 : "locality-spec", sym->name, &expr->where);
8784 4 : continue;
8785 : }
8786 :
8787 430 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8788 864 : iter; iter = iter->next)
8789 : {
8790 434 : if (iter->var->symtree->n.sym == sym)
8791 : {
8792 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8793 : "locality-spec", sym->name, &expr->where);
8794 1 : continue;
8795 : }
8796 :
8797 433 : data.sym_hash->add (iter->var->symtree->n.sym);
8798 : }
8799 :
8800 430 : if (locality == LOCALITY_LOCAL
8801 430 : || locality == LOCALITY_LOCAL_INIT
8802 430 : || locality == LOCALITY_REDUCE)
8803 : {
8804 272 : if (sym->attr.optional)
8805 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8806 : "locality-spec at %L",
8807 : sym->name, name, &expr->where);
8808 :
8809 272 : if (sym->attr.dimension
8810 66 : && sym->as
8811 66 : && sym->as->type == AS_ASSUMED_SIZE)
8812 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8813 : "locality-spec at %L",
8814 : sym->name, name, &expr->where);
8815 :
8816 272 : gfc_check_vardef_context (expr, false, false, false, name);
8817 : }
8818 :
8819 272 : if (locality == LOCALITY_LOCAL
8820 : || locality == LOCALITY_LOCAL_INIT)
8821 : {
8822 181 : symbol_attribute attr = gfc_expr_attr (expr);
8823 :
8824 181 : if (attr.allocatable)
8825 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8826 : "locality-spec at %L",
8827 : sym->name, name, &expr->where);
8828 :
8829 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8830 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8831 : " for %qs in %s locality-spec at %L",
8832 : sym->name, name, &expr->where);
8833 :
8834 177 : else if (attr.codimension)
8835 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8836 : "at %L",
8837 : sym->name, name, &expr->where);
8838 :
8839 177 : else if (expr->ts.type == BT_DERIVED
8840 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8841 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8842 : "locality-spec at %L",
8843 : sym->name, name, &expr->where);
8844 :
8845 177 : else if (gfc_has_ultimate_allocatable (expr))
8846 4 : gfc_error ("Type with ultimate allocatable component not "
8847 : "permitted for %qs in %s locality-spec at %L",
8848 : sym->name, name, &expr->where);
8849 : }
8850 :
8851 249 : else if (locality == LOCALITY_REDUCE)
8852 : {
8853 91 : if (sym->attr.asynchronous)
8854 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8855 : "REDUCE locality-spec at %L",
8856 : sym->name, &expr->where);
8857 91 : if (sym->attr.volatile_)
8858 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8859 : "locality-spec at %L", sym->name, &expr->where);
8860 : }
8861 :
8862 430 : data.sym_hash->add (sym);
8863 : }
8864 :
8865 1408 : if (locality == LOCALITY_LOCAL)
8866 : {
8867 352 : gcc_assert (locality == 0);
8868 :
8869 352 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8870 723 : iter; iter = iter->next)
8871 : {
8872 371 : gfc_expr_walker (&iter->start,
8873 : do_concur_locality_specs_f2023,
8874 : &data);
8875 :
8876 371 : gfc_expr_walker (&iter->end,
8877 : do_concur_locality_specs_f2023,
8878 : &data);
8879 :
8880 371 : gfc_expr_walker (&iter->stride,
8881 : do_concur_locality_specs_f2023,
8882 : &data);
8883 : }
8884 :
8885 352 : if (code->expr1)
8886 7 : gfc_expr_walker (&code->expr1,
8887 : do_concur_locality_specs_f2023,
8888 : &data);
8889 : }
8890 : }
8891 :
8892 352 : gfc_expr *reduce_op = NULL;
8893 :
8894 352 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8895 548 : list; list = list->next)
8896 : {
8897 196 : gfc_expr *expr = list->expr;
8898 :
8899 196 : if (expr->expr_type != EXPR_VARIABLE)
8900 : {
8901 98 : reduce_op = expr;
8902 98 : continue;
8903 : }
8904 :
8905 98 : if (reduce_op->expr_type == EXPR_OP)
8906 : {
8907 91 : switch (reduce_op->value.op.op)
8908 : {
8909 91 : case INTRINSIC_PLUS:
8910 91 : case INTRINSIC_TIMES:
8911 91 : if (!gfc_numeric_ts (&expr->ts))
8912 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8913 3 : "got %s", expr->symtree->n.sym->name,
8914 : &expr->where, gfc_basic_typename (expr->ts.type));
8915 : break;
8916 0 : case INTRINSIC_AND:
8917 0 : case INTRINSIC_OR:
8918 0 : case INTRINSIC_EQV:
8919 0 : case INTRINSIC_NEQV:
8920 0 : if (expr->ts.type != BT_LOGICAL)
8921 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8922 0 : "got %qs", expr->symtree->n.sym->name,
8923 : &expr->where, gfc_basic_typename (expr->ts.type));
8924 : break;
8925 0 : default:
8926 0 : gcc_unreachable ();
8927 : }
8928 : }
8929 :
8930 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8931 : {
8932 7 : switch (reduce_op->value.function.isym->id)
8933 : {
8934 6 : case GFC_ISYM_MIN:
8935 6 : case GFC_ISYM_MAX:
8936 6 : if (expr->ts.type != BT_INTEGER
8937 : && expr->ts.type != BT_REAL
8938 : && expr->ts.type != BT_CHARACTER)
8939 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8940 : "in REDUCE with MIN/MAX at %L, got %s",
8941 2 : expr->symtree->n.sym->name, &expr->where,
8942 : gfc_basic_typename (expr->ts.type));
8943 : break;
8944 1 : case GFC_ISYM_IAND:
8945 1 : case GFC_ISYM_IOR:
8946 1 : case GFC_ISYM_IEOR:
8947 1 : if (expr->ts.type != BT_INTEGER)
8948 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8949 : "IAND/IOR/IEOR at %L, got %s",
8950 1 : expr->symtree->n.sym->name, &expr->where,
8951 : gfc_basic_typename (expr->ts.type));
8952 : break;
8953 0 : default:
8954 0 : gcc_unreachable ();
8955 : }
8956 : }
8957 :
8958 : else
8959 0 : gcc_unreachable ();
8960 : }
8961 :
8962 1760 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8963 : {
8964 1947 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8965 539 : list = list->next)
8966 : {
8967 539 : if (list->expr->expr_type == EXPR_VARIABLE)
8968 441 : list->expr->symtree->n.sym->mark = 0;
8969 : }
8970 : }
8971 :
8972 352 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8973 : check_default_none_expr, &data);
8974 :
8975 2112 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8976 : {
8977 1408 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8978 1947 : while (*plist)
8979 : {
8980 539 : gfc_expr *expr = (*plist)->expr;
8981 539 : if (expr->expr_type == EXPR_VARIABLE)
8982 : {
8983 441 : gfc_symbol *sym = expr->symtree->n.sym;
8984 441 : if (sym->mark == 0)
8985 : {
8986 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8987 : "locality-spec at %L is not used",
8988 : sym->name, &expr->where);
8989 70 : gfc_expr_list *tmp = *plist;
8990 70 : *plist = (*plist)->next;
8991 70 : gfc_free_expr (tmp->expr);
8992 70 : free (tmp);
8993 70 : continue;
8994 70 : }
8995 : }
8996 469 : plist = &((*plist)->next);
8997 : }
8998 : }
8999 :
9000 704 : delete data.sym_hash;
9001 352 : }
9002 :
9003 : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
9004 : to be a scalar INTEGER variable. The subscripts and stride are scalar
9005 : INTEGERs, and if stride is a constant it must be nonzero.
9006 : Furthermore "A subscript or stride in a forall-triplet-spec shall
9007 : not contain a reference to any index-name in the
9008 : forall-triplet-spec-list in which it appears." (7.5.4.1) */
9009 :
9010 : static void
9011 2345 : resolve_forall_iterators (gfc_forall_iterator *it)
9012 : {
9013 2345 : gfc_forall_iterator *iter, *iter2;
9014 :
9015 6608 : for (iter = it; iter; iter = iter->next)
9016 : {
9017 4263 : if (gfc_resolve_expr (iter->var)
9018 4263 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
9019 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
9020 : &iter->var->where);
9021 :
9022 4263 : if (gfc_resolve_expr (iter->start)
9023 4263 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
9024 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
9025 : &iter->start->where);
9026 4263 : if (iter->var->ts.kind != iter->start->ts.kind)
9027 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
9028 :
9029 4263 : if (gfc_resolve_expr (iter->end)
9030 4263 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
9031 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
9032 : &iter->end->where);
9033 4263 : if (iter->var->ts.kind != iter->end->ts.kind)
9034 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
9035 :
9036 4263 : if (gfc_resolve_expr (iter->stride))
9037 : {
9038 4263 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
9039 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
9040 : &iter->stride->where, "INTEGER");
9041 :
9042 4263 : if (iter->stride->expr_type == EXPR_CONSTANT
9043 4259 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
9044 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
9045 : &iter->stride->where);
9046 : }
9047 4263 : if (iter->var->ts.kind != iter->stride->ts.kind)
9048 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
9049 :
9050 4263 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
9051 : VALUE_USED);
9052 4263 : gfc_value_used_expr (iter->start, VALUE_USED);
9053 4263 : gfc_value_used_expr (iter->end, VALUE_USED);
9054 4263 : gfc_value_used_expr (iter->stride, VALUE_USED);
9055 : }
9056 :
9057 6608 : for (iter = it; iter; iter = iter->next)
9058 11370 : for (iter2 = iter; iter2; iter2 = iter2->next)
9059 : {
9060 7107 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
9061 7105 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
9062 14210 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
9063 6 : gfc_error ("FORALL index %qs may not appear in triplet "
9064 6 : "specification at %L", iter->var->symtree->name,
9065 6 : &iter2->start->where);
9066 : }
9067 2345 : }
9068 :
9069 :
9070 : /* Given a pointer to a symbol that is a derived type, see if it's
9071 : inaccessible, i.e. if it's defined in another module and the components are
9072 : PRIVATE. The search is recursive if necessary. Returns zero if no
9073 : inaccessible components are found, nonzero otherwise. */
9074 :
9075 : static bool
9076 1364 : derived_inaccessible (gfc_symbol *sym)
9077 : {
9078 1364 : gfc_component *c;
9079 :
9080 1364 : if (sym->attr.use_assoc && sym->attr.private_comp)
9081 : return 1;
9082 :
9083 4031 : for (c = sym->components; c; c = c->next)
9084 : {
9085 : /* Prevent an infinite loop through this function. */
9086 2680 : if (c->ts.type == BT_DERIVED
9087 289 : && (c->attr.pointer || c->attr.allocatable)
9088 72 : && sym == c->ts.u.derived)
9089 72 : continue;
9090 :
9091 2608 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
9092 : return 1;
9093 : }
9094 :
9095 : return 0;
9096 : }
9097 :
9098 :
9099 : /* Resolve the argument of a deallocate expression. The expression must be
9100 : a pointer or a full array. */
9101 :
9102 : static bool
9103 8590 : resolve_deallocate_expr (gfc_expr *e)
9104 : {
9105 8590 : symbol_attribute attr;
9106 8590 : int allocatable, pointer;
9107 8590 : gfc_ref *ref;
9108 8590 : gfc_symbol *sym;
9109 8590 : gfc_component *c;
9110 8590 : bool unlimited;
9111 :
9112 8590 : if (!gfc_resolve_expr (e))
9113 : return false;
9114 :
9115 8590 : if (e->expr_type != EXPR_VARIABLE)
9116 0 : goto bad;
9117 :
9118 8590 : sym = e->symtree->n.sym;
9119 8590 : unlimited = UNLIMITED_POLY(sym);
9120 :
9121 8590 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
9122 : {
9123 1635 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9124 1635 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9125 : }
9126 : else
9127 : {
9128 6955 : allocatable = sym->attr.allocatable;
9129 6955 : pointer = sym->attr.pointer;
9130 : }
9131 17210 : for (ref = e->ref; ref; ref = ref->next)
9132 : {
9133 8620 : switch (ref->type)
9134 : {
9135 6438 : case REF_ARRAY:
9136 6438 : if (ref->u.ar.type != AR_FULL
9137 6693 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
9138 255 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
9139 : allocatable = 0;
9140 : break;
9141 :
9142 2182 : case REF_COMPONENT:
9143 2182 : c = ref->u.c.component;
9144 2182 : if (c->ts.type == BT_CLASS)
9145 : {
9146 303 : allocatable = CLASS_DATA (c)->attr.allocatable;
9147 303 : pointer = CLASS_DATA (c)->attr.class_pointer;
9148 : }
9149 : else
9150 : {
9151 1879 : allocatable = c->attr.allocatable;
9152 1879 : pointer = c->attr.pointer;
9153 : }
9154 : break;
9155 :
9156 : case REF_SUBSTRING:
9157 : case REF_INQUIRY:
9158 8620 : allocatable = 0;
9159 : break;
9160 : }
9161 : }
9162 :
9163 8590 : attr = gfc_expr_attr (e);
9164 :
9165 8590 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
9166 : {
9167 3 : bad:
9168 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9169 : &e->where);
9170 3 : return false;
9171 : }
9172 :
9173 : /* F2008, C644. */
9174 8587 : if (gfc_is_coindexed (e))
9175 : {
9176 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
9177 1 : return false;
9178 : }
9179 :
9180 8586 : if (pointer
9181 10990 : && !gfc_check_vardef_context (e, true, true, false,
9182 2404 : _("DEALLOCATE object")))
9183 : return false;
9184 8584 : if (!gfc_check_vardef_context (e, false, true, false,
9185 8584 : _("DEALLOCATE object")))
9186 : return false;
9187 :
9188 : return true;
9189 : }
9190 :
9191 :
9192 : /* Returns true if the expression e contains a reference to the symbol sym. */
9193 : static bool
9194 47477 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
9195 : {
9196 47477 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
9197 2081 : return true;
9198 :
9199 : return false;
9200 : }
9201 :
9202 : bool
9203 20080 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
9204 : {
9205 20080 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
9206 : }
9207 :
9208 : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
9209 : of character expressions. */
9210 : static bool
9211 20573 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
9212 : {
9213 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
9214 : }
9215 :
9216 :
9217 : /* Given the expression node e for an allocatable/pointer of derived type to be
9218 : allocated, get the expression node to be initialized afterwards (needed for
9219 : derived types with default initializers, and derived types with allocatable
9220 : components that need nullification.) */
9221 :
9222 : gfc_expr *
9223 6059 : gfc_expr_to_initialize (gfc_expr *e)
9224 : {
9225 6059 : gfc_expr *result;
9226 6059 : gfc_ref *ref;
9227 6059 : int i;
9228 :
9229 6059 : result = gfc_copy_expr (e);
9230 :
9231 : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
9232 12142 : for (ref = result->ref; ref; ref = ref->next)
9233 9549 : if (ref->type == REF_ARRAY && ref->next == NULL)
9234 : {
9235 3466 : if (ref->u.ar.dimen == 0
9236 89 : && ref->u.ar.as && ref->u.ar.as->corank)
9237 : return result;
9238 :
9239 3377 : ref->u.ar.type = AR_FULL;
9240 :
9241 7606 : for (i = 0; i < ref->u.ar.dimen; i++)
9242 4229 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
9243 :
9244 : break;
9245 : }
9246 :
9247 5970 : gfc_free_shape (&result->shape, result->rank);
9248 :
9249 : /* Recalculate rank, shape, etc. */
9250 5970 : gfc_resolve_expr (result);
9251 5970 : return result;
9252 : }
9253 :
9254 :
9255 : /* If the last ref of an expression is an array ref, return a copy of the
9256 : expression with that one removed. Otherwise, a copy of the original
9257 : expression. This is used for allocate-expressions and pointer assignment
9258 : LHS, where there may be an array specification that needs to be stripped
9259 : off when using gfc_check_vardef_context. */
9260 :
9261 : static gfc_expr*
9262 28598 : remove_last_array_ref (gfc_expr* e)
9263 : {
9264 28598 : gfc_expr* e2;
9265 28598 : gfc_ref** r;
9266 :
9267 28598 : e2 = gfc_copy_expr (e);
9268 37139 : for (r = &e2->ref; *r; r = &(*r)->next)
9269 25517 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9270 : {
9271 16976 : gfc_free_ref_list (*r);
9272 16976 : *r = NULL;
9273 16976 : break;
9274 : }
9275 :
9276 28598 : return e2;
9277 : }
9278 :
9279 :
9280 : /* Used in resolve_allocate_expr to check that a allocation-object and
9281 : a source-expr are conformable. This does not catch all possible
9282 : cases; in particular a runtime checking is needed. */
9283 :
9284 : static bool
9285 1964 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9286 : {
9287 1964 : gfc_ref *tail;
9288 1964 : bool scalar;
9289 :
9290 2786 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9291 :
9292 : /* If MOLD= is present and is not scalar, and the allocate-object has an
9293 : explicit-shape-spec, the ranks need not agree. This may be unintended,
9294 : so let's emit a warning if -Wsurprising is given. */
9295 1964 : scalar = !tail || tail->type == REF_COMPONENT;
9296 1964 : if (e1->mold && e1->rank > 0
9297 166 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9298 : {
9299 27 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9300 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9301 : "but MOLD= expression at %L has rank %d",
9302 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9303 : &e1->where, e1->rank);
9304 : return true;
9305 : }
9306 :
9307 : /* First compare rank. */
9308 1934 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9309 2 : || (!tail && e1->rank != e2->rank))
9310 : {
9311 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9312 : "same rank as the allocate-object at %L",
9313 : &e1->where, &e2->where);
9314 7 : return false;
9315 : }
9316 :
9317 1927 : if (e1->shape)
9318 : {
9319 1409 : int i;
9320 1409 : mpz_t s;
9321 :
9322 1409 : mpz_init (s);
9323 :
9324 3261 : for (i = 0; i < e1->rank; i++)
9325 : {
9326 1415 : if (tail->u.ar.start[i] == NULL)
9327 : break;
9328 :
9329 443 : if (tail->u.ar.end[i])
9330 : {
9331 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9332 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9333 54 : mpz_add_ui (s, s, 1);
9334 : }
9335 : else
9336 : {
9337 389 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9338 : }
9339 :
9340 443 : if (mpz_cmp (e1->shape[i], s) != 0)
9341 : {
9342 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9343 : "have the same shape", &e1->where, &e2->where);
9344 0 : mpz_clear (s);
9345 0 : return false;
9346 : }
9347 : }
9348 :
9349 1409 : mpz_clear (s);
9350 : }
9351 :
9352 : return true;
9353 : }
9354 :
9355 :
9356 : /* Resolve the expression in an ALLOCATE statement, doing the additional
9357 : checks to see whether the expression is OK or not. The expression must
9358 : have a trailing array reference that gives the size of the array. */
9359 :
9360 : static bool
9361 17912 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9362 : {
9363 17912 : int i, pointer, allocatable, dimension, is_abstract;
9364 17912 : int codimension;
9365 17912 : bool coindexed;
9366 17912 : bool unlimited;
9367 17912 : symbol_attribute attr;
9368 17912 : gfc_ref *ref, *ref2;
9369 17912 : gfc_expr *e2;
9370 17912 : gfc_array_ref *ar;
9371 17912 : gfc_symbol *sym = NULL;
9372 17912 : gfc_alloc *a;
9373 17912 : gfc_component *c;
9374 17912 : bool t;
9375 :
9376 : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9377 : checking of coarrays. */
9378 23058 : for (ref = e->ref; ref; ref = ref->next)
9379 18711 : if (ref->next == NULL)
9380 : break;
9381 :
9382 17912 : if (ref && ref->type == REF_ARRAY)
9383 12352 : ref->u.ar.in_allocate = true;
9384 :
9385 17912 : if (!gfc_resolve_expr (e))
9386 1 : goto failure;
9387 :
9388 : /* Make sure the expression is allocatable or a pointer. If it is
9389 : pointer, the next-to-last reference must be a pointer. */
9390 :
9391 17911 : ref2 = NULL;
9392 17911 : if (e->symtree)
9393 17911 : sym = e->symtree->n.sym;
9394 :
9395 : /* Check whether ultimate component is abstract and CLASS. */
9396 35822 : is_abstract = 0;
9397 :
9398 : /* Is the allocate-object unlimited polymorphic? */
9399 17911 : unlimited = UNLIMITED_POLY(e);
9400 :
9401 17911 : if (e->expr_type != EXPR_VARIABLE)
9402 : {
9403 0 : allocatable = 0;
9404 0 : attr = gfc_expr_attr (e);
9405 0 : pointer = attr.pointer;
9406 0 : dimension = attr.dimension;
9407 0 : codimension = attr.codimension;
9408 : }
9409 : else
9410 : {
9411 17911 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9412 : {
9413 3624 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9414 3624 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9415 3624 : dimension = CLASS_DATA (sym)->attr.dimension;
9416 3624 : codimension = CLASS_DATA (sym)->attr.codimension;
9417 3624 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9418 : }
9419 : else
9420 : {
9421 14287 : allocatable = sym->attr.allocatable;
9422 14287 : pointer = sym->attr.pointer;
9423 14287 : dimension = sym->attr.dimension;
9424 14287 : codimension = sym->attr.codimension;
9425 : }
9426 :
9427 17911 : coindexed = false;
9428 :
9429 36616 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9430 : {
9431 18707 : switch (ref->type)
9432 : {
9433 13949 : case REF_ARRAY:
9434 13949 : if (ref->u.ar.codimen > 0)
9435 : {
9436 845 : int n;
9437 1146 : for (n = ref->u.ar.dimen;
9438 1146 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9439 886 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9440 : {
9441 : coindexed = true;
9442 : break;
9443 : }
9444 : }
9445 :
9446 13949 : if (ref->next != NULL)
9447 1599 : pointer = 0;
9448 : break;
9449 :
9450 4758 : case REF_COMPONENT:
9451 : /* F2008, C644. */
9452 4758 : if (coindexed)
9453 : {
9454 2 : gfc_error ("Coindexed allocatable object at %L",
9455 : &e->where);
9456 2 : goto failure;
9457 : }
9458 :
9459 4756 : c = ref->u.c.component;
9460 4756 : if (c->ts.type == BT_CLASS)
9461 : {
9462 1018 : allocatable = CLASS_DATA (c)->attr.allocatable;
9463 1018 : pointer = CLASS_DATA (c)->attr.class_pointer;
9464 1018 : dimension = CLASS_DATA (c)->attr.dimension;
9465 1018 : codimension = CLASS_DATA (c)->attr.codimension;
9466 1018 : is_abstract = CLASS_DATA (c)->attr.abstract;
9467 : }
9468 : else
9469 : {
9470 3738 : allocatable = c->attr.allocatable;
9471 3738 : pointer = c->attr.pointer;
9472 3738 : dimension = c->attr.dimension;
9473 3738 : codimension = c->attr.codimension;
9474 3738 : is_abstract = c->attr.abstract;
9475 : }
9476 : break;
9477 :
9478 0 : case REF_SUBSTRING:
9479 0 : case REF_INQUIRY:
9480 0 : allocatable = 0;
9481 0 : pointer = 0;
9482 0 : break;
9483 : }
9484 : }
9485 : }
9486 :
9487 : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9488 : pointer or an allocatable variable. */
9489 17909 : if (allocatable == 0 && pointer == 0)
9490 : {
9491 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9492 : &e->where);
9493 4 : goto failure;
9494 : }
9495 :
9496 : /* Some checks for the SOURCE tag. */
9497 17905 : if (code->expr3)
9498 : {
9499 : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9500 : rank as allocate-object". This would require the MOLD argument to
9501 : NULL() as source-expr for subsequent checking. However, even the
9502 : resulting disassociated pointer or unallocated array has no shape that
9503 : could be used for SOURCE= or MOLD=. */
9504 3996 : if (code->expr3->expr_type == EXPR_NULL)
9505 : {
9506 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9507 : &code->expr3->where);
9508 4 : goto failure;
9509 : }
9510 :
9511 : /* Check F03:C631. */
9512 3992 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9513 : {
9514 10 : gfc_error ("Type of entity at %L is type incompatible with "
9515 10 : "source-expr at %L", &e->where, &code->expr3->where);
9516 10 : goto failure;
9517 : }
9518 :
9519 : /* Check F03:C632 and restriction following Note 6.18. */
9520 3982 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9521 7 : goto failure;
9522 :
9523 : /* Check F03:C633. */
9524 3975 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9525 : {
9526 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9527 : "shall have the same kind type parameter",
9528 : &e->where, &code->expr3->where);
9529 1 : goto failure;
9530 : }
9531 :
9532 : /* Check F2008, C642. */
9533 3974 : if (code->expr3->ts.type == BT_DERIVED
9534 3974 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9535 1240 : || (code->expr3->ts.u.derived->from_intmod
9536 : == INTMOD_ISO_FORTRAN_ENV
9537 0 : && code->expr3->ts.u.derived->intmod_sym_id
9538 : == ISOFORTRAN_LOCK_TYPE)))
9539 : {
9540 0 : gfc_error ("The source-expr at %L shall neither be of type "
9541 : "LOCK_TYPE nor have a LOCK_TYPE component if "
9542 : "allocate-object at %L is a coarray",
9543 0 : &code->expr3->where, &e->where);
9544 0 : goto failure;
9545 : }
9546 :
9547 : /* Check F2008:C639: "Corresponding kind type parameters of
9548 : allocate-object and source-expr shall have the same values." */
9549 3974 : if (e->ts.type == BT_CHARACTER
9550 822 : && !e->ts.deferred
9551 162 : && e->ts.u.cl->length
9552 162 : && code->expr3->ts.type == BT_CHARACTER
9553 4136 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9554 : "SOURCE= or MOLD= specifier"))
9555 17 : goto failure;
9556 :
9557 : /* Check TS18508, C702/C703. */
9558 3957 : if (code->expr3->ts.type == BT_DERIVED
9559 5197 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9560 1240 : || (code->expr3->ts.u.derived->from_intmod
9561 : == INTMOD_ISO_FORTRAN_ENV
9562 0 : && code->expr3->ts.u.derived->intmod_sym_id
9563 : == ISOFORTRAN_EVENT_TYPE)))
9564 : {
9565 0 : gfc_error ("The source-expr at %L shall neither be of type "
9566 : "EVENT_TYPE nor have a EVENT_TYPE component if "
9567 : "allocate-object at %L is a coarray",
9568 0 : &code->expr3->where, &e->where);
9569 0 : goto failure;
9570 : }
9571 : }
9572 :
9573 : /* Check F08:C629. */
9574 17866 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9575 159 : && !code->expr3)
9576 : {
9577 2 : gcc_assert (e->ts.type == BT_CLASS);
9578 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9579 : "type-spec or source-expr", sym->name, &e->where);
9580 2 : goto failure;
9581 : }
9582 :
9583 : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9584 : if and only if each allocate-object is a dummy argument for which the
9585 : corresponding type parameter is assumed. */
9586 17864 : if (code->ext.alloc.ts.type == BT_CHARACTER
9587 533 : && code->ext.alloc.ts.u.cl->length != NULL
9588 518 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9589 23 : && e->ts.u.cl->length == NULL
9590 2 : && e->symtree->n.sym->attr.dummy)
9591 : {
9592 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9593 : "shall be an asterisk as allocate object %qs at %L is a "
9594 : "dummy argument with assumed type parameter",
9595 : sym->name, &e->where);
9596 2 : goto failure;
9597 : }
9598 :
9599 : /* Check F08:C632. */
9600 17862 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9601 60 : && !UNLIMITED_POLY (e))
9602 : {
9603 36 : int cmp = 0;
9604 :
9605 36 : if (!e->ts.u.cl->length)
9606 15 : goto failure;
9607 :
9608 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9609 21 : code->ext.alloc.ts.u.cl->length);
9610 21 : if (cmp == 1 || cmp == -1)
9611 : {
9612 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9613 : "character-length parameter as in the declaration",
9614 : sym->name, &e->where);
9615 2 : goto failure;
9616 : }
9617 : }
9618 :
9619 : /* In the variable definition context checks, gfc_expr_attr is used
9620 : on the expression. This is fooled by the array specification
9621 : present in e, thus we have to eliminate that one temporarily. */
9622 17845 : e2 = remove_last_array_ref (e);
9623 17845 : t = true;
9624 17845 : if (t && pointer)
9625 3933 : t = gfc_check_vardef_context (e2, true, true, false,
9626 3933 : _("ALLOCATE object"));
9627 3933 : if (t)
9628 17837 : t = gfc_check_vardef_context (e2, false, true, false,
9629 17837 : _("ALLOCATE object"));
9630 17845 : gfc_free_expr (e2);
9631 17845 : if (!t)
9632 11 : goto failure;
9633 :
9634 17834 : code->ext.alloc.expr3_not_explicit = 0;
9635 17834 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9636 1704 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9637 : {
9638 : /* For class arrays, the initialization with SOURCE is done
9639 : using _copy and trans_call. It is convenient to exploit that
9640 : when the allocated type is different from the declared type but
9641 : no SOURCE exists by setting expr3. */
9642 341 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9643 341 : code->ext.alloc.expr3_not_explicit = 1;
9644 : }
9645 17493 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9646 2732 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9647 6 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9648 : {
9649 : /* We have to zero initialize the integer variable. */
9650 2 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9651 2 : code->ext.alloc.expr3_not_explicit = 1;
9652 : }
9653 :
9654 17834 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9655 : {
9656 : /* Make sure the vtab symbol is present when
9657 : the module variables are generated. */
9658 3110 : gfc_typespec ts = e->ts;
9659 3110 : if (code->expr3)
9660 1343 : ts = code->expr3->ts;
9661 1767 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9662 774 : ts = code->ext.alloc.ts;
9663 :
9664 : /* Finding the vtab also publishes the type's symbol. Therefore this
9665 : statement is necessary. */
9666 3110 : gfc_find_derived_vtab (ts.u.derived);
9667 3110 : }
9668 14724 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9669 : {
9670 : /* Again, make sure the vtab symbol is present when
9671 : the module variables are generated. */
9672 488 : gfc_typespec *ts = NULL;
9673 488 : if (code->expr3)
9674 377 : ts = &code->expr3->ts;
9675 : else
9676 : {
9677 111 : ts = &code->ext.alloc.ts;
9678 111 : if (ts->type == BT_DERIVED && ts->u.derived->attr.pdt_type)
9679 : {
9680 24 : code->expr3 = gfc_default_initializer (ts);
9681 24 : code->expr3->mold = 1;
9682 24 : code->ext.alloc.expr3_not_explicit = 1;
9683 : }
9684 : }
9685 :
9686 377 : gcc_assert (ts);
9687 :
9688 : /* Finding the vtab also publishes the type's symbol. Therefore this
9689 : statement is necessary. */
9690 488 : gfc_find_vtab (ts);
9691 : }
9692 :
9693 17834 : if (dimension == 0 && codimension == 0)
9694 5513 : goto success;
9695 :
9696 : /* Make sure the last reference node is an array specification. */
9697 :
9698 12321 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9699 11058 : || (dimension && ref2->u.ar.dimen == 0))
9700 : {
9701 : /* F08:C633. */
9702 1263 : if (code->expr3)
9703 : {
9704 1262 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9705 : "in ALLOCATE statement at %L", &e->where))
9706 0 : goto failure;
9707 1262 : if (code->expr3->rank != 0)
9708 1261 : *array_alloc_wo_spec = true;
9709 : else
9710 : {
9711 1 : gfc_error ("Array specification or array-valued SOURCE= "
9712 : "expression required in ALLOCATE statement at %L",
9713 : &e->where);
9714 1 : goto failure;
9715 : }
9716 : }
9717 : else
9718 : {
9719 1 : gfc_error ("Array specification required in ALLOCATE statement "
9720 : "at %L", &e->where);
9721 1 : goto failure;
9722 : }
9723 : }
9724 :
9725 : /* Make sure that the array section reference makes sense in the
9726 : context of an ALLOCATE specification. */
9727 :
9728 12319 : ar = &ref2->u.ar;
9729 :
9730 12319 : if (codimension)
9731 1352 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9732 : {
9733 780 : switch (ar->dimen_type[i])
9734 : {
9735 2 : case DIMEN_THIS_IMAGE:
9736 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9737 : "at %L", &e->where);
9738 2 : goto failure;
9739 :
9740 98 : case DIMEN_RANGE:
9741 : /* F2018:R937:
9742 : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9743 : */
9744 98 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9745 : {
9746 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9747 : "at %L", &e->where);
9748 8 : goto failure;
9749 : }
9750 90 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9751 : {
9752 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9753 2 : &ar->start[i]->where);
9754 2 : goto failure;
9755 : }
9756 : break;
9757 :
9758 108 : case DIMEN_ELEMENT:
9759 108 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9760 : {
9761 100 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9762 100 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9763 : {
9764 1 : gfc_error ("Upper cobound is less than lower cobound "
9765 : "of 1 at %L", &ar->start[i]->where);
9766 1 : goto failure;
9767 : }
9768 : }
9769 : break;
9770 :
9771 : case DIMEN_STAR:
9772 : break;
9773 :
9774 0 : default:
9775 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9776 : &e->where);
9777 0 : goto failure;
9778 :
9779 : }
9780 : }
9781 29978 : for (i = 0; i < ar->dimen; i++)
9782 : {
9783 17676 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9784 14937 : goto check_symbols;
9785 :
9786 2739 : switch (ar->dimen_type[i])
9787 : {
9788 : case DIMEN_ELEMENT:
9789 : break;
9790 :
9791 2473 : case DIMEN_RANGE:
9792 2473 : if (ar->start[i] != NULL
9793 2473 : && ar->end[i] != NULL
9794 2472 : && ar->stride[i] == NULL)
9795 : break;
9796 :
9797 : /* Fall through. */
9798 :
9799 1 : case DIMEN_UNKNOWN:
9800 1 : case DIMEN_VECTOR:
9801 1 : case DIMEN_STAR:
9802 1 : case DIMEN_THIS_IMAGE:
9803 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9804 : &e->where);
9805 1 : goto failure;
9806 : }
9807 :
9808 2472 : check_symbols:
9809 45794 : for (a = code->ext.alloc.list; a; a = a->next)
9810 : {
9811 28122 : sym = a->expr->symtree->n.sym;
9812 :
9813 : /* TODO - check derived type components. */
9814 28122 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9815 9591 : continue;
9816 :
9817 18531 : if ((ar->start[i] != NULL
9818 17850 : && gfc_find_var_in_expr (sym, ar->start[i]))
9819 36378 : || (ar->end[i] != NULL
9820 2723 : && gfc_find_var_in_expr (sym, ar->end[i])))
9821 : {
9822 3 : gfc_error ("%qs must not appear in the array specification at "
9823 : "%L in the same ALLOCATE statement where it is "
9824 : "itself allocated", sym->name, &ar->where);
9825 3 : goto failure;
9826 : }
9827 : }
9828 : }
9829 :
9830 12496 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9831 : {
9832 959 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9833 765 : || ar->dimen_type[i] == DIMEN_RANGE)
9834 : {
9835 194 : if (i == (ar->dimen + ar->codimen - 1))
9836 : {
9837 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9838 : "statement at %L", &e->where);
9839 0 : goto failure;
9840 : }
9841 194 : continue;
9842 : }
9843 :
9844 571 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9845 571 : && ar->stride[i] == NULL)
9846 : break;
9847 :
9848 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9849 : &e->where);
9850 0 : goto failure;
9851 : }
9852 :
9853 12302 : success:
9854 17815 : gfc_used_in_allocate_expr (e, &e->where, ALLOCATED_ALLOCATE_STMT);
9855 :
9856 17815 : if (code->expr3)
9857 4176 : gfc_value_set_at (e->symtree->n.sym, &code->expr3->where, VALUE_VARDEF);
9858 :
9859 : return true;
9860 :
9861 17912 : failure:
9862 : return false;
9863 : }
9864 :
9865 :
9866 : static void
9867 21131 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9868 : {
9869 21131 : gfc_expr *stat, *errmsg, *pe, *qe;
9870 21131 : gfc_alloc *a, *p, *q;
9871 :
9872 21131 : stat = code->expr1;
9873 21131 : errmsg = code->expr2;
9874 :
9875 : /* Check the stat variable. */
9876 21131 : if (stat)
9877 : {
9878 673 : if (!gfc_check_vardef_context (stat, false, false, false,
9879 673 : _("STAT variable")))
9880 8 : goto done_stat;
9881 :
9882 665 : if (stat->ts.type != BT_INTEGER
9883 656 : || stat->rank > 0)
9884 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9885 : "variable", &stat->where);
9886 :
9887 665 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9888 0 : goto done_stat;
9889 :
9890 : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9891 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9892 : */
9893 1378 : for (p = code->ext.alloc.list; p; p = p->next)
9894 720 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9895 : {
9896 9 : gfc_ref *ref1, *ref2;
9897 9 : bool found = true;
9898 :
9899 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9900 7 : ref1 = ref1->next, ref2 = ref2->next)
9901 : {
9902 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9903 5 : continue;
9904 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9905 : {
9906 : found = false;
9907 : break;
9908 : }
9909 : }
9910 :
9911 9 : if (found)
9912 : {
9913 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9914 : "the same %s statement", &stat->where, fcn, fcn);
9915 7 : break;
9916 : }
9917 : }
9918 : }
9919 :
9920 20458 : done_stat:
9921 :
9922 : /* Check the errmsg variable. */
9923 21131 : if (errmsg)
9924 : {
9925 150 : if (!stat)
9926 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9927 : &errmsg->where);
9928 :
9929 150 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9930 150 : _("ERRMSG variable")))
9931 6 : goto done_errmsg;
9932 :
9933 : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9934 : F18:R930 errmsg-variable is scalar-default-char-variable
9935 : F18:R906 default-char-variable is variable
9936 : F18:C906 default-char-variable shall be default character. */
9937 144 : if (errmsg->ts.type != BT_CHARACTER
9938 142 : || errmsg->rank > 0
9939 141 : || errmsg->ts.kind != gfc_default_character_kind)
9940 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9941 : "variable", &errmsg->where);
9942 :
9943 144 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9944 0 : goto done_errmsg;
9945 :
9946 : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9947 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9948 : */
9949 286 : for (p = code->ext.alloc.list; p; p = p->next)
9950 147 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9951 : {
9952 9 : gfc_ref *ref1, *ref2;
9953 9 : bool found = true;
9954 :
9955 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9956 7 : ref1 = ref1->next, ref2 = ref2->next)
9957 : {
9958 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9959 4 : continue;
9960 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9961 : {
9962 : found = false;
9963 : break;
9964 : }
9965 : }
9966 :
9967 9 : if (found)
9968 : {
9969 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9970 : "the same %s statement", &errmsg->where, fcn, fcn);
9971 5 : break;
9972 : }
9973 : }
9974 : }
9975 :
9976 20981 : done_errmsg:
9977 :
9978 : /* Check that an allocate-object appears only once in the statement. */
9979 :
9980 47633 : for (p = code->ext.alloc.list; p; p = p->next)
9981 : {
9982 26502 : pe = p->expr;
9983 35875 : for (q = p->next; q; q = q->next)
9984 : {
9985 9373 : qe = q->expr;
9986 9373 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9987 : {
9988 : /* This is a potential collision. */
9989 2094 : gfc_ref *pr = pe->ref;
9990 2094 : gfc_ref *qr = qe->ref;
9991 :
9992 : /* Follow the references until
9993 : a) They start to differ, in which case there is no error;
9994 : you can deallocate a%b and a%c in a single statement
9995 : b) Both of them stop, which is an error
9996 : c) One of them stops, which is also an error. */
9997 4518 : while (1)
9998 : {
9999 3306 : if (pr == NULL && qr == NULL)
10000 : {
10001 7 : gfc_error ("Allocate-object at %L also appears at %L",
10002 : &pe->where, &qe->where);
10003 7 : break;
10004 : }
10005 3299 : else if (pr != NULL && qr == NULL)
10006 : {
10007 2 : gfc_error ("Allocate-object at %L is subobject of"
10008 : " object at %L", &pe->where, &qe->where);
10009 2 : break;
10010 : }
10011 3297 : else if (pr == NULL && qr != NULL)
10012 : {
10013 2 : gfc_error ("Allocate-object at %L is subobject of"
10014 : " object at %L", &qe->where, &pe->where);
10015 2 : break;
10016 : }
10017 : /* Here, pr != NULL && qr != NULL */
10018 3295 : gcc_assert(pr->type == qr->type);
10019 3295 : if (pr->type == REF_ARRAY)
10020 : {
10021 : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
10022 : which are legal. */
10023 1065 : gcc_assert (qr->type == REF_ARRAY);
10024 :
10025 1065 : if (pr->next && qr->next)
10026 : {
10027 : int i;
10028 : gfc_array_ref *par = &(pr->u.ar);
10029 : gfc_array_ref *qar = &(qr->u.ar);
10030 :
10031 1840 : for (i=0; i<par->dimen; i++)
10032 : {
10033 954 : if ((par->start[i] != NULL
10034 0 : || qar->start[i] != NULL)
10035 1908 : && gfc_dep_compare_expr (par->start[i],
10036 954 : qar->start[i]) != 0)
10037 168 : goto break_label;
10038 : }
10039 : }
10040 : }
10041 : else
10042 : {
10043 2230 : if (pr->u.c.component->name != qr->u.c.component->name)
10044 : break;
10045 : }
10046 :
10047 1212 : pr = pr->next;
10048 1212 : qr = qr->next;
10049 1212 : }
10050 9373 : break_label:
10051 : ;
10052 : }
10053 : }
10054 : }
10055 :
10056 21131 : if (strcmp (fcn, "ALLOCATE") == 0)
10057 : {
10058 14849 : bool arr_alloc_wo_spec = false;
10059 :
10060 : /* Resolve and mark as used the length of the type spec. */
10061 14849 : if (code->ext.alloc.ts.type == BT_CHARACTER)
10062 : {
10063 491 : gfc_expr *length = code->ext.alloc.ts.u.cl->length;
10064 491 : gfc_resolve_expr (length);
10065 491 : gfc_value_used_expr (length, VALUE_USED);
10066 : }
10067 :
10068 : /* Resolving the expr3 in the loop over all objects to allocate would
10069 : execute loop invariant code for each loop item. Therefore do it just
10070 : once here. */
10071 14849 : if (code->expr3 && code->expr3->mold
10072 369 : && code->expr3->ts.type == BT_DERIVED
10073 36 : && !IS_PDT (code->expr3) && !IS_CLASS_PDT (code->expr3)
10074 27 : && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
10075 : {
10076 : /* Default initialization via MOLD (non-polymorphic). */
10077 25 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
10078 25 : if (rhs != NULL)
10079 : {
10080 6 : gfc_resolve_expr (rhs);
10081 6 : gfc_free_expr (code->expr3);
10082 6 : code->expr3 = rhs;
10083 : }
10084 : }
10085 32761 : for (a = code->ext.alloc.list; a; a = a->next)
10086 17912 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
10087 :
10088 14849 : if (arr_alloc_wo_spec && code->expr3)
10089 : {
10090 : /* Mark the allocate to have to take the array specification
10091 : from the expr3. */
10092 1255 : code->ext.alloc.arr_spec_from_expr3 = 1;
10093 : }
10094 : }
10095 : else
10096 : {
10097 14872 : for (a = code->ext.alloc.list; a; a = a->next)
10098 8590 : resolve_deallocate_expr (a->expr);
10099 : }
10100 21131 : }
10101 :
10102 :
10103 : /************ SELECT CASE resolution subroutines ************/
10104 :
10105 : /* Callback function for our mergesort variant. Determines interval
10106 : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
10107 : op1 > op2. Assumes we're not dealing with the default case.
10108 : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
10109 : There are nine situations to check. */
10110 :
10111 : static int
10112 1615 : compare_cases (const gfc_case *op1, const gfc_case *op2)
10113 : {
10114 1615 : int retval;
10115 :
10116 1615 : if (op1->low == NULL) /* op1 = (:L) */
10117 : {
10118 : /* op2 = (:N), so overlap. */
10119 52 : retval = 0;
10120 : /* op2 = (M:) or (M:N), L < M */
10121 52 : if (op2->low != NULL
10122 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10123 : retval = -1;
10124 : }
10125 1563 : else if (op1->high == NULL) /* op1 = (K:) */
10126 : {
10127 : /* op2 = (M:), so overlap. */
10128 10 : retval = 0;
10129 : /* op2 = (:N) or (M:N), K > N */
10130 10 : if (op2->high != NULL
10131 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10132 : retval = 1;
10133 : }
10134 : else /* op1 = (K:L) */
10135 : {
10136 1553 : if (op2->low == NULL) /* op2 = (:N), K > N */
10137 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10138 18 : ? 1 : 0;
10139 1535 : else if (op2->high == NULL) /* op2 = (M:), L < M */
10140 10 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10141 10 : ? -1 : 0;
10142 : else /* op2 = (M:N) */
10143 : {
10144 1525 : retval = 0;
10145 : /* L < M */
10146 1525 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10147 : retval = -1;
10148 : /* K > N */
10149 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10150 438 : retval = 1;
10151 : }
10152 : }
10153 :
10154 1615 : return retval;
10155 : }
10156 :
10157 :
10158 : /* Merge-sort a double linked case list, detecting overlap in the
10159 : process. LIST is the head of the double linked case list before it
10160 : is sorted. Returns the head of the sorted list if we don't see any
10161 : overlap, or NULL otherwise. */
10162 :
10163 : static gfc_case *
10164 664 : check_case_overlap (gfc_case *list)
10165 : {
10166 664 : gfc_case *p, *q, *e, *tail;
10167 664 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
10168 :
10169 : /* If the passed list was empty, return immediately. */
10170 664 : if (!list)
10171 : return NULL;
10172 :
10173 : overlap_seen = 0;
10174 : insize = 1;
10175 :
10176 : /* Loop unconditionally. The only exit from this loop is a return
10177 : statement, when we've finished sorting the case list. */
10178 1392 : for (;;)
10179 : {
10180 1028 : p = list;
10181 1028 : list = NULL;
10182 1028 : tail = NULL;
10183 :
10184 : /* Count the number of merges we do in this pass. */
10185 1028 : nmerges = 0;
10186 :
10187 : /* Loop while there exists a merge to be done. */
10188 2595 : while (p)
10189 : {
10190 1567 : int i;
10191 :
10192 : /* Count this merge. */
10193 1567 : nmerges++;
10194 :
10195 : /* Cut the list in two pieces by stepping INSIZE places
10196 : forward in the list, starting from P. */
10197 1567 : psize = 0;
10198 1567 : q = p;
10199 3287 : for (i = 0; i < insize; i++)
10200 : {
10201 2297 : psize++;
10202 2297 : q = q->right;
10203 2297 : if (!q)
10204 : break;
10205 : }
10206 1567 : qsize = insize;
10207 :
10208 : /* Now we have two lists. Merge them! */
10209 5135 : while (psize > 0 || (qsize > 0 && q != NULL))
10210 : {
10211 : /* See from which the next case to merge comes from. */
10212 833 : if (psize == 0)
10213 : {
10214 : /* P is empty so the next case must come from Q. */
10215 833 : e = q;
10216 833 : q = q->right;
10217 833 : qsize--;
10218 : }
10219 2735 : else if (qsize == 0 || q == NULL)
10220 : {
10221 : /* Q is empty. */
10222 1120 : e = p;
10223 1120 : p = p->right;
10224 1120 : psize--;
10225 : }
10226 : else
10227 : {
10228 1615 : cmp = compare_cases (p, q);
10229 1615 : if (cmp < 0)
10230 : {
10231 : /* The whole case range for P is less than the
10232 : one for Q. */
10233 1173 : e = p;
10234 1173 : p = p->right;
10235 1173 : psize--;
10236 : }
10237 442 : else if (cmp > 0)
10238 : {
10239 : /* The whole case range for Q is greater than
10240 : the case range for P. */
10241 438 : e = q;
10242 438 : q = q->right;
10243 438 : qsize--;
10244 : }
10245 : else
10246 : {
10247 : /* The cases overlap, or they are the same
10248 : element in the list. Either way, we must
10249 : issue an error and get the next case from P. */
10250 : /* FIXME: Sort P and Q by line number. */
10251 4 : gfc_error ("CASE label at %L overlaps with CASE "
10252 : "label at %L", &p->where, &q->where);
10253 4 : overlap_seen = 1;
10254 4 : e = p;
10255 4 : p = p->right;
10256 4 : psize--;
10257 : }
10258 : }
10259 :
10260 : /* Add the next element to the merged list. */
10261 3568 : if (tail)
10262 2540 : tail->right = e;
10263 : else
10264 : list = e;
10265 3568 : e->left = tail;
10266 3568 : tail = e;
10267 : }
10268 :
10269 : /* P has now stepped INSIZE places along, and so has Q. So
10270 : they're the same. */
10271 : p = q;
10272 : }
10273 1028 : tail->right = NULL;
10274 :
10275 : /* If we have done only one merge or none at all, we've
10276 : finished sorting the cases. */
10277 1028 : if (nmerges <= 1)
10278 : {
10279 664 : if (!overlap_seen)
10280 : return list;
10281 : else
10282 4 : return NULL;
10283 : }
10284 :
10285 : /* Otherwise repeat, merging lists twice the size. */
10286 364 : insize *= 2;
10287 364 : }
10288 : }
10289 :
10290 :
10291 : /* Check to see if an expression is suitable for use in a CASE statement.
10292 : Makes sure that all case expressions are scalar constants of the same
10293 : type. Return false if anything is wrong. */
10294 :
10295 : static bool
10296 3393 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10297 : {
10298 3393 : if (e == NULL) return true;
10299 :
10300 3300 : if (e->ts.type != case_expr->ts.type)
10301 : {
10302 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10303 : &e->where, gfc_basic_typename (case_expr->ts.type));
10304 4 : return false;
10305 : }
10306 :
10307 : /* C805 (R808) For a given case-construct, each case-value shall be of
10308 : the same type as case-expr. For character type, length differences
10309 : are allowed, but the kind type parameters shall be the same. */
10310 :
10311 3296 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10312 : {
10313 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10314 : &e->where, case_expr->ts.kind);
10315 4 : return false;
10316 : }
10317 :
10318 : /* Convert the case value kind to that of case expression kind,
10319 : if needed */
10320 :
10321 3292 : if (e->ts.kind != case_expr->ts.kind)
10322 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10323 :
10324 3292 : if (e->rank != 0)
10325 : {
10326 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10327 : &e->where);
10328 0 : return false;
10329 : }
10330 :
10331 : return true;
10332 : }
10333 :
10334 :
10335 : /* Given a completely parsed select statement, we:
10336 :
10337 : - Validate all expressions and code within the SELECT.
10338 : - Make sure that the selection expression is not of the wrong type.
10339 : - Make sure that no case ranges overlap.
10340 : - Eliminate unreachable cases and unreachable code resulting from
10341 : removing case labels.
10342 :
10343 : The standard does allow unreachable cases, e.g. CASE (5:3). But
10344 : they are a hassle for code generation, and to prevent that, we just
10345 : cut them out here. This is not necessary for overlapping cases
10346 : because they are illegal and we never even try to generate code.
10347 :
10348 : We have the additional caveat that a SELECT construct could have
10349 : been a computed GOTO in the source code. Fortunately we can fairly
10350 : easily work around that here: The case_expr for a "real" SELECT CASE
10351 : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10352 : we have to do is make sure that the case_expr is a scalar integer
10353 : expression. */
10354 :
10355 : static void
10356 705 : resolve_select (gfc_code *code, bool select_type)
10357 : {
10358 705 : gfc_code *body;
10359 705 : gfc_expr *case_expr;
10360 705 : gfc_case *cp, *default_case, *tail, *head;
10361 705 : int seen_unreachable;
10362 705 : int seen_logical;
10363 705 : int ncases;
10364 705 : bt type;
10365 705 : bool t;
10366 :
10367 705 : if (code->expr1 == NULL)
10368 : {
10369 : /* This was actually a computed GOTO statement. */
10370 5 : case_expr = code->expr2;
10371 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10372 3 : gfc_error ("Selection expression in computed GOTO statement "
10373 : "at %L must be a scalar integer expression",
10374 : &case_expr->where);
10375 :
10376 : /* Further checking is not necessary because this SELECT was built
10377 : by the compiler, so it should always be OK. Just move the
10378 : case_expr from expr2 to expr so that we can handle computed
10379 : GOTOs as normal SELECTs from here on. */
10380 5 : code->expr1 = code->expr2;
10381 5 : code->expr2 = NULL;
10382 5 : gfc_value_used_expr (code->expr1, VALUE_USED);
10383 5 : return;
10384 : }
10385 :
10386 700 : case_expr = code->expr1;
10387 700 : type = case_expr->ts.type;
10388 :
10389 : /* F08:C830. */
10390 700 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10391 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10392 :
10393 : {
10394 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10395 : &case_expr->where, gfc_typename (case_expr));
10396 :
10397 : /* Punt. Going on here just produce more garbage error messages. */
10398 0 : return;
10399 : }
10400 :
10401 : /* F08:R842. */
10402 700 : if (!select_type && case_expr->rank != 0)
10403 : {
10404 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10405 : "expression", &case_expr->where);
10406 :
10407 : /* Punt. */
10408 1 : return;
10409 : }
10410 :
10411 : /* Raise a warning if an INTEGER case value exceeds the range of
10412 : the case-expr. Later, all expressions will be promoted to the
10413 : largest kind of all case-labels. */
10414 :
10415 699 : if (type == BT_INTEGER)
10416 1989 : for (body = code->block; body; body = body->block)
10417 2940 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10418 : {
10419 1506 : if (cp->low
10420 1506 : && gfc_check_integer_range (cp->low->value.integer,
10421 : case_expr->ts.kind) != ARITH_OK)
10422 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10423 6 : "not in the range of %s", &cp->low->where,
10424 : gfc_typename (case_expr));
10425 :
10426 1506 : if (cp->high
10427 1221 : && cp->low != cp->high
10428 1614 : && gfc_check_integer_range (cp->high->value.integer,
10429 : case_expr->ts.kind) != ARITH_OK)
10430 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10431 0 : "not in the range of %s", &cp->high->where,
10432 : gfc_typename (case_expr));
10433 : }
10434 :
10435 : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10436 : of the SELECT CASE expression and its CASE values. Walk the lists
10437 : of case values, and if we find a mismatch, promote case_expr to
10438 : the appropriate kind. */
10439 :
10440 699 : if (type == BT_LOGICAL || type == BT_INTEGER)
10441 : {
10442 2175 : for (body = code->block; body; body = body->block)
10443 : {
10444 : /* Walk the case label list. */
10445 3201 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10446 : {
10447 : /* Intercept the DEFAULT case. It does not have a kind. */
10448 1641 : if (cp->low == NULL && cp->high == NULL)
10449 293 : continue;
10450 :
10451 : /* Unreachable case ranges are discarded, so ignore. */
10452 1303 : if (cp->low != NULL && cp->high != NULL
10453 1255 : && cp->low != cp->high
10454 1413 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10455 33 : continue;
10456 :
10457 1315 : if (cp->low != NULL
10458 1315 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10459 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10460 :
10461 1315 : if (cp->high != NULL
10462 1315 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10463 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10464 : }
10465 : }
10466 : }
10467 :
10468 : /* Assume there is no DEFAULT case. */
10469 699 : default_case = NULL;
10470 699 : head = tail = NULL;
10471 699 : ncases = 0;
10472 699 : seen_logical = 0;
10473 :
10474 2564 : for (body = code->block; body; body = body->block)
10475 : {
10476 : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10477 1865 : t = true;
10478 1865 : seen_unreachable = 0;
10479 :
10480 : /* Walk the case label list, making sure that all case labels
10481 : are legal. */
10482 3917 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10483 : {
10484 : /* Count the number of cases in the whole construct. */
10485 2063 : ncases++;
10486 :
10487 : /* Intercept the DEFAULT case. */
10488 2063 : if (cp->low == NULL && cp->high == NULL)
10489 : {
10490 363 : if (default_case != NULL)
10491 : {
10492 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10493 : "by a second DEFAULT CASE at %L",
10494 : &default_case->where, &cp->where);
10495 0 : t = false;
10496 0 : break;
10497 : }
10498 : else
10499 : {
10500 363 : default_case = cp;
10501 363 : continue;
10502 : }
10503 : }
10504 :
10505 : /* Deal with single value cases and case ranges. Errors are
10506 : issued from the validation function. */
10507 1700 : if (!validate_case_label_expr (cp->low, case_expr)
10508 1700 : || !validate_case_label_expr (cp->high, case_expr))
10509 : {
10510 : t = false;
10511 : break;
10512 : }
10513 :
10514 1692 : if (type == BT_LOGICAL
10515 78 : && ((cp->low == NULL || cp->high == NULL)
10516 76 : || cp->low != cp->high))
10517 : {
10518 2 : gfc_error ("Logical range in CASE statement at %L is not "
10519 : "allowed",
10520 1 : cp->low ? &cp->low->where : &cp->high->where);
10521 2 : t = false;
10522 2 : break;
10523 : }
10524 :
10525 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10526 : {
10527 76 : int value;
10528 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10529 76 : if (value & seen_logical)
10530 : {
10531 1 : gfc_error ("Constant logical value in CASE statement "
10532 : "is repeated at %L",
10533 : &cp->low->where);
10534 1 : t = false;
10535 1 : break;
10536 : }
10537 75 : seen_logical |= value;
10538 : }
10539 :
10540 1645 : if (cp->low != NULL && cp->high != NULL
10541 1598 : && cp->low != cp->high
10542 1801 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10543 : {
10544 35 : if (warn_surprising)
10545 1 : gfc_warning (OPT_Wsurprising,
10546 : "Range specification at %L can never be matched",
10547 : &cp->where);
10548 :
10549 35 : cp->unreachable = 1;
10550 35 : seen_unreachable = 1;
10551 : }
10552 : else
10553 : {
10554 : /* If the case range can be matched, it can also overlap with
10555 : other cases. To make sure it does not, we put it in a
10556 : double linked list here. We sort that with a merge sort
10557 : later on to detect any overlapping cases. */
10558 1654 : if (!head)
10559 : {
10560 664 : head = tail = cp;
10561 664 : head->right = head->left = NULL;
10562 : }
10563 : else
10564 : {
10565 990 : tail->right = cp;
10566 990 : tail->right->left = tail;
10567 990 : tail = tail->right;
10568 990 : tail->right = NULL;
10569 : }
10570 : }
10571 : }
10572 :
10573 : /* It there was a failure in the previous case label, give up
10574 : for this case label list. Continue with the next block. */
10575 1865 : if (!t)
10576 11 : continue;
10577 :
10578 : /* See if any case labels that are unreachable have been seen.
10579 : If so, we eliminate them. This is a bit of a kludge because
10580 : the case lists for a single case statement (label) is a
10581 : single forward linked lists. */
10582 1854 : if (seen_unreachable)
10583 : {
10584 : /* Advance until the first case in the list is reachable. */
10585 69 : while (body->ext.block.case_list != NULL
10586 69 : && body->ext.block.case_list->unreachable)
10587 : {
10588 34 : gfc_case *n = body->ext.block.case_list;
10589 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10590 34 : n->next = NULL;
10591 34 : gfc_free_case_list (n);
10592 : }
10593 :
10594 : /* Strip all other unreachable cases. */
10595 35 : if (body->ext.block.case_list)
10596 : {
10597 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10598 : {
10599 1 : if (cp->next->unreachable)
10600 : {
10601 1 : gfc_case *n = cp->next;
10602 1 : cp->next = cp->next->next;
10603 1 : n->next = NULL;
10604 1 : gfc_free_case_list (n);
10605 : }
10606 : }
10607 : }
10608 : }
10609 : }
10610 :
10611 : /* See if there were overlapping cases. If the check returns NULL,
10612 : there was overlap. In that case we don't do anything. If head
10613 : is non-NULL, we prepend the DEFAULT case. The sorted list can
10614 : then used during code generation for SELECT CASE constructs with
10615 : a case expression of a CHARACTER type. */
10616 699 : if (head)
10617 : {
10618 664 : head = check_case_overlap (head);
10619 :
10620 : /* Prepend the default_case if it is there. */
10621 664 : if (head != NULL && default_case)
10622 : {
10623 346 : default_case->left = NULL;
10624 346 : default_case->right = head;
10625 346 : head->left = default_case;
10626 : }
10627 : }
10628 :
10629 : /* Eliminate dead blocks that may be the result if we've seen
10630 : unreachable case labels for a block. */
10631 2530 : for (body = code; body && body->block; body = body->block)
10632 : {
10633 1831 : if (body->block->ext.block.case_list == NULL)
10634 : {
10635 : /* Cut the unreachable block from the code chain. */
10636 34 : gfc_code *c = body->block;
10637 34 : body->block = c->block;
10638 :
10639 : /* Kill the dead block, but not the blocks below it. */
10640 34 : c->block = NULL;
10641 34 : gfc_free_statements (c);
10642 : }
10643 : }
10644 :
10645 : /* More than two cases is legal but insane for logical selects.
10646 : Issue a warning for it. */
10647 699 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10648 0 : gfc_warning (OPT_Wsurprising,
10649 : "Logical SELECT CASE block at %L has more that two cases",
10650 : &code->loc);
10651 :
10652 : /* Finally, mark the expression as used. */
10653 699 : gfc_value_used_expr (case_expr, VALUE_USED);
10654 : }
10655 :
10656 :
10657 : /* Check if a derived type is extensible. */
10658 :
10659 : bool
10660 24908 : gfc_type_is_extensible (gfc_symbol *sym)
10661 : {
10662 24908 : return !(sym->attr.is_bind_c || sym->attr.sequence
10663 24892 : || (sym->attr.is_class
10664 2226 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10665 : }
10666 :
10667 :
10668 : static void
10669 : resolve_types (gfc_namespace *ns);
10670 :
10671 : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10672 : correct as well as possibly the array-spec. */
10673 :
10674 : static void
10675 13622 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10676 : {
10677 13622 : gfc_expr* target;
10678 :
10679 13622 : gcc_assert (sym->assoc);
10680 13622 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10681 :
10682 13622 : if (sym->assoc->target
10683 8218 : && sym->assoc->target->expr_type == EXPR_FUNCTION
10684 622 : && sym->assoc->target->symtree
10685 622 : && sym->assoc->target->symtree->n.sym
10686 622 : && sym->assoc->target->symtree->n.sym->attr.generic)
10687 : {
10688 33 : if (gfc_resolve_expr (sym->assoc->target))
10689 33 : sym->ts = sym->assoc->target->ts;
10690 : else
10691 : {
10692 0 : gfc_error ("%s could not be resolved to a specific function at %L",
10693 0 : sym->assoc->target->symtree->n.sym->name,
10694 0 : &sym->assoc->target->where);
10695 0 : return;
10696 : }
10697 : }
10698 :
10699 : /* If this is for SELECT TYPE, the target may not yet be set. In that
10700 : case, return. Resolution will be called later manually again when
10701 : this is done. */
10702 13622 : target = sym->assoc->target;
10703 13622 : if (!target)
10704 : return;
10705 8218 : gcc_assert (!sym->assoc->dangling);
10706 :
10707 8218 : if (resolve_target && !gfc_resolve_expr (target))
10708 : return;
10709 :
10710 8213 : if (sym->assoc->ar)
10711 : {
10712 : int dim;
10713 : gfc_array_ref *ar = sym->assoc->ar;
10714 68 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10715 : {
10716 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10717 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10718 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10719 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10720 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10721 : "remapping of associate name %s at %L",
10722 : sym->name, &sym->declared_at);
10723 : }
10724 : }
10725 :
10726 : /* For variable targets, we get some attributes from the target. */
10727 8213 : if (target->expr_type == EXPR_VARIABLE
10728 1176 : || (target->expr_type == EXPR_OP
10729 305 : && target->value.op.op == INTRINSIC_PARENTHESES
10730 74 : && target->value.op.op1->expr_type == EXPR_VARIABLE))
10731 : {
10732 7098 : gfc_symbol *tsym, *dsym;
10733 :
10734 7098 : tsym = target->expr_type == EXPR_VARIABLE ? target->symtree->n.sym :
10735 61 : target->value.op.op1->symtree->n.sym;
10736 :
10737 7098 : if (gfc_expr_attr (target).proc_pointer)
10738 : {
10739 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10740 : tsym->name, &target->where);
10741 0 : return;
10742 : }
10743 :
10744 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10745 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10746 7099 : && dsym->attr.flavor == FL_DERIVED)
10747 : {
10748 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10749 : tsym->name, &target->where);
10750 1 : return;
10751 : }
10752 :
10753 7097 : if (tsym->attr.flavor == FL_PROCEDURE)
10754 : {
10755 73 : bool is_error = true;
10756 73 : if (tsym->attr.function && tsym->result == tsym)
10757 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10758 137 : if (tsym == ns->proc_name)
10759 : {
10760 : is_error = false;
10761 : break;
10762 : }
10763 64 : if (is_error)
10764 : {
10765 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10766 : tsym->name, &target->where);
10767 13 : return;
10768 : }
10769 : }
10770 :
10771 7084 : if (target->expr_type == EXPR_VARIABLE)
10772 : {
10773 7025 : sym->attr.asynchronous = tsym->attr.asynchronous;
10774 7025 : sym->attr.volatile_ = tsym->attr.volatile_;
10775 :
10776 14050 : sym->attr.target = tsym->attr.target
10777 7025 : || gfc_expr_attr (target).pointer;
10778 7025 : if (is_subref_array (target))
10779 442 : sym->attr.subref_array_pointer = 1;
10780 : }
10781 : }
10782 1115 : else if (target->ts.type == BT_PROCEDURE)
10783 : {
10784 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10785 : &target->where);
10786 0 : return;
10787 : }
10788 :
10789 : /* The elements of a pointer function result may be spaced by more than
10790 : the element size. */
10791 8199 : if (target->expr_type == EXPR_FUNCTION
10792 569 : && target->rank > 0
10793 8768 : && gfc_expr_attr (target).pointer)
10794 37 : sym->attr.subref_array_pointer = 1;
10795 :
10796 8199 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10797 : {
10798 : /* By now, the type of the target has been fixed up. */
10799 314 : symbol_attribute attr;
10800 :
10801 314 : if (sym->ts.type == BT_DERIVED
10802 181 : && target->ts.type == BT_CLASS
10803 31 : && !UNLIMITED_POLY (target))
10804 : {
10805 : /* Inferred to be derived type but the target has type class. */
10806 31 : sym->ts = CLASS_DATA (target)->ts;
10807 31 : if (!sym->as)
10808 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10809 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10810 31 : sym->attr.dimension = target->rank ? 1 : 0;
10811 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10812 : target->corank);
10813 31 : sym->as = NULL;
10814 : }
10815 283 : else if (target->ts.type == BT_DERIVED
10816 150 : && target->symtree && target->symtree->n.sym
10817 126 : && target->symtree->n.sym->ts.type == BT_CLASS
10818 0 : && IS_INFERRED_TYPE (target)
10819 0 : && target->ref && target->ref->next
10820 0 : && target->ref->next->type == REF_ARRAY
10821 0 : && !target->ref->next->next)
10822 : {
10823 : /* A inferred type selector whose symbol has been determined to be
10824 : a class array but which only has an array reference. Change the
10825 : associate name and the selector to class type. */
10826 0 : sym->ts = target->ts;
10827 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10828 0 : sym->attr.dimension = target->rank ? 1 : 0;
10829 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10830 : target->corank);
10831 0 : sym->as = NULL;
10832 0 : target->ts = sym->ts;
10833 : }
10834 283 : else if ((target->ts.type == BT_DERIVED)
10835 133 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10836 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10837 : /* Confirmed to be either a derived type or misidentified to be a
10838 : scalar class object, when the selector is a class array. */
10839 156 : sym->ts = target->ts;
10840 127 : else if (sym->assoc->inferred_type
10841 120 : && (sym->ts.type == BT_COMPLEX
10842 78 : || sym->ts.type == BT_CHARACTER)
10843 66 : && target->ts.type == sym->ts.type
10844 66 : && sym->ts.kind != target->ts.kind)
10845 : /* The inferred type was set from a %re, %im or %len inquiry on
10846 : the associate name with the default kind, before the target's
10847 : actual type was known. Now that the target has been resolved,
10848 : update the kind to match. */
10849 6 : sym->ts = target->ts;
10850 : }
10851 :
10852 :
10853 8199 : if (target->expr_type == EXPR_NULL)
10854 : {
10855 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10856 1 : return;
10857 : }
10858 8198 : else if (target->ts.type == BT_UNKNOWN)
10859 : {
10860 2 : gfc_error ("Selector at %L has no type", &target->where);
10861 2 : return;
10862 : }
10863 :
10864 : /* Get type if this was not already set. Note that it can be
10865 : some other type than the target in case this is a SELECT TYPE
10866 : selector! So we must not update when the type is already there. */
10867 8196 : if (sym->ts.type == BT_UNKNOWN)
10868 265 : sym->ts = target->ts;
10869 :
10870 8196 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10871 :
10872 : /* See if this is a valid association-to-variable. */
10873 16392 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10874 7025 : && !gfc_has_vector_subscript (target))
10875 8223 : || gfc_is_ptr_fcn (target));
10876 :
10877 : /* A type parameter inquiry is not a variable. */
10878 8196 : if (sym->assoc->variable && target->expr_type == EXPR_VARIABLE)
10879 15569 : for (gfc_ref *ref = target->ref; ref; ref = ref->next)
10880 8595 : if (ref->type == REF_INQUIRY
10881 24 : && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
10882 : {
10883 24 : sym->assoc->variable = false;
10884 24 : break;
10885 : }
10886 :
10887 : /* Finally resolve if this is an array or not. */
10888 8196 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10889 237 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10890 : {
10891 142 : gfc_expression_rank (target);
10892 142 : if (target->ts.type == BT_DERIVED
10893 95 : && !sym->as
10894 95 : && target->symtree->n.sym->as)
10895 : {
10896 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10897 0 : sym->attr.dimension = 1;
10898 : }
10899 142 : else if (target->ts.type == BT_CLASS
10900 47 : && CLASS_DATA (target)->as)
10901 : {
10902 0 : target->rank = CLASS_DATA (target)->as->rank;
10903 0 : target->corank = CLASS_DATA (target)->as->corank;
10904 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10905 : {
10906 0 : sym->ts = target->ts;
10907 0 : sym->attr.dimension = 0;
10908 : }
10909 : }
10910 : }
10911 :
10912 :
10913 8196 : if (sym->attr.dimension && target->rank == 0)
10914 : {
10915 : /* primary.cc makes the assumption that a reference to an associate
10916 : name followed by a left parenthesis is an array reference. */
10917 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10918 : {
10919 12 : gfc_expression_rank (sym->assoc->target);
10920 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10921 12 : if (!sym->attr.dimension && sym->as)
10922 0 : sym->as = NULL;
10923 : }
10924 :
10925 17 : if (sym->attr.dimension && target->rank == 0)
10926 : {
10927 5 : if (sym->ts.type != BT_CHARACTER)
10928 5 : gfc_error ("Associate-name %qs at %L is used as array",
10929 : sym->name, &sym->declared_at);
10930 5 : sym->attr.dimension = 0;
10931 5 : return;
10932 : }
10933 : }
10934 :
10935 : /* We cannot deal with class selectors that need temporaries. */
10936 8191 : if (target->ts.type == BT_CLASS
10937 8191 : && gfc_ref_needs_temporary_p (target->ref))
10938 : {
10939 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10940 : "yet implemented", &target->where);
10941 1 : return;
10942 : }
10943 :
10944 8190 : if (target->ts.type == BT_CLASS)
10945 3004 : gfc_fix_class_refs (target);
10946 :
10947 8190 : if ((target->rank > 0 || target->corank > 0)
10948 2939 : && !sym->attr.select_rank_temporary)
10949 : {
10950 2939 : gfc_array_spec *as;
10951 : /* The rank may be incorrectly guessed at parsing, therefore make sure
10952 : it is corrected now. */
10953 2939 : if (sym->ts.type != BT_CLASS
10954 2300 : && (!sym->as || sym->as->corank != target->corank))
10955 : {
10956 175 : if (!sym->as)
10957 168 : sym->as = gfc_get_array_spec ();
10958 175 : as = sym->as;
10959 175 : as->rank = target->rank;
10960 175 : as->type = AS_DEFERRED;
10961 175 : as->corank = target->corank;
10962 175 : sym->attr.dimension = 1;
10963 175 : if (as->corank != 0)
10964 7 : sym->attr.codimension = 1;
10965 : }
10966 2764 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10967 638 : && (!CLASS_DATA (sym)->as
10968 638 : || CLASS_DATA (sym)->as->corank != target->corank))
10969 : {
10970 0 : if (!CLASS_DATA (sym)->as)
10971 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10972 0 : as = CLASS_DATA (sym)->as;
10973 0 : as->rank = target->rank;
10974 0 : as->type = AS_DEFERRED;
10975 0 : as->corank = target->corank;
10976 0 : CLASS_DATA (sym)->attr.dimension = 1;
10977 0 : if (as->corank != 0)
10978 0 : CLASS_DATA (sym)->attr.codimension = 1;
10979 : }
10980 : }
10981 5251 : else if (!sym->attr.select_rank_temporary)
10982 : {
10983 : /* target's rank is 0, but the type of the sym is still array valued,
10984 : which has to be corrected. */
10985 3826 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10986 772 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10987 : {
10988 24 : gfc_array_spec *as;
10989 24 : symbol_attribute attr;
10990 : /* The associated variable's type is still the array type
10991 : correct this now. */
10992 24 : gfc_typespec *ts = &target->ts;
10993 24 : gfc_ref *ref;
10994 : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10995 : */
10996 24 : bool internal_ref = true;
10997 :
10998 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10999 : {
11000 48 : switch (ref->type)
11001 : {
11002 24 : case REF_COMPONENT:
11003 24 : ts = &ref->u.c.component->ts;
11004 24 : internal_ref
11005 24 : = target->ref == ref && ref->next
11006 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
11007 : break;
11008 24 : case REF_ARRAY:
11009 24 : if (ts->type == BT_CLASS)
11010 0 : ts = &ts->u.derived->components->ts;
11011 24 : if (internal_ref && ref->u.ar.codimen > 0)
11012 0 : for (int i = ref->u.ar.dimen;
11013 : internal_ref
11014 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
11015 : ++i)
11016 0 : internal_ref
11017 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
11018 : break;
11019 : default:
11020 : break;
11021 : }
11022 : }
11023 : /* Only rewrite the type of this symbol, when the refs are not the
11024 : internal ones for class and co-array this-image. */
11025 24 : if (!internal_ref)
11026 : {
11027 : /* Create a scalar instance of the current class type. Because
11028 : the rank of a class array goes into its name, the type has to
11029 : be rebuilt. The alternative of (re-)setting just the
11030 : attributes and as in the current type, destroys the type also
11031 : in other places. */
11032 0 : as = NULL;
11033 0 : sym->ts = *ts;
11034 0 : sym->ts.type = BT_CLASS;
11035 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
11036 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
11037 0 : sym->as = NULL;
11038 : }
11039 : }
11040 : }
11041 :
11042 : /* Mark this as an associate variable. */
11043 8190 : sym->attr.associate_var = 1;
11044 :
11045 : /* Fix up the type-spec for CHARACTER types. */
11046 8190 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
11047 : {
11048 563 : gfc_ref *ref;
11049 853 : for (ref = target->ref; ref; ref = ref->next)
11050 316 : if (ref->type == REF_SUBSTRING
11051 74 : && (ref->u.ss.start == NULL
11052 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
11053 74 : || ref->u.ss.end == NULL
11054 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
11055 : break;
11056 :
11057 563 : if (!sym->ts.u.cl)
11058 182 : sym->ts.u.cl = target->ts.u.cl;
11059 :
11060 563 : if (sym->ts.deferred
11061 231 : && sym->ts.u.cl == target->ts.u.cl)
11062 : {
11063 116 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
11064 116 : sym->ts.deferred = 1;
11065 : }
11066 :
11067 563 : if (!sym->ts.u.cl->length
11068 357 : && !sym->ts.deferred
11069 126 : && target->expr_type == EXPR_CONSTANT)
11070 : {
11071 30 : sym->ts.u.cl->length =
11072 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
11073 30 : target->value.character.length);
11074 : }
11075 533 : else if (((!sym->ts.u.cl->length
11076 206 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11077 333 : && target->expr_type != EXPR_VARIABLE)
11078 403 : || ref)
11079 : {
11080 156 : if (!sym->ts.deferred)
11081 : {
11082 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
11083 45 : sym->ts.deferred = 1;
11084 : }
11085 :
11086 : /* This is reset in trans-stmt.cc after the assignment
11087 : of the target expression to the associate name. */
11088 156 : if (ref && sym->as)
11089 26 : sym->attr.pointer = 1;
11090 : else
11091 130 : sym->attr.allocatable = 1;
11092 : }
11093 : }
11094 :
11095 8190 : if (sym->ts.type == BT_CLASS
11096 1556 : && IS_INFERRED_TYPE (target)
11097 13 : && target->ts.type == BT_DERIVED
11098 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
11099 0 : && target->ref && target->ref->next && !target->ref->next->next
11100 0 : && target->ref->next->type == REF_ARRAY)
11101 0 : target->ts = target->symtree->n.sym->ts;
11102 :
11103 : /* If the target is a good class object, so is the associate variable. */
11104 8190 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
11105 1351 : sym->attr.class_ok = 1;
11106 :
11107 : /* If the target is a contiguous pointer, so is the associate variable. */
11108 8190 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
11109 3 : sym->attr.contiguous = 1;
11110 : }
11111 :
11112 :
11113 : /* Ensure that SELECT TYPE expressions have the correct rank and a full
11114 : array reference, where necessary. The symbols are artificial and so
11115 : the dimension attribute and arrayspec can also be set. In addition,
11116 : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
11117 : This is corrected here as well.*/
11118 :
11119 : static void
11120 1833 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
11121 : gfc_ref *ref)
11122 : {
11123 1833 : gfc_ref *nref = (*expr1)->ref;
11124 1833 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
11125 1833 : gfc_symbol *sym2;
11126 1833 : gfc_expr *selector = gfc_copy_expr (expr2);
11127 :
11128 1833 : (*expr1)->rank = rank;
11129 1833 : (*expr1)->corank = corank;
11130 1833 : if (selector)
11131 : {
11132 372 : gfc_resolve_expr (selector);
11133 372 : if (selector->expr_type == EXPR_OP
11134 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
11135 2 : sym2 = selector->value.op.op1->symtree->n.sym;
11136 370 : else if (selector->expr_type == EXPR_VARIABLE
11137 13 : || selector->expr_type == EXPR_FUNCTION)
11138 370 : sym2 = selector->symtree->n.sym;
11139 : else
11140 0 : gcc_unreachable ();
11141 : }
11142 : else
11143 : sym2 = NULL;
11144 :
11145 1833 : if (sym1->ts.type == BT_CLASS)
11146 : {
11147 1833 : if ((*expr1)->ts.type != BT_CLASS)
11148 19 : (*expr1)->ts = sym1->ts;
11149 :
11150 1833 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
11151 1833 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
11152 1833 : if (CLASS_DATA (sym1)->as == NULL && sym2)
11153 1 : CLASS_DATA (sym1)->as
11154 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
11155 : }
11156 : else
11157 : {
11158 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
11159 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
11160 0 : if (sym1->as == NULL && sym2)
11161 0 : sym1->as = gfc_copy_array_spec (sym2->as);
11162 : }
11163 :
11164 3288 : for (; nref; nref = nref->next)
11165 2916 : if (nref->next == NULL)
11166 : break;
11167 :
11168 1833 : if (ref && nref && nref->type != REF_ARRAY)
11169 6 : nref->next = gfc_copy_ref (ref);
11170 1827 : else if (ref && !nref)
11171 357 : (*expr1)->ref = gfc_copy_ref (ref);
11172 1470 : else if (ref && nref->u.ar.codimen != corank)
11173 : {
11174 976 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
11175 915 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
11176 61 : nref->u.ar.codimen = corank;
11177 : }
11178 1833 : }
11179 :
11180 :
11181 : static gfc_expr *
11182 7150 : build_loc_call (gfc_expr *sym_expr)
11183 : {
11184 7150 : gfc_expr *loc_call;
11185 7150 : loc_call = gfc_get_expr ();
11186 7150 : loc_call->expr_type = EXPR_FUNCTION;
11187 7150 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
11188 7150 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
11189 7150 : loc_call->symtree->n.sym->attr.intrinsic = 1;
11190 7150 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
11191 7150 : gfc_commit_symbol (loc_call->symtree->n.sym);
11192 7150 : loc_call->ts.type = BT_INTEGER;
11193 7150 : loc_call->ts.kind = gfc_index_integer_kind;
11194 7150 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
11195 7150 : loc_call->value.function.actual = gfc_get_actual_arglist ();
11196 7150 : loc_call->value.function.actual->expr = sym_expr;
11197 7150 : loc_call->where = sym_expr->where;
11198 7150 : return loc_call;
11199 : }
11200 :
11201 : /* Resolve a SELECT TYPE statement. */
11202 :
11203 : static void
11204 3219 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
11205 : {
11206 3219 : gfc_symbol *selector_type;
11207 3219 : gfc_code *body, *new_st, *if_st, *tail;
11208 3219 : gfc_code *class_is = NULL, *default_case = NULL;
11209 3219 : gfc_case *c;
11210 3219 : gfc_symtree *st;
11211 3219 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
11212 3219 : gfc_namespace *ns;
11213 3219 : int error = 0;
11214 3219 : int rank = 0, corank = 0;
11215 3219 : gfc_ref* ref = NULL;
11216 3219 : gfc_expr *selector_expr = NULL;
11217 3219 : gfc_code *old_code = code;
11218 :
11219 3219 : ns = code->ext.block.ns;
11220 3219 : if (code->expr2)
11221 : {
11222 : /* Set this, or coarray checks in resolve will fail. */
11223 742 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
11224 : }
11225 3219 : gfc_resolve (ns);
11226 :
11227 : /* Check for F03:C813. */
11228 3219 : if (code->expr1->ts.type != BT_CLASS
11229 42 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
11230 : {
11231 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
11232 : "at %L", &code->loc);
11233 42 : return;
11234 : }
11235 :
11236 : /* Prevent segfault, when class type is not initialized due to previous
11237 : error. */
11238 3206 : if (!code->expr1->symtree->n.sym->attr.class_ok
11239 3204 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
11240 : return;
11241 :
11242 3199 : if (code->expr2)
11243 : {
11244 733 : gfc_ref *ref2 = NULL;
11245 1682 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
11246 949 : if (ref->type == REF_COMPONENT
11247 483 : && ref->u.c.component->ts.type == BT_CLASS)
11248 949 : ref2 = ref;
11249 :
11250 733 : if (ref2)
11251 : {
11252 389 : if (code->expr1->symtree->n.sym->attr.untyped)
11253 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
11254 389 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
11255 : }
11256 : else
11257 : {
11258 344 : if (code->expr1->symtree->n.sym->attr.untyped)
11259 34 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
11260 : /* Sometimes the selector expression is given the typespec of the
11261 : '_data' field, which is logical enough but inappropriate here. */
11262 344 : if (code->expr2->ts.type == BT_DERIVED
11263 73 : && code->expr2->symtree
11264 73 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
11265 73 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
11266 344 : selector_type = CLASS_DATA (code->expr2)
11267 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
11268 : }
11269 :
11270 733 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
11271 : {
11272 352 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
11273 352 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
11274 352 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
11275 : }
11276 :
11277 : /* F2008: C803 The selector expression must not be coindexed. */
11278 733 : if (gfc_is_coindexed (code->expr2))
11279 : {
11280 4 : gfc_error ("Selector at %L must not be coindexed",
11281 4 : &code->expr2->where);
11282 4 : return;
11283 : }
11284 :
11285 : }
11286 : else
11287 : {
11288 2466 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
11289 :
11290 2466 : if (gfc_is_coindexed (code->expr1))
11291 : {
11292 0 : gfc_error ("Selector at %L must not be coindexed",
11293 0 : &code->expr1->where);
11294 0 : return;
11295 : }
11296 : }
11297 :
11298 : /* Loop over TYPE IS / CLASS IS cases. */
11299 8897 : for (body = code->block; body; body = body->block)
11300 : {
11301 5703 : c = body->ext.block.case_list;
11302 :
11303 5703 : if (!error)
11304 : {
11305 : /* Check for repeated cases. */
11306 8818 : for (tail = code->block; tail; tail = tail->block)
11307 : {
11308 8818 : gfc_case *d = tail->ext.block.case_list;
11309 8818 : if (tail == body)
11310 : break;
11311 :
11312 3124 : if (c->ts.type == d->ts.type
11313 540 : && ((c->ts.type == BT_DERIVED
11314 424 : && c->ts.u.derived && d->ts.u.derived
11315 424 : && !strcmp (c->ts.u.derived->name,
11316 : d->ts.u.derived->name))
11317 539 : || c->ts.type == BT_UNKNOWN
11318 539 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11319 55 : && c->ts.kind == d->ts.kind)))
11320 : {
11321 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11322 : &c->where, &d->where);
11323 1 : return;
11324 : }
11325 : }
11326 : }
11327 :
11328 : /* Check F03:C815. */
11329 3622 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11330 2448 : && selector_type
11331 2448 : && !selector_type->attr.unlimited_polymorphic
11332 7791 : && !gfc_type_is_extensible (c->ts.u.derived))
11333 : {
11334 1 : gfc_error ("Derived type %qs at %L must be extensible",
11335 1 : c->ts.u.derived->name, &c->where);
11336 1 : error++;
11337 1 : continue;
11338 : }
11339 :
11340 : /* Check F03:C816. */
11341 5707 : if (c->ts.type != BT_UNKNOWN
11342 3971 : && selector_type && !selector_type->attr.unlimited_polymorphic
11343 7793 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11344 2088 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11345 : {
11346 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11347 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11348 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11349 : else
11350 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11351 : gfc_basic_typename (c->ts.type), &c->where);
11352 6 : error++;
11353 6 : continue;
11354 : }
11355 :
11356 : /* Check F03:C814. */
11357 5695 : if (c->ts.type == BT_CHARACTER
11358 754 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11359 : {
11360 0 : gfc_error ("The type-spec at %L shall specify that each length "
11361 : "type parameter is assumed", &c->where);
11362 0 : error++;
11363 0 : continue;
11364 : }
11365 :
11366 : /* Intercept the DEFAULT case. */
11367 5695 : if (c->ts.type == BT_UNKNOWN)
11368 : {
11369 : /* Check F03:C818. */
11370 1730 : if (default_case)
11371 : {
11372 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11373 : "by a second DEFAULT CASE at %L",
11374 1 : &default_case->ext.block.case_list->where, &c->where);
11375 1 : error++;
11376 1 : continue;
11377 : }
11378 :
11379 : default_case = body;
11380 : }
11381 : }
11382 :
11383 3194 : if (error > 0)
11384 : return;
11385 :
11386 : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11387 : target if present. If there are any EXIT statements referring to the
11388 : SELECT TYPE construct, this is no problem because the gfc_code
11389 : reference stays the same and EXIT is equally possible from the BLOCK
11390 : it is changed to. */
11391 3191 : code->op = EXEC_BLOCK;
11392 3191 : if (code->expr2)
11393 : {
11394 729 : gfc_association_list* assoc;
11395 :
11396 729 : assoc = gfc_get_association_list ();
11397 729 : assoc->st = code->expr1->symtree;
11398 729 : assoc->target = gfc_copy_expr (code->expr2);
11399 729 : assoc->target->where = code->expr2->where;
11400 : /* assoc->variable will be set by resolve_assoc_var. */
11401 :
11402 729 : code->ext.block.assoc = assoc;
11403 729 : code->expr1->symtree->n.sym->assoc = assoc;
11404 :
11405 729 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11406 : }
11407 : else
11408 2462 : code->ext.block.assoc = NULL;
11409 :
11410 : /* Ensure that the selector rank and arrayspec are available to
11411 : correct expressions in which they might be missing. */
11412 3191 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11413 : {
11414 372 : rank = code->expr2->rank;
11415 372 : corank = code->expr2->corank;
11416 668 : for (ref = code->expr2->ref; ref; ref = ref->next)
11417 653 : if (ref->next == NULL)
11418 : break;
11419 372 : if (ref && ref->type == REF_ARRAY)
11420 357 : ref = gfc_copy_ref (ref);
11421 :
11422 : /* Fixup expr1 if necessary. */
11423 372 : if (rank || corank)
11424 372 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11425 : }
11426 2819 : else if (code->expr1->rank || code->expr1->corank)
11427 : {
11428 910 : rank = code->expr1->rank;
11429 910 : corank = code->expr1->corank;
11430 910 : for (ref = code->expr1->ref; ref; ref = ref->next)
11431 910 : if (ref->next == NULL)
11432 : break;
11433 910 : if (ref && ref->type == REF_ARRAY)
11434 910 : ref = gfc_copy_ref (ref);
11435 : }
11436 :
11437 3191 : gfc_expr *orig_expr1 = code->expr1;
11438 :
11439 : /* Add EXEC_SELECT to switch on type. */
11440 3191 : new_st = gfc_get_code (code->op);
11441 3191 : new_st->expr1 = code->expr1;
11442 3191 : new_st->expr2 = code->expr2;
11443 3191 : new_st->block = code->block;
11444 3191 : code->expr1 = code->expr2 = NULL;
11445 3191 : code->block = NULL;
11446 3191 : if (!ns->code)
11447 3191 : ns->code = new_st;
11448 : else
11449 0 : ns->code->next = new_st;
11450 3191 : code = new_st;
11451 3191 : code->op = EXEC_SELECT_TYPE;
11452 :
11453 : /* Use the intrinsic LOC function to generate an integer expression
11454 : for the vtable of the selector. Note that the rank of the selector
11455 : expression has to be set to zero. */
11456 3191 : gfc_add_vptr_component (code->expr1);
11457 3191 : code->expr1->rank = 0;
11458 3191 : code->expr1->corank = 0;
11459 3191 : code->expr1 = build_loc_call (code->expr1);
11460 3191 : selector_expr = code->expr1->value.function.actual->expr;
11461 :
11462 : /* Loop over TYPE IS / CLASS IS cases. */
11463 8878 : for (body = code->block; body; body = body->block)
11464 : {
11465 5687 : gfc_symbol *vtab;
11466 5687 : c = body->ext.block.case_list;
11467 :
11468 : /* Generate an index integer expression for address of the
11469 : TYPE/CLASS vtable and store it in c->low. The hash expression
11470 : is stored in c->high and is used to resolve intrinsic cases. */
11471 5687 : if (c->ts.type != BT_UNKNOWN)
11472 : {
11473 3959 : gfc_expr *e;
11474 3959 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11475 : {
11476 2439 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11477 2439 : gcc_assert (vtab);
11478 2439 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11479 2439 : c->ts.u.derived->hash_value);
11480 : }
11481 : else
11482 : {
11483 1520 : vtab = gfc_find_vtab (&c->ts);
11484 1520 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11485 1520 : e = CLASS_DATA (vtab)->initializer;
11486 1520 : c->high = gfc_copy_expr (e);
11487 1520 : if (c->high->ts.kind != gfc_integer_4_kind)
11488 : {
11489 1 : gfc_typespec ts;
11490 1 : ts.kind = gfc_integer_4_kind;
11491 1 : ts.type = BT_INTEGER;
11492 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11493 : }
11494 : }
11495 :
11496 3959 : e = gfc_lval_expr_from_sym (vtab);
11497 3959 : c->low = build_loc_call (e);
11498 : }
11499 : else
11500 1728 : continue;
11501 :
11502 : /* Associate temporary to selector. This should only be done
11503 : when this case is actually true, so build a new ASSOCIATE
11504 : that does precisely this here (instead of using the
11505 : 'global' one). */
11506 :
11507 : /* First check the derived type import status. */
11508 3959 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11509 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11510 : {
11511 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11512 6 : c->ts.u.derived->name);
11513 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11514 : gfc_current_ns))
11515 6 : error++;
11516 : }
11517 :
11518 3959 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11519 3959 : if (c->ts.type == BT_CLASS)
11520 366 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11521 366 : c->ts.u.derived->name, var_name);
11522 3593 : else if (c->ts.type == BT_DERIVED)
11523 2073 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11524 2073 : c->ts.u.derived->name, var_name);
11525 1520 : else if (c->ts.type == BT_CHARACTER)
11526 : {
11527 754 : HOST_WIDE_INT charlen = 0;
11528 754 : if (c->ts.u.cl && c->ts.u.cl->length
11529 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11530 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11531 754 : snprintf (name, sizeof (name),
11532 : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11533 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11534 : var_name);
11535 : }
11536 : else
11537 766 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11538 : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11539 :
11540 3959 : st = gfc_find_symtree (ns->sym_root, name);
11541 3959 : gcc_assert (st->n.sym->assoc);
11542 3959 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11543 3959 : st->n.sym->assoc->target->where = selector_expr->where;
11544 3959 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11545 : {
11546 3593 : gfc_add_data_component (st->n.sym->assoc->target);
11547 : /* Fixup the target expression if necessary. */
11548 3593 : if (rank || corank)
11549 1461 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11550 : ref);
11551 : }
11552 :
11553 3959 : new_st = gfc_get_code (EXEC_BLOCK);
11554 3959 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11555 3959 : new_st->ext.block.ns->code = body->next;
11556 3959 : body->next = new_st;
11557 :
11558 : /* Chain in the new list only if it is marked as dangling. Otherwise
11559 : there is a CASE label overlap and this is already used. Just ignore,
11560 : the error is diagnosed elsewhere. */
11561 3959 : if (st->n.sym->assoc->dangling)
11562 : {
11563 3958 : new_st->ext.block.assoc = st->n.sym->assoc;
11564 3958 : st->n.sym->assoc->dangling = 0;
11565 : }
11566 :
11567 3959 : resolve_assoc_var (st->n.sym, false);
11568 : }
11569 :
11570 : /* Take out CLASS IS cases for separate treatment. */
11571 : body = code;
11572 8878 : while (body && body->block)
11573 : {
11574 5687 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11575 : {
11576 : /* Add to class_is list. */
11577 366 : if (class_is == NULL)
11578 : {
11579 323 : class_is = body->block;
11580 323 : tail = class_is;
11581 : }
11582 : else
11583 : {
11584 61 : for (tail = class_is; tail->block; tail = tail->block) ;
11585 43 : tail->block = body->block;
11586 43 : tail = tail->block;
11587 : }
11588 : /* Remove from EXEC_SELECT list. */
11589 366 : body->block = body->block->block;
11590 366 : tail->block = NULL;
11591 : }
11592 : else
11593 : body = body->block;
11594 : }
11595 :
11596 3191 : if (class_is)
11597 : {
11598 323 : gfc_symbol *vtab;
11599 :
11600 323 : if (!default_case)
11601 : {
11602 : /* Add a default case to hold the CLASS IS cases. */
11603 321 : for (tail = code; tail->block; tail = tail->block) ;
11604 213 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11605 213 : tail = tail->block;
11606 213 : tail->ext.block.case_list = gfc_get_case ();
11607 213 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11608 213 : tail->next = NULL;
11609 213 : default_case = tail;
11610 : }
11611 :
11612 : /* More than one CLASS IS block? */
11613 323 : if (class_is->block)
11614 : {
11615 43 : gfc_code **c1,*c2;
11616 43 : bool swapped;
11617 : /* Sort CLASS IS blocks by extension level. */
11618 42 : do
11619 : {
11620 43 : swapped = false;
11621 115 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11622 : {
11623 : #define C1_DERIVED (*c1)->ext.block.case_list->ts.u.derived
11624 : #define C2_DERIVED c2->ext.block.case_list->ts.u.derived
11625 73 : c2 = (*c1)->block;
11626 :
11627 : /* F03:C817 (check for doubles). */
11628 73 : if (C1_DERIVED->hash_value == C2_DERIVED->hash_value)
11629 : {
11630 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11631 : "statement at %L",
11632 : &c2->ext.block.case_list->where);
11633 1 : return;
11634 : }
11635 : #undef C1_DERIVED
11636 : #undef C2_DERIVED
11637 72 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11638 72 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11639 : {
11640 : /* Swap. */
11641 24 : (*c1)->block = c2->block;
11642 24 : c2->block = *c1;
11643 24 : *c1 = c2;
11644 24 : swapped = true;
11645 : }
11646 : }
11647 : }
11648 : while (swapped);
11649 : }
11650 :
11651 : /* Generate IF chain. */
11652 322 : if_st = gfc_get_code (EXEC_IF);
11653 322 : new_st = if_st;
11654 686 : for (body = class_is; body; body = body->block)
11655 : {
11656 364 : new_st->block = gfc_get_code (EXEC_IF);
11657 364 : new_st = new_st->block;
11658 : /* Set up IF condition: Call _gfortran_is_extension_of. */
11659 364 : new_st->expr1 = gfc_get_expr ();
11660 364 : new_st->expr1->expr_type = EXPR_FUNCTION;
11661 364 : new_st->expr1->ts.type = BT_LOGICAL;
11662 364 : new_st->expr1->ts.kind = 4;
11663 364 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11664 364 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11665 364 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11666 : /* Set up arguments. */
11667 364 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11668 364 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11669 364 : new_st->expr1->value.function.actual->expr->where = code->loc;
11670 364 : new_st->expr1->where = code->loc;
11671 364 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11672 364 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11673 364 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11674 364 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11675 364 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11676 364 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11677 : /* Set up types in formal arg list. */
11678 364 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11679 364 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11680 364 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11681 364 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11682 :
11683 364 : new_st->next = body->next;
11684 : }
11685 322 : if (default_case->next)
11686 : {
11687 110 : new_st->block = gfc_get_code (EXEC_IF);
11688 110 : new_st = new_st->block;
11689 110 : new_st->next = default_case->next;
11690 : }
11691 :
11692 : /* Replace CLASS DEFAULT code by the IF chain. */
11693 322 : default_case->next = if_st;
11694 : }
11695 :
11696 : /* Resolve the internal code. This cannot be done earlier because
11697 : it requires that the sym->assoc of selectors is set already. */
11698 3190 : gfc_current_ns = ns;
11699 3190 : gfc_resolve_blocks (code->block, gfc_current_ns);
11700 3190 : gfc_current_ns = old_ns;
11701 :
11702 3190 : free (ref);
11703 : }
11704 :
11705 :
11706 : /* Resolve a SELECT RANK statement. */
11707 :
11708 : static void
11709 1048 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11710 : {
11711 1048 : gfc_namespace *ns;
11712 1048 : gfc_code *body, *new_st, *tail;
11713 1048 : gfc_case *c;
11714 1048 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11715 1048 : char name[2 * GFC_MAX_SYMBOL_LEN];
11716 1048 : gfc_symtree *st;
11717 1048 : gfc_expr *selector_expr = NULL;
11718 1048 : int case_value;
11719 1048 : HOST_WIDE_INT charlen = 0;
11720 :
11721 1048 : ns = code->ext.block.ns;
11722 1048 : gfc_resolve (ns);
11723 :
11724 1048 : code->op = EXEC_BLOCK;
11725 1048 : if (code->expr2)
11726 : {
11727 42 : gfc_association_list* assoc;
11728 :
11729 42 : assoc = gfc_get_association_list ();
11730 42 : assoc->st = code->expr1->symtree;
11731 42 : assoc->target = gfc_copy_expr (code->expr2);
11732 42 : assoc->target->where = code->expr2->where;
11733 : /* assoc->variable will be set by resolve_assoc_var. */
11734 :
11735 42 : code->ext.block.assoc = assoc;
11736 42 : code->expr1->symtree->n.sym->assoc = assoc;
11737 :
11738 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11739 : }
11740 : else
11741 1006 : code->ext.block.assoc = NULL;
11742 :
11743 : /* Loop over RANK cases. Note that returning on the errors causes a
11744 : cascade of further errors because the case blocks do not compile
11745 : correctly. */
11746 3416 : for (body = code->block; body; body = body->block)
11747 : {
11748 2368 : c = body->ext.block.case_list;
11749 2368 : if (c->low)
11750 1425 : case_value = (int) mpz_get_si (c->low->value.integer);
11751 : else
11752 : case_value = -2;
11753 :
11754 : /* Check for repeated cases. */
11755 5950 : for (tail = code->block; tail; tail = tail->block)
11756 : {
11757 5950 : gfc_case *d = tail->ext.block.case_list;
11758 5950 : int case_value2;
11759 :
11760 5950 : if (tail == body)
11761 : break;
11762 :
11763 : /* Check F2018: C1153. */
11764 3582 : if (!c->low && !d->low)
11765 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11766 : &c->where, &d->where);
11767 :
11768 3582 : if (!c->low || !d->low)
11769 1289 : continue;
11770 :
11771 : /* Check F2018: C1153. */
11772 2293 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11773 2293 : if ((case_value == case_value2) && case_value == -1)
11774 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11775 : &c->where, &d->where);
11776 2292 : else if (case_value == case_value2)
11777 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11778 : case_value, &c->where, &d->where);
11779 : }
11780 :
11781 2368 : if (!c->low)
11782 943 : continue;
11783 :
11784 : /* Check F2018: C1155. */
11785 1425 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11786 1425 : || gfc_expr_attr (code->expr1).pointer))
11787 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11788 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11789 : }
11790 :
11791 : /* Add EXEC_SELECT to switch on rank. */
11792 1048 : new_st = gfc_get_code (code->op);
11793 1048 : new_st->expr1 = code->expr1;
11794 1048 : new_st->expr2 = code->expr2;
11795 1048 : new_st->block = code->block;
11796 1048 : code->expr1 = code->expr2 = NULL;
11797 1048 : code->block = NULL;
11798 1048 : if (!ns->code)
11799 1048 : ns->code = new_st;
11800 : else
11801 0 : ns->code->next = new_st;
11802 1048 : code = new_st;
11803 1048 : code->op = EXEC_SELECT_RANK;
11804 :
11805 1048 : selector_expr = code->expr1;
11806 :
11807 : /* Loop over SELECT RANK cases. */
11808 3416 : for (body = code->block; body; body = body->block)
11809 : {
11810 2368 : c = body->ext.block.case_list;
11811 2368 : int case_value;
11812 :
11813 : /* Pass on the default case. */
11814 2368 : if (c->low == NULL)
11815 943 : continue;
11816 :
11817 : /* Associate temporary to selector. This should only be done
11818 : when this case is actually true, so build a new ASSOCIATE
11819 : that does precisely this here (instead of using the
11820 : 'global' one). */
11821 1425 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11822 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11823 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11824 :
11825 1425 : if (c->ts.type == BT_CLASS)
11826 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11827 1280 : else if (c->ts.type == BT_DERIVED)
11828 116 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11829 1164 : else if (c->ts.type != BT_CHARACTER)
11830 605 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11831 : else
11832 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11833 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11834 :
11835 1425 : case_value = (int) mpz_get_si (c->low->value.integer);
11836 1425 : if (case_value >= 0)
11837 1392 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11838 : else
11839 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11840 :
11841 1425 : st = gfc_find_symtree (ns->sym_root, name);
11842 1425 : gcc_assert (st->n.sym->assoc);
11843 :
11844 1425 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11845 1425 : st->n.sym->assoc->target->where = selector_expr->where;
11846 :
11847 1425 : new_st = gfc_get_code (EXEC_BLOCK);
11848 1425 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11849 1425 : new_st->ext.block.ns->code = body->next;
11850 1425 : body->next = new_st;
11851 :
11852 : /* Chain in the new list only if it is marked as dangling. Otherwise
11853 : there is a CASE label overlap and this is already used. Just ignore,
11854 : the error is diagnosed elsewhere. */
11855 1425 : if (st->n.sym->assoc->dangling)
11856 : {
11857 1423 : new_st->ext.block.assoc = st->n.sym->assoc;
11858 1423 : st->n.sym->assoc->dangling = 0;
11859 : }
11860 :
11861 1425 : resolve_assoc_var (st->n.sym, false);
11862 : }
11863 :
11864 1048 : gfc_current_ns = ns;
11865 1048 : gfc_resolve_blocks (code->block, gfc_current_ns);
11866 1048 : gfc_current_ns = old_ns;
11867 1048 : }
11868 :
11869 :
11870 : /* Resolve a transfer statement. This is making sure that:
11871 : -- a derived type being transferred has only non-pointer components
11872 : -- a derived type being transferred doesn't have private components, unless
11873 : it's being transferred from the module where the type was defined
11874 : -- we're not trying to transfer a whole assumed size array. */
11875 :
11876 : static void
11877 47876 : resolve_transfer (gfc_code *code)
11878 : {
11879 47876 : gfc_symbol *sym, *derived;
11880 47876 : gfc_ref *ref;
11881 47876 : gfc_expr *exp;
11882 47876 : bool write = false;
11883 47876 : bool formatted = false;
11884 47876 : gfc_dt *dt = code->ext.dt;
11885 47876 : gfc_symbol *dtio_sub = NULL;
11886 :
11887 47876 : exp = code->expr1;
11888 :
11889 95758 : while (exp != NULL && exp->expr_type == EXPR_OP
11890 48810 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11891 6 : exp = exp->value.op.op1;
11892 :
11893 47876 : if (exp && exp->expr_type == EXPR_NULL
11894 2 : && code->ext.dt)
11895 : {
11896 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11897 : &exp->where);
11898 2 : return;
11899 : }
11900 :
11901 47874 : if (dt && (dt->dt_io_kind->value.iokind == M_WRITE
11902 47722 : || dt->dt_io_kind->value.iokind == M_PRINT))
11903 40116 : gfc_value_used_expr (exp, VALUE_USED);
11904 :
11905 47874 : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11906 : && exp->expr_type != EXPR_FUNCTION
11907 : && exp->expr_type != EXPR_ARRAY
11908 : && exp->expr_type != EXPR_STRUCTURE))
11909 : return;
11910 :
11911 26540 : if (dt && dt->dt_io_kind->value.iokind == M_READ)
11912 : {
11913 : /* If we are reading, the variable will be changed. Note that
11914 : code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE
11915 : statement -- but in this case, we are not reading, either. */
11916 7606 : if (!gfc_check_vardef_context (exp, false, false, false,
11917 7606 : _("item in READ")))
11918 : return;
11919 :
11920 7602 : gfc_expr_set_at (exp, &exp->where, VALUE_READ);
11921 : }
11922 :
11923 26536 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11924 26536 : || exp->expr_type == EXPR_FUNCTION
11925 22125 : || exp->expr_type == EXPR_ARRAY
11926 48661 : ? &exp->ts : &exp->symtree->n.sym->ts;
11927 :
11928 : /* Go to actual component transferred. */
11929 34447 : for (ref = exp->ref; ref; ref = ref->next)
11930 7911 : if (ref->type == REF_COMPONENT)
11931 2229 : ts = &ref->u.c.component->ts;
11932 :
11933 26536 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11934 26388 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11935 : {
11936 720 : derived = ts->u.derived;
11937 :
11938 : /* Determine when to use the formatted DTIO procedure. */
11939 720 : if (dt && (dt->format_expr || dt->format_label))
11940 645 : formatted = true;
11941 :
11942 720 : write = dt->dt_io_kind->value.iokind == M_WRITE
11943 720 : || dt->dt_io_kind->value.iokind == M_PRINT;
11944 720 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11945 :
11946 720 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11947 : {
11948 450 : dt->udtio = exp;
11949 450 : sym = exp->symtree->n.sym->ns->proc_name;
11950 : /* Check to see if this is a nested DTIO call, with the
11951 : dummy as the io-list object. */
11952 450 : if (sym && sym == dtio_sub && sym->formal
11953 30 : && sym->formal->sym == exp->symtree->n.sym
11954 30 : && exp->ref == NULL)
11955 : {
11956 0 : if (!sym->attr.recursive)
11957 : {
11958 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11959 : sym->name, &sym->declared_at);
11960 0 : return;
11961 : }
11962 : }
11963 : }
11964 : }
11965 :
11966 26536 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11967 : {
11968 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11969 : "it is processed by a defined input/output procedure",
11970 : &code->loc);
11971 3 : return;
11972 : }
11973 :
11974 26533 : if (ts->type == BT_DERIVED)
11975 : {
11976 : /* Check that transferred derived type doesn't contain POINTER
11977 : components unless it is processed by a defined input/output
11978 : procedure". */
11979 688 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11980 : {
11981 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11982 : "components unless it is processed by a defined "
11983 : "input/output procedure", &code->loc);
11984 2 : return;
11985 : }
11986 :
11987 : /* F08:C935. */
11988 686 : if (ts->u.derived->attr.proc_pointer_comp)
11989 : {
11990 2 : gfc_error ("Data transfer element at %L cannot have "
11991 : "procedure pointer components", &code->loc);
11992 2 : return;
11993 : }
11994 :
11995 684 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11996 : {
11997 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11998 : "components unless it is processed by a defined "
11999 : "input/output procedure", &code->loc);
12000 6 : return;
12001 : }
12002 :
12003 : /* C_PTR and C_FUNPTR have private components which means they cannot
12004 : be printed. However, if -std=gnu and not -pedantic, allow
12005 : the component to be printed to help debugging. */
12006 678 : if (ts->u.derived->ts.f90_type == BT_VOID)
12007 : {
12008 4 : gfc_error ("Data transfer element at %L "
12009 : "cannot have PRIVATE components", &code->loc);
12010 4 : return;
12011 : }
12012 674 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
12013 : {
12014 4 : gfc_error ("Data transfer element at %L cannot have "
12015 : "PRIVATE components unless it is processed by "
12016 : "a defined input/output procedure", &code->loc);
12017 4 : return;
12018 : }
12019 : }
12020 :
12021 26515 : if (exp->expr_type == EXPR_STRUCTURE)
12022 : return;
12023 :
12024 26470 : if (exp->expr_type == EXPR_ARRAY)
12025 : return;
12026 :
12027 26088 : sym = exp->symtree->n.sym;
12028 :
12029 26088 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
12030 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
12031 : {
12032 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
12033 : "an assumed-size array", &code->loc);
12034 1 : return;
12035 : }
12036 :
12037 : }
12038 :
12039 :
12040 : /*********** Toplevel code resolution subroutines ***********/
12041 :
12042 : /* Find the set of labels that are reachable from this block. We also
12043 : record the last statement in each block. */
12044 :
12045 : static void
12046 704492 : find_reachable_labels (gfc_code *block)
12047 : {
12048 704492 : gfc_code *c;
12049 :
12050 704492 : if (!block)
12051 : return;
12052 :
12053 436203 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
12054 :
12055 : /* Collect labels in this block. We don't keep those corresponding
12056 : to END {IF|SELECT}, these are checked in resolve_branch by going
12057 : up through the code_stack. */
12058 1596776 : for (c = block; c; c = c->next)
12059 : {
12060 1160573 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
12061 3716 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
12062 : }
12063 :
12064 : /* Merge with labels from parent block. */
12065 436203 : if (cs_base->prev)
12066 : {
12067 357474 : gcc_assert (cs_base->prev->reachable_labels);
12068 357474 : bitmap_ior_into (cs_base->reachable_labels,
12069 : cs_base->prev->reachable_labels);
12070 : }
12071 : }
12072 :
12073 : static void
12074 197 : resolve_lock_unlock_event (gfc_code *code)
12075 : {
12076 197 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
12077 197 : && (code->expr1->ts.type != BT_DERIVED
12078 137 : || code->expr1->expr_type != EXPR_VARIABLE
12079 137 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12080 136 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
12081 136 : || code->expr1->rank != 0
12082 181 : || (!gfc_is_coarray (code->expr1) &&
12083 46 : !gfc_is_coindexed (code->expr1))))
12084 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
12085 4 : &code->expr1->where);
12086 193 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
12087 58 : && (code->expr1->ts.type != BT_DERIVED
12088 58 : || code->expr1->expr_type != EXPR_VARIABLE
12089 58 : || code->expr1->ts.u.derived->from_intmod
12090 : != INTMOD_ISO_FORTRAN_ENV
12091 58 : || code->expr1->ts.u.derived->intmod_sym_id
12092 : != ISOFORTRAN_EVENT_TYPE
12093 58 : || code->expr1->rank != 0))
12094 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
12095 : &code->expr1->where);
12096 34 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
12097 209 : && !gfc_is_coindexed (code->expr1))
12098 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
12099 0 : &code->expr1->where);
12100 193 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
12101 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
12102 0 : "coindexed", &code->expr1->where);
12103 :
12104 : /* Check STAT. */
12105 197 : if (code->expr2
12106 54 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
12107 54 : || code->expr2->expr_type != EXPR_VARIABLE))
12108 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12109 : &code->expr2->where);
12110 :
12111 197 : if (code->expr2
12112 251 : && !gfc_check_vardef_context (code->expr2, false, false, false,
12113 54 : _("STAT variable")))
12114 : return;
12115 :
12116 : /* Check ERRMSG. */
12117 197 : if (code->expr3
12118 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
12119 2 : || code->expr3->expr_type != EXPR_VARIABLE))
12120 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12121 : &code->expr3->where);
12122 :
12123 197 : if (code->expr3
12124 199 : && !gfc_check_vardef_context (code->expr3, false, false, false,
12125 2 : _("ERRMSG variable")))
12126 : return;
12127 :
12128 : /* Check for LOCK the ACQUIRED_LOCK. */
12129 197 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12130 22 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
12131 22 : || code->expr4->expr_type != EXPR_VARIABLE))
12132 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
12133 : "variable", &code->expr4->where);
12134 :
12135 173 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12136 219 : && !gfc_check_vardef_context (code->expr4, false, false, false,
12137 22 : _("ACQUIRED_LOCK variable")))
12138 : return;
12139 :
12140 : /* Check for EVENT WAIT the UNTIL_COUNT. */
12141 197 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
12142 : {
12143 36 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
12144 36 : || code->expr4->rank != 0)
12145 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
12146 0 : "expression", &code->expr4->where);
12147 : }
12148 : }
12149 :
12150 : static void
12151 363 : resolve_team_argument (gfc_expr *team)
12152 : {
12153 363 : gfc_resolve_expr (team);
12154 363 : if (team->rank != 0 || team->ts.type != BT_DERIVED
12155 356 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12156 356 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
12157 : {
12158 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
12159 : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
12160 : &team->where);
12161 : }
12162 363 : }
12163 :
12164 : static void
12165 1720 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
12166 : gfc_expr *e)
12167 : {
12168 1720 : gfc_resolve_expr (e);
12169 1720 : if (e
12170 167 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
12171 152 : || e->expr_type != EXPR_VARIABLE))
12172 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
12173 : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
12174 : exp_kind);
12175 1720 : }
12176 :
12177 : void
12178 860 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
12179 : {
12180 860 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
12181 860 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
12182 : gfc_default_character_kind,
12183 : sync_stat->errmsg);
12184 860 : }
12185 :
12186 : static void
12187 368 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
12188 : gfc_expr *e)
12189 : {
12190 368 : gfc_resolve_expr (e);
12191 368 : if (e
12192 217 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
12193 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
12194 : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
12195 368 : }
12196 :
12197 : static void
12198 184 : resolve_form_team (gfc_code *code)
12199 : {
12200 184 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
12201 : code->expr1);
12202 184 : resolve_team_argument (code->expr2);
12203 184 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
12204 : code->expr3);
12205 184 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12206 184 : }
12207 :
12208 : static void resolve_block_construct (gfc_code *);
12209 :
12210 : static void
12211 131 : resolve_change_team (gfc_code *code)
12212 : {
12213 131 : resolve_team_argument (code->expr1);
12214 131 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
12215 262 : resolve_block_construct (code);
12216 : /* Map the coarray bounds as selected. */
12217 134 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
12218 3 : if (a->ar)
12219 : {
12220 3 : gfc_array_spec *src = a->ar->as, *dst;
12221 3 : if (a->st->n.sym->ts.type == BT_CLASS)
12222 0 : dst = CLASS_DATA (a->st->n.sym)->as;
12223 : else
12224 3 : dst = a->st->n.sym->as;
12225 3 : dst->corank = src->corank;
12226 3 : dst->cotype = src->cotype;
12227 6 : for (int i = 0; i < src->corank; ++i)
12228 : {
12229 3 : dst->lower[dst->rank + i] = src->lower[i];
12230 3 : dst->upper[dst->rank + i] = src->upper[i];
12231 3 : src->lower[i] = src->upper[i] = nullptr;
12232 : }
12233 3 : gfc_free_array_spec (src);
12234 3 : free (a->ar);
12235 3 : a->ar = nullptr;
12236 3 : dst->resolved = false;
12237 3 : gfc_resolve_array_spec (dst, 0);
12238 : }
12239 131 : }
12240 :
12241 : static void
12242 48 : resolve_sync_team (gfc_code *code)
12243 : {
12244 48 : resolve_team_argument (code->expr1);
12245 48 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12246 48 : }
12247 :
12248 : static void
12249 129 : resolve_end_team (gfc_code *code)
12250 : {
12251 129 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12252 129 : }
12253 :
12254 : static void
12255 54 : resolve_critical (gfc_code *code)
12256 : {
12257 54 : gfc_symtree *symtree;
12258 54 : gfc_symbol *lock_type;
12259 54 : char name[GFC_MAX_SYMBOL_LEN];
12260 54 : static int serial = 0;
12261 :
12262 54 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12263 :
12264 54 : if (flag_coarray != GFC_FCOARRAY_LIB)
12265 30 : return;
12266 :
12267 24 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12268 : GFC_PREFIX ("lock_type"));
12269 24 : if (symtree)
12270 12 : lock_type = symtree->n.sym;
12271 : else
12272 : {
12273 12 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
12274 : false) != 0)
12275 0 : gcc_unreachable ();
12276 12 : lock_type = symtree->n.sym;
12277 12 : lock_type->attr.flavor = FL_DERIVED;
12278 12 : lock_type->attr.zero_comp = 1;
12279 12 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
12280 12 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
12281 : }
12282 :
12283 24 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
12284 24 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
12285 0 : gcc_unreachable ();
12286 :
12287 24 : code->resolved_sym = symtree->n.sym;
12288 24 : symtree->n.sym->attr.flavor = FL_VARIABLE;
12289 24 : symtree->n.sym->attr.referenced = 1;
12290 24 : symtree->n.sym->attr.artificial = 1;
12291 24 : symtree->n.sym->attr.codimension = 1;
12292 24 : symtree->n.sym->ts.type = BT_DERIVED;
12293 24 : symtree->n.sym->ts.u.derived = lock_type;
12294 24 : symtree->n.sym->as = gfc_get_array_spec ();
12295 24 : symtree->n.sym->as->corank = 1;
12296 24 : symtree->n.sym->as->type = AS_EXPLICIT;
12297 24 : symtree->n.sym->as->cotype = AS_EXPLICIT;
12298 24 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
12299 : NULL, 1);
12300 24 : gfc_commit_symbols();
12301 : }
12302 :
12303 :
12304 : static void
12305 1435 : resolve_sync (gfc_code *code)
12306 : {
12307 : /* Check imageset. The * case matches expr1 == NULL. */
12308 1435 : if (code->expr1)
12309 : {
12310 107 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
12311 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
12312 : "INTEGER expression", &code->expr1->where);
12313 107 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
12314 48 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
12315 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
12316 : &code->expr1->where);
12317 106 : else if (code->expr1->expr_type == EXPR_ARRAY
12318 106 : && gfc_simplify_expr (code->expr1, 0))
12319 : {
12320 35 : gfc_constructor *cons;
12321 35 : cons = gfc_constructor_first (code->expr1->value.constructor);
12322 120 : for (; cons; cons = gfc_constructor_next (cons))
12323 50 : if (cons->expr->expr_type == EXPR_CONSTANT
12324 50 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
12325 0 : gfc_error ("Imageset argument at %L must between 1 and "
12326 : "num_images()", &cons->expr->where);
12327 : }
12328 : }
12329 :
12330 : /* Check STAT. */
12331 1435 : gfc_resolve_expr (code->expr2);
12332 1435 : if (code->expr2)
12333 : {
12334 161 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12335 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12336 : &code->expr2->where);
12337 : else
12338 160 : gfc_check_vardef_context (code->expr2, false, false, false,
12339 160 : _("STAT variable"));
12340 : }
12341 :
12342 : /* Check ERRMSG. */
12343 1435 : gfc_resolve_expr (code->expr3);
12344 1435 : if (code->expr3)
12345 : {
12346 90 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12347 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12348 : &code->expr3->where);
12349 : else
12350 86 : gfc_check_vardef_context (code->expr3, false, false, false,
12351 86 : _("ERRMSG variable"));
12352 : }
12353 1435 : }
12354 :
12355 :
12356 : /* Given a branch to a label, see if the branch is conforming.
12357 : The code node describes where the branch is located. */
12358 :
12359 : static void
12360 112606 : resolve_branch (gfc_st_label *label, gfc_code *code)
12361 : {
12362 112606 : code_stack *stack;
12363 :
12364 112606 : if (label == NULL)
12365 : return;
12366 :
12367 : /* Step one: is this a valid branching target? */
12368 :
12369 2514 : if (label->defined == ST_LABEL_UNKNOWN)
12370 : {
12371 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12372 : &code->loc);
12373 4 : return;
12374 : }
12375 :
12376 2510 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12377 : {
12378 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12379 : "for the branch statement at %L", &label->where, &code->loc);
12380 4 : return;
12381 : }
12382 :
12383 : /* Step two: make sure this branch is not a branch to itself ;-) */
12384 :
12385 2506 : if (code->here == label)
12386 : {
12387 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12388 : &code->loc);
12389 0 : return;
12390 : }
12391 :
12392 : /* Step three: See if the label is in the same block as the
12393 : branching statement. The hard work has been done by setting up
12394 : the bitmap reachable_labels. */
12395 :
12396 2506 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12397 : {
12398 : /* Check now whether there is a CRITICAL construct; if so, check
12399 : whether the label is still visible outside of the CRITICAL block,
12400 : which is invalid. */
12401 6375 : for (stack = cs_base; stack; stack = stack->prev)
12402 : {
12403 3937 : if (stack->current->op == EXEC_CRITICAL
12404 3937 : && bitmap_bit_p (stack->reachable_labels, label->value))
12405 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12406 : "label at %L", &code->loc, &label->where);
12407 3935 : else if (stack->current->op == EXEC_DO_CONCURRENT
12408 3935 : && bitmap_bit_p (stack->reachable_labels, label->value))
12409 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12410 : "for label at %L", &code->loc, &label->where);
12411 3935 : else if (stack->current->op == EXEC_CHANGE_TEAM
12412 3935 : && bitmap_bit_p (stack->reachable_labels, label->value))
12413 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12414 : "for label at %L", &code->loc, &label->where);
12415 : }
12416 :
12417 : return;
12418 : }
12419 :
12420 : /* Step four: If we haven't found the label in the bitmap, it may
12421 : still be the label of the END of the enclosing block, in which
12422 : case we find it by going up the code_stack. */
12423 :
12424 167 : for (stack = cs_base; stack; stack = stack->prev)
12425 : {
12426 131 : if (stack->current->next && stack->current->next->here == label)
12427 : break;
12428 101 : if (stack->current->op == EXEC_CRITICAL)
12429 : {
12430 : /* Note: A label at END CRITICAL does not leave the CRITICAL
12431 : construct as END CRITICAL is still part of it. */
12432 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12433 : " at %L", &code->loc, &label->where);
12434 2 : return;
12435 : }
12436 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12437 : {
12438 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12439 : "label at %L", &code->loc, &label->where);
12440 0 : return;
12441 : }
12442 : }
12443 :
12444 66 : if (stack)
12445 : {
12446 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12447 : return;
12448 : }
12449 :
12450 : /* The label is not in an enclosing block, so illegal. This was
12451 : allowed in Fortran 66, so we allow it as extension. No
12452 : further checks are necessary in this case. */
12453 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12454 : "as the GOTO statement at %L", &label->where,
12455 : &code->loc);
12456 36 : return;
12457 : }
12458 :
12459 :
12460 : /* Check whether EXPR1 has the same shape as EXPR2. */
12461 :
12462 : static bool
12463 1479 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12464 : {
12465 1479 : mpz_t shape[GFC_MAX_DIMENSIONS];
12466 1479 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12467 1479 : bool result = false;
12468 1479 : int i;
12469 :
12470 : /* Compare the rank. */
12471 1479 : if (expr1->rank != expr2->rank)
12472 : return result;
12473 :
12474 : /* Compare the size of each dimension. */
12475 2835 : for (i=0; i<expr1->rank; i++)
12476 : {
12477 1507 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12478 151 : goto ignore;
12479 :
12480 1356 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12481 0 : goto ignore;
12482 :
12483 1356 : if (mpz_cmp (shape[i], shape2[i]))
12484 0 : goto over;
12485 : }
12486 :
12487 : /* When either of the two expression is an assumed size array, we
12488 : ignore the comparison of dimension sizes. */
12489 1328 : ignore:
12490 : result = true;
12491 :
12492 1479 : over:
12493 1479 : gfc_clear_shape (shape, i);
12494 1479 : gfc_clear_shape (shape2, i);
12495 1479 : return result;
12496 : }
12497 :
12498 :
12499 : /* Check whether a WHERE assignment target or a WHERE mask expression
12500 : has the same shape as the outermost WHERE mask expression. */
12501 :
12502 : static void
12503 515 : resolve_where (gfc_code *code, gfc_expr *mask)
12504 : {
12505 515 : gfc_code *cblock;
12506 515 : gfc_code *cnext;
12507 515 : gfc_expr *e = NULL;
12508 :
12509 515 : cblock = code->block;
12510 :
12511 : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12512 : In case of nested WHERE, only the outermost one is stored. */
12513 515 : if (mask == NULL) /* outermost WHERE */
12514 459 : e = cblock->expr1;
12515 : else /* inner WHERE */
12516 515 : e = mask;
12517 :
12518 1399 : while (cblock)
12519 : {
12520 884 : if (cblock->expr1)
12521 : {
12522 : /* Check if the mask-expr has a consistent shape with the
12523 : outermost WHERE mask-expr. */
12524 720 : if (!resolve_where_shape (cblock->expr1, e))
12525 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12526 0 : &cblock->expr1->where);
12527 : }
12528 :
12529 : /* the assignment statement of a WHERE statement, or the first
12530 : statement in where-body-construct of a WHERE construct */
12531 884 : cnext = cblock->next;
12532 1745 : while (cnext)
12533 : {
12534 861 : switch (cnext->op)
12535 : {
12536 : /* WHERE assignment statement */
12537 759 : case EXEC_ASSIGN:
12538 :
12539 : /* Check shape consistent for WHERE assignment target. */
12540 759 : if (e && !resolve_where_shape (cnext->expr1, e))
12541 0 : gfc_error ("WHERE assignment target at %L has "
12542 0 : "inconsistent shape", &cnext->expr1->where);
12543 :
12544 759 : if (cnext->op == EXEC_ASSIGN
12545 759 : && gfc_may_be_finalized (cnext->expr1->ts))
12546 0 : cnext->expr1->must_finalize = 1;
12547 :
12548 : break;
12549 :
12550 :
12551 46 : case EXEC_ASSIGN_CALL:
12552 46 : resolve_call (cnext);
12553 46 : if (!cnext->resolved_sym->attr.elemental)
12554 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12555 2 : &cnext->ext.actual->expr->where);
12556 : break;
12557 :
12558 : /* WHERE or WHERE construct is part of a where-body-construct */
12559 56 : case EXEC_WHERE:
12560 56 : resolve_where (cnext, e);
12561 56 : break;
12562 :
12563 0 : default:
12564 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12565 : &cnext->loc);
12566 : }
12567 : /* the next statement within the same where-body-construct */
12568 861 : cnext = cnext->next;
12569 : }
12570 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12571 884 : cblock = cblock->block;
12572 : }
12573 515 : }
12574 :
12575 :
12576 : /* Resolve assignment in FORALL construct.
12577 : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12578 : FORALL index variables. */
12579 :
12580 : static void
12581 2450 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12582 : {
12583 2450 : int n;
12584 2450 : gfc_symbol *forall_index;
12585 :
12586 6952 : for (n = 0; n < nvar; n++)
12587 : {
12588 4502 : forall_index = var_expr[n]->symtree->n.sym;
12589 :
12590 : /* Check whether the assignment target is one of the FORALL index
12591 : variable. */
12592 4502 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12593 4502 : && (code->expr1->symtree->n.sym == forall_index))
12594 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12595 : &code->expr1->where);
12596 : else
12597 : {
12598 : /* If one of the FORALL index variables doesn't appear in the
12599 : assignment variable, then there could be a many-to-one
12600 : assignment. Emit a warning rather than an error because the
12601 : mask could be resolving this problem.
12602 : DO NOT emit this warning for DO CONCURRENT - reduction-like
12603 : many-to-one assignments are semantically valid (formalized with
12604 : the REDUCE locality-spec in Fortran 2023). */
12605 4502 : if (!find_forall_index (code->expr1, forall_index, 0)
12606 4502 : && !gfc_do_concurrent_flag)
12607 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12608 : "left side of the assignment at %L and so might "
12609 : "cause multiple assignment to this object",
12610 0 : var_expr[n]->symtree->name, &code->expr1->where);
12611 : }
12612 : }
12613 2450 : }
12614 :
12615 :
12616 : /* Resolve WHERE statement in FORALL construct. */
12617 :
12618 : static void
12619 53 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12620 : gfc_expr **var_expr)
12621 : {
12622 53 : gfc_code *cblock;
12623 53 : gfc_code *cnext;
12624 :
12625 53 : cblock = code->block;
12626 125 : while (cblock)
12627 : {
12628 : /* the assignment statement of a WHERE statement, or the first
12629 : statement in where-body-construct of a WHERE construct */
12630 72 : cnext = cblock->next;
12631 144 : while (cnext)
12632 : {
12633 72 : switch (cnext->op)
12634 : {
12635 : /* WHERE assignment statement */
12636 72 : case EXEC_ASSIGN:
12637 72 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12638 :
12639 72 : if (cnext->op == EXEC_ASSIGN
12640 72 : && gfc_may_be_finalized (cnext->expr1->ts))
12641 0 : cnext->expr1->must_finalize = 1;
12642 :
12643 : break;
12644 :
12645 : /* WHERE operator assignment statement */
12646 0 : case EXEC_ASSIGN_CALL:
12647 0 : resolve_call (cnext);
12648 0 : if (!cnext->resolved_sym->attr.elemental)
12649 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12650 0 : &cnext->ext.actual->expr->where);
12651 : break;
12652 :
12653 : /* WHERE or WHERE construct is part of a where-body-construct */
12654 0 : case EXEC_WHERE:
12655 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12656 0 : break;
12657 :
12658 0 : default:
12659 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12660 : &cnext->loc);
12661 : }
12662 : /* the next statement within the same where-body-construct */
12663 72 : cnext = cnext->next;
12664 : }
12665 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12666 72 : cblock = cblock->block;
12667 : }
12668 53 : }
12669 :
12670 :
12671 : /* Traverse the FORALL body to check whether the following errors exist:
12672 : 1. For assignment, check if a many-to-one assignment happens.
12673 : 2. For WHERE statement, check the WHERE body to see if there is any
12674 : many-to-one assignment. */
12675 :
12676 : static void
12677 2345 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12678 : {
12679 2345 : gfc_code *c;
12680 :
12681 2345 : c = code->block->next;
12682 5118 : while (c)
12683 : {
12684 2773 : switch (c->op)
12685 : {
12686 2378 : case EXEC_ASSIGN:
12687 2378 : case EXEC_POINTER_ASSIGN:
12688 2378 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12689 :
12690 2378 : if (c->op == EXEC_ASSIGN
12691 2378 : && gfc_may_be_finalized (c->expr1->ts))
12692 0 : c->expr1->must_finalize = 1;
12693 :
12694 : break;
12695 :
12696 0 : case EXEC_ASSIGN_CALL:
12697 0 : resolve_call (c);
12698 0 : break;
12699 :
12700 : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12701 : there is no need to handle it here. */
12702 : case EXEC_FORALL:
12703 : break;
12704 53 : case EXEC_WHERE:
12705 53 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12706 53 : break;
12707 : default:
12708 : break;
12709 : }
12710 : /* The next statement in the FORALL body. */
12711 2773 : c = c->next;
12712 : }
12713 2345 : }
12714 :
12715 :
12716 : /* Counts the number of iterators needed inside a forall construct, including
12717 : nested forall constructs. This is used to allocate the needed memory
12718 : in gfc_resolve_forall. */
12719 :
12720 : static int gfc_count_forall_iterators (gfc_code *code);
12721 :
12722 : /* Return the deepest nested FORALL/DO CONCURRENT iterator count in CODE's
12723 : next-chain, descending into block arms such as IF/ELSE branches. */
12724 :
12725 : static int
12726 2585 : gfc_max_forall_iterators_in_chain (gfc_code *code)
12727 : {
12728 2585 : int max_iters = 0;
12729 :
12730 5633 : for (gfc_code *c = code; c; c = c->next)
12731 : {
12732 3048 : int sub_iters = 0;
12733 :
12734 3048 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12735 124 : sub_iters = gfc_count_forall_iterators (c);
12736 2924 : else if (c->op == EXEC_BLOCK)
12737 : {
12738 : /* BLOCK/ASSOCIATE bodies live in the block namespace code chain,
12739 : not in the generic c->block arm list used by IF/SELECT. */
12740 40 : if (c->ext.block.ns && c->ext.block.ns->code)
12741 40 : sub_iters = gfc_max_forall_iterators_in_chain (c->ext.block.ns->code);
12742 : }
12743 2884 : else if (c->block)
12744 367 : for (gfc_code *b = c->block; b; b = b->block)
12745 : {
12746 200 : int arm_iters = gfc_max_forall_iterators_in_chain (b->next);
12747 200 : if (arm_iters > sub_iters)
12748 : sub_iters = arm_iters;
12749 : }
12750 :
12751 3048 : if (sub_iters > max_iters)
12752 : max_iters = sub_iters;
12753 : }
12754 :
12755 2585 : return max_iters;
12756 : }
12757 :
12758 :
12759 : static int
12760 2345 : gfc_count_forall_iterators (gfc_code *code)
12761 : {
12762 2345 : int current_iters = 0;
12763 2345 : gfc_forall_iterator *fa;
12764 :
12765 2345 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12766 :
12767 6608 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12768 4263 : current_iters++;
12769 :
12770 2345 : return current_iters + gfc_max_forall_iterators_in_chain (code->block->next);
12771 : }
12772 :
12773 :
12774 : /* Given a FORALL construct.
12775 : 1) Resolve the FORALL iterator.
12776 : 2) Check for shadow index-name(s) and update code block.
12777 : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12778 :
12779 : /* Shadow variable that replace_forall_var substitutes in; set by
12780 : replace_in_expr_recursive before each traversal. */
12781 :
12782 : static gfc_symtree *forall_shadow_st;
12783 :
12784 : /* gfc_traverse_expr callback: point a reference to OLD_SYM at the
12785 : construct-scoped shadow variable. */
12786 :
12787 : static bool
12788 872 : replace_forall_var (gfc_expr *expr, gfc_symbol *old_sym,
12789 : int *f ATTRIBUTE_UNUSED)
12790 : {
12791 872 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12792 : {
12793 198 : expr->symtree = forall_shadow_st;
12794 198 : expr->ts = forall_shadow_st->n.sym->ts;
12795 : }
12796 :
12797 872 : return false;
12798 : }
12799 :
12800 :
12801 : /* Replace every reference to OLD_SYM in EXPR with NEW_ST. Traversal is
12802 : left to gfc_traverse_expr so that all expression forms are covered;
12803 : character length type parameters are skipped since those belong to
12804 : declarations that may be shared outside the construct. */
12805 :
12806 : static void
12807 974 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym,
12808 : gfc_symtree *new_st)
12809 : {
12810 974 : if (!expr)
12811 : return;
12812 :
12813 412 : forall_shadow_st = new_st;
12814 412 : gfc_traverse_expr (expr, old_sym, replace_forall_var, -1);
12815 : }
12816 :
12817 :
12818 : /* Walk code tree and replace all variable references */
12819 :
12820 : static void
12821 200 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12822 : {
12823 200 : if (!code)
12824 : return;
12825 :
12826 412 : for (gfc_code *c = code; c; c = c->next)
12827 : {
12828 : /* Replace in expressions associated with this code node */
12829 212 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12830 212 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12831 212 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12832 212 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12833 :
12834 : /* Handle special code types with additional expressions */
12835 212 : switch (c->op)
12836 : {
12837 0 : case EXEC_DO:
12838 0 : if (c->ext.iterator)
12839 : {
12840 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12841 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12842 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12843 : }
12844 : break;
12845 :
12846 0 : case EXEC_CALL:
12847 0 : case EXEC_ASSIGN_CALL:
12848 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12849 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12850 : break;
12851 :
12852 6 : case EXEC_SELECT:
12853 6 : case EXEC_SELECT_TYPE:
12854 6 : case EXEC_SELECT_RANK:
12855 12 : for (gfc_code *b = c->block; b; b = b->block)
12856 : {
12857 12 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12858 : {
12859 6 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12860 6 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12861 : }
12862 6 : replace_in_code_recursive (b->next, old_sym, new_st);
12863 : }
12864 : break;
12865 :
12866 18 : case EXEC_IF:
12867 18 : case EXEC_WHERE:
12868 : /* Each block in the chain holds its condition or mask in EXPR1
12869 : and its body in NEXT; the trailing ELSE/ELSEWHERE has no
12870 : condition. The generic recursion below only reaches the first
12871 : branch, so walk the whole chain here. */
12872 48 : for (gfc_code *b = c->block; b; b = b->block)
12873 : {
12874 30 : replace_in_expr_recursive (b->expr1, old_sym, new_st);
12875 30 : replace_in_code_recursive (b->next, old_sym, new_st);
12876 : }
12877 : break;
12878 :
12879 6 : case EXEC_ALLOCATE:
12880 6 : case EXEC_DEALLOCATE:
12881 : /* Bounds and lengths of the allocate-objects. */
12882 12 : for (gfc_alloc *al = c->ext.alloc.list; al; al = al->next)
12883 6 : replace_in_expr_recursive (al->expr, old_sym, new_st);
12884 : break;
12885 :
12886 24 : case EXEC_FORALL:
12887 24 : case EXEC_DO_CONCURRENT:
12888 48 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12889 : {
12890 24 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12891 24 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12892 24 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12893 : }
12894 : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12895 : they'll be handled separately */
12896 : break;
12897 :
12898 12 : case EXEC_BLOCK:
12899 : /* Replace in ASSOCIATE selector expressions and the body.
12900 : The body of an EXEC_BLOCK lives in c->ext.block.ns->code, not
12901 : c->block->next, so without this case both selectors and body
12902 : are silently skipped, leaving shadow iterator references unreplaced
12903 : and producing wrong values at runtime. */
12904 12 : for (gfc_association_list *alist = c->ext.block.assoc;
12905 18 : alist; alist = alist->next)
12906 6 : replace_in_expr_recursive (alist->target, old_sym, new_st);
12907 12 : if (c->ext.block.ns)
12908 12 : replace_in_code_recursive (c->ext.block.ns->code, old_sym, new_st);
12909 : break;
12910 :
12911 : default:
12912 : break;
12913 : }
12914 :
12915 : /* Recurse into blocks, except a nested FORALL/DO CONCURRENT that
12916 : shadows OLD_SYM itself. */
12917 212 : bool skip_nested_shadow = false;
12918 212 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12919 24 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator;
12920 24 : fa; fa = fa->next)
12921 24 : if (fa->shadow && fa->shadow_outer_sym == old_sym)
12922 : {
12923 : skip_nested_shadow = true;
12924 : break;
12925 : }
12926 :
12927 212 : if (c->block && !skip_nested_shadow)
12928 24 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12929 : }
12930 : }
12931 :
12932 :
12933 : /* Replace all references to outer_sym with shadow_st in the given code. */
12934 :
12935 : static void
12936 128 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12937 : gfc_symtree *shadow_st)
12938 : {
12939 : /* Use custom recursive walker to ensure we visit ALL expressions */
12940 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12941 0 : }
12942 :
12943 :
12944 : static void
12945 2345 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12946 : {
12947 2345 : static gfc_expr **var_expr;
12948 2345 : static int total_var = 0;
12949 2345 : static int nvar = 0;
12950 2345 : int i, old_nvar, tmp;
12951 2345 : gfc_forall_iterator *fa;
12952 2345 : bool shadow = false;
12953 :
12954 2345 : old_nvar = nvar;
12955 :
12956 : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12957 2345 : if (code->op == EXEC_FORALL
12958 2345 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12959 : return;
12960 :
12961 : /* Start to resolve a FORALL construct */
12962 : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12963 : forall_save==0 means we're not nested in a FORALL in the current scope,
12964 : but nvar==0 ensures we're not nested in a parent scope either (prevents
12965 : double allocation when FORALL is nested inside DO CONCURRENT). */
12966 2345 : if (forall_save == 0 && nvar == 0)
12967 : {
12968 : /* Count the total number of FORALL indices in the nested FORALL
12969 : construct in order to allocate the VAR_EXPR with proper size. */
12970 2221 : total_var = gfc_count_forall_iterators (code);
12971 :
12972 : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12973 2221 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12974 : }
12975 :
12976 : /* The information about FORALL iterator, including FORALL indices start,
12977 : end and stride. An outer FORALL indice cannot appear in start, end or
12978 : stride. Check for a shadow index-name. */
12979 6608 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12980 : {
12981 : /* Fortran 2008: C738 (R753). */
12982 4263 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12983 : {
12984 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12985 : "of type integer", &fa->var->where);
12986 2 : continue;
12987 : }
12988 :
12989 : /* Check if any outer FORALL index name is the same as the current
12990 : one. Skip this check if the iterator is a shadow variable (from
12991 : DO CONCURRENT type spec) which may not have a symtree yet. */
12992 7314 : for (i = 0; i < nvar; i++)
12993 : {
12994 3053 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12995 3053 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12996 0 : gfc_error ("An outer FORALL construct already has an index "
12997 : "with this name %L", &fa->var->where);
12998 : }
12999 :
13000 4261 : if (fa->shadow)
13001 128 : shadow = true;
13002 :
13003 : /* Record the current FORALL index. */
13004 4261 : var_expr[nvar] = gfc_copy_expr (fa->var);
13005 :
13006 4261 : nvar++;
13007 :
13008 : /* No memory leak. */
13009 4261 : gcc_assert (nvar <= total_var);
13010 : }
13011 :
13012 : /* Need to walk the code and replace references to the index-name with
13013 : references to the shadow index-name. This must be done BEFORE resolving
13014 : the body so that resolution uses the correct shadow variables. */
13015 2345 : if (shadow)
13016 : {
13017 : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
13018 262 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
13019 : {
13020 134 : if (fa->shadow)
13021 : {
13022 128 : gfc_symtree *shadow_st = fa->var->symtree;
13023 :
13024 128 : gfc_symbol *iter_sym = fa->shadow_outer_sym;
13025 :
13026 : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
13027 128 : if (code->block && code->block->next)
13028 128 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
13029 : }
13030 : }
13031 : }
13032 :
13033 : /* Resolve the FORALL body. */
13034 2345 : gfc_resolve_forall_body (code, nvar, var_expr);
13035 :
13036 : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
13037 2345 : gfc_resolve_blocks (code->block, ns);
13038 :
13039 2345 : tmp = nvar;
13040 2345 : nvar = old_nvar;
13041 : /* Free only the VAR_EXPRs allocated in this frame. */
13042 6606 : for (i = nvar; i < tmp; i++)
13043 4261 : gfc_free_expr (var_expr[i]);
13044 :
13045 2345 : if (nvar == 0)
13046 : {
13047 : /* We are in the outermost FORALL construct. */
13048 2221 : gcc_assert (forall_save == 0);
13049 :
13050 : /* VAR_EXPR is not needed any more. */
13051 2221 : free (var_expr);
13052 2221 : total_var = 0;
13053 : }
13054 : }
13055 :
13056 :
13057 : /* Resolve a BLOCK construct statement. */
13058 :
13059 : static void
13060 8714 : resolve_block_construct (gfc_code* code)
13061 : {
13062 8714 : gfc_namespace *ns = code->ext.block.ns;
13063 :
13064 : /* For an ASSOCIATE block, the associations (and their targets) will be
13065 : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
13066 : namespace. However, marking variables as used ans defined requires
13067 : passing ext.block.assoc. */
13068 8714 : gfc_resolve (ns, code->ext.block.assoc);
13069 8583 : }
13070 :
13071 : /* Mark everything in an association list as used and set if applicable,
13072 : respectively. */
13073 :
13074 : static void
13075 316385 : mark_assoc_used (gfc_association_list *a)
13076 : {
13077 323607 : while (a != NULL)
13078 : {
13079 7222 : gfc_symbol *n_sym = a->st->n.sym;
13080 7222 : if (n_sym->attr.value_used != VALUE_UNUSED)
13081 5150 : gfc_value_used_expr (a->target, n_sym->attr.value_used);
13082 :
13083 7222 : if (a->variable && n_sym->attr.value_set != VALUE_UNSET)
13084 1378 : gfc_expr_set_at (a->target, &n_sym->other_loc, n_sym->attr.value_set);
13085 :
13086 7222 : a = a->next;
13087 : }
13088 316385 : }
13089 :
13090 : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
13091 : DO code nodes. */
13092 :
13093 : void
13094 339272 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
13095 : {
13096 339272 : bool t;
13097 :
13098 690253 : for (; b; b = b->block)
13099 : {
13100 350981 : t = gfc_resolve_expr (b->expr1);
13101 350981 : if (!gfc_resolve_expr (b->expr2))
13102 0 : t = false;
13103 :
13104 350981 : switch (b->op)
13105 : {
13106 242452 : case EXEC_IF:
13107 242452 : if (t && b->expr1 != NULL
13108 238108 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
13109 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
13110 : &b->expr1->where);
13111 : break;
13112 :
13113 770 : case EXEC_WHERE:
13114 770 : if (t
13115 770 : && b->expr1 != NULL
13116 637 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
13117 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
13118 : &b->expr1->where);
13119 : break;
13120 :
13121 76 : case EXEC_GOTO:
13122 76 : resolve_branch (b->label1, b);
13123 76 : break;
13124 :
13125 0 : case EXEC_BLOCK:
13126 0 : resolve_block_construct (b);
13127 0 : break;
13128 :
13129 : case EXEC_SELECT:
13130 : case EXEC_SELECT_TYPE:
13131 : case EXEC_SELECT_RANK:
13132 : case EXEC_FORALL:
13133 : case EXEC_DO:
13134 : case EXEC_DO_WHILE:
13135 : case EXEC_DO_CONCURRENT:
13136 : case EXEC_CRITICAL:
13137 : case EXEC_READ:
13138 : case EXEC_WRITE:
13139 : case EXEC_IOLENGTH:
13140 : case EXEC_WAIT:
13141 : break;
13142 :
13143 2710 : case EXEC_OMP_ATOMIC:
13144 2710 : case EXEC_OACC_ATOMIC:
13145 2710 : {
13146 : /* Verify this before calling gfc_resolve_code, which might
13147 : change it. */
13148 2710 : gcc_assert (b->op == EXEC_OMP_ATOMIC
13149 : || (b->next && b->next->op == EXEC_ASSIGN));
13150 : }
13151 : break;
13152 :
13153 : case EXEC_OACC_PARALLEL_LOOP:
13154 : case EXEC_OACC_PARALLEL:
13155 : case EXEC_OACC_KERNELS_LOOP:
13156 : case EXEC_OACC_KERNELS:
13157 : case EXEC_OACC_SERIAL_LOOP:
13158 : case EXEC_OACC_SERIAL:
13159 : case EXEC_OACC_DATA:
13160 : case EXEC_OACC_HOST_DATA:
13161 : case EXEC_OACC_LOOP:
13162 : case EXEC_OACC_UPDATE:
13163 : case EXEC_OACC_WAIT:
13164 : case EXEC_OACC_CACHE:
13165 : case EXEC_OACC_ENTER_DATA:
13166 : case EXEC_OACC_EXIT_DATA:
13167 : case EXEC_OACC_ROUTINE:
13168 : case EXEC_OACC_INIT:
13169 : case EXEC_OACC_SHUTDOWN:
13170 : case EXEC_OACC_SET:
13171 : case EXEC_OMP_ALLOCATE:
13172 : case EXEC_OMP_ALLOCATORS:
13173 : case EXEC_OMP_ASSUME:
13174 : case EXEC_OMP_CRITICAL:
13175 : case EXEC_OMP_DISPATCH:
13176 : case EXEC_OMP_DISTRIBUTE:
13177 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13178 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13179 : case EXEC_OMP_DISTRIBUTE_SIMD:
13180 : case EXEC_OMP_DO:
13181 : case EXEC_OMP_DO_SIMD:
13182 : case EXEC_OMP_ERROR:
13183 : case EXEC_OMP_LOOP:
13184 : case EXEC_OMP_MASKED:
13185 : case EXEC_OMP_MASKED_TASKLOOP:
13186 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13187 : case EXEC_OMP_MASTER:
13188 : case EXEC_OMP_MASTER_TASKLOOP:
13189 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13190 : case EXEC_OMP_ORDERED:
13191 : case EXEC_OMP_PARALLEL:
13192 : case EXEC_OMP_PARALLEL_DO:
13193 : case EXEC_OMP_PARALLEL_DO_SIMD:
13194 : case EXEC_OMP_PARALLEL_LOOP:
13195 : case EXEC_OMP_PARALLEL_MASKED:
13196 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13197 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13198 : case EXEC_OMP_PARALLEL_MASTER:
13199 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13200 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13201 : case EXEC_OMP_PARALLEL_SECTIONS:
13202 : case EXEC_OMP_PARALLEL_WORKSHARE:
13203 : case EXEC_OMP_SECTIONS:
13204 : case EXEC_OMP_SIMD:
13205 : case EXEC_OMP_SCOPE:
13206 : case EXEC_OMP_SINGLE:
13207 : case EXEC_OMP_TARGET:
13208 : case EXEC_OMP_TARGET_DATA:
13209 : case EXEC_OMP_TARGET_ENTER_DATA:
13210 : case EXEC_OMP_TARGET_EXIT_DATA:
13211 : case EXEC_OMP_TARGET_PARALLEL:
13212 : case EXEC_OMP_TARGET_PARALLEL_DO:
13213 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13214 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13215 : case EXEC_OMP_TARGET_SIMD:
13216 : case EXEC_OMP_TARGET_TEAMS:
13217 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13218 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13219 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13220 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13221 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13222 : case EXEC_OMP_TARGET_UPDATE:
13223 : case EXEC_OMP_TASK:
13224 : case EXEC_OMP_TASKGROUP:
13225 : case EXEC_OMP_TASKLOOP:
13226 : case EXEC_OMP_TASKLOOP_SIMD:
13227 : case EXEC_OMP_TASKWAIT:
13228 : case EXEC_OMP_TASKYIELD:
13229 : case EXEC_OMP_TEAMS:
13230 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13231 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13232 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13233 : case EXEC_OMP_TEAMS_LOOP:
13234 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13235 : case EXEC_OMP_TILE:
13236 : case EXEC_OMP_UNROLL:
13237 : case EXEC_OMP_WORKSHARE:
13238 : break;
13239 :
13240 0 : default:
13241 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
13242 : }
13243 350981 : gfc_value_used_expr (b->expr1, VALUE_USED);
13244 350981 : gfc_value_used_expr (b->expr2, VALUE_USED);
13245 350981 : gfc_resolve_code (b->next, ns);
13246 : }
13247 339272 : }
13248 :
13249 : bool
13250 0 : caf_possible_reallocate (gfc_expr *e)
13251 : {
13252 0 : symbol_attribute caf_attr;
13253 0 : gfc_ref *last_arr_ref = nullptr;
13254 :
13255 0 : caf_attr = gfc_caf_attr (e);
13256 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
13257 : return false;
13258 :
13259 : /* Only full array refs can indicate a needed reallocation. */
13260 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
13261 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
13262 0 : last_arr_ref = ref;
13263 :
13264 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
13265 : }
13266 :
13267 : /* Does everything to resolve an ordinary assignment. Returns true
13268 : if this is an interface assignment. */
13269 : static bool
13270 290202 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
13271 : {
13272 290202 : bool rval = false;
13273 290202 : gfc_expr *lhs;
13274 290202 : gfc_expr *rhs;
13275 290202 : int n;
13276 290202 : gfc_ref *ref;
13277 290202 : symbol_attribute attr;
13278 :
13279 290202 : if (gfc_extend_assign (code, ns))
13280 : {
13281 924 : gfc_expr** rhsptr;
13282 :
13283 924 : if (code->op == EXEC_ASSIGN_CALL)
13284 : {
13285 469 : lhs = code->ext.actual->expr;
13286 469 : rhsptr = &code->ext.actual->next->expr;
13287 : }
13288 : else
13289 : {
13290 455 : gfc_actual_arglist* args;
13291 455 : gfc_typebound_proc* tbp;
13292 :
13293 455 : gcc_assert (code->op == EXEC_COMPCALL);
13294 :
13295 455 : args = code->expr1->value.compcall.actual;
13296 455 : lhs = args->expr;
13297 455 : rhsptr = &args->next->expr;
13298 :
13299 455 : tbp = code->expr1->value.compcall.tbp;
13300 455 : gcc_assert (!tbp->is_generic);
13301 : }
13302 :
13303 : /* Make a temporary rhs when there is a default initializer
13304 : and rhs is the same symbol as the lhs. */
13305 924 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
13306 513 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
13307 442 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
13308 1218 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
13309 60 : *rhsptr = gfc_get_parentheses (*rhsptr);
13310 :
13311 : return true;
13312 : }
13313 :
13314 289278 : lhs = code->expr1;
13315 289278 : rhs = code->expr2;
13316 :
13317 289278 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
13318 268142 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
13319 23965 : && !lhs->symtree->n.sym->attr.proc_pointer
13320 313243 : && gfc_expr_attr (lhs).proc_pointer)
13321 : {
13322 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
13323 : "pointer component",
13324 : &lhs->where);
13325 1 : return false;
13326 : }
13327 :
13328 341257 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
13329 252821 : && rhs->ts.type == BT_CHARACTER
13330 289670 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
13331 : {
13332 : /* Use of -fdec-char-conversions allows assignment of character data
13333 : to non-character variables. This not permitted for nonconstant
13334 : strings. */
13335 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
13336 : gfc_typename (lhs), &rhs->where);
13337 29 : return false;
13338 : }
13339 :
13340 289248 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
13341 : {
13342 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
13343 : gfc_typename (lhs), &rhs->where);
13344 0 : return false;
13345 : }
13346 :
13347 : /* Handle the case of a BOZ literal on the RHS. */
13348 289248 : if (rhs->ts.type == BT_BOZ)
13349 : {
13350 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
13351 : "statement value nor an actual argument of "
13352 : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
13353 : &rhs->where))
13354 : return false;
13355 :
13356 1 : switch (lhs->ts.type)
13357 : {
13358 0 : case BT_INTEGER:
13359 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
13360 : return false;
13361 : break;
13362 1 : case BT_REAL:
13363 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
13364 : return false;
13365 : break;
13366 0 : default:
13367 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13368 0 : return false;
13369 : }
13370 : }
13371 :
13372 289246 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13373 : {
13374 67 : HOST_WIDE_INT llen = 0, rlen = 0;
13375 67 : if (lhs->ts.u.cl != NULL
13376 67 : && lhs->ts.u.cl->length != NULL
13377 61 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13378 61 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13379 :
13380 67 : if (rhs->expr_type == EXPR_CONSTANT)
13381 29 : rlen = rhs->value.character.length;
13382 :
13383 38 : else if (rhs->ts.u.cl != NULL
13384 38 : && rhs->ts.u.cl->length != NULL
13385 36 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13386 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13387 :
13388 67 : if (rlen && llen && rlen > llen)
13389 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13390 : "CHARACTER expression will be truncated "
13391 : "in assignment (%wd/%wd) at %L",
13392 : llen, rlen, &code->loc);
13393 : }
13394 :
13395 : /* Ensure that a vector index expression for the lvalue is evaluated
13396 : to a temporary if the lvalue symbol is referenced in it. */
13397 289246 : if (lhs->rank)
13398 : {
13399 115331 : for (ref = lhs->ref; ref; ref= ref->next)
13400 61766 : if (ref->type == REF_ARRAY)
13401 : {
13402 135307 : for (n = 0; n < ref->u.ar.dimen; n++)
13403 79874 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13404 80104 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13405 230 : ref->u.ar.start[n]))
13406 14 : ref->u.ar.start[n]
13407 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13408 : }
13409 : }
13410 :
13411 289246 : if (gfc_pure (NULL))
13412 : {
13413 3621 : if (lhs->ts.type == BT_DERIVED
13414 136 : && lhs->expr_type == EXPR_VARIABLE
13415 136 : && lhs->ts.u.derived->attr.pointer_comp
13416 4 : && rhs->expr_type == EXPR_VARIABLE
13417 3624 : && (gfc_impure_variable (rhs->symtree->n.sym)
13418 2 : || gfc_is_coindexed (rhs)))
13419 : {
13420 : /* F2008, C1283. */
13421 2 : if (gfc_is_coindexed (rhs))
13422 1 : gfc_error ("Coindexed expression at %L is assigned to "
13423 : "a derived type variable with a POINTER "
13424 : "component in a PURE procedure",
13425 : &rhs->where);
13426 : else
13427 : /* F2008, C1283 (4). */
13428 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13429 : "shall not be used as the expr at %L of an intrinsic "
13430 : "assignment statement in which the variable is of a "
13431 : "derived type if the derived type has a pointer "
13432 : "component at any level of component selection.",
13433 : &rhs->where);
13434 : return rval;
13435 : }
13436 :
13437 : /* Fortran 2008, C1283. */
13438 3619 : if (gfc_is_coindexed (lhs))
13439 : {
13440 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13441 : "procedure", &rhs->where);
13442 1 : return rval;
13443 : }
13444 : }
13445 :
13446 289243 : if (gfc_implicit_pure (NULL))
13447 : {
13448 7678 : if (lhs->expr_type == EXPR_VARIABLE
13449 7678 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13450 5478 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13451 256 : gfc_unset_implicit_pure (NULL);
13452 :
13453 7678 : if (lhs->ts.type == BT_DERIVED
13454 384 : && lhs->expr_type == EXPR_VARIABLE
13455 384 : && lhs->ts.u.derived->attr.pointer_comp
13456 7 : && rhs->expr_type == EXPR_VARIABLE
13457 7685 : && (gfc_impure_variable (rhs->symtree->n.sym)
13458 7 : || gfc_is_coindexed (rhs)))
13459 0 : gfc_unset_implicit_pure (NULL);
13460 :
13461 : /* Fortran 2008, C1283. */
13462 7678 : if (gfc_is_coindexed (lhs))
13463 0 : gfc_unset_implicit_pure (NULL);
13464 : }
13465 :
13466 : /* F2008, 7.2.1.2. */
13467 289243 : attr = gfc_expr_attr (lhs);
13468 289243 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13469 : {
13470 1042 : if (attr.codimension)
13471 : {
13472 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13473 : "permitted", &lhs->where);
13474 1 : return false;
13475 : }
13476 1041 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13477 : "polymorphic variable at %L", &lhs->where))
13478 : return false;
13479 1040 : if (!flag_realloc_lhs)
13480 : {
13481 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13482 : "requires %<-frealloc-lhs%>", &lhs->where);
13483 1 : return false;
13484 : }
13485 : }
13486 288201 : else if (lhs->ts.type == BT_CLASS)
13487 : {
13488 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13489 : "assignment at %L - check that there is a matching specific "
13490 : "subroutine for %<=%> operator", &lhs->where);
13491 9 : return false;
13492 : }
13493 :
13494 289231 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13495 :
13496 : /* F2008, Section 7.2.1.2. */
13497 289231 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13498 : {
13499 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13500 : "component in assignment at %L", &lhs->where);
13501 1 : return false;
13502 : }
13503 :
13504 : /* Assign the 'data' of a class object to a derived type. */
13505 289230 : if (lhs->ts.type == BT_DERIVED
13506 7567 : && rhs->ts.type == BT_CLASS
13507 180 : && (rhs->expr_type != EXPR_ARRAY
13508 174 : && rhs->expr_type != EXPR_OP))
13509 168 : gfc_add_data_component (rhs);
13510 :
13511 : /* Make sure there is a vtable and, in particular, a _copy for the
13512 : rhs type. */
13513 289230 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13514 628 : gfc_find_vtab (&rhs->ts);
13515 :
13516 289230 : gfc_check_assign (lhs, rhs, 1);
13517 :
13518 289230 : return false;
13519 : }
13520 :
13521 :
13522 : /* Add a component reference onto an expression. */
13523 :
13524 : static void
13525 647 : add_comp_ref (gfc_expr *e, gfc_component *c)
13526 : {
13527 647 : gfc_ref **ref;
13528 647 : ref = &(e->ref);
13529 871 : while (*ref)
13530 224 : ref = &((*ref)->next);
13531 647 : *ref = gfc_get_ref ();
13532 647 : (*ref)->type = REF_COMPONENT;
13533 647 : (*ref)->u.c.sym = e->ts.u.derived;
13534 647 : (*ref)->u.c.component = c;
13535 647 : e->ts = c->ts;
13536 :
13537 : /* Add a full array ref, as necessary. */
13538 647 : if (c->as)
13539 : {
13540 84 : gfc_add_full_array_ref (e, c->as);
13541 84 : e->rank = c->as->rank;
13542 84 : e->corank = c->as->corank;
13543 : }
13544 647 : }
13545 :
13546 :
13547 : /* Build an assignment. Keep the argument 'op' for future use, so that
13548 : pointer assignments can be made. */
13549 :
13550 : static gfc_code *
13551 982 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13552 : gfc_component *comp1, gfc_component *comp2, locus loc)
13553 : {
13554 982 : gfc_code *this_code;
13555 :
13556 982 : this_code = gfc_get_code (op);
13557 982 : this_code->next = NULL;
13558 982 : this_code->expr1 = gfc_copy_expr (expr1);
13559 982 : this_code->expr2 = gfc_copy_expr (expr2);
13560 982 : this_code->loc = loc;
13561 982 : if (comp1 && comp2)
13562 : {
13563 288 : add_comp_ref (this_code->expr1, comp1);
13564 288 : add_comp_ref (this_code->expr2, comp2);
13565 : }
13566 :
13567 982 : return this_code;
13568 : }
13569 :
13570 :
13571 : /* Makes a temporary variable expression based on the characteristics of
13572 : a given variable expression. If allocatable is set, the temporary is
13573 : unconditionally allocatable*/
13574 :
13575 : static gfc_expr*
13576 500 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
13577 : bool allocatable = false)
13578 : {
13579 500 : static int serial = 0;
13580 500 : char name[GFC_MAX_SYMBOL_LEN];
13581 500 : gfc_symtree *tmp;
13582 500 : gfc_array_spec *as;
13583 500 : gfc_array_ref *aref;
13584 500 : gfc_ref *ref;
13585 :
13586 500 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13587 500 : gfc_get_sym_tree (name, ns, &tmp, false);
13588 500 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13589 :
13590 500 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13591 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13592 : NULL,
13593 0 : e->value.character.length);
13594 :
13595 500 : as = NULL;
13596 500 : ref = NULL;
13597 500 : aref = NULL;
13598 :
13599 : /* Obtain the arrayspec for the temporary. */
13600 500 : if (e->rank && e->expr_type != EXPR_ARRAY
13601 : && e->expr_type != EXPR_FUNCTION
13602 : && e->expr_type != EXPR_OP)
13603 : {
13604 52 : aref = gfc_find_array_ref (e);
13605 52 : if (e->expr_type == EXPR_VARIABLE
13606 52 : && e->symtree->n.sym->as == aref->as)
13607 : as = aref->as;
13608 : else
13609 : {
13610 0 : for (ref = e->ref; ref; ref = ref->next)
13611 0 : if (ref->type == REF_COMPONENT
13612 0 : && ref->u.c.component->as == aref->as)
13613 : {
13614 : as = aref->as;
13615 : break;
13616 : }
13617 : }
13618 : }
13619 :
13620 : /* Add the attributes and the arrayspec to the temporary. */
13621 500 : tmp->n.sym->attr = gfc_expr_attr (e);
13622 500 : tmp->n.sym->attr.function = 0;
13623 500 : tmp->n.sym->attr.proc_pointer = 0;
13624 500 : tmp->n.sym->attr.result = 0;
13625 500 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13626 500 : tmp->n.sym->attr.dummy = 0;
13627 500 : tmp->n.sym->attr.use_assoc = 0;
13628 500 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13629 :
13630 :
13631 500 : if (as && !allocatable)
13632 : {
13633 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13634 52 : if (!ref)
13635 52 : ref = e->ref;
13636 52 : if (as->type == AS_DEFERRED)
13637 46 : tmp->n.sym->attr.allocatable = 1;
13638 : }
13639 448 : else if ((e->rank || e->corank)
13640 136 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13641 24 : || e->expr_type == EXPR_OP || allocatable))
13642 : {
13643 136 : tmp->n.sym->as = gfc_get_array_spec ();
13644 136 : tmp->n.sym->as->type = AS_DEFERRED;
13645 136 : tmp->n.sym->as->rank = e->rank;
13646 136 : tmp->n.sym->as->corank = e->corank;
13647 136 : tmp->n.sym->attr.allocatable = 1;
13648 136 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13649 272 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13650 : }
13651 : else
13652 312 : tmp->n.sym->attr.dimension = 0;
13653 :
13654 500 : gfc_set_sym_referenced (tmp->n.sym);
13655 500 : gfc_commit_symbol (tmp->n.sym);
13656 500 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13657 :
13658 : /* Should the lhs be a section, use its array ref for the
13659 : temporary expression. */
13660 500 : if (aref && aref->type != AR_FULL && !allocatable)
13661 : {
13662 6 : gfc_free_ref_list (e->ref);
13663 6 : e->ref = gfc_copy_ref (ref);
13664 : }
13665 500 : return e;
13666 : }
13667 :
13668 :
13669 : gfc_expr*
13670 30 : gfc_get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
13671 : bool allocatable = false)
13672 : {
13673 30 : return get_temp_from_expr (e, ns, allocatable);
13674 : }
13675 :
13676 :
13677 : /* Helper function to take an argument in a subroutine call with a dependency
13678 : on another argument, copy it to an allocatable temporary and use the
13679 : temporary in the call expression. The new code is embedded in a block to
13680 : ensure local, automatic deallocation. */
13681 :
13682 : static void
13683 36 : add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,
13684 : gfc_expr **rhsptr)
13685 : {
13686 36 : gfc_namespace *block_ns;
13687 36 : gfc_expr *tmp_var;
13688 :
13689 : /* Wrap the new code in a block so that the temporary is deallocated. */
13690 36 : block_ns = gfc_build_block_ns (ns);
13691 :
13692 : /* As it stands, the block_ns does not not stand up to resolution because the
13693 : the assignment would be converted to a call and, in any case, the modified
13694 : call fails in gfc_check_conformance. */
13695 36 : block_ns->resolved = 1;
13696 :
13697 : /* Assign the original expression to the temporary. */
13698 36 : tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);
13699 72 : block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,
13700 36 : NULL, NULL, (*rhsptr)->where);
13701 :
13702 : /* Transfer the call to the block and terminate block code. */
13703 36 : *rhsptr = gfc_copy_expr (tmp_var);
13704 36 : block_ns->code->next = gfc_get_code (EXEC_NOP);
13705 36 : *(block_ns->code->next) = *code;
13706 36 : block_ns->code->next->next = NULL;
13707 :
13708 : /* Convert the original code to execute the block. */
13709 36 : code->op = EXEC_BLOCK;
13710 36 : code->ext.block.ns = block_ns;
13711 36 : code->ext.block.assoc = NULL;
13712 36 : code->expr1 = code->expr2 = NULL;
13713 36 : }
13714 :
13715 :
13716 : /* Add one line of code to the code chain, making sure that 'head' and
13717 : 'tail' are appropriately updated. */
13718 :
13719 : static void
13720 650 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13721 : {
13722 650 : gcc_assert (this_code);
13723 650 : if (*head == NULL)
13724 302 : *head = *tail = *this_code;
13725 : else
13726 348 : *tail = gfc_append_code (*tail, *this_code);
13727 650 : *this_code = NULL;
13728 650 : }
13729 :
13730 :
13731 : /* Generate a final call from a variable expression */
13732 :
13733 : static void
13734 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13735 : {
13736 81 : gfc_code *this_code;
13737 81 : gfc_expr *final_expr = NULL;
13738 81 : gfc_expr *size_expr;
13739 81 : gfc_expr *fini_coarray;
13740 :
13741 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13742 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13743 75 : return;
13744 :
13745 : /* Now generate the finalizer call. */
13746 6 : this_code = gfc_get_code (EXEC_CALL);
13747 6 : this_code->symtree = final_expr->symtree;
13748 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13749 :
13750 : //* Expression to be finalized */
13751 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13752 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13753 :
13754 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13755 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13756 6 : size_expr = gfc_get_expr ();
13757 6 : size_expr->where = gfc_current_locus;
13758 6 : size_expr->expr_type = EXPR_OP;
13759 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13760 6 : size_expr->value.op.op1
13761 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13762 : "storage_size", gfc_current_locus, 2,
13763 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13764 : gfc_get_int_expr (gfc_index_integer_kind,
13765 : NULL, 0));
13766 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13767 : gfc_character_storage_size);
13768 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13769 6 : size_expr->ts = size_expr->value.op.op1->ts;
13770 6 : this_code->ext.actual->next->expr = size_expr;
13771 :
13772 : /* fini_coarray */
13773 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13774 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13775 : &tmp_expr->where);
13776 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13777 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13778 :
13779 6 : add_code_to_chain (&this_code, head, tail);
13780 :
13781 : }
13782 :
13783 : /* Counts the potential number of part array references that would
13784 : result from resolution of typebound defined assignments. */
13785 :
13786 :
13787 : static int
13788 249 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13789 : {
13790 249 : gfc_component *c;
13791 249 : int c_depth = 0, t_depth;
13792 :
13793 596 : for (c= derived->components; c; c = c->next)
13794 : {
13795 347 : if ((!gfc_bt_struct (c->ts.type)
13796 267 : || c->attr.pointer
13797 267 : || c->attr.allocatable
13798 266 : || c->attr.proc_pointer_comp
13799 266 : || c->attr.class_pointer
13800 266 : || c->attr.proc_pointer)
13801 81 : && !c->attr.defined_assign_comp)
13802 81 : continue;
13803 :
13804 266 : if (c->as && c_depth == 0)
13805 266 : c_depth = 1;
13806 :
13807 266 : if (c->ts.u.derived->attr.defined_assign_comp)
13808 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13809 : c->as ? 1 : 0);
13810 : else
13811 : t_depth = 0;
13812 :
13813 266 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13814 : }
13815 249 : return depth + c_depth;
13816 : }
13817 :
13818 :
13819 : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13820 : "An intrinsic assignment where the variable is of derived type is performed
13821 : as if each component of the variable were assigned from the corresponding
13822 : component of expr using pointer assignment (10.2.2) for each pointer
13823 : component, defined assignment for each nonpointer nonallocatable component
13824 : of a type that has a type-bound defined assignment consistent with the
13825 : component, intrinsic assignment for each other nonpointer nonallocatable
13826 : component, and intrinsic assignment for each allocated coarray component.
13827 : For unallocated coarray components, the corresponding component of the
13828 : variable shall be unallocated. For a noncoarray allocatable component the
13829 : following sequence of operations is applied.
13830 : (1) If the component of the variable is allocated, it is deallocated.
13831 : (2) If the component of the value of expr is allocated, the
13832 : corresponding component of the variable is allocated with the same
13833 : dynamic type and type parameters as the component of the value of
13834 : expr. If it is an array, it is allocated with the same bounds. The
13835 : value of the component of the value of expr is then assigned to the
13836 : corresponding component of the variable using defined assignment if
13837 : the declared type of the component has a type-bound defined
13838 : assignment consistent with the component, and intrinsic assignment
13839 : for the dynamic type of that component otherwise."
13840 :
13841 : The pointer assignments are taken care of by the intrinsic assignment of the
13842 : structure itself. This function recursively adds defined assignments where
13843 : required. The recursion is accomplished by calling gfc_resolve_code.
13844 :
13845 : When the lhs in a defined assignment has intent INOUT or is intent OUT
13846 : and the component of 'var' is finalizable, we need a temporary for the
13847 : lhs. In pseudo-code for an assignment var = expr:
13848 :
13849 : ! Confine finalization of temporaries, as far as possible.
13850 : Enclose the code for the assignment in a block
13851 : ! Only call function 'expr' once.
13852 : #if ('expr is not a constant or an variable)
13853 : temp_expr = expr
13854 : expr = temp_x
13855 : ! Do the intrinsic assignment
13856 : #if typeof ('var') has a typebound final subroutine
13857 : finalize (var)
13858 : var = expr
13859 : ! Now do the component assignments
13860 : #do over derived type components [%cmp]
13861 : #if (cmp is a pointer of any kind)
13862 : continue
13863 : build the assignment
13864 : resolve the code
13865 : #if the code is a typebound assignment
13866 : #if (arg1 is INOUT or finalizable OUT && !t1)
13867 : t1 = var
13868 : arg1 = t1
13869 : deal with allocatation or not of var and this component
13870 : #elseif the code is an assignment by itself
13871 : #if this component does not need finalization
13872 : delete code and continue
13873 : #else
13874 : remove the leading assignment
13875 : #endif
13876 : commit the code
13877 : #if (t1 and (arg1 is INOUT or finalizable OUT))
13878 : var%cmp = t1%cmp
13879 : #enddo
13880 : put all code chunks involving t1 to the top of the generated code
13881 : insert the generated block in place of the original code
13882 : */
13883 :
13884 : static bool
13885 393 : is_finalizable_type (gfc_typespec ts)
13886 : {
13887 393 : gfc_component *c;
13888 :
13889 393 : if (ts.type != BT_DERIVED)
13890 : return false;
13891 :
13892 : /* (1) Check for FINAL subroutines. */
13893 393 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13894 : return true;
13895 :
13896 : /* (2) Check for components of finalizable type. */
13897 815 : for (c = ts.u.derived->components; c; c = c->next)
13898 476 : if (c->ts.type == BT_DERIVED
13899 249 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13900 248 : && c->ts.u.derived->f2k_derived
13901 248 : && c->ts.u.derived->f2k_derived->finalizers)
13902 : return true;
13903 :
13904 : return false;
13905 : }
13906 :
13907 : /* The temporary assignments have to be put on top of the additional
13908 : code to avoid the result being changed by the intrinsic assignment.
13909 : */
13910 : static int component_assignment_level = 0;
13911 : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13912 : static bool finalizable_comp;
13913 :
13914 : static void
13915 194 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13916 : {
13917 194 : gfc_component *comp1, *comp2;
13918 194 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13919 194 : gfc_code *tmp_code = NULL;
13920 194 : gfc_expr *t1 = NULL;
13921 194 : gfc_expr *tmp_expr = NULL;
13922 194 : int error_count, depth;
13923 194 : bool finalizable_lhs;
13924 194 : bool use_finalize_only;
13925 :
13926 194 : gfc_get_errors (NULL, &error_count);
13927 :
13928 : /* Filter out continuing processing after an error. */
13929 194 : if (error_count
13930 194 : || (*code)->expr1->ts.type != BT_DERIVED
13931 194 : || (*code)->expr2->ts.type != BT_DERIVED)
13932 146 : return;
13933 :
13934 : /* TODO: Handle more than one part array reference in assignments. */
13935 194 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13936 194 : (*code)->expr1->rank ? 1 : 0);
13937 194 : if (depth > 1)
13938 : {
13939 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13940 : "done because multiple part array references would "
13941 : "occur in intermediate expressions.", &(*code)->loc);
13942 6 : return;
13943 : }
13944 :
13945 188 : if (!component_assignment_level)
13946 140 : finalizable_comp = true;
13947 :
13948 : /* Build a block so that function result temporaries are finalized
13949 : locally on exiting the rather than enclosing scope. */
13950 188 : if (!component_assignment_level)
13951 : {
13952 140 : ns = gfc_build_block_ns (ns);
13953 140 : tmp_code = gfc_get_code (EXEC_NOP);
13954 140 : *tmp_code = **code;
13955 140 : tmp_code->next = NULL;
13956 140 : (*code)->op = EXEC_BLOCK;
13957 140 : (*code)->ext.block.ns = ns;
13958 140 : (*code)->ext.block.assoc = NULL;
13959 140 : (*code)->expr1 = (*code)->expr2 = NULL;
13960 140 : ns->code = tmp_code;
13961 140 : code = &ns->code;
13962 : }
13963 :
13964 188 : component_assignment_level++;
13965 :
13966 188 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13967 :
13968 : /* When the lhs is finalized as a whole and none of its components needs the
13969 : structure copy to handle it (no pointer or allocatable components), the
13970 : copy can be done component by component. The whole-derived-type assignment
13971 : then only finalizes the lhs and a component with a defined assignment keeps
13972 : its post-finalization value for the INTENT (OUT) finalization in that
13973 : defined assignment. */
13974 188 : use_finalize_only = finalizable_lhs;
13975 188 : if (use_finalize_only)
13976 66 : for (comp1 = (*code)->expr1->ts.u.derived->components; comp1;
13977 42 : comp1 = comp1->next)
13978 42 : if (comp1->attr.pointer || comp1->attr.allocatable
13979 42 : || comp1->attr.proc_pointer_comp || comp1->attr.class_pointer
13980 42 : || comp1->attr.proc_pointer)
13981 : {
13982 : use_finalize_only = false;
13983 : break;
13984 : }
13985 :
13986 : /* Create a temporary so that functions get called only once. */
13987 188 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13988 188 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13989 : {
13990 : /* Assign the rhs to the temporary. */
13991 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13992 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13993 : {
13994 : /* Use allocate on assignment for the sake of simplicity. The
13995 : temporary must not take on the optional attribute. Assume
13996 : that the assignment is guarded by a PRESENT condition if the
13997 : lhs is optional. */
13998 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13999 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
14000 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
14001 : }
14002 162 : this_code = build_assignment (EXEC_ASSIGN,
14003 : tmp_expr, (*code)->expr2,
14004 81 : NULL, NULL, (*code)->loc);
14005 81 : this_code->expr2->must_finalize = 1;
14006 : /* Add the code and substitute the rhs expression. */
14007 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
14008 81 : gfc_free_expr ((*code)->expr2);
14009 81 : (*code)->expr2 = tmp_expr;
14010 : }
14011 :
14012 : /* Do the intrinsic assignment. This is not needed if the lhs is one
14013 : of the temporaries generated here, since the intrinsic assignment
14014 : to the final result already does this. */
14015 188 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
14016 : {
14017 188 : if (finalizable_lhs)
14018 24 : (*code)->expr1->must_finalize = 1;
14019 188 : this_code = build_assignment (EXEC_ASSIGN,
14020 : (*code)->expr1, (*code)->expr2,
14021 : NULL, NULL, (*code)->loc);
14022 188 : if (use_finalize_only)
14023 24 : this_code->expr1->finalize_only = 1;
14024 188 : add_code_to_chain (&this_code, &head, &tail);
14025 : }
14026 :
14027 188 : comp1 = (*code)->expr1->ts.u.derived->components;
14028 188 : comp2 = (*code)->expr2->ts.u.derived->components;
14029 :
14030 461 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
14031 : {
14032 273 : bool inout = false;
14033 273 : bool finalizable_out = false;
14034 :
14035 : /* The intrinsic assignment does the right thing for pointers
14036 : of all kinds and allocatable components. */
14037 273 : if (!gfc_bt_struct (comp1->ts.type)
14038 206 : || comp1->attr.pointer
14039 206 : || comp1->attr.allocatable
14040 205 : || comp1->attr.proc_pointer_comp
14041 205 : || comp1->attr.class_pointer
14042 205 : || comp1->attr.proc_pointer)
14043 : {
14044 : /* With finalize_only the whole-derived-type assignment does not copy
14045 : the components, so emit the copy for this one here. Only plain
14046 : components reach this point, since use_finalize_only excludes
14047 : pointer and allocatable components. */
14048 68 : if (use_finalize_only)
14049 : {
14050 24 : this_code = build_assignment (EXEC_ASSIGN,
14051 : (*code)->expr1, (*code)->expr2,
14052 12 : comp1, comp2, (*code)->loc);
14053 12 : add_code_to_chain (&this_code, &head, &tail);
14054 : }
14055 68 : continue;
14056 : }
14057 :
14058 410 : finalizable_comp = is_finalizable_type (comp1->ts)
14059 205 : && !finalizable_lhs;
14060 :
14061 : /* Make an assignment for this component. */
14062 410 : this_code = build_assignment (EXEC_ASSIGN,
14063 : (*code)->expr1, (*code)->expr2,
14064 205 : comp1, comp2, (*code)->loc);
14065 :
14066 : /* Convert the assignment if there is a defined assignment for
14067 : this type. Otherwise, using the call from gfc_resolve_code,
14068 : recurse into its components. */
14069 205 : gfc_resolve_code (this_code, ns);
14070 :
14071 205 : if (this_code->op == EXEC_ASSIGN_CALL)
14072 : {
14073 150 : gfc_formal_arglist *dummy_args;
14074 150 : gfc_symbol *rsym;
14075 : /* Check that there is a typebound defined assignment. If not,
14076 : then this must be a module defined assignment. We cannot
14077 : use the defined_assign_comp attribute here because it must
14078 : be this derived type that has the defined assignment and not
14079 : a parent type. */
14080 150 : if (!(comp1->ts.u.derived->f2k_derived
14081 : && comp1->ts.u.derived->f2k_derived
14082 150 : ->tb_op[INTRINSIC_ASSIGN]))
14083 : {
14084 1 : gfc_free_statements (this_code);
14085 1 : this_code = NULL;
14086 1 : continue;
14087 : }
14088 :
14089 : /* If the first argument of the subroutine has intent INOUT
14090 : a temporary must be generated and used instead. */
14091 149 : rsym = this_code->resolved_sym;
14092 149 : dummy_args = gfc_sym_get_dummy_args (rsym);
14093 274 : finalizable_out = gfc_may_be_finalized (comp1->ts)
14094 24 : && dummy_args
14095 173 : && dummy_args->sym->attr.intent == INTENT_OUT;
14096 274 : inout = dummy_args
14097 274 : && dummy_args->sym->attr.intent == INTENT_INOUT;
14098 : /* With finalize_only the lhs component keeps its post-finalization
14099 : value, so the defined assignment can finalize it directly through
14100 : its INTENT (OUT) argument and no temporary is needed. */
14101 78 : if ((inout || (finalizable_out && !use_finalize_only))
14102 71 : && !comp1->attr.allocatable)
14103 : {
14104 71 : gfc_code *temp_code;
14105 71 : inout = true;
14106 :
14107 : /* Build the temporary required for the assignment and put
14108 : it at the head of the generated code. */
14109 71 : if (!t1)
14110 : {
14111 71 : gfc_namespace *tmp_ns = ns;
14112 71 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
14113 0 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
14114 71 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
14115 71 : t1->symtree->n.sym->attr.artificial = 1;
14116 142 : temp_code = build_assignment (EXEC_ASSIGN,
14117 : t1, (*code)->expr1,
14118 71 : NULL, NULL, (*code)->loc);
14119 :
14120 : /* For allocatable LHS, check whether it is allocated. Note
14121 : that allocatable components with defined assignment are
14122 : not yet support. See PR 57696. */
14123 71 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
14124 : {
14125 24 : gfc_code *block;
14126 24 : gfc_expr *e =
14127 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
14128 24 : block = gfc_get_code (EXEC_IF);
14129 24 : block->block = gfc_get_code (EXEC_IF);
14130 24 : block->block->expr1
14131 48 : = gfc_build_intrinsic_call (ns,
14132 : GFC_ISYM_ALLOCATED, "allocated",
14133 24 : (*code)->loc, 1, e);
14134 24 : block->block->next = temp_code;
14135 24 : temp_code = block;
14136 : }
14137 71 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
14138 : }
14139 :
14140 : /* Replace the first actual arg with the component of the
14141 : temporary. */
14142 71 : gfc_free_expr (this_code->ext.actual->expr);
14143 71 : this_code->ext.actual->expr = gfc_copy_expr (t1);
14144 71 : add_comp_ref (this_code->ext.actual->expr, comp1);
14145 :
14146 : /* If the LHS variable is allocatable and wasn't allocated and
14147 : the temporary is allocatable, pointer assign the address of
14148 : the freshly allocated LHS to the temporary. */
14149 71 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
14150 71 : && gfc_expr_attr ((*code)->expr1).allocatable)
14151 : {
14152 18 : gfc_code *block;
14153 18 : gfc_expr *cond;
14154 :
14155 18 : cond = gfc_get_expr ();
14156 18 : cond->ts.type = BT_LOGICAL;
14157 18 : cond->ts.kind = gfc_default_logical_kind;
14158 18 : cond->expr_type = EXPR_OP;
14159 18 : cond->where = (*code)->loc;
14160 18 : cond->value.op.op = INTRINSIC_NOT;
14161 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
14162 : GFC_ISYM_ALLOCATED, "allocated",
14163 18 : (*code)->loc, 1, gfc_copy_expr (t1));
14164 18 : block = gfc_get_code (EXEC_IF);
14165 18 : block->block = gfc_get_code (EXEC_IF);
14166 18 : block->block->expr1 = cond;
14167 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14168 : t1, (*code)->expr1,
14169 18 : NULL, NULL, (*code)->loc);
14170 18 : add_code_to_chain (&block, &head, &tail);
14171 : }
14172 : }
14173 : }
14174 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
14175 : {
14176 : /* Don't add intrinsic assignments since they are already
14177 : effected by the intrinsic assignment of the structure, unless
14178 : finalization is required or, with finalize_only, the structure
14179 : assignment does not copy the components. */
14180 7 : if (finalizable_comp)
14181 0 : this_code->expr1->must_finalize = 1;
14182 7 : else if (!use_finalize_only)
14183 : {
14184 1 : gfc_free_statements (this_code);
14185 1 : this_code = NULL;
14186 1 : continue;
14187 : }
14188 : }
14189 : else
14190 : {
14191 : /* Resolution has expanded an assignment of a derived type with
14192 : defined assigned components. Remove the redundant, leading
14193 : assignment. */
14194 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
14195 48 : gfc_code *tmp = this_code;
14196 48 : this_code = this_code->next;
14197 48 : tmp->next = NULL;
14198 48 : gfc_free_statements (tmp);
14199 : }
14200 :
14201 203 : add_code_to_chain (&this_code, &head, &tail);
14202 :
14203 203 : if (t1 && (inout || (finalizable_out && !use_finalize_only)))
14204 : {
14205 : /* Transfer the value to the final result. */
14206 142 : this_code = build_assignment (EXEC_ASSIGN,
14207 : (*code)->expr1, t1,
14208 71 : comp1, comp2, (*code)->loc);
14209 71 : this_code->expr1->must_finalize = 0;
14210 71 : add_code_to_chain (&this_code, &head, &tail);
14211 : }
14212 : }
14213 :
14214 : /* Put the temporary assignments at the top of the generated code. */
14215 188 : if (tmp_head && component_assignment_level == 1)
14216 : {
14217 114 : gfc_append_code (tmp_head, head);
14218 114 : head = tmp_head;
14219 114 : tmp_head = tmp_tail = NULL;
14220 : }
14221 :
14222 : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
14223 : not accidentally deallocated. Hence, nullify t1. */
14224 71 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
14225 259 : && gfc_expr_attr ((*code)->expr1).allocatable)
14226 : {
14227 18 : gfc_code *block;
14228 18 : gfc_expr *cond;
14229 18 : gfc_expr *e;
14230 :
14231 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
14232 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
14233 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
14234 18 : block = gfc_get_code (EXEC_IF);
14235 18 : block->block = gfc_get_code (EXEC_IF);
14236 18 : block->block->expr1 = cond;
14237 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14238 : t1, gfc_get_null_expr (&(*code)->loc),
14239 18 : NULL, NULL, (*code)->loc);
14240 18 : gfc_append_code (tail, block);
14241 18 : tail = block;
14242 : }
14243 :
14244 188 : component_assignment_level--;
14245 :
14246 : /* Make an explicit final call for the function result. */
14247 188 : if (tmp_expr)
14248 81 : generate_final_call (tmp_expr, &head, &tail);
14249 :
14250 188 : if (tmp_code)
14251 : {
14252 140 : ns->code = head;
14253 140 : return;
14254 : }
14255 :
14256 : /* Now attach the remaining code chain to the input code. Step on
14257 : to the end of the new code since resolution is complete. */
14258 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
14259 48 : tail->next = (*code)->next;
14260 : /* Overwrite 'code' because this would place the intrinsic assignment
14261 : before the temporary for the lhs is created. */
14262 48 : gfc_free_expr ((*code)->expr1);
14263 48 : gfc_free_expr ((*code)->expr2);
14264 48 : **code = *head;
14265 48 : if (head != tail)
14266 48 : free (head);
14267 48 : *code = tail;
14268 : }
14269 :
14270 :
14271 : /* F2008: Pointer function assignments are of the form:
14272 : ptr_fcn (args) = expr
14273 : This function breaks these assignments into two statements:
14274 : temporary_pointer => ptr_fcn(args)
14275 : temporary_pointer = expr */
14276 :
14277 : static bool
14278 290456 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
14279 : {
14280 290456 : gfc_expr *tmp_ptr_expr;
14281 290456 : gfc_code *this_code;
14282 290456 : gfc_component *comp;
14283 290456 : gfc_symbol *s;
14284 :
14285 290456 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
14286 : return false;
14287 :
14288 : /* Even if standard does not support this feature, continue to build
14289 : the two statements to avoid upsetting frontend_passes.c. */
14290 211 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
14291 : "%L", &(*code)->loc);
14292 :
14293 211 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
14294 :
14295 211 : if (comp)
14296 6 : s = comp->ts.interface;
14297 : else
14298 205 : s = (*code)->expr1->symtree->n.sym;
14299 :
14300 211 : if (s == NULL || !s->result->attr.pointer)
14301 : {
14302 5 : gfc_error ("The function result on the lhs of the assignment at "
14303 : "%L must have the pointer attribute.",
14304 5 : &(*code)->expr1->where);
14305 5 : (*code)->op = EXEC_NOP;
14306 5 : return false;
14307 : }
14308 :
14309 206 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
14310 :
14311 : /* get_temp_from_expression is set up for ordinary assignments. To that
14312 : end, where array bounds are not known, arrays are made allocatable.
14313 : Change the temporary to a pointer here. */
14314 206 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
14315 206 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
14316 206 : tmp_ptr_expr->where = (*code)->loc;
14317 :
14318 : /* A new charlen is required to ensure that the variable string length
14319 : is different to that of the original lhs for deferred results. */
14320 206 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
14321 : {
14322 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
14323 60 : tmp_ptr_expr->ts.deferred = 1;
14324 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
14325 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
14326 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
14327 : }
14328 :
14329 412 : this_code = build_assignment (EXEC_ASSIGN,
14330 : tmp_ptr_expr, (*code)->expr2,
14331 206 : NULL, NULL, (*code)->loc);
14332 206 : this_code->next = (*code)->next;
14333 206 : (*code)->next = this_code;
14334 206 : (*code)->op = EXEC_POINTER_ASSIGN;
14335 206 : (*code)->expr2 = (*code)->expr1;
14336 206 : (*code)->expr1 = tmp_ptr_expr;
14337 :
14338 206 : return true;
14339 : }
14340 :
14341 :
14342 : /* Deferred character length assignments from an operator expression
14343 : require a temporary because the character length of the lhs can
14344 : change in the course of the assignment. */
14345 :
14346 : static bool
14347 289278 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
14348 : {
14349 289278 : gfc_expr *tmp_expr;
14350 289278 : gfc_code *this_code;
14351 :
14352 289278 : if (!((*code)->expr1->ts.type == BT_CHARACTER
14353 27836 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
14354 860 : && (*code)->expr2->ts.type == BT_CHARACTER
14355 859 : && (*code)->expr2->expr_type == EXPR_OP))
14356 : return false;
14357 :
14358 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
14359 : return false;
14360 :
14361 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
14362 : return false;
14363 :
14364 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
14365 22 : tmp_expr->where = (*code)->loc;
14366 :
14367 : /* A new charlen is required to ensure that the variable string
14368 : length is different to that of the original lhs. */
14369 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
14370 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
14371 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
14372 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
14373 :
14374 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
14375 :
14376 22 : this_code = build_assignment (EXEC_ASSIGN,
14377 22 : (*code)->expr1,
14378 : gfc_copy_expr (tmp_expr),
14379 : NULL, NULL, (*code)->loc);
14380 :
14381 22 : (*code)->expr1 = tmp_expr;
14382 :
14383 22 : this_code->next = (*code)->next;
14384 22 : (*code)->next = this_code;
14385 :
14386 22 : return true;
14387 : }
14388 :
14389 : static void mark_lhs_assignments_set (gfc_code *code);
14390 :
14391 : /* Given a block of code, recursively resolve everything pointed to by this
14392 : code block. */
14393 :
14394 : void
14395 704492 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
14396 : {
14397 704492 : int omp_workshare_save;
14398 704492 : int forall_save, do_concurrent_save;
14399 704492 : code_stack frame;
14400 704492 : bool t;
14401 704492 : gfc_code *orig_code = code;
14402 :
14403 704492 : frame.prev = cs_base;
14404 704492 : frame.head = code;
14405 704492 : cs_base = &frame;
14406 :
14407 704492 : find_reachable_labels (code);
14408 :
14409 2569837 : for (; code; code = code->next)
14410 : {
14411 1160854 : frame.current = code;
14412 1160854 : forall_save = forall_flag;
14413 1160854 : do_concurrent_save = gfc_do_concurrent_flag;
14414 :
14415 1160854 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
14416 : {
14417 2345 : if (code->op == EXEC_FORALL)
14418 1993 : forall_flag = 1;
14419 352 : else if (code->op == EXEC_DO_CONCURRENT)
14420 352 : gfc_do_concurrent_flag = 1;
14421 2345 : gfc_resolve_forall (code, ns, forall_save);
14422 2345 : if (code->op == EXEC_FORALL)
14423 1993 : forall_flag = 2;
14424 352 : else if (code->op == EXEC_DO_CONCURRENT)
14425 352 : gfc_do_concurrent_flag = 2;
14426 : }
14427 1158509 : else if (code->op == EXEC_OMP_METADIRECTIVE)
14428 146 : for (gfc_omp_variant *variant
14429 : = code->ext.omp_variants;
14430 473 : variant; variant = variant->next)
14431 327 : gfc_resolve_code (variant->code, ns);
14432 1158363 : else if (code->block)
14433 : {
14434 336930 : omp_workshare_save = -1;
14435 336930 : switch (code->op)
14436 : {
14437 10119 : case EXEC_OACC_PARALLEL_LOOP:
14438 10119 : case EXEC_OACC_PARALLEL:
14439 10119 : case EXEC_OACC_KERNELS_LOOP:
14440 10119 : case EXEC_OACC_KERNELS:
14441 10119 : case EXEC_OACC_SERIAL_LOOP:
14442 10119 : case EXEC_OACC_SERIAL:
14443 10119 : case EXEC_OACC_DATA:
14444 10119 : case EXEC_OACC_HOST_DATA:
14445 10119 : case EXEC_OACC_LOOP:
14446 10119 : gfc_resolve_oacc_blocks (code, ns);
14447 10119 : break;
14448 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
14449 54 : omp_workshare_save = omp_workshare_flag;
14450 54 : omp_workshare_flag = 1;
14451 54 : gfc_resolve_omp_parallel_blocks (code, ns);
14452 54 : break;
14453 6075 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14454 6075 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14455 6075 : case EXEC_OMP_MASKED_TASKLOOP:
14456 6075 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14457 6075 : case EXEC_OMP_MASTER_TASKLOOP:
14458 6075 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14459 6075 : case EXEC_OMP_PARALLEL:
14460 6075 : case EXEC_OMP_PARALLEL_DO:
14461 6075 : case EXEC_OMP_PARALLEL_DO_SIMD:
14462 6075 : case EXEC_OMP_PARALLEL_LOOP:
14463 6075 : case EXEC_OMP_PARALLEL_MASKED:
14464 6075 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14465 6075 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14466 6075 : case EXEC_OMP_PARALLEL_MASTER:
14467 6075 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14468 6075 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14469 6075 : case EXEC_OMP_PARALLEL_SECTIONS:
14470 6075 : case EXEC_OMP_TARGET_PARALLEL:
14471 6075 : case EXEC_OMP_TARGET_PARALLEL_DO:
14472 6075 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14473 6075 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14474 6075 : case EXEC_OMP_TARGET_TEAMS:
14475 6075 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14476 6075 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14477 6075 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14478 6075 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14479 6075 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14480 6075 : case EXEC_OMP_TASK:
14481 6075 : case EXEC_OMP_TASKLOOP:
14482 6075 : case EXEC_OMP_TASKLOOP_SIMD:
14483 6075 : case EXEC_OMP_TEAMS:
14484 6075 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14485 6075 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14486 6075 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14487 6075 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14488 6075 : case EXEC_OMP_TEAMS_LOOP:
14489 6075 : omp_workshare_save = omp_workshare_flag;
14490 6075 : omp_workshare_flag = 0;
14491 6075 : gfc_resolve_omp_parallel_blocks (code, ns);
14492 6075 : break;
14493 3088 : case EXEC_OMP_DISTRIBUTE:
14494 3088 : case EXEC_OMP_DISTRIBUTE_SIMD:
14495 3088 : case EXEC_OMP_DO:
14496 3088 : case EXEC_OMP_DO_SIMD:
14497 3088 : case EXEC_OMP_LOOP:
14498 3088 : case EXEC_OMP_SIMD:
14499 3088 : case EXEC_OMP_TARGET_SIMD:
14500 3088 : case EXEC_OMP_TILE:
14501 3088 : case EXEC_OMP_UNROLL:
14502 3088 : gfc_resolve_omp_do_blocks (code, ns);
14503 3088 : break;
14504 : case EXEC_SELECT_TYPE:
14505 : case EXEC_SELECT_RANK:
14506 : /* Blocks are handled in resolve_select_type/rank because we
14507 : have to transform the SELECT TYPE into ASSOCIATE first. */
14508 : break;
14509 : case EXEC_DO_CONCURRENT:
14510 : gfc_do_concurrent_flag = 1;
14511 : gfc_resolve_blocks (code->block, ns);
14512 : gfc_do_concurrent_flag = 2;
14513 : break;
14514 39 : case EXEC_OMP_WORKSHARE:
14515 39 : omp_workshare_save = omp_workshare_flag;
14516 39 : omp_workshare_flag = 1;
14517 : /* FALL THROUGH */
14518 313353 : default:
14519 313353 : gfc_resolve_blocks (code->block, ns);
14520 313353 : break;
14521 : }
14522 :
14523 332689 : if (omp_workshare_save != -1)
14524 6168 : omp_workshare_flag = omp_workshare_save;
14525 : }
14526 1160854 : start:
14527 1161065 : t = true;
14528 1161065 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14529 1159628 : t = gfc_resolve_expr (code->expr1);
14530 :
14531 1161065 : forall_flag = forall_save;
14532 1161065 : gfc_do_concurrent_flag = do_concurrent_save;
14533 :
14534 1161065 : if (!gfc_resolve_expr (code->expr2))
14535 646 : t = false;
14536 :
14537 1161065 : if (code->op == EXEC_ALLOCATE
14538 1161065 : && !gfc_resolve_expr (code->expr3))
14539 : t = false;
14540 :
14541 1161065 : switch (code->op)
14542 : {
14543 : case EXEC_NOP:
14544 : case EXEC_END_BLOCK:
14545 : case EXEC_END_NESTED_BLOCK:
14546 : case EXEC_CYCLE:
14547 : break;
14548 :
14549 222436 : case EXEC_STOP:
14550 222436 : case EXEC_ERROR_STOP:
14551 222436 : if (code->expr1 != NULL && t)
14552 : {
14553 201920 : if (!(code->expr1->ts.type == BT_CHARACTER
14554 : || code->expr1->ts.type == BT_INTEGER))
14555 1 : gfc_error ("STOP code at %L must be either INTEGER or CHARACTER "
14556 : "type", &code->expr1->where);
14557 201919 : else if (code->expr1->rank != 0)
14558 0 : gfc_error ("STOP code at %L must be scalar",
14559 : &code->expr1->where);
14560 201919 : else if (code->expr1->ts.type == BT_CHARACTER
14561 498 : && code->expr1->ts.kind != gfc_default_character_kind)
14562 0 : gfc_error ("STOP code at %L must be default character KIND=%d",
14563 : &code->expr1->where, (int) gfc_default_character_kind);
14564 201919 : else if (code->expr1->ts.type == BT_INTEGER
14565 201421 : && code->expr1->ts.kind != gfc_default_integer_kind)
14566 8 : gfc_notify_std (GFC_STD_F2018, "STOP code at %L must be default "
14567 : "integer KIND=%d", &code->expr1->where,
14568 : (int) gfc_default_integer_kind);
14569 : }
14570 222436 : if (code->expr2 != NULL
14571 37 : && (code->expr2->ts.type != BT_LOGICAL
14572 37 : || code->expr2->rank != 0))
14573 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14574 : &code->expr2->where);
14575 :
14576 : /* Fall through. */
14577 222466 : case EXEC_PAUSE:
14578 222466 : gfc_value_used_expr (code->expr1, VALUE_USED);
14579 222466 : break;
14580 :
14581 : case EXEC_EXIT:
14582 : case EXEC_CONTINUE:
14583 : case EXEC_DT_END:
14584 : case EXEC_ASSIGN_CALL:
14585 : break;
14586 :
14587 54 : case EXEC_CRITICAL:
14588 54 : resolve_critical (code);
14589 54 : break;
14590 :
14591 1435 : case EXEC_SYNC_ALL:
14592 1435 : case EXEC_SYNC_IMAGES:
14593 1435 : case EXEC_SYNC_MEMORY:
14594 1435 : resolve_sync (code);
14595 1435 : break;
14596 :
14597 197 : case EXEC_LOCK:
14598 197 : case EXEC_UNLOCK:
14599 197 : case EXEC_EVENT_POST:
14600 197 : case EXEC_EVENT_WAIT:
14601 197 : resolve_lock_unlock_event (code);
14602 197 : break;
14603 :
14604 : case EXEC_FAIL_IMAGE:
14605 : break;
14606 :
14607 184 : case EXEC_FORM_TEAM:
14608 184 : resolve_form_team (code);
14609 184 : break;
14610 :
14611 131 : case EXEC_CHANGE_TEAM:
14612 131 : resolve_change_team (code);
14613 131 : break;
14614 :
14615 129 : case EXEC_END_TEAM:
14616 129 : resolve_end_team (code);
14617 129 : break;
14618 :
14619 48 : case EXEC_SYNC_TEAM:
14620 48 : resolve_sync_team (code);
14621 48 : break;
14622 :
14623 1491 : case EXEC_ENTRY:
14624 : /* Keep track of which entry we are up to. */
14625 1491 : current_entry_id = code->ext.entry->id;
14626 1491 : break;
14627 :
14628 459 : case EXEC_WHERE:
14629 459 : resolve_where (code, NULL);
14630 459 : break;
14631 :
14632 1304 : case EXEC_GOTO:
14633 1304 : if (code->expr1 != NULL)
14634 : {
14635 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14636 76 : || code->expr1->ts.type != BT_INTEGER
14637 76 : || (code->expr1->ref
14638 1 : && code->expr1->ref->type == REF_ARRAY)
14639 75 : || code->expr1->symtree == NULL
14640 75 : || (code->expr1->symtree->n.sym
14641 75 : && (code->expr1->symtree->n.sym->attr.flavor
14642 75 : == FL_PARAMETER)))
14643 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14644 : "scalar INTEGER variable", &code->expr1->where);
14645 74 : else if (code->expr1->symtree->n.sym
14646 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14647 1 : gfc_error ("Variable %qs has not been assigned a target "
14648 : "label at %L", code->expr1->symtree->n.sym->name,
14649 : &code->expr1->where);
14650 : }
14651 : else
14652 1226 : resolve_branch (code->label1, code);
14653 : break;
14654 :
14655 3272 : case EXEC_RETURN:
14656 3272 : if (code->expr1 != NULL
14657 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14658 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14659 : "INTEGER return specifier", &code->expr1->where);
14660 : break;
14661 :
14662 : case EXEC_INIT_ASSIGN:
14663 : case EXEC_END_PROCEDURE:
14664 : break;
14665 :
14666 291640 : case EXEC_ASSIGN:
14667 291640 : if (!t)
14668 : break;
14669 :
14670 290956 : if (flag_coarray == GFC_FCOARRAY_LIB
14671 290956 : && gfc_is_coindexed (code->expr1))
14672 : {
14673 : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14674 : coindexed variable. */
14675 500 : code->op = EXEC_CALL;
14676 500 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14677 : true);
14678 500 : code->resolved_sym = code->symtree->n.sym;
14679 500 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14680 500 : code->resolved_sym->attr.intrinsic = 1;
14681 500 : code->resolved_sym->attr.subroutine = 1;
14682 500 : code->resolved_isym
14683 500 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14684 500 : gfc_commit_symbol (code->resolved_sym);
14685 500 : code->ext.actual = gfc_get_actual_arglist ();
14686 500 : code->ext.actual->expr = code->expr1;
14687 500 : code->ext.actual->next = gfc_get_actual_arglist ();
14688 500 : if (code->expr2->expr_type != EXPR_VARIABLE
14689 500 : && code->expr2->expr_type != EXPR_CONSTANT)
14690 : {
14691 : /* Convert assignments of expr1[...] = expr2 into
14692 : tvar = expr2
14693 : expr1[...] = tvar
14694 : when expr2 is not trivial. */
14695 54 : gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
14696 54 : gfc_code next_code = *code;
14697 54 : gfc_code *rhs_code
14698 108 : = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
14699 54 : NULL, code->expr2->where);
14700 54 : *code = *rhs_code;
14701 54 : code->next = rhs_code;
14702 54 : *rhs_code = next_code;
14703 :
14704 54 : rhs_code->ext.actual->next->expr = tvar;
14705 54 : rhs_code->expr1 = NULL;
14706 54 : rhs_code->expr2 = NULL;
14707 : }
14708 : else
14709 : {
14710 446 : code->ext.actual->next->expr = code->expr2;
14711 :
14712 446 : code->expr1 = NULL;
14713 446 : code->expr2 = NULL;
14714 : }
14715 : break;
14716 : }
14717 :
14718 290456 : if (code->expr1->ts.type == BT_CLASS)
14719 1169 : gfc_find_vtab (&code->expr2->ts);
14720 :
14721 : /* If this is a pointer function in an lvalue variable context,
14722 : the new code will have to be resolved afresh. This is also the
14723 : case with an error, where the code is transformed into NOP to
14724 : prevent ICEs downstream. */
14725 290456 : if (resolve_ptr_fcn_assign (&code, ns)
14726 290456 : || code->op == EXEC_NOP)
14727 211 : goto start;
14728 :
14729 290245 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14730 290245 : _("assignment")))
14731 : break;
14732 :
14733 290202 : if (resolve_ordinary_assign (code, ns))
14734 : {
14735 924 : if (omp_workshare_flag)
14736 : {
14737 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14738 1 : "at %L", &code->loc);
14739 1 : break;
14740 : }
14741 923 : if (code->op == EXEC_COMPCALL)
14742 455 : goto compcall;
14743 : else
14744 468 : goto call;
14745 : }
14746 :
14747 : /* Check for dependencies in deferred character length array
14748 : assignments and generate a temporary, if necessary. */
14749 289278 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14750 : break;
14751 :
14752 : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14753 289256 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14754 7570 : && code->expr1->ts.u.derived
14755 7570 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14756 194 : generate_component_assignments (&code, ns);
14757 289062 : else if (code->op == EXEC_ASSIGN)
14758 : {
14759 289062 : if (gfc_may_be_finalized (code->expr1->ts))
14760 1368 : code->expr1->must_finalize = 1;
14761 289062 : if (code->expr2->expr_type == EXPR_ARRAY
14762 289062 : && gfc_may_be_finalized (code->expr2->ts))
14763 79 : code->expr2->must_finalize = 1;
14764 : }
14765 :
14766 : break;
14767 :
14768 126 : case EXEC_LABEL_ASSIGN:
14769 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14770 0 : gfc_error ("Label %d referenced at %L is never defined",
14771 : code->label1->value, &code->label1->where);
14772 126 : if (t
14773 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14774 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14775 126 : || code->expr1->symtree->n.sym->ts.kind
14776 126 : != gfc_default_integer_kind
14777 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14778 125 : || code->expr1->symtree->n.sym->as != NULL))
14779 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14780 : "default INTEGER variable", &code->expr1->where);
14781 : break;
14782 :
14783 10758 : case EXEC_POINTER_ASSIGN:
14784 10758 : {
14785 10758 : gfc_expr* e;
14786 :
14787 10758 : if (!t)
14788 : break;
14789 :
14790 : /* This is both a variable definition and pointer assignment
14791 : context, so check both of them. For rank remapping, a final
14792 : array ref may be present on the LHS and fool gfc_expr_attr
14793 : used in gfc_check_vardef_context. Remove it. */
14794 10753 : e = remove_last_array_ref (code->expr1);
14795 21506 : t = gfc_check_vardef_context (e, true, false, false,
14796 10753 : _("pointer assignment"));
14797 10753 : if (t)
14798 10724 : t = gfc_check_vardef_context (e, false, false, false,
14799 10724 : _("pointer assignment"));
14800 10753 : gfc_free_expr (e);
14801 :
14802 10753 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14803 :
14804 10608 : if (!t)
14805 : break;
14806 :
14807 : /* Assigning a class object always is a regular assign. */
14808 10608 : if (code->expr2->ts.type == BT_CLASS
14809 612 : && code->expr1->ts.type == BT_CLASS
14810 515 : && CLASS_DATA (code->expr2)
14811 514 : && !CLASS_DATA (code->expr2)->attr.dimension
14812 11275 : && !(gfc_expr_attr (code->expr1).proc_pointer
14813 55 : && code->expr2->expr_type == EXPR_VARIABLE
14814 43 : && code->expr2->symtree->n.sym->attr.flavor
14815 43 : == FL_PROCEDURE))
14816 340 : code->op = EXEC_ASSIGN;
14817 : break;
14818 : }
14819 :
14820 72 : case EXEC_ARITHMETIC_IF:
14821 72 : {
14822 72 : gfc_expr *e = code->expr1;
14823 :
14824 72 : gfc_resolve_expr (e);
14825 72 : if (e->expr_type == EXPR_NULL)
14826 1 : gfc_error ("Invalid NULL at %L", &e->where);
14827 :
14828 72 : if (t && (e->rank > 0
14829 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14830 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14831 : "REAL or INTEGER expression", &e->where);
14832 :
14833 72 : resolve_branch (code->label1, code);
14834 72 : resolve_branch (code->label2, code);
14835 72 : resolve_branch (code->label3, code);
14836 : }
14837 72 : break;
14838 :
14839 236208 : case EXEC_IF:
14840 236208 : if (t && code->expr1 != NULL
14841 0 : && (code->expr1->ts.type != BT_LOGICAL
14842 0 : || code->expr1->rank != 0))
14843 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14844 : &code->expr1->where);
14845 : break;
14846 :
14847 81415 : case EXEC_CALL:
14848 81415 : call:
14849 81415 : resolve_call (code);
14850 81415 : break;
14851 :
14852 1768 : case EXEC_COMPCALL:
14853 1768 : compcall:
14854 1768 : resolve_typebound_subroutine (code);
14855 1768 : break;
14856 :
14857 124 : case EXEC_CALL_PPC:
14858 124 : resolve_ppc_call (code);
14859 124 : break;
14860 :
14861 705 : case EXEC_SELECT:
14862 : /* Select is complicated. Also, a SELECT construct could be
14863 : a transformed computed GOTO. */
14864 705 : resolve_select (code, false);
14865 705 : break;
14866 :
14867 3219 : case EXEC_SELECT_TYPE:
14868 3219 : resolve_select_type (code, ns);
14869 3219 : break;
14870 :
14871 1048 : case EXEC_SELECT_RANK:
14872 1048 : resolve_select_rank (code, ns);
14873 1048 : break;
14874 :
14875 8583 : case EXEC_BLOCK:
14876 8583 : resolve_block_construct (code);
14877 8583 : break;
14878 :
14879 33475 : case EXEC_DO:
14880 33475 : if (code->ext.iterator != NULL)
14881 : {
14882 33475 : gfc_iterator *iter = code->ext.iterator;
14883 33475 : if (gfc_resolve_iterator (iter, true, false))
14884 33461 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14885 : true);
14886 : }
14887 : break;
14888 :
14889 552 : case EXEC_DO_WHILE:
14890 552 : if (code->expr1 == NULL)
14891 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14892 : "DO WHILE");
14893 552 : if (t
14894 552 : && (code->expr1->rank != 0
14895 552 : || code->expr1->ts.type != BT_LOGICAL))
14896 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14897 : "a scalar LOGICAL expression", &code->expr1->where);
14898 : break;
14899 :
14900 14851 : case EXEC_ALLOCATE:
14901 14851 : if (t)
14902 14849 : resolve_allocate_deallocate (code, "ALLOCATE");
14903 :
14904 : break;
14905 :
14906 6282 : case EXEC_DEALLOCATE:
14907 6282 : if (t)
14908 6282 : resolve_allocate_deallocate (code, "DEALLOCATE");
14909 :
14910 : break;
14911 :
14912 3967 : case EXEC_OPEN:
14913 3967 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14914 : break;
14915 :
14916 3740 : resolve_branch (code->ext.open->err, code);
14917 3740 : break;
14918 :
14919 3160 : case EXEC_CLOSE:
14920 3160 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14921 : break;
14922 :
14923 3126 : resolve_branch (code->ext.close->err, code);
14924 3126 : break;
14925 :
14926 2863 : case EXEC_BACKSPACE:
14927 2863 : case EXEC_ENDFILE:
14928 2863 : case EXEC_REWIND:
14929 2863 : case EXEC_FLUSH:
14930 2863 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14931 : break;
14932 :
14933 2797 : resolve_branch (code->ext.filepos->err, code);
14934 2797 : break;
14935 :
14936 838 : case EXEC_INQUIRE:
14937 838 : if (!gfc_resolve_inquire (code->ext.inquire))
14938 : break;
14939 :
14940 790 : resolve_branch (code->ext.inquire->err, code);
14941 790 : break;
14942 :
14943 92 : case EXEC_IOLENGTH:
14944 92 : gcc_assert (code->ext.inquire != NULL);
14945 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14946 : break;
14947 :
14948 90 : resolve_branch (code->ext.inquire->err, code);
14949 90 : break;
14950 :
14951 89 : case EXEC_WAIT:
14952 89 : if (!gfc_resolve_wait (code->ext.wait))
14953 : break;
14954 :
14955 74 : resolve_branch (code->ext.wait->err, code);
14956 74 : resolve_branch (code->ext.wait->end, code);
14957 74 : resolve_branch (code->ext.wait->eor, code);
14958 74 : break;
14959 :
14960 33749 : case EXEC_READ:
14961 33749 : case EXEC_WRITE:
14962 33749 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14963 : break;
14964 :
14965 33441 : resolve_branch (code->ext.dt->err, code);
14966 33441 : resolve_branch (code->ext.dt->end, code);
14967 33441 : resolve_branch (code->ext.dt->eor, code);
14968 33441 : break;
14969 :
14970 47876 : case EXEC_TRANSFER:
14971 47876 : resolve_transfer (code);
14972 47876 : break;
14973 :
14974 2345 : case EXEC_DO_CONCURRENT:
14975 2345 : case EXEC_FORALL:
14976 2345 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14977 :
14978 2345 : if (code->expr1 != NULL
14979 732 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14980 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14981 : "expression", &code->expr1->where);
14982 :
14983 2345 : if (code->op == EXEC_DO_CONCURRENT)
14984 352 : resolve_locality_spec (code, ns);
14985 : break;
14986 :
14987 13538 : case EXEC_OACC_PARALLEL_LOOP:
14988 13538 : case EXEC_OACC_PARALLEL:
14989 13538 : case EXEC_OACC_KERNELS_LOOP:
14990 13538 : case EXEC_OACC_KERNELS:
14991 13538 : case EXEC_OACC_SERIAL_LOOP:
14992 13538 : case EXEC_OACC_SERIAL:
14993 13538 : case EXEC_OACC_DATA:
14994 13538 : case EXEC_OACC_HOST_DATA:
14995 13538 : case EXEC_OACC_LOOP:
14996 13538 : case EXEC_OACC_UPDATE:
14997 13538 : case EXEC_OACC_WAIT:
14998 13538 : case EXEC_OACC_CACHE:
14999 13538 : case EXEC_OACC_ENTER_DATA:
15000 13538 : case EXEC_OACC_EXIT_DATA:
15001 13538 : case EXEC_OACC_ATOMIC:
15002 13538 : case EXEC_OACC_DECLARE:
15003 13538 : case EXEC_OACC_INIT:
15004 13538 : case EXEC_OACC_SHUTDOWN:
15005 13538 : case EXEC_OACC_SET:
15006 13538 : gfc_resolve_oacc_directive (code, ns);
15007 13538 : break;
15008 :
15009 17448 : case EXEC_OMP_ALLOCATE:
15010 17448 : case EXEC_OMP_ALLOCATORS:
15011 17448 : case EXEC_OMP_ASSUME:
15012 17448 : case EXEC_OMP_ATOMIC:
15013 17448 : case EXEC_OMP_BARRIER:
15014 17448 : case EXEC_OMP_CANCEL:
15015 17448 : case EXEC_OMP_CANCELLATION_POINT:
15016 17448 : case EXEC_OMP_CRITICAL:
15017 17448 : case EXEC_OMP_FLUSH:
15018 17448 : case EXEC_OMP_DEPOBJ:
15019 17448 : case EXEC_OMP_DISPATCH:
15020 17448 : case EXEC_OMP_DISTRIBUTE:
15021 17448 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
15022 17448 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
15023 17448 : case EXEC_OMP_DISTRIBUTE_SIMD:
15024 17448 : case EXEC_OMP_DO:
15025 17448 : case EXEC_OMP_DO_SIMD:
15026 17448 : case EXEC_OMP_ERROR:
15027 17448 : case EXEC_OMP_INTEROP:
15028 17448 : case EXEC_OMP_LOOP:
15029 17448 : case EXEC_OMP_MASTER:
15030 17448 : case EXEC_OMP_MASTER_TASKLOOP:
15031 17448 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
15032 17448 : case EXEC_OMP_MASKED:
15033 17448 : case EXEC_OMP_MASKED_TASKLOOP:
15034 17448 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
15035 17448 : case EXEC_OMP_METADIRECTIVE:
15036 17448 : case EXEC_OMP_ORDERED:
15037 17448 : case EXEC_OMP_SCAN:
15038 17448 : case EXEC_OMP_SCOPE:
15039 17448 : case EXEC_OMP_SECTIONS:
15040 17448 : case EXEC_OMP_SIMD:
15041 17448 : case EXEC_OMP_SINGLE:
15042 17448 : case EXEC_OMP_TARGET:
15043 17448 : case EXEC_OMP_TARGET_DATA:
15044 17448 : case EXEC_OMP_TARGET_ENTER_DATA:
15045 17448 : case EXEC_OMP_TARGET_EXIT_DATA:
15046 17448 : case EXEC_OMP_TARGET_PARALLEL:
15047 17448 : case EXEC_OMP_TARGET_PARALLEL_DO:
15048 17448 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
15049 17448 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
15050 17448 : case EXEC_OMP_TARGET_SIMD:
15051 17448 : case EXEC_OMP_TARGET_TEAMS:
15052 17448 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
15053 17448 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
15054 17448 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
15055 17448 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
15056 17448 : case EXEC_OMP_TARGET_TEAMS_LOOP:
15057 17448 : case EXEC_OMP_TARGET_UPDATE:
15058 17448 : case EXEC_OMP_TASK:
15059 17448 : case EXEC_OMP_TASKGROUP:
15060 17448 : case EXEC_OMP_TASKLOOP:
15061 17448 : case EXEC_OMP_TASKLOOP_SIMD:
15062 17448 : case EXEC_OMP_TASKWAIT:
15063 17448 : case EXEC_OMP_TASKYIELD:
15064 17448 : case EXEC_OMP_TEAMS:
15065 17448 : case EXEC_OMP_TEAMS_DISTRIBUTE:
15066 17448 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
15067 17448 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
15068 17448 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
15069 17448 : case EXEC_OMP_TEAMS_LOOP:
15070 17448 : case EXEC_OMP_TILE:
15071 17448 : case EXEC_OMP_UNROLL:
15072 17448 : case EXEC_OMP_WORKSHARE:
15073 17448 : gfc_resolve_omp_directive (code, ns);
15074 17448 : break;
15075 :
15076 3937 : case EXEC_OMP_PARALLEL:
15077 3937 : case EXEC_OMP_PARALLEL_DO:
15078 3937 : case EXEC_OMP_PARALLEL_DO_SIMD:
15079 3937 : case EXEC_OMP_PARALLEL_LOOP:
15080 3937 : case EXEC_OMP_PARALLEL_MASKED:
15081 3937 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
15082 3937 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
15083 3937 : case EXEC_OMP_PARALLEL_MASTER:
15084 3937 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
15085 3937 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
15086 3937 : case EXEC_OMP_PARALLEL_SECTIONS:
15087 3937 : case EXEC_OMP_PARALLEL_WORKSHARE:
15088 3937 : omp_workshare_save = omp_workshare_flag;
15089 3937 : omp_workshare_flag = 0;
15090 3937 : gfc_resolve_omp_directive (code, ns);
15091 3937 : omp_workshare_flag = omp_workshare_save;
15092 3937 : break;
15093 :
15094 0 : default:
15095 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
15096 : }
15097 1160853 : gfc_value_used_expr (code->expr2, VALUE_USED);
15098 1160853 : gfc_value_used_expr (code->expr3, VALUE_USED);
15099 1160853 : gfc_value_used_expr (code->expr4, VALUE_USED);
15100 : }
15101 :
15102 704491 : mark_lhs_assignments_set (orig_code);
15103 :
15104 704491 : cs_base = frame.prev;
15105 704491 : }
15106 :
15107 :
15108 : /* Resolve initial values and make sure they are compatible with
15109 : the variable. */
15110 :
15111 : static void
15112 1961291 : resolve_values (gfc_symbol *sym)
15113 : {
15114 1961291 : bool t;
15115 :
15116 1961291 : if (sym->value == NULL)
15117 : return;
15118 :
15119 448354 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
15120 14 : gfc_warning (OPT_Wdeprecated_declarations,
15121 : "Using parameter %qs declared at %L is deprecated",
15122 : sym->name, &sym->declared_at);
15123 :
15124 448354 : if (sym->value->expr_type == EXPR_STRUCTURE)
15125 41751 : t= resolve_structure_cons (sym->value, 1);
15126 : else
15127 406603 : t = gfc_resolve_expr (sym->value);
15128 :
15129 448354 : if (!t)
15130 : return;
15131 :
15132 448352 : gfc_check_assign_symbol (sym, NULL, sym->value);
15133 : }
15134 :
15135 :
15136 : /* Verify any BIND(C) derived types in the namespace so we can report errors
15137 : for them once, rather than for each variable declared of that type. */
15138 :
15139 : static void
15140 1929979 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
15141 : {
15142 1929979 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
15143 87786 : && derived_sym->attr.is_bind_c == 1)
15144 27891 : verify_bind_c_derived_type (derived_sym);
15145 :
15146 1929979 : return;
15147 : }
15148 :
15149 :
15150 : /* Check the interfaces of DTIO procedures associated with derived
15151 : type 'sym'. These procedures can either have typebound bindings or
15152 : can appear in DTIO generic interfaces. */
15153 :
15154 : static void
15155 1962262 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
15156 : {
15157 1962262 : if (!sym || sym->attr.flavor != FL_DERIVED)
15158 : return;
15159 :
15160 97710 : gfc_check_dtio_interfaces (sym);
15161 :
15162 97710 : return;
15163 : }
15164 :
15165 : /* Auxiliary function, checks if an argument decays to a pointer. */
15166 :
15167 : static bool
15168 70442 : decays_to_pointer (gfc_symbol *sym)
15169 : {
15170 70442 : if (!sym->as)
15171 : return true;
15172 :
15173 19603 : if (sym->as->type == AS_ASSUMED_SHAPE)
15174 : return false;
15175 :
15176 15846 : if (sym->as->type == AS_ASSUMED_RANK)
15177 : return false;
15178 :
15179 10748 : if (sym->as->type == AS_DEFERRED && sym->attr.dummy)
15180 968 : return false;
15181 :
15182 : return true;
15183 : }
15184 :
15185 : /* Helper function, returns true if the types conform according to the C
15186 : standard, when they are not equal on the Fortran side. If we decide to
15187 : include or exclude any types from this, this is the place to change. */
15188 :
15189 : static bool
15190 390 : c_types_conform (gfc_typespec *ts1, gfc_typespec *ts2)
15191 : {
15192 390 : if (ts1->type == BT_ASSUMED || ts2->type == BT_ASSUMED)
15193 : return true;
15194 :
15195 384 : if (ts1->kind == ts2->kind
15196 : && (ts1->type == BT_CHARACTER || ts1->type == BT_INTEGER
15197 : || ts1->type == BT_UNSIGNED)
15198 : && (ts2->type == BT_CHARACTER || ts2->type == BT_INTEGER
15199 : || ts2->type == BT_UNSIGNED))
15200 384 : return true;
15201 :
15202 : return false;
15203 :
15204 : }
15205 :
15206 : /* Check argument lists of BIND(C) procedures against each other, return
15207 : false if they do not. */
15208 :
15209 : static bool
15210 12888 : compare_c_binding_arglists (gfc_symbol *osym, gfc_symbol *nsym)
15211 : {
15212 12888 : gfc_formal_arglist *oarg, *narg;
15213 12888 : bool ret = true;
15214 12888 : locus *oloc, *nloc;
15215 :
15216 12888 : oarg = osym->formal;
15217 12888 : narg = nsym->formal;
15218 12888 : oloc = &osym->declared_at;
15219 12888 : nloc = &nsym->declared_at;
15220 48119 : for ( ; oarg && narg ; oarg = oarg->next, narg = narg->next)
15221 : {
15222 35231 : oloc = &oarg->sym->declared_at;
15223 35231 : nloc = &narg->sym->declared_at;
15224 :
15225 35231 : if (!gfc_compare_types (&oarg->sym->ts, &narg->sym->ts)
15226 35231 : && (pedantic || !c_types_conform (&oarg->sym->ts, &narg->sym->ts)))
15227 : {
15228 24 : gfc_error ("Type mismatch in argument %qs at %L (%s/%s) "
15229 8 : "originally declared at %L", narg->sym->name,
15230 8 : nloc, gfc_typename (&narg->sym->ts),
15231 8 : gfc_typename (&oarg->sym->ts), oloc);
15232 8 : ret = false;
15233 8 : continue;
15234 : }
15235 35223 : if (oarg->sym->attr.value != narg->sym->attr.value)
15236 : {
15237 1 : gfc_error ("VALUE attribute mismatch in argument %qs at %L "
15238 : "originally declared at %L",narg->sym->name,
15239 : nloc, oloc);
15240 1 : ret = false;
15241 1 : continue;
15242 : }
15243 :
15244 : /* According to the Fortran standard, ranks have to match for arguments.
15245 : In this case, this makes little sense because both decay to C
15246 : pointers. Only issue an error if -pedantic or if the argument does
15247 : not decay to a pointer. Same thing for CFI_desc arrays, which include
15248 : assumed rank. */
15249 :
15250 35222 : int orank = gfc_symbol_rank (oarg->sym);
15251 35222 : int nrank = gfc_symbol_rank (narg->sym);
15252 35222 : if (orank != nrank && pedantic)
15253 : {
15254 1 : gfc_error ("Rank mismatch in argument %qs (%d/%d) at %L originally "
15255 1 : "declared at %L", narg->sym->name, nrank, orank, nloc,
15256 : oloc);
15257 1 : ret = false;
15258 1 : continue;
15259 : }
15260 :
15261 : /* Confusion between CFI_desc and "normal" arrays. */
15262 :
15263 35221 : if (decays_to_pointer (oarg->sym) != decays_to_pointer (narg->sym))
15264 : {
15265 1 : gfc_error ("Array specification mismatch in argument %qs at %L "
15266 : "originally declared at %L", narg->sym->name,
15267 : nloc, oloc);
15268 1 : ret = false;
15269 1 : continue;
15270 : }
15271 : }
15272 :
15273 12888 : if (oarg && !narg)
15274 : {
15275 0 : gfc_error ("Not enough arguments for procedure %qs with binding label "
15276 : "%qs after %L, originally declared at %L", nsym->name,
15277 0 : nsym->binding_label, nloc, &oarg->sym->declared_at);
15278 0 : ret = false;
15279 : }
15280 :
15281 12888 : if (!oarg && narg)
15282 : {
15283 2 : gfc_error ("Too many arguments for procedure %qs with binding label "
15284 : "%qs at %L, originally declared at %L", nsym->name,
15285 2 : nsym->binding_label, &narg->sym->declared_at, oloc);
15286 2 : ret = false;
15287 : }
15288 :
15289 12888 : return ret;
15290 : }
15291 :
15292 :
15293 : /* Verify that any binding labels used in a given namespace do not collide
15294 : with the names or binding labels of any global symbols. Multiple INTERFACE
15295 : for the same procedure are permitted. Abstract interfaces and dummy
15296 : arguments are not checked. */
15297 :
15298 : static void
15299 1962262 : gfc_verify_binding_labels (gfc_symbol *sym)
15300 : {
15301 1962262 : gfc_gsymbol *gsym;
15302 1962262 : const char *module;
15303 :
15304 1962262 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
15305 70696 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
15306 41864 : || sym->attr.abstract || sym->attr.dummy)
15307 : return;
15308 :
15309 : /* Avoid double error reporting. */
15310 41728 : if (sym->error)
15311 : return;
15312 :
15313 : /* TODO: Check the names of reserved external C identifiers here, see
15314 : PR 125251. */
15315 :
15316 : /* According to the Fortran standard, global identifiers are case
15317 : insensitive, which also holds for C identifiers. This was probably done
15318 : for systems which had case-insensitive linkers. Such systems could not
15319 : accommodate the C standards referenced, so this restriction makes little
15320 : sense for modern systems. Therefore, check case-sensitive labels unless
15321 : -pedantic is in force. */
15322 :
15323 41728 : if (pedantic)
15324 4681 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
15325 : else
15326 37047 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
15327 :
15328 41728 : if (sym->module)
15329 : module = sym->module;
15330 13145 : else if (sym->ns && sym->ns->proc_name
15331 13145 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
15332 4603 : module = sym->ns->proc_name->name;
15333 8542 : else if (sym->ns && sym->ns->parent
15334 358 : && sym->ns && sym->ns->parent->proc_name
15335 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15336 272 : module = sym->ns->parent->proc_name->name;
15337 : else
15338 : module = NULL;
15339 :
15340 41728 : if (gsym)
15341 : {
15342 12932 : if (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)
15343 : {
15344 12891 : gfc_symbol *global_sym;
15345 12891 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &global_sym);
15346 :
15347 : /* For when the symtree does not match the symbol name, which can happen
15348 : in modules with PRIVATE. */
15349 :
15350 12891 : if (global_sym == NULL)
15351 1 : gfc_find_symbol_by_name (gsym->sym_name, gsym->ns, &global_sym);
15352 :
15353 12891 : gcc_assert (global_sym);
15354 :
15355 : /* If subroutines and functions are conflated, there is little point
15356 : in continuing checks. */
15357 12891 : if ((sym->attr.function && gsym->type == GSYM_SUBROUTINE)
15358 12891 : || (sym->attr.subroutine && gsym->type == GSYM_FUNCTION))
15359 : {
15360 1 : gfc_global_used (gsym, &sym->declared_at);
15361 1 : sym->binding_label = NULL;
15362 1 : sym->error = 1;
15363 13 : return;
15364 : }
15365 :
15366 7254 : if (gsym->type == GSYM_FUNCTION && sym->attr.function
15367 20144 : && !gfc_compare_types (&sym->ts, &global_sym->ts))
15368 : {
15369 2 : gfc_error ("Return type mismatch of function %qs with binding "
15370 : "label %qs at %L (%s/%s), originally declared at %L",
15371 : sym->name, sym->binding_label,
15372 : &sym->declared_at,
15373 : gfc_typename (&sym->ts),
15374 2 : gfc_typename (&global_sym->ts),
15375 : &gsym->where);
15376 2 : sym->binding_label = NULL;
15377 2 : sym->error = 1;
15378 2 : return;
15379 : }
15380 12888 : if (!compare_c_binding_arglists (global_sym, sym))
15381 : {
15382 10 : sym->binding_label = NULL;
15383 10 : sym->error = 1;
15384 10 : return;
15385 : }
15386 : }
15387 : }
15388 :
15389 12878 : if (!gsym
15390 12919 : || (!gsym->defined
15391 9967 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
15392 : {
15393 28796 : if (!gsym)
15394 28796 : gsym = gfc_get_gsymbol (sym->binding_label, true);
15395 38763 : gsym->where = sym->declared_at;
15396 38763 : gsym->sym_name = sym->name;
15397 38763 : gsym->binding_label = sym->binding_label;
15398 38763 : gsym->ns = sym->ns;
15399 38763 : gsym->mod_name = module;
15400 38763 : if (sym->attr.function)
15401 26340 : gsym->type = GSYM_FUNCTION;
15402 12423 : else if (sym->attr.subroutine)
15403 12283 : gsym->type = GSYM_SUBROUTINE;
15404 : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
15405 38763 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
15406 38763 : return;
15407 : }
15408 :
15409 2952 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
15410 : {
15411 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
15412 : "identifier as entity at %L", sym->name,
15413 : sym->binding_label, &sym->declared_at, &gsym->where);
15414 : /* Clear the binding label to prevent checking multiple times. */
15415 1 : sym->binding_label = NULL;
15416 1 : return;
15417 : }
15418 :
15419 2951 : if (sym->attr.flavor == FL_VARIABLE && module
15420 37 : && (strcmp (module, gsym->mod_name) != 0
15421 35 : || strcmp (sym->name, gsym->sym_name) != 0))
15422 : {
15423 : /* This can only happen if the variable is defined in a module - if it
15424 : isn't the same module, reject it. */
15425 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
15426 : "uses the same global identifier as entity at %L from module %qs",
15427 : sym->name, module, sym->binding_label,
15428 : &sym->declared_at, &gsym->where, gsym->mod_name);
15429 3 : sym->binding_label = NULL;
15430 3 : return;
15431 : }
15432 :
15433 2948 : if ((sym->attr.function || sym->attr.subroutine)
15434 2912 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
15435 2910 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
15436 2527 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
15437 2095 : && (module != gsym->mod_name
15438 2091 : || strcmp (gsym->sym_name, sym->name) != 0
15439 2091 : || (module && strcmp (module, gsym->mod_name) != 0)))
15440 : {
15441 : /* Print an error if the procedure is defined multiple times; we have to
15442 : exclude references to the same procedure via module association or
15443 : multiple checks for the same procedure. */
15444 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
15445 : "global identifier as entity at %L", sym->name,
15446 : sym->binding_label, &sym->declared_at, &gsym->where);
15447 4 : sym->binding_label = NULL;
15448 4 : return;
15449 : }
15450 : }
15451 :
15452 :
15453 : /* Resolve an index expression. */
15454 :
15455 : static bool
15456 270363 : resolve_index_expr (gfc_expr *e)
15457 : {
15458 270363 : if (!gfc_resolve_expr (e))
15459 : return false;
15460 :
15461 270353 : if (!gfc_simplify_expr (e, 0))
15462 : return false;
15463 :
15464 270351 : if (!gfc_specification_expr (e))
15465 : return false;
15466 :
15467 : return true;
15468 : }
15469 :
15470 :
15471 : /* Resolve a charlen structure. */
15472 :
15473 : static bool
15474 105292 : resolve_charlen (gfc_charlen *cl)
15475 : {
15476 105292 : int k;
15477 105292 : bool saved_specification_expr;
15478 :
15479 105292 : if (cl->resolved)
15480 : return true;
15481 :
15482 96269 : cl->resolved = 1;
15483 96269 : saved_specification_expr = specification_expr;
15484 96269 : specification_expr = true;
15485 :
15486 96269 : if (cl->length_from_typespec)
15487 : {
15488 1502 : if (!gfc_resolve_expr (cl->length))
15489 : {
15490 1 : specification_expr = saved_specification_expr;
15491 1 : return false;
15492 : }
15493 :
15494 1501 : if (!gfc_simplify_expr (cl->length, 0))
15495 : {
15496 0 : specification_expr = saved_specification_expr;
15497 0 : return false;
15498 : }
15499 :
15500 : /* cl->length has been resolved. It should have an integer type. */
15501 1501 : if (cl->length
15502 1500 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
15503 : {
15504 4 : gfc_error ("Scalar INTEGER expression expected at %L",
15505 : &cl->length->where);
15506 4 : return false;
15507 : }
15508 : }
15509 : else
15510 : {
15511 94767 : if (!resolve_index_expr (cl->length))
15512 : {
15513 19 : specification_expr = saved_specification_expr;
15514 19 : return false;
15515 : }
15516 : }
15517 :
15518 : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
15519 : a negative value, the length of character entities declared is zero. */
15520 96245 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15521 57786 : && mpz_sgn (cl->length->value.integer) < 0)
15522 0 : gfc_replace_expr (cl->length,
15523 : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
15524 :
15525 : /* Check that the character length is not too large. */
15526 96245 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
15527 96245 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15528 57786 : && cl->length->ts.type == BT_INTEGER
15529 57786 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
15530 : {
15531 4 : gfc_error ("String length at %L is too large", &cl->length->where);
15532 4 : specification_expr = saved_specification_expr;
15533 4 : return false;
15534 : }
15535 :
15536 96241 : specification_expr = saved_specification_expr;
15537 96241 : return true;
15538 : }
15539 :
15540 :
15541 : /* Test for non-constant shape arrays. */
15542 :
15543 : static bool
15544 120781 : is_non_constant_shape_array (gfc_symbol *sym)
15545 : {
15546 120781 : gfc_expr *e;
15547 120781 : int i;
15548 120781 : bool not_constant;
15549 :
15550 120781 : not_constant = false;
15551 120781 : if (sym->as != NULL)
15552 : {
15553 : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
15554 : has not been simplified; parameter array references. Do the
15555 : simplification now. */
15556 158379 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
15557 : {
15558 91365 : if (i == GFC_MAX_DIMENSIONS)
15559 : break;
15560 :
15561 91363 : e = sym->as->lower[i];
15562 91363 : if (e && (!resolve_index_expr(e)
15563 88429 : || !gfc_is_constant_expr (e)))
15564 : not_constant = true;
15565 91363 : e = sym->as->upper[i];
15566 91363 : if (e && (!resolve_index_expr(e)
15567 87139 : || !gfc_is_constant_expr (e)))
15568 : not_constant = true;
15569 : }
15570 : }
15571 120781 : return not_constant;
15572 : }
15573 :
15574 : /* Given a symbol and an initialization expression, add code to initialize
15575 : the symbol to the function entry. */
15576 : static void
15577 2210 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
15578 : {
15579 2210 : gfc_expr *lval;
15580 2210 : gfc_code *init_st;
15581 2210 : gfc_namespace *ns = sym->ns;
15582 :
15583 2210 : if (sym->attr.function && sym->result == sym && IS_PDT (sym))
15584 : {
15585 46 : gfc_free_expr (init);
15586 46 : return;
15587 : }
15588 :
15589 : /* Search for the function namespace if this is a contained
15590 : function without an explicit result. */
15591 2164 : if (sym->attr.function && sym == sym->result
15592 299 : && sym->name != sym->ns->proc_name->name)
15593 : {
15594 298 : ns = ns->contained;
15595 1376 : for (;ns; ns = ns->sibling)
15596 1315 : if (strcmp (ns->proc_name->name, sym->name) == 0)
15597 : break;
15598 : }
15599 :
15600 2164 : if (ns == NULL)
15601 : {
15602 61 : gfc_free_expr (init);
15603 61 : return;
15604 : }
15605 :
15606 : /* Build an l-value expression for the result. */
15607 2103 : lval = gfc_lval_expr_from_sym (sym);
15608 :
15609 : /* Add the code at scope entry. */
15610 2103 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
15611 2103 : init_st->next = ns->code;
15612 2103 : ns->code = init_st;
15613 :
15614 : /* Assign the default initializer to the l-value. */
15615 2103 : init_st->loc = sym->declared_at;
15616 2103 : init_st->expr1 = lval;
15617 2103 : init_st->expr2 = init;
15618 : }
15619 :
15620 :
15621 : /* Whether or not we can generate a default initializer for a symbol. */
15622 :
15623 : static bool
15624 31767 : can_generate_init (gfc_symbol *sym)
15625 : {
15626 31767 : symbol_attribute *a;
15627 31767 : if (!sym)
15628 : return false;
15629 31767 : a = &sym->attr;
15630 :
15631 : /* These symbols should never have a default initialization. */
15632 52390 : return !(
15633 31767 : a->allocatable
15634 31767 : || a->external
15635 30588 : || a->pointer
15636 30588 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
15637 6127 : && (CLASS_DATA (sym)->attr.class_pointer
15638 4031 : || CLASS_DATA (sym)->attr.proc_pointer))
15639 28492 : || a->in_equivalence
15640 28371 : || a->in_common
15641 28324 : || a->data
15642 28146 : || sym->module
15643 24203 : || a->cray_pointee
15644 24141 : || a->cray_pointer
15645 24141 : || sym->assoc
15646 21304 : || (!a->referenced && !a->result)
15647 20623 : || (a->dummy && (a->intent != INTENT_OUT
15648 1159 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
15649 20623 : || (a->function && sym != sym->result)
15650 : );
15651 : }
15652 :
15653 :
15654 : /* Assign the default initializer to a derived type variable or result. */
15655 :
15656 : static void
15657 12083 : apply_default_init (gfc_symbol *sym)
15658 : {
15659 12083 : gfc_expr *init = NULL;
15660 :
15661 12083 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15662 : return;
15663 :
15664 11718 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
15665 10805 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15666 :
15667 11718 : if (init == NULL && sym->ts.type != BT_CLASS)
15668 : return;
15669 :
15670 1828 : build_init_assign (sym, init);
15671 1828 : sym->attr.referenced = 1;
15672 : }
15673 :
15674 :
15675 : /* Build an initializer for a local. Returns null if the symbol should not have
15676 : a default initialization. */
15677 :
15678 : static gfc_expr *
15679 210985 : build_default_init_expr (gfc_symbol *sym)
15680 : {
15681 : /* These symbols should never have a default initialization. */
15682 210985 : if (sym->attr.allocatable
15683 196941 : || sym->attr.external
15684 196941 : || sym->attr.dummy
15685 129262 : || sym->attr.pointer
15686 120781 : || sym->attr.in_equivalence
15687 118405 : || sym->attr.in_common
15688 115303 : || sym->attr.data
15689 113005 : || sym->module
15690 110289 : || sym->attr.cray_pointee
15691 109988 : || sym->attr.cray_pointer
15692 109686 : || sym->assoc)
15693 : return NULL;
15694 :
15695 : /* Get the appropriate init expression. */
15696 104583 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
15697 : }
15698 :
15699 : /* Add an initialization expression to a local variable. */
15700 : static void
15701 210985 : apply_default_init_local (gfc_symbol *sym)
15702 : {
15703 210985 : gfc_expr *init = NULL;
15704 :
15705 : /* The symbol should be a variable or a function return value. */
15706 210985 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15707 210985 : || (sym->attr.function && sym->result != sym))
15708 : return;
15709 :
15710 : /* Try to build the initializer expression. If we can't initialize
15711 : this symbol, then init will be NULL. */
15712 210985 : init = build_default_init_expr (sym);
15713 210985 : if (init == NULL)
15714 : return;
15715 :
15716 : /* For saved variables, we don't want to add an initializer at function
15717 : entry, so we just add a static initializer. Note that automatic variables
15718 : are stack allocated even with -fno-automatic; we have also to exclude
15719 : result variable, which are also nonstatic. */
15720 419 : if (!sym->attr.automatic
15721 419 : && (sym->attr.save || sym->ns->save_all
15722 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15723 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15724 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15725 : {
15726 : /* Don't clobber an existing initializer! */
15727 37 : gcc_assert (sym->value == NULL);
15728 37 : sym->value = init;
15729 37 : return;
15730 : }
15731 :
15732 382 : build_init_assign (sym, init);
15733 : }
15734 :
15735 :
15736 : /* Resolution of common features of flavors variable and procedure. */
15737 :
15738 : static bool
15739 1016396 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15740 : {
15741 1016396 : gfc_array_spec *as;
15742 :
15743 1016396 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15744 20307 : && sym->ts.u.derived && CLASS_DATA (sym))
15745 20302 : as = CLASS_DATA (sym)->as;
15746 : else
15747 996094 : as = sym->as;
15748 :
15749 : /* Constraints on deferred shape variable. */
15750 1016396 : if (as == NULL || as->type != AS_DEFERRED)
15751 : {
15752 991047 : bool pointer, allocatable, dimension;
15753 :
15754 991047 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15755 16885 : && sym->ts.u.derived && CLASS_DATA (sym))
15756 : {
15757 16880 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15758 16880 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15759 16880 : dimension = CLASS_DATA (sym)->attr.dimension;
15760 : }
15761 : else
15762 : {
15763 974167 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15764 974167 : allocatable = sym->attr.allocatable;
15765 974167 : dimension = sym->attr.dimension;
15766 : }
15767 :
15768 991047 : if (allocatable)
15769 : {
15770 8350 : if (dimension
15771 8350 : && as
15772 524 : && as->type != AS_ASSUMED_RANK
15773 5 : && !sym->attr.select_rank_temporary)
15774 : {
15775 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15776 : "shape or assumed rank", sym->name, &sym->declared_at);
15777 3 : return false;
15778 : }
15779 8347 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15780 : "%qs at %L may not be ALLOCATABLE",
15781 : sym->name, &sym->declared_at))
15782 : return false;
15783 : }
15784 :
15785 991043 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15786 : {
15787 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15788 : "assumed rank", sym->name, &sym->declared_at);
15789 4 : sym->error = 1;
15790 4 : return false;
15791 : }
15792 : }
15793 : else
15794 : {
15795 25349 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15796 4972 : && sym->ts.type != BT_CLASS && !sym->assoc)
15797 : {
15798 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15799 : sym->name, &sym->declared_at);
15800 3 : return false;
15801 : }
15802 : }
15803 :
15804 : /* Constraints on polymorphic variables. */
15805 1016385 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15806 : {
15807 : /* F03:C502. */
15808 19609 : if (sym->attr.class_ok
15809 19553 : && sym->ts.u.derived
15810 19548 : && !sym->attr.select_type_temporary
15811 18330 : && !UNLIMITED_POLY (sym)
15812 15610 : && CLASS_DATA (sym)
15813 15610 : && CLASS_DATA (sym)->ts.u.derived
15814 35218 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15815 : {
15816 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15817 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15818 : &sym->declared_at);
15819 5 : return false;
15820 : }
15821 :
15822 : /* F03:C509. */
15823 : /* Assume that use associated symbols were checked in the module ns.
15824 : Class-variables that are associate-names are also something special
15825 : and excepted from the test. */
15826 19604 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15827 54 : && !sym->attr.select_type_temporary
15828 54 : && !sym->attr.select_rank_temporary)
15829 : {
15830 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15831 : "or pointer", sym->name, &sym->declared_at);
15832 54 : return false;
15833 : }
15834 : }
15835 :
15836 : return true;
15837 : }
15838 :
15839 :
15840 : /* Additional checks for symbols with flavor variable and derived
15841 : type. To be called from resolve_fl_variable. */
15842 :
15843 : static bool
15844 85463 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15845 : {
15846 85463 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15847 :
15848 : /* Check to see if a derived type is blocked from being host
15849 : associated by the presence of another class I symbol in the same
15850 : namespace. 14.6.1.3 of the standard and the discussion on
15851 : comp.lang.fortran. */
15852 85463 : if (sym->ts.u.derived
15853 85458 : && sym->ns != sym->ts.u.derived->ns
15854 48840 : && !sym->ts.u.derived->attr.use_assoc
15855 18338 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15856 : {
15857 17343 : gfc_symbol *s;
15858 17343 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15859 17343 : if (s && s->attr.generic)
15860 2 : s = gfc_find_dt_in_generic (s);
15861 17343 : if (s && !gfc_fl_struct (s->attr.flavor))
15862 : {
15863 2 : gfc_error ("The type %qs cannot be host associated at %L "
15864 : "because it is blocked by an incompatible object "
15865 : "of the same name declared at %L",
15866 2 : sym->ts.u.derived->name, &sym->declared_at,
15867 : &s->declared_at);
15868 2 : return false;
15869 : }
15870 : }
15871 :
15872 : /* 4th constraint in section 11.3: "If an object of a type for which
15873 : component-initialization is specified (R429) appears in the
15874 : specification-part of a module and does not have the ALLOCATABLE
15875 : or POINTER attribute, the object shall have the SAVE attribute."
15876 :
15877 : The check for initializers is performed with
15878 : gfc_has_default_initializer because gfc_default_initializer generates
15879 : a hidden default for allocatable components. */
15880 84772 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15881 19659 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15882 441 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15883 21 : && !sym->attr.pointer && !sym->attr.allocatable
15884 21 : && gfc_has_default_initializer (sym->ts.u.derived)
15885 85470 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15886 : "%qs at %L, needed due to the default "
15887 : "initialization", sym->name, &sym->declared_at))
15888 : return false;
15889 :
15890 : /* Assign default initializer. */
15891 85459 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15892 78985 : && (!no_init_flag
15893 61230 : || (sym->attr.intent == INTENT_OUT
15894 3381 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15895 20962 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15896 :
15897 : return true;
15898 : }
15899 :
15900 :
15901 : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15902 : except in the declaration of an entity or component that has the POINTER
15903 : or ALLOCATABLE attribute. */
15904 :
15905 : static bool
15906 1597127 : deferred_requirements (gfc_symbol *sym)
15907 : {
15908 1597127 : if (sym->ts.deferred
15909 8212 : && !(sym->attr.pointer
15910 2502 : || sym->attr.allocatable
15911 127 : || sym->attr.associate_var
15912 7 : || sym->attr.omp_udr_artificial_var))
15913 : {
15914 : /* If a function has a result variable, only check the variable. */
15915 7 : if (sym->result && sym->name != sym->result->name)
15916 : return true;
15917 :
15918 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15919 : "requires either the POINTER or ALLOCATABLE attribute",
15920 : sym->name, &sym->declared_at);
15921 6 : return false;
15922 : }
15923 : return true;
15924 : }
15925 :
15926 :
15927 : /* Resolve symbols with flavor variable. */
15928 :
15929 : static bool
15930 681151 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15931 : {
15932 681151 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15933 : "SAVE attribute");
15934 :
15935 681151 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15936 : return false;
15937 :
15938 : /* Set this flag to check that variables are parameters of all entries.
15939 : This check is effected by the call to gfc_resolve_expr through
15940 : is_non_constant_shape_array. */
15941 681091 : bool saved_specification_expr = specification_expr;
15942 681091 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
15943 681091 : specification_expr = true;
15944 681091 : specification_expr_symbol = sym;
15945 :
15946 681091 : if (sym->ns->proc_name
15947 680996 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15948 675715 : || sym->ns->proc_name->attr.is_main_program)
15949 85336 : && !sym->attr.use_assoc
15950 81932 : && !sym->attr.allocatable
15951 75979 : && !sym->attr.pointer
15952 753315 : && is_non_constant_shape_array (sym))
15953 : {
15954 : /* F08:C541. The shape of an array defined in a main program or module
15955 : * needs to be constant. */
15956 3 : gfc_error ("The module or main program array %qs at %L must "
15957 : "have constant shape", sym->name, &sym->declared_at);
15958 3 : specification_expr = saved_specification_expr;
15959 3 : specification_expr_symbol = saved_specification_expr_symbol;
15960 3 : return false;
15961 : }
15962 :
15963 : /* Constraints on deferred type parameter. */
15964 681088 : if (!deferred_requirements (sym))
15965 : return false;
15966 :
15967 681084 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15968 : {
15969 : /* Make sure that character string variables with assumed length are
15970 : dummy arguments. */
15971 36905 : gfc_expr *e = NULL;
15972 :
15973 36905 : if (sym->ts.u.cl)
15974 36905 : e = sym->ts.u.cl->length;
15975 : else
15976 : return false;
15977 :
15978 36905 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15979 2718 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15980 2 : && !sym->attr.omp_udr_artificial_var)
15981 : {
15982 2 : gfc_error ("Entity with assumed character length at %L must be a "
15983 : "dummy argument or a PARAMETER", &sym->declared_at);
15984 2 : specification_expr = saved_specification_expr;
15985 2 : specification_expr_symbol = saved_specification_expr_symbol;
15986 2 : return false;
15987 : }
15988 :
15989 21401 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15990 : {
15991 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15992 1 : specification_expr = saved_specification_expr;
15993 1 : specification_expr_symbol = saved_specification_expr_symbol;
15994 1 : return false;
15995 : }
15996 :
15997 36902 : if (!gfc_is_constant_expr (e)
15998 36902 : && !(e->expr_type == EXPR_VARIABLE
15999 1448 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
16000 : {
16001 2262 : if (!sym->attr.use_assoc && sym->ns->proc_name
16002 1740 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
16003 1739 : || sym->ns->proc_name->attr.is_main_program))
16004 : {
16005 3 : gfc_error ("%qs at %L must have constant character length "
16006 : "in this context", sym->name, &sym->declared_at);
16007 3 : specification_expr = saved_specification_expr;
16008 3 : specification_expr_symbol = saved_specification_expr_symbol;
16009 3 : return false;
16010 : }
16011 2259 : if (sym->attr.in_common)
16012 : {
16013 1 : gfc_error ("COMMON variable %qs at %L must have constant "
16014 : "character length", sym->name, &sym->declared_at);
16015 1 : specification_expr = saved_specification_expr;
16016 1 : specification_expr_symbol = saved_specification_expr_symbol;
16017 1 : return false;
16018 : }
16019 : }
16020 : }
16021 :
16022 681077 : if (sym->value == NULL && sym->attr.referenced
16023 212932 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
16024 210985 : apply_default_init_local (sym); /* Try to apply a default initialization. */
16025 :
16026 : /* Determine if the symbol may not have an initializer. */
16027 681077 : int no_init_flag = 0, automatic_flag = 0;
16028 681077 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
16029 175365 : || sym->attr.intrinsic || sym->attr.result)
16030 : no_init_flag = 1;
16031 142612 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
16032 178014 : && is_non_constant_shape_array (sym))
16033 : {
16034 1355 : no_init_flag = automatic_flag = 1;
16035 :
16036 : /* Also, they must not have the SAVE attribute.
16037 : SAVE_IMPLICIT is checked below. */
16038 1355 : if (sym->as && sym->attr.codimension)
16039 : {
16040 7 : int corank = sym->as->corank;
16041 7 : sym->as->corank = 0;
16042 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
16043 7 : sym->as->corank = corank;
16044 : }
16045 1355 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
16046 : {
16047 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
16048 2 : specification_expr = saved_specification_expr;
16049 2 : specification_expr_symbol = saved_specification_expr_symbol;
16050 2 : return false;
16051 : }
16052 : }
16053 :
16054 : /* Ensure that any initializer is simplified. */
16055 681075 : if (sym->value)
16056 8498 : gfc_simplify_expr (sym->value, 1);
16057 :
16058 : /* Reject illegal initializers. */
16059 681075 : if (!sym->mark && sym->value)
16060 : {
16061 8498 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
16062 67 : && CLASS_DATA (sym)->attr.allocatable))
16063 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
16064 : sym->name, &sym->declared_at);
16065 8497 : else if (sym->attr.external)
16066 0 : gfc_error ("External %qs at %L cannot have an initializer",
16067 : sym->name, &sym->declared_at);
16068 8497 : else if (sym->attr.dummy)
16069 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
16070 : sym->name, &sym->declared_at);
16071 8494 : else if (sym->attr.intrinsic)
16072 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
16073 : sym->name, &sym->declared_at);
16074 8494 : else if (sym->attr.result)
16075 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
16076 : sym->name, &sym->declared_at);
16077 8493 : else if (automatic_flag)
16078 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
16079 : sym->name, &sym->declared_at);
16080 : else
16081 8488 : goto no_init_error;
16082 10 : specification_expr = saved_specification_expr;
16083 10 : specification_expr_symbol = saved_specification_expr_symbol;
16084 10 : return false;
16085 : }
16086 :
16087 672577 : no_init_error:
16088 681065 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
16089 : {
16090 85463 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
16091 85463 : specification_expr = saved_specification_expr;
16092 85463 : specification_expr_symbol = saved_specification_expr_symbol;
16093 85463 : return res;
16094 : }
16095 :
16096 595602 : specification_expr = saved_specification_expr;
16097 595602 : specification_expr_symbol = saved_specification_expr_symbol;
16098 595602 : return true;
16099 : }
16100 :
16101 :
16102 : /* Compare the dummy characteristics of a module procedure interface
16103 : declaration with the corresponding declaration in a submodule. */
16104 : static gfc_formal_arglist *new_formal;
16105 : static char errmsg[200];
16106 :
16107 : static void
16108 1352 : compare_fsyms (gfc_symbol *sym)
16109 : {
16110 1352 : gfc_symbol *fsym;
16111 :
16112 1352 : if (sym == NULL || new_formal == NULL)
16113 : return;
16114 :
16115 1352 : fsym = new_formal->sym;
16116 :
16117 1352 : if (sym == fsym)
16118 : return;
16119 :
16120 1328 : if (strcmp (sym->name, fsym->name) == 0)
16121 : {
16122 523 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
16123 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
16124 : }
16125 : }
16126 :
16127 :
16128 : /* Resolve a procedure. */
16129 :
16130 : static bool
16131 504115 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
16132 : {
16133 504115 : gfc_formal_arglist *arg;
16134 504115 : bool allocatable_or_pointer = false;
16135 :
16136 504115 : if (sym->attr.function
16137 504115 : && !resolve_fl_var_and_proc (sym, mp_flag))
16138 : return false;
16139 :
16140 : /* Constraints on deferred type parameter. */
16141 504105 : if (!deferred_requirements (sym))
16142 : return false;
16143 :
16144 504104 : if (sym->ts.type == BT_CHARACTER)
16145 : {
16146 12057 : gfc_charlen *cl = sym->ts.u.cl;
16147 :
16148 7806 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
16149 13412 : && !resolve_charlen (cl))
16150 : return false;
16151 :
16152 12056 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
16153 10702 : && sym->attr.proc == PROC_ST_FUNCTION)
16154 : {
16155 0 : gfc_error ("Character-valued statement function %qs at %L must "
16156 : "have constant length", sym->name, &sym->declared_at);
16157 0 : return false;
16158 : }
16159 : }
16160 :
16161 : /* Ensure that derived type for are not of a private type. Internal
16162 : module procedures are excluded by 2.2.3.3 - i.e., they are not
16163 : externally accessible and can access all the objects accessible in
16164 : the host. */
16165 116328 : if (!(sym->ns->parent && sym->ns->parent->proc_name
16166 116328 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
16167 593602 : && gfc_check_symbol_access (sym))
16168 : {
16169 469981 : gfc_interface *iface;
16170 :
16171 999302 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
16172 : {
16173 529322 : if (arg->sym
16174 529182 : && arg->sym->ts.type == BT_DERIVED
16175 43880 : && arg->sym->ts.u.derived
16176 43880 : && !arg->sym->ts.u.derived->attr.use_assoc
16177 4424 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16178 529331 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
16179 : "and cannot be a dummy argument"
16180 : " of %qs, which is PUBLIC at %L",
16181 9 : arg->sym->name, sym->name,
16182 : &sym->declared_at))
16183 : {
16184 : /* Stop this message from recurring. */
16185 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16186 1 : return false;
16187 : }
16188 : }
16189 :
16190 : /* PUBLIC interfaces may expose PRIVATE procedures that take types
16191 : PRIVATE to the containing module. */
16192 667550 : for (iface = sym->generic; iface; iface = iface->next)
16193 : {
16194 464370 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
16195 : {
16196 266800 : if (arg->sym
16197 266768 : && arg->sym->ts.type == BT_DERIVED
16198 8033 : && !arg->sym->ts.u.derived->attr.use_assoc
16199 232 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16200 266804 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
16201 : "PUBLIC interface %qs at %L "
16202 : "takes dummy arguments of %qs which "
16203 : "is PRIVATE", iface->sym->name,
16204 4 : sym->name, &iface->sym->declared_at,
16205 4 : gfc_typename(&arg->sym->ts)))
16206 : {
16207 : /* Stop this message from recurring. */
16208 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16209 1 : return false;
16210 : }
16211 : }
16212 : }
16213 : }
16214 :
16215 504101 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
16216 86 : && !sym->attr.proc_pointer)
16217 : {
16218 2 : gfc_error ("Function %qs at %L cannot have an initializer",
16219 : sym->name, &sym->declared_at);
16220 :
16221 : /* Make sure no second error is issued for this. */
16222 2 : sym->value->error = 1;
16223 2 : return false;
16224 : }
16225 :
16226 : /* An external symbol may not have an initializer because it is taken to be
16227 : a procedure. Exception: Procedure Pointers. */
16228 504099 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
16229 : {
16230 0 : gfc_error ("External object %qs at %L may not have an initializer",
16231 : sym->name, &sym->declared_at);
16232 0 : return false;
16233 : }
16234 :
16235 : /* An elemental function is required to return a scalar 12.7.1 */
16236 504099 : if (sym->attr.elemental && sym->attr.function
16237 86649 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16238 2 : && CLASS_DATA (sym)->as)))
16239 : {
16240 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
16241 : "result", sym->name, &sym->declared_at);
16242 : /* Reset so that the error only occurs once. */
16243 3 : sym->attr.elemental = 0;
16244 3 : return false;
16245 : }
16246 :
16247 504096 : if (sym->attr.proc == PROC_ST_FUNCTION
16248 223 : && (sym->attr.allocatable || sym->attr.pointer))
16249 : {
16250 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
16251 : "allocatable attribute", sym->name, &sym->declared_at);
16252 2 : return false;
16253 : }
16254 :
16255 : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
16256 : char-len-param shall not be array-valued, pointer-valued, recursive
16257 : or pure. ....snip... A character value of * may only be used in the
16258 : following ways: (i) Dummy arg of procedure - dummy associates with
16259 : actual length; (ii) To declare a named constant; or (iii) External
16260 : function - but length must be declared in calling scoping unit. */
16261 504094 : if (sym->attr.function
16262 335226 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
16263 6916 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
16264 : {
16265 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
16266 178 : || (sym->attr.recursive) || (sym->attr.pure))
16267 : {
16268 4 : if (sym->as && sym->as->rank)
16269 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16270 : "array-valued", sym->name, &sym->declared_at);
16271 :
16272 4 : if (sym->attr.pointer)
16273 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16274 : "pointer-valued", sym->name, &sym->declared_at);
16275 :
16276 4 : if (sym->attr.pure)
16277 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16278 : "pure", sym->name, &sym->declared_at);
16279 :
16280 4 : if (sym->attr.recursive)
16281 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16282 : "recursive", sym->name, &sym->declared_at);
16283 :
16284 : return false;
16285 : }
16286 :
16287 : /* Appendix B.2 of the standard. Contained functions give an
16288 : error anyway. Deferred character length is an F2003 feature.
16289 : Don't warn on intrinsic conversion functions, which start
16290 : with two underscores. */
16291 176 : if (!sym->attr.contained && !sym->ts.deferred
16292 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
16293 172 : gfc_notify_std (GFC_STD_F95_OBS,
16294 : "CHARACTER(*) function %qs at %L",
16295 : sym->name, &sym->declared_at);
16296 : }
16297 :
16298 : /* F2008, C1218. */
16299 504090 : if (sym->attr.elemental)
16300 : {
16301 89951 : if (sym->attr.proc_pointer)
16302 : {
16303 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
16304 : : sym->name);
16305 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
16306 : name, &sym->declared_at);
16307 7 : return false;
16308 : }
16309 89944 : if (sym->attr.dummy)
16310 : {
16311 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
16312 : sym->name, &sym->declared_at);
16313 3 : return false;
16314 : }
16315 : }
16316 :
16317 : /* F2018, C15100: "The result of an elemental function shall be scalar,
16318 : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
16319 : pointer is tested and caught elsewhere. */
16320 504080 : if (sym->result)
16321 281885 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
16322 281885 : && CLASS_DATA (sym->result) ?
16323 1702 : (CLASS_DATA (sym->result)->attr.allocatable
16324 1702 : || CLASS_DATA (sym->result)->attr.pointer) :
16325 280183 : (sym->result->attr.allocatable
16326 280183 : || sym->result->attr.pointer);
16327 :
16328 504080 : if (sym->attr.elemental && sym->result
16329 86254 : && allocatable_or_pointer)
16330 : {
16331 4 : gfc_error ("Function result variable %qs at %L of elemental "
16332 : "function %qs shall not have an ALLOCATABLE or POINTER "
16333 : "attribute", sym->result->name,
16334 : &sym->result->declared_at, sym->name);
16335 4 : return false;
16336 : }
16337 :
16338 : /* F2018:C1585: "The function result of a pure function shall not be both
16339 : polymorphic and allocatable, or have a polymorphic allocatable ultimate
16340 : component." */
16341 504076 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
16342 : {
16343 2544 : if (sym->ts.type == BT_CLASS
16344 5 : && sym->attr.class_ok
16345 4 : && CLASS_DATA (sym->result)
16346 4 : && CLASS_DATA (sym->result)->attr.allocatable)
16347 : {
16348 4 : gfc_error ("Result variable %qs of pure function at %L is "
16349 : "polymorphic allocatable",
16350 : sym->result->name, &sym->result->declared_at);
16351 4 : return false;
16352 : }
16353 :
16354 2540 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
16355 : {
16356 : gfc_component *c = sym->ts.u.derived->components;
16357 4805 : for (; c; c = c->next)
16358 2574 : if (c->ts.type == BT_CLASS
16359 2 : && CLASS_DATA (c)
16360 2 : && CLASS_DATA (c)->attr.allocatable)
16361 : {
16362 2 : gfc_error ("Result variable %qs of pure function at %L has "
16363 : "polymorphic allocatable component %qs",
16364 : sym->result->name, &sym->result->declared_at,
16365 : c->name);
16366 2 : return false;
16367 : }
16368 : }
16369 : }
16370 :
16371 504070 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
16372 : {
16373 7244 : gfc_formal_arglist *curr_arg;
16374 7244 : int has_non_interop_arg = 0;
16375 :
16376 7244 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
16377 7244 : sym->common_block))
16378 : {
16379 : /* Clear these to prevent looking at them again if there was an
16380 : error. */
16381 2 : sym->attr.is_bind_c = 0;
16382 2 : sym->attr.is_c_interop = 0;
16383 2 : sym->ts.is_c_interop = 0;
16384 : }
16385 : else
16386 : {
16387 : /* So far, no errors have been found. */
16388 : sym->attr.is_c_interop = 1;
16389 : sym->ts.is_c_interop = 1;
16390 : }
16391 :
16392 7244 : curr_arg = gfc_sym_get_dummy_args (sym);
16393 31869 : while (curr_arg != NULL)
16394 : {
16395 : /* Skip implicitly typed dummy args here. */
16396 17381 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
16397 17324 : if (!gfc_verify_c_interop_param (curr_arg->sym))
16398 : /* If something is found to fail, record the fact so we
16399 : can mark the symbol for the procedure as not being
16400 : BIND(C) to try and prevent multiple errors being
16401 : reported. */
16402 17381 : has_non_interop_arg = 1;
16403 :
16404 17381 : curr_arg = curr_arg->next;
16405 : }
16406 :
16407 : /* See if any of the arguments were not interoperable and if so, clear
16408 : the procedure symbol to prevent duplicate error messages. */
16409 7244 : if (has_non_interop_arg != 0)
16410 : {
16411 128 : sym->attr.is_c_interop = 0;
16412 128 : sym->ts.is_c_interop = 0;
16413 128 : sym->attr.is_bind_c = 0;
16414 : }
16415 : }
16416 :
16417 504070 : if (!sym->attr.proc_pointer)
16418 : {
16419 502961 : if (sym->attr.save == SAVE_EXPLICIT)
16420 : {
16421 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
16422 : "in %qs at %L", sym->name, &sym->declared_at);
16423 5 : return false;
16424 : }
16425 502956 : if (sym->attr.intent)
16426 : {
16427 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
16428 : "in %qs at %L", sym->name, &sym->declared_at);
16429 1 : return false;
16430 : }
16431 502955 : if (sym->attr.subroutine && sym->attr.result)
16432 : {
16433 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
16434 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
16435 2 : return false;
16436 : }
16437 502953 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
16438 145024 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
16439 145021 : || sym->attr.contained))
16440 : {
16441 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
16442 : "in %qs at %L", sym->name, &sym->declared_at);
16443 3 : return false;
16444 : }
16445 502950 : if (strcmp ("ppr@", sym->name) == 0)
16446 : {
16447 0 : gfc_error ("Procedure pointer result %qs at %L "
16448 : "is missing the pointer attribute",
16449 0 : sym->ns->proc_name->name, &sym->declared_at);
16450 0 : return false;
16451 : }
16452 : }
16453 :
16454 : /* Assume that a procedure whose body is not known has references
16455 : to external arrays. */
16456 504059 : if (sym->attr.if_source != IFSRC_DECL)
16457 346689 : sym->attr.array_outer_dependency = 1;
16458 :
16459 : /* Compare the characteristics of a module procedure with the
16460 : interface declaration. Ideally this would be done with
16461 : gfc_compare_interfaces but, at present, the formal interface
16462 : cannot be copied to the ts.interface. */
16463 504059 : if (sym->attr.module_procedure
16464 1615 : && sym->attr.if_source == IFSRC_DECL)
16465 : {
16466 659 : gfc_symbol *iface;
16467 659 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
16468 659 : char *module_name;
16469 659 : char *submodule_name;
16470 659 : strcpy (name, sym->ns->proc_name->name);
16471 659 : module_name = strtok (name, ".");
16472 659 : submodule_name = strtok (NULL, ".");
16473 :
16474 659 : iface = sym->tlink;
16475 659 : sym->tlink = NULL;
16476 :
16477 : /* Make sure that the result uses the correct charlen for deferred
16478 : length results. */
16479 659 : if (iface && sym->result
16480 192 : && iface->ts.type == BT_CHARACTER
16481 19 : && iface->ts.deferred)
16482 6 : sym->result->ts.u.cl = iface->ts.u.cl;
16483 :
16484 6 : if (iface == NULL)
16485 196 : goto check_formal;
16486 :
16487 : /* Check the procedure characteristics. */
16488 463 : if (sym->attr.elemental != iface->attr.elemental)
16489 : {
16490 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
16491 : "PROCEDURE at %L and its interface in %s",
16492 : &sym->declared_at, module_name);
16493 10 : return false;
16494 : }
16495 :
16496 462 : if (sym->attr.pure != iface->attr.pure)
16497 : {
16498 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
16499 : "PROCEDURE at %L and its interface in %s",
16500 : &sym->declared_at, module_name);
16501 2 : return false;
16502 : }
16503 :
16504 460 : if (sym->attr.recursive != iface->attr.recursive)
16505 : {
16506 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
16507 : "PROCEDURE at %L and its interface in %s",
16508 : &sym->declared_at, module_name);
16509 2 : return false;
16510 : }
16511 :
16512 : /* Check the result characteristics. */
16513 458 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
16514 : {
16515 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
16516 : "in MODULE %qs and the declaration at %L in "
16517 : "(SUB)MODULE %qs",
16518 : errmsg, module_name, &sym->declared_at,
16519 : submodule_name ? submodule_name : module_name);
16520 5 : return false;
16521 : }
16522 :
16523 453 : check_formal:
16524 : /* Check the characteristics of the formal arguments. */
16525 649 : if (sym->formal && sym->formal_ns)
16526 : {
16527 1260 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
16528 : {
16529 722 : new_formal = arg;
16530 722 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
16531 : }
16532 : }
16533 : }
16534 :
16535 : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
16536 : BIND(C) attribute. */
16537 504049 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
16538 : {
16539 1 : gfc_error ("Interface of %qs at %L must be explicit",
16540 : sym->name, &sym->declared_at);
16541 1 : return false;
16542 : }
16543 :
16544 : return true;
16545 : }
16546 :
16547 :
16548 : /* Resolve a list of finalizer procedures. That is, after they have hopefully
16549 : been defined and we now know their defined arguments, check that they fulfill
16550 : the requirements of the standard for procedures used as finalizers. */
16551 :
16552 : static bool
16553 118502 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
16554 : {
16555 118502 : gfc_finalizer *list, *pdt_finalizers = NULL;
16556 118502 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
16557 118502 : bool result = true;
16558 118502 : bool seen_scalar = false;
16559 118502 : gfc_symbol *vtab;
16560 118502 : gfc_component *c;
16561 118502 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
16562 :
16563 118502 : if (parent)
16564 16697 : gfc_resolve_finalizers (parent, finalizable);
16565 :
16566 : /* Ensure that derived-type components have a their finalizers resolved. */
16567 118502 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
16568 375182 : for (c = derived->components; c; c = c->next)
16569 256680 : if (c->ts.type == BT_DERIVED
16570 71573 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
16571 : {
16572 9308 : bool has_final2 = false;
16573 9308 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
16574 0 : return false; /* Error. */
16575 9308 : has_final = has_final || has_final2;
16576 : }
16577 : /* Return early if not finalizable. */
16578 118502 : if (!has_final)
16579 : {
16580 115721 : if (finalizable)
16581 9324 : *finalizable = false;
16582 : return true;
16583 : }
16584 :
16585 : /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of
16586 : the template. If the finalizers field has the same value, it needs to be
16587 : supplied with finalizers of the same pdt_type. */
16588 2781 : if (derived->attr.pdt_type
16589 78 : && derived->template_sym
16590 36 : && derived->template_sym->f2k_derived
16591 36 : && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers)
16592 2817 : && derived->f2k_derived->finalizers == pdt_finalizers)
16593 : {
16594 36 : gfc_finalizer *tmp = NULL;
16595 36 : derived->f2k_derived->finalizers = NULL;
16596 36 : prev_link = &derived->f2k_derived->finalizers;
16597 132 : for (list = pdt_finalizers; list; list = list->next)
16598 : {
16599 96 : gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym);
16600 96 : if (args->sym
16601 96 : && args->sym->ts.type == BT_DERIVED
16602 96 : && args->sym->ts.u.derived
16603 96 : && !strcmp (args->sym->ts.u.derived->name, derived->name))
16604 : {
16605 54 : tmp = gfc_get_finalizer ();
16606 54 : *tmp = *list;
16607 54 : tmp->next = NULL;
16608 54 : *prev_link = tmp;
16609 54 : prev_link = &(tmp->next);
16610 54 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16611 : }
16612 : }
16613 : }
16614 :
16615 : /* Walk over the list of finalizer-procedures, check them, and if any one
16616 : does not fit in with the standard's definition, print an error and remove
16617 : it from the list. */
16618 2781 : prev_link = &derived->f2k_derived->finalizers;
16619 5746 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
16620 : {
16621 2965 : gfc_formal_arglist *dummy_args;
16622 2965 : gfc_symbol* arg;
16623 2965 : gfc_finalizer* i;
16624 2965 : int my_rank;
16625 :
16626 : /* Skip this finalizer if we already resolved it. */
16627 2965 : if (list->proc_tree)
16628 : {
16629 2378 : if (list->proc_tree->n.sym->formal->sym->as == NULL
16630 620 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
16631 1758 : seen_scalar = true;
16632 2378 : prev_link = &(list->next);
16633 2378 : continue;
16634 : }
16635 :
16636 : /* Check this exists and is a SUBROUTINE. */
16637 587 : if (!list->proc_sym->attr.subroutine)
16638 : {
16639 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
16640 : list->proc_sym->name, &list->where);
16641 3 : goto error;
16642 : }
16643 :
16644 : /* We should have exactly one argument. */
16645 584 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
16646 584 : if (!dummy_args || dummy_args->next)
16647 : {
16648 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
16649 : &list->where);
16650 2 : goto error;
16651 : }
16652 582 : arg = dummy_args->sym;
16653 :
16654 582 : if (!arg)
16655 : {
16656 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16657 1 : &list->proc_sym->declared_at, derived->name);
16658 1 : goto error;
16659 : }
16660 :
16661 581 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
16662 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
16663 : {
16664 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
16665 : "be the only finalizer with the same kind/type "
16666 : "(F2018: C790)", &list->where);
16667 0 : goto error;
16668 : }
16669 :
16670 : /* This argument must be of our type. */
16671 581 : if (!derived->attr.pdt_template
16672 569 : && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived))
16673 : {
16674 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16675 : &arg->declared_at, derived->name);
16676 2 : goto error;
16677 : }
16678 :
16679 : /* It must neither be a pointer nor allocatable nor optional. */
16680 579 : if (arg->attr.pointer)
16681 : {
16682 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
16683 : &arg->declared_at);
16684 1 : goto error;
16685 : }
16686 578 : if (arg->attr.allocatable)
16687 : {
16688 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16689 : " ALLOCATABLE", &arg->declared_at);
16690 1 : goto error;
16691 : }
16692 577 : if (arg->attr.optional)
16693 : {
16694 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
16695 : &arg->declared_at);
16696 1 : goto error;
16697 : }
16698 :
16699 : /* It must not be INTENT(OUT). */
16700 576 : if (arg->attr.intent == INTENT_OUT)
16701 : {
16702 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16703 : " INTENT(OUT)", &arg->declared_at);
16704 1 : goto error;
16705 : }
16706 :
16707 : /* Warn if the procedure is non-scalar and not assumed shape. */
16708 575 : if (warn_surprising && arg->as && arg->as->rank != 0
16709 3 : && arg->as->type != AS_ASSUMED_SHAPE)
16710 2 : gfc_warning (OPT_Wsurprising,
16711 : "Non-scalar FINAL procedure at %L should have assumed"
16712 : " shape argument", &arg->declared_at);
16713 :
16714 : /* Check that it does not match in kind and rank with a FINAL procedure
16715 : defined earlier. To really loop over the *earlier* declarations,
16716 : we need to walk the tail of the list as new ones were pushed at the
16717 : front. */
16718 : /* TODO: Handle kind parameters once they are implemented. */
16719 575 : my_rank = (arg->as ? arg->as->rank : 0);
16720 688 : for (i = list->next; i; i = i->next)
16721 : {
16722 115 : gfc_formal_arglist *dummy_args;
16723 :
16724 : /* Argument list might be empty; that is an error signalled earlier,
16725 : but we nevertheless continued resolving. */
16726 115 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
16727 115 : if (dummy_args && !derived->attr.pdt_template)
16728 : {
16729 113 : gfc_symbol* i_arg = dummy_args->sym;
16730 113 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
16731 113 : if (i_rank == my_rank)
16732 : {
16733 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
16734 : " rank (%d) as %qs",
16735 2 : list->proc_sym->name, &list->where, my_rank,
16736 2 : i->proc_sym->name);
16737 2 : goto error;
16738 : }
16739 : }
16740 : }
16741 :
16742 : /* Is this the/a scalar finalizer procedure? */
16743 573 : if (my_rank == 0)
16744 435 : seen_scalar = true;
16745 :
16746 : /* Find the symtree for this procedure. */
16747 573 : gcc_assert (!list->proc_tree);
16748 573 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16749 :
16750 573 : prev_link = &list->next;
16751 573 : continue;
16752 :
16753 : /* Remove wrong nodes immediately from the list so we don't risk any
16754 : troubles in the future when they might fail later expectations. */
16755 14 : error:
16756 14 : i = list;
16757 14 : *prev_link = list->next;
16758 14 : gfc_free_finalizer (i);
16759 14 : result = false;
16760 573 : }
16761 :
16762 2781 : if (result == false)
16763 : return false;
16764 :
16765 : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16766 : were nodes in the list, must have been for arrays. It is surely a good
16767 : idea to have a scalar version there if there's something to finalize. */
16768 2777 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16769 1 : gfc_warning (OPT_Wsurprising,
16770 : "Only array FINAL procedures declared for derived type %qs"
16771 : " defined at %L, suggest also scalar one unless an assumed"
16772 : " rank finalizer has been declared",
16773 : derived->name, &derived->declared_at);
16774 :
16775 2777 : if (!derived->attr.pdt_template)
16776 : {
16777 2717 : vtab = gfc_find_derived_vtab (derived);
16778 2717 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16779 2717 : if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym)
16780 2717 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16781 : }
16782 :
16783 2777 : if (finalizable)
16784 676 : *finalizable = true;
16785 :
16786 : return true;
16787 : }
16788 :
16789 :
16790 : static gfc_symbol * containing_dt;
16791 :
16792 : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16793 : arguments whose declared types are PDT instances only transmit the PASS arg
16794 : if they match the enclosing derived type. */
16795 :
16796 : static bool
16797 1496 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16798 : {
16799 1496 : gfc_formal_arglist *dummy_args;
16800 1496 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16801 : {
16802 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16803 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16804 126 : dummy_args = dummy_args->next;
16805 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16806 532 : if (dummy_args->sym->ts.type == BT_CLASS
16807 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16808 : containing_dt->name))
16809 356 : return true;
16810 : }
16811 : return false;
16812 : }
16813 :
16814 :
16815 : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16816 :
16817 : static bool
16818 750 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16819 : const char* generic_name, locus where)
16820 : {
16821 750 : gfc_symbol *sym1, *sym2;
16822 750 : const char *pass1, *pass2;
16823 750 : gfc_formal_arglist *dummy_args;
16824 :
16825 750 : gcc_assert (t1->specific && t2->specific);
16826 750 : gcc_assert (!t1->specific->is_generic);
16827 750 : gcc_assert (!t2->specific->is_generic);
16828 750 : gcc_assert (t1->is_operator == t2->is_operator);
16829 :
16830 750 : sym1 = t1->specific->u.specific->n.sym;
16831 750 : sym2 = t2->specific->u.specific->n.sym;
16832 :
16833 750 : if (sym1 == sym2)
16834 : return true;
16835 :
16836 : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16837 750 : if (sym1->attr.subroutine != sym2->attr.subroutine
16838 748 : || sym1->attr.function != sym2->attr.function)
16839 : {
16840 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16841 : " GENERIC %qs at %L",
16842 : sym1->name, sym2->name, generic_name, &where);
16843 2 : return false;
16844 : }
16845 :
16846 : /* Determine PASS arguments. */
16847 748 : if (t1->specific->nopass)
16848 : pass1 = NULL;
16849 697 : else if (t1->specific->pass_arg)
16850 : pass1 = t1->specific->pass_arg;
16851 : else
16852 : {
16853 438 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16854 438 : if (dummy_args)
16855 437 : pass1 = dummy_args->sym->name;
16856 : else
16857 : pass1 = NULL;
16858 : }
16859 748 : if (t2->specific->nopass)
16860 : pass2 = NULL;
16861 696 : else if (t2->specific->pass_arg)
16862 : pass2 = t2->specific->pass_arg;
16863 : else
16864 : {
16865 559 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16866 559 : if (dummy_args)
16867 558 : pass2 = dummy_args->sym->name;
16868 : else
16869 : pass2 = NULL;
16870 : }
16871 :
16872 : /* Care must be taken with pdt types and templates because the declared type
16873 : of the argument that is not 'no_pass' need not be the same as the
16874 : containing derived type. If this is the case, subject the argument to
16875 : the full interface check, even though it cannot be used in the type
16876 : bound context. */
16877 748 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16878 748 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16879 :
16880 748 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16881 748 : pass1 = pass2 = NULL;
16882 :
16883 : /* Compare the interfaces. */
16884 748 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16885 : NULL, 0, pass1, pass2))
16886 : {
16887 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16888 : sym1->name, sym2->name, generic_name, &where);
16889 8 : return false;
16890 : }
16891 :
16892 : return true;
16893 : }
16894 :
16895 :
16896 : /* Worker function for resolving a generic procedure binding; this is used to
16897 : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16898 :
16899 : The difference between those cases is finding possible inherited bindings
16900 : that are overridden, as one has to look for them in tb_sym_root,
16901 : tb_uop_root or tb_op, respectively. Thus the caller must already find
16902 : the super-type and set p->overridden correctly. */
16903 :
16904 : static bool
16905 2421 : resolve_tb_generic_targets (gfc_symbol* super_type,
16906 : gfc_typebound_proc* p, const char* name)
16907 : {
16908 2421 : gfc_tbp_generic* target;
16909 2421 : gfc_symtree* first_target;
16910 2421 : gfc_symtree* inherited;
16911 :
16912 2421 : gcc_assert (p && p->is_generic);
16913 :
16914 : /* Try to find the specific bindings for the symtrees in our target-list. */
16915 2421 : gcc_assert (p->u.generic);
16916 5446 : for (target = p->u.generic; target; target = target->next)
16917 3042 : if (!target->specific)
16918 : {
16919 2627 : gfc_typebound_proc* overridden_tbp;
16920 2627 : gfc_tbp_generic* g;
16921 2627 : const char* target_name;
16922 :
16923 2627 : target_name = target->specific_st->name;
16924 :
16925 : /* Defined for this type directly. */
16926 2627 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16927 : {
16928 2618 : target->specific = target->specific_st->n.tb;
16929 2618 : goto specific_found;
16930 : }
16931 :
16932 : /* Look for an inherited specific binding. */
16933 9 : if (super_type)
16934 : {
16935 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16936 : true, NULL);
16937 :
16938 5 : if (inherited)
16939 : {
16940 5 : gcc_assert (inherited->n.tb);
16941 5 : target->specific = inherited->n.tb;
16942 5 : goto specific_found;
16943 : }
16944 : }
16945 :
16946 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16947 : " at %L", target_name, name, &p->where);
16948 4 : return false;
16949 :
16950 : /* Once we've found the specific binding, check it is not ambiguous with
16951 : other specifics already found or inherited for the same GENERIC. */
16952 2623 : specific_found:
16953 2623 : gcc_assert (target->specific);
16954 :
16955 : /* This must really be a specific binding! */
16956 2623 : if (target->specific->is_generic)
16957 : {
16958 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16959 : " %qs is GENERIC, too", name, &p->where, target_name);
16960 3 : return false;
16961 : }
16962 :
16963 : /* Check those already resolved on this type directly. */
16964 6690 : for (g = p->u.generic; g; g = g->next)
16965 1464 : if (g != target && g->specific
16966 4809 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16967 : return false;
16968 :
16969 : /* Check for ambiguity with inherited specific targets. */
16970 2629 : for (overridden_tbp = p->overridden; overridden_tbp;
16971 16 : overridden_tbp = overridden_tbp->overridden)
16972 19 : if (overridden_tbp->is_generic)
16973 : {
16974 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16975 : {
16976 18 : gcc_assert (g->specific);
16977 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16978 : return false;
16979 : }
16980 : }
16981 : }
16982 :
16983 : /* If we attempt to "overwrite" a specific binding, this is an error. */
16984 2404 : if (p->overridden && !p->overridden->is_generic)
16985 : {
16986 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16987 : " the same name", name, &p->where);
16988 1 : return false;
16989 : }
16990 :
16991 : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16992 : all must have the same attributes here. */
16993 2403 : first_target = p->u.generic->specific->u.specific;
16994 2403 : gcc_assert (first_target);
16995 2403 : p->subroutine = first_target->n.sym->attr.subroutine;
16996 2403 : p->function = first_target->n.sym->attr.function;
16997 :
16998 2403 : return true;
16999 : }
17000 :
17001 :
17002 : /* Resolve a GENERIC procedure binding for a derived type. */
17003 :
17004 : static bool
17005 1249 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
17006 : {
17007 1249 : gfc_symbol* super_type;
17008 :
17009 : /* Find the overridden binding if any. */
17010 1249 : st->n.tb->overridden = NULL;
17011 1249 : super_type = gfc_get_derived_super_type (derived);
17012 1249 : if (super_type)
17013 : {
17014 40 : gfc_symtree* overridden;
17015 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
17016 : true, NULL);
17017 :
17018 40 : if (overridden && overridden->n.tb)
17019 21 : st->n.tb->overridden = overridden->n.tb;
17020 : }
17021 :
17022 : /* Resolve using worker function. */
17023 1249 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
17024 : }
17025 :
17026 :
17027 : /* Retrieve the target-procedure of an operator binding and do some checks in
17028 : common for intrinsic and user-defined type-bound operators. */
17029 :
17030 : static gfc_symbol*
17031 1244 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
17032 : {
17033 1244 : gfc_symbol* target_proc;
17034 :
17035 1244 : gcc_assert (target->specific && !target->specific->is_generic);
17036 1244 : target_proc = target->specific->u.specific->n.sym;
17037 1244 : gcc_assert (target_proc);
17038 :
17039 : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
17040 1244 : if (target->specific->nopass)
17041 : {
17042 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
17043 2 : return NULL;
17044 : }
17045 :
17046 : return target_proc;
17047 : }
17048 :
17049 :
17050 : /* Resolve a type-bound intrinsic operator. */
17051 :
17052 : static bool
17053 1059 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
17054 : gfc_typebound_proc* p)
17055 : {
17056 1059 : gfc_symbol* super_type;
17057 1059 : gfc_tbp_generic* target;
17058 :
17059 : /* If there's already an error here, do nothing (but don't fail again). */
17060 1059 : if (p->error)
17061 : return true;
17062 :
17063 : /* Operators should always be GENERIC bindings. */
17064 1059 : gcc_assert (p->is_generic);
17065 :
17066 : /* Look for an overridden binding. */
17067 1059 : super_type = gfc_get_derived_super_type (derived);
17068 1059 : if (super_type && super_type->f2k_derived)
17069 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
17070 : op, true, NULL);
17071 : else
17072 1058 : p->overridden = NULL;
17073 :
17074 : /* Resolve general GENERIC properties using worker function. */
17075 1059 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
17076 1 : goto error;
17077 :
17078 : /* Check the targets to be procedures of correct interface. */
17079 2163 : for (target = p->u.generic; target; target = target->next)
17080 : {
17081 1130 : gfc_symbol* target_proc;
17082 :
17083 1130 : target_proc = get_checked_tb_operator_target (target, p->where);
17084 1130 : if (!target_proc)
17085 1 : goto error;
17086 :
17087 1129 : if (!gfc_check_operator_interface (target_proc, op, p->where))
17088 3 : goto error;
17089 :
17090 : /* Add target to non-typebound operator list. */
17091 1126 : if (!target->specific->deferred && !derived->attr.use_assoc
17092 397 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
17093 : {
17094 395 : gfc_interface *head, *intr;
17095 :
17096 : /* Preempt 'gfc_check_new_interface' for submodules, where the
17097 : mechanism for handling module procedures winds up resolving
17098 : operator interfaces twice and would otherwise cause an error.
17099 : Likewise, new instances of PDTs can cause the operator inter-
17100 : faces to be resolved multiple times. */
17101 467 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
17102 91 : if (intr->sym == target_proc
17103 21 : && (target_proc->attr.used_in_submodule
17104 4 : || derived->attr.pdt_type
17105 2 : || derived->attr.pdt_template))
17106 : return true;
17107 :
17108 376 : if (!gfc_check_new_interface (derived->ns->op[op],
17109 : target_proc, p->where))
17110 : return false;
17111 374 : head = derived->ns->op[op];
17112 374 : intr = gfc_get_interface ();
17113 374 : intr->sym = target_proc;
17114 374 : intr->where = p->where;
17115 374 : intr->next = head;
17116 374 : derived->ns->op[op] = intr;
17117 : }
17118 : }
17119 :
17120 : return true;
17121 :
17122 5 : error:
17123 5 : p->error = 1;
17124 5 : return false;
17125 : }
17126 :
17127 :
17128 : /* Resolve a type-bound user operator (tree-walker callback). */
17129 :
17130 : static gfc_symbol* resolve_bindings_derived;
17131 : static bool resolve_bindings_result;
17132 :
17133 : static bool check_uop_procedure (gfc_symbol* sym, locus where);
17134 :
17135 : static void
17136 113 : resolve_typebound_user_op (gfc_symtree* stree)
17137 : {
17138 113 : gfc_symbol* super_type;
17139 113 : gfc_tbp_generic* target;
17140 :
17141 113 : gcc_assert (stree && stree->n.tb);
17142 :
17143 113 : if (stree->n.tb->error)
17144 : return;
17145 :
17146 : /* Operators should always be GENERIC bindings. */
17147 113 : gcc_assert (stree->n.tb->is_generic);
17148 :
17149 : /* Find overridden procedure, if any. */
17150 113 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
17151 113 : if (super_type && super_type->f2k_derived)
17152 : {
17153 18 : gfc_symtree* overridden;
17154 18 : overridden = gfc_find_typebound_user_op (super_type, NULL,
17155 : stree->name, true, NULL);
17156 :
17157 18 : if (overridden && overridden->n.tb)
17158 0 : stree->n.tb->overridden = overridden->n.tb;
17159 : }
17160 : else
17161 95 : stree->n.tb->overridden = NULL;
17162 :
17163 : /* Resolve basically using worker function. */
17164 113 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
17165 0 : goto error;
17166 :
17167 : /* Check the targets to be functions of correct interface. */
17168 224 : for (target = stree->n.tb->u.generic; target; target = target->next)
17169 : {
17170 114 : gfc_symbol* target_proc;
17171 :
17172 114 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
17173 114 : if (!target_proc)
17174 1 : goto error;
17175 :
17176 113 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
17177 2 : goto error;
17178 : }
17179 :
17180 : return;
17181 :
17182 3 : error:
17183 3 : resolve_bindings_result = false;
17184 3 : stree->n.tb->error = 1;
17185 : }
17186 :
17187 :
17188 : /* Resolve the type-bound procedures for a derived type. */
17189 :
17190 : static void
17191 10231 : resolve_typebound_procedure (gfc_symtree* stree)
17192 : {
17193 10231 : gfc_symbol* proc;
17194 10231 : locus where;
17195 10231 : gfc_symbol* me_arg;
17196 10231 : gfc_symbol* super_type;
17197 10231 : gfc_component* comp;
17198 :
17199 10231 : gcc_assert (stree);
17200 :
17201 : /* Undefined specific symbol from GENERIC target definition. */
17202 10231 : if (!stree->n.tb)
17203 10149 : return;
17204 :
17205 10225 : if (stree->n.tb->error)
17206 : return;
17207 :
17208 : /* If this is a GENERIC binding, use that routine. */
17209 10209 : if (stree->n.tb->is_generic)
17210 : {
17211 1249 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
17212 17 : goto error;
17213 : return;
17214 : }
17215 :
17216 : /* Get the target-procedure to check it. */
17217 8960 : gcc_assert (!stree->n.tb->is_generic);
17218 8960 : gcc_assert (stree->n.tb->u.specific);
17219 8960 : proc = stree->n.tb->u.specific->n.sym;
17220 8960 : where = stree->n.tb->where;
17221 :
17222 : /* Default access should already be resolved from the parser. */
17223 8960 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
17224 :
17225 8960 : if (stree->n.tb->deferred)
17226 : {
17227 676 : if (!check_proc_interface (proc, &where))
17228 5 : goto error;
17229 : }
17230 : else
17231 : {
17232 : /* If proc has not been resolved at this point, proc->name may
17233 : actually be a USE associated entity. See PR fortran/89647. */
17234 8284 : if (!proc->resolve_symbol_called
17235 5734 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
17236 : {
17237 11 : gfc_symbol *tmp;
17238 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
17239 11 : if (tmp && tmp->attr.use_assoc)
17240 : {
17241 1 : proc->module = tmp->module;
17242 1 : proc->attr.proc = tmp->attr.proc;
17243 1 : proc->attr.function = tmp->attr.function;
17244 1 : proc->attr.subroutine = tmp->attr.subroutine;
17245 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
17246 1 : proc->ts = tmp->ts;
17247 1 : proc->result = tmp->result;
17248 : }
17249 : }
17250 :
17251 : /* Check for F08:C465. */
17252 8284 : if ((!proc->attr.subroutine && !proc->attr.function)
17253 8274 : || (proc->attr.proc != PROC_MODULE
17254 70 : && proc->attr.if_source != IFSRC_IFBODY
17255 7 : && !proc->attr.module_procedure)
17256 8273 : || proc->attr.abstract)
17257 : {
17258 12 : gfc_error ("%qs must be a module procedure or an external "
17259 : "procedure with an explicit interface at %L",
17260 : proc->name, &where);
17261 12 : goto error;
17262 : }
17263 : }
17264 :
17265 8943 : stree->n.tb->subroutine = proc->attr.subroutine;
17266 8943 : stree->n.tb->function = proc->attr.function;
17267 :
17268 : /* Find the super-type of the current derived type. We could do this once and
17269 : store in a global if speed is needed, but as long as not I believe this is
17270 : more readable and clearer. */
17271 8943 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
17272 :
17273 : /* If PASS, resolve and check arguments if not already resolved / loaded
17274 : from a .mod file. */
17275 8943 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
17276 : {
17277 2844 : gfc_formal_arglist *dummy_args;
17278 :
17279 2844 : dummy_args = gfc_sym_get_dummy_args (proc);
17280 2844 : if (stree->n.tb->pass_arg)
17281 : {
17282 468 : gfc_formal_arglist *i;
17283 :
17284 : /* If an explicit passing argument name is given, walk the arg-list
17285 : and look for it. */
17286 :
17287 468 : me_arg = NULL;
17288 468 : stree->n.tb->pass_arg_num = 1;
17289 601 : for (i = dummy_args; i; i = i->next)
17290 : {
17291 599 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
17292 : {
17293 : me_arg = i->sym;
17294 : break;
17295 : }
17296 133 : ++stree->n.tb->pass_arg_num;
17297 : }
17298 :
17299 468 : if (!me_arg)
17300 : {
17301 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
17302 : " argument %qs",
17303 : proc->name, stree->n.tb->pass_arg, &where,
17304 : stree->n.tb->pass_arg);
17305 2 : goto error;
17306 : }
17307 : }
17308 : else
17309 : {
17310 : /* Otherwise, take the first one; there should in fact be at least
17311 : one. */
17312 2376 : stree->n.tb->pass_arg_num = 1;
17313 2376 : if (!dummy_args)
17314 : {
17315 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
17316 : " least one argument", proc->name, &where);
17317 2 : goto error;
17318 : }
17319 2374 : me_arg = dummy_args->sym;
17320 : }
17321 :
17322 : /* Now check that the argument-type matches and the passed-object
17323 : dummy argument is generally fine. */
17324 :
17325 2374 : gcc_assert (me_arg);
17326 :
17327 2840 : if (me_arg->ts.type != BT_CLASS)
17328 : {
17329 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17330 : " at %L", proc->name, &where);
17331 5 : goto error;
17332 : }
17333 :
17334 : /* The derived type is not a PDT template or type. Resolve as usual. */
17335 2835 : if (!resolve_bindings_derived->attr.pdt_template
17336 2826 : && !(containing_dt && containing_dt->attr.pdt_type
17337 60 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
17338 2806 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
17339 : {
17340 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17341 : "the derived-type %qs", me_arg->name, proc->name,
17342 : me_arg->name, &where, resolve_bindings_derived->name);
17343 0 : goto error;
17344 : }
17345 :
17346 2835 : if (resolve_bindings_derived->attr.pdt_template
17347 2844 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
17348 9 : CLASS_DATA (me_arg)->ts.u.derived))
17349 : {
17350 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17351 : "the parametric derived-type %qs", me_arg->name,
17352 : proc->name, me_arg->name, &where,
17353 : resolve_bindings_derived->name);
17354 0 : goto error;
17355 : }
17356 :
17357 2835 : if (((resolve_bindings_derived->attr.pdt_template
17358 9 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
17359 9 : CLASS_DATA (me_arg)->ts.u.derived))
17360 2826 : || resolve_bindings_derived->attr.pdt_type)
17361 69 : && (me_arg->param_list != NULL)
17362 2904 : && (gfc_spec_list_type (me_arg->param_list,
17363 69 : CLASS_DATA(me_arg)->ts.u.derived)
17364 : != SPEC_ASSUMED))
17365 : {
17366 :
17367 : /* Add a check to verify if there are any LEN parameters in the
17368 : first place. If there are LEN parameters, throw this error.
17369 : If there are only KIND parameters, then don't trigger
17370 : this error. */
17371 6 : gfc_component *c;
17372 6 : bool seen_len_param = false;
17373 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
17374 :
17375 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
17376 : {
17377 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
17378 : me_arg_param->name, true, true, NULL);
17379 :
17380 6 : gcc_assert (c != NULL);
17381 :
17382 6 : if (c->attr.pdt_kind)
17383 0 : continue;
17384 :
17385 : /* Getting here implies that there is a pdt_len parameter
17386 : in the list. */
17387 : seen_len_param = true;
17388 : break;
17389 : }
17390 :
17391 6 : if (seen_len_param)
17392 : {
17393 6 : gfc_error ("All LEN type parameters of the passed dummy "
17394 : "argument %qs of %qs at %L must be ASSUMED.",
17395 : me_arg->name, proc->name, &where);
17396 6 : goto error;
17397 : }
17398 : }
17399 :
17400 2829 : gcc_assert (me_arg->ts.type == BT_CLASS);
17401 2829 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
17402 : {
17403 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
17404 : " scalar", proc->name, &where);
17405 1 : goto error;
17406 : }
17407 2828 : if (CLASS_DATA (me_arg)->attr.allocatable)
17408 : {
17409 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17410 : " be ALLOCATABLE", proc->name, &where);
17411 2 : goto error;
17412 : }
17413 2826 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17414 : {
17415 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17416 : " be POINTER", proc->name, &where);
17417 2 : goto error;
17418 : }
17419 : }
17420 :
17421 : /* If we are extending some type, check that we don't override a procedure
17422 : flagged NON_OVERRIDABLE. */
17423 8923 : stree->n.tb->overridden = NULL;
17424 8923 : if (super_type)
17425 : {
17426 1513 : gfc_symtree* overridden;
17427 1513 : overridden = gfc_find_typebound_proc (super_type, NULL,
17428 : stree->name, true, NULL);
17429 :
17430 1513 : if (overridden)
17431 : {
17432 1218 : if (overridden->n.tb)
17433 1218 : stree->n.tb->overridden = overridden->n.tb;
17434 :
17435 1218 : if (!gfc_check_typebound_override (stree, overridden))
17436 26 : goto error;
17437 : }
17438 : }
17439 :
17440 : /* See if there's a name collision with a component directly in this type. */
17441 21297 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
17442 12401 : if (!strcmp (comp->name, stree->name))
17443 : {
17444 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
17445 : " %qs",
17446 : stree->name, &where, resolve_bindings_derived->name);
17447 1 : goto error;
17448 : }
17449 :
17450 : /* Try to find a name collision with an inherited component. */
17451 8896 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
17452 : NULL))
17453 : {
17454 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
17455 : " component of %qs",
17456 : stree->name, &where, resolve_bindings_derived->name);
17457 1 : goto error;
17458 : }
17459 :
17460 8895 : stree->n.tb->error = 0;
17461 8895 : return;
17462 :
17463 82 : error:
17464 82 : resolve_bindings_result = false;
17465 82 : stree->n.tb->error = 1;
17466 : }
17467 :
17468 :
17469 : static bool
17470 90223 : resolve_typebound_procedures (gfc_symbol* derived)
17471 : {
17472 90223 : int op;
17473 90223 : gfc_symbol* super_type;
17474 :
17475 : /* Resolve the super-type first so that inherited bindings (including
17476 : user operators) are fully resolved before we look them up via
17477 : gfc_find_typebound_user_op. This must happen even when 'derived'
17478 : has no direct type-bound bindings of its own. */
17479 90223 : super_type = gfc_get_derived_super_type (derived);
17480 90223 : if (super_type)
17481 14107 : resolve_symbol (super_type);
17482 :
17483 90223 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
17484 : return true;
17485 :
17486 4900 : resolve_bindings_derived = derived;
17487 4900 : resolve_bindings_result = true;
17488 :
17489 4900 : containing_dt = derived; /* Needed for checks of PDTs. */
17490 4900 : if (derived->f2k_derived->tb_sym_root)
17491 4900 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
17492 : &resolve_typebound_procedure);
17493 :
17494 4900 : if (derived->f2k_derived->tb_uop_root)
17495 91 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
17496 : &resolve_typebound_user_op);
17497 4900 : containing_dt = NULL;
17498 :
17499 142100 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
17500 : {
17501 137200 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
17502 137200 : if (p && !resolve_typebound_intrinsic_op (derived,
17503 : (gfc_intrinsic_op)op, p))
17504 7 : resolve_bindings_result = false;
17505 : }
17506 :
17507 4900 : return resolve_bindings_result;
17508 : }
17509 :
17510 :
17511 : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
17512 : to give all identical derived types the same backend_decl. */
17513 : static void
17514 185391 : add_dt_to_dt_list (gfc_symbol *derived)
17515 : {
17516 185391 : if (!derived->dt_next)
17517 : {
17518 86863 : if (gfc_derived_types)
17519 : {
17520 71016 : derived->dt_next = gfc_derived_types->dt_next;
17521 71016 : gfc_derived_types->dt_next = derived;
17522 : }
17523 : else
17524 : {
17525 15847 : derived->dt_next = derived;
17526 : }
17527 86863 : gfc_derived_types = derived;
17528 : }
17529 185391 : }
17530 :
17531 :
17532 : /* Ensure that a derived-type is really not abstract, meaning that every
17533 : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
17534 :
17535 : static bool
17536 7212 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
17537 : {
17538 7212 : if (!st)
17539 : return true;
17540 :
17541 2772 : if (!ensure_not_abstract_walker (sub, st->left))
17542 : return false;
17543 2772 : if (!ensure_not_abstract_walker (sub, st->right))
17544 : return false;
17545 :
17546 2771 : if (st->n.tb && st->n.tb->deferred)
17547 : {
17548 2019 : gfc_symtree* overriding;
17549 2019 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
17550 2019 : if (!overriding)
17551 : return false;
17552 2018 : gcc_assert (overriding->n.tb);
17553 2018 : if (overriding->n.tb->deferred)
17554 : {
17555 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
17556 : " %qs is DEFERRED and not overridden",
17557 : sub->name, &sub->declared_at, st->name);
17558 5 : return false;
17559 : }
17560 : }
17561 :
17562 : return true;
17563 : }
17564 :
17565 : static bool
17566 1520 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
17567 : {
17568 : /* The algorithm used here is to recursively travel up the ancestry of sub
17569 : and for each ancestor-type, check all bindings. If any of them is
17570 : DEFERRED, look it up starting from sub and see if the found (overriding)
17571 : binding is not DEFERRED.
17572 : This is not the most efficient way to do this, but it should be ok and is
17573 : clearer than something sophisticated. */
17574 :
17575 1669 : gcc_assert (ancestor && !sub->attr.abstract);
17576 :
17577 1669 : if (!ancestor->attr.abstract)
17578 : return true;
17579 :
17580 : /* Walk bindings of this ancestor. */
17581 1668 : if (ancestor->f2k_derived)
17582 : {
17583 1668 : bool t;
17584 1668 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
17585 1668 : if (!t)
17586 : return false;
17587 : }
17588 :
17589 : /* Find next ancestor type and recurse on it. */
17590 1662 : ancestor = gfc_get_derived_super_type (ancestor);
17591 1662 : if (ancestor)
17592 : return ensure_not_abstract (sub, ancestor);
17593 :
17594 : return true;
17595 : }
17596 :
17597 :
17598 : /* This check for typebound defined assignments is done recursively
17599 : since the order in which derived types are resolved is not always in
17600 : order of the declarations. */
17601 :
17602 : static void
17603 191038 : check_defined_assignments (gfc_symbol *derived)
17604 : {
17605 191038 : gfc_component *c;
17606 :
17607 644838 : for (c = derived->components; c; c = c->next)
17608 : {
17609 455607 : if (!gfc_bt_struct (c->ts.type)
17610 109759 : || c->attr.pointer
17611 22649 : || c->attr.proc_pointer_comp
17612 22649 : || c->attr.class_pointer
17613 22643 : || c->attr.proc_pointer)
17614 433498 : continue;
17615 :
17616 22109 : if (c->ts.u.derived->attr.defined_assign_comp
17617 21874 : || (c->ts.u.derived->f2k_derived
17618 21292 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
17619 : {
17620 1783 : derived->attr.defined_assign_comp = 1;
17621 1783 : return;
17622 : }
17623 :
17624 20326 : if (c->attr.allocatable)
17625 7178 : continue;
17626 :
17627 13148 : check_defined_assignments (c->ts.u.derived);
17628 13148 : if (c->ts.u.derived->attr.defined_assign_comp)
17629 : {
17630 24 : derived->attr.defined_assign_comp = 1;
17631 24 : return;
17632 : }
17633 : }
17634 : }
17635 :
17636 :
17637 : /* Resolve a single component of a derived type or structure. */
17638 :
17639 : static bool
17640 432612 : resolve_component (gfc_component *c, gfc_symbol *sym)
17641 : {
17642 432612 : gfc_symbol *super_type;
17643 432612 : symbol_attribute *attr;
17644 :
17645 432612 : if (c->attr.artificial)
17646 : return true;
17647 :
17648 : /* Do not allow vtype components to be resolved in nameless namespaces
17649 : such as block data because the procedure pointers will cause ICEs
17650 : and vtables are not needed in these contexts. */
17651 296058 : if (sym->attr.vtype && sym->attr.use_assoc
17652 50648 : && sym->ns->proc_name == NULL)
17653 : return true;
17654 :
17655 : /* F2008, C442. */
17656 296049 : if ((!sym->attr.is_class || c != sym->components)
17657 296049 : && c->attr.codimension
17658 230 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
17659 : {
17660 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
17661 : "deferred shape", c->name, &c->loc);
17662 4 : return false;
17663 : }
17664 :
17665 : /* F2008, C443. */
17666 296045 : if (c->attr.codimension && c->ts.type == BT_DERIVED
17667 85 : && c->ts.u.derived->ts.is_iso_c)
17668 : {
17669 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17670 : "shall not be a coarray", c->name, &c->loc);
17671 1 : return false;
17672 : }
17673 :
17674 : /* F2008, C444. */
17675 296044 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
17676 28 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
17677 26 : || c->attr.allocatable))
17678 : {
17679 3 : gfc_error ("Component %qs at %L with coarray component "
17680 : "shall be a nonpointer, nonallocatable scalar",
17681 : c->name, &c->loc);
17682 3 : return false;
17683 : }
17684 :
17685 : /* F2008, C448. */
17686 296041 : if (c->ts.type == BT_CLASS)
17687 : {
17688 7364 : if (c->attr.class_ok && CLASS_DATA (c))
17689 : {
17690 7356 : attr = &(CLASS_DATA (c)->attr);
17691 :
17692 : /* Fix up contiguous attribute. */
17693 7356 : if (c->attr.contiguous)
17694 11 : attr->contiguous = 1;
17695 : }
17696 : else
17697 : attr = NULL;
17698 : }
17699 : else
17700 288677 : attr = &c->attr;
17701 :
17702 296033 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
17703 : {
17704 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
17705 : "is not an array pointer", c->name, &c->loc);
17706 5 : return false;
17707 : }
17708 :
17709 : /* F2003, 15.2.1 - length has to be one. */
17710 41748 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
17711 296055 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
17712 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
17713 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
17714 : {
17715 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
17716 : c->name, &c->loc);
17717 1 : return false;
17718 : }
17719 :
17720 55341 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
17721 481 : && !sym->attr.pdt_type && !sym->attr.pdt_template
17722 296043 : && !(gfc_get_derived_super_type (sym)
17723 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
17724 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
17725 : {
17726 8 : gfc_actual_arglist *type_spec_list;
17727 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
17728 : &type_spec_list)
17729 : != MATCH_YES)
17730 0 : return false;
17731 8 : gfc_free_actual_arglist (c->param_list);
17732 8 : c->param_list = type_spec_list;
17733 8 : if (!sym->attr.pdt_type)
17734 8 : sym->attr.pdt_comp = 1;
17735 : }
17736 296027 : else if (IS_PDT (c) && !sym->attr.pdt_type)
17737 54 : sym->attr.pdt_comp = 1;
17738 :
17739 296035 : if (c->attr.proc_pointer && c->ts.interface)
17740 : {
17741 14986 : gfc_symbol *ifc = c->ts.interface;
17742 :
17743 14986 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
17744 : {
17745 6 : c->tb->error = 1;
17746 6 : return false;
17747 : }
17748 :
17749 14980 : if (ifc->attr.if_source || ifc->attr.intrinsic)
17750 : {
17751 : /* Resolve interface and copy attributes. */
17752 14931 : if (ifc->formal && !ifc->formal_ns)
17753 2611 : resolve_symbol (ifc);
17754 14931 : if (ifc->attr.intrinsic)
17755 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17756 :
17757 14931 : if (ifc->result)
17758 : {
17759 7809 : c->ts = ifc->result->ts;
17760 7809 : c->attr.allocatable = ifc->result->attr.allocatable;
17761 7809 : c->attr.pointer = ifc->result->attr.pointer;
17762 7809 : c->attr.dimension = ifc->result->attr.dimension;
17763 7809 : c->as = gfc_copy_array_spec (ifc->result->as);
17764 7809 : c->attr.class_ok = ifc->result->attr.class_ok;
17765 : }
17766 : else
17767 : {
17768 7122 : c->ts = ifc->ts;
17769 7122 : c->attr.allocatable = ifc->attr.allocatable;
17770 7122 : c->attr.pointer = ifc->attr.pointer;
17771 7122 : c->attr.dimension = ifc->attr.dimension;
17772 7122 : c->as = gfc_copy_array_spec (ifc->as);
17773 7122 : c->attr.class_ok = ifc->attr.class_ok;
17774 : }
17775 14931 : c->ts.interface = ifc;
17776 14931 : c->attr.function = ifc->attr.function;
17777 14931 : c->attr.subroutine = ifc->attr.subroutine;
17778 :
17779 14931 : c->attr.pure = ifc->attr.pure;
17780 14931 : c->attr.elemental = ifc->attr.elemental;
17781 14931 : c->attr.recursive = ifc->attr.recursive;
17782 14931 : c->attr.always_explicit = ifc->attr.always_explicit;
17783 14931 : c->attr.ext_attr |= ifc->attr.ext_attr;
17784 : /* Copy char length. */
17785 14931 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17786 : {
17787 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17788 454 : if (cl->length && !cl->resolved
17789 601 : && !gfc_resolve_expr (cl->length))
17790 : {
17791 0 : c->tb->error = 1;
17792 0 : return false;
17793 : }
17794 491 : c->ts.u.cl = cl;
17795 : }
17796 : }
17797 : }
17798 281049 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17799 : {
17800 : /* Since PPCs are not implicitly typed, a PPC without an explicit
17801 : interface must be a subroutine. */
17802 116 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17803 : }
17804 :
17805 : /* Procedure pointer components: Check PASS arg. */
17806 296029 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17807 578 : && !sym->attr.vtype)
17808 : {
17809 95 : gfc_symbol* me_arg;
17810 :
17811 95 : if (c->tb->pass_arg)
17812 : {
17813 20 : gfc_formal_arglist* i;
17814 :
17815 : /* If an explicit passing argument name is given, walk the arg-list
17816 : and look for it. */
17817 :
17818 20 : me_arg = NULL;
17819 20 : c->tb->pass_arg_num = 1;
17820 34 : for (i = c->ts.interface->formal; i; i = i->next)
17821 : {
17822 33 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17823 : {
17824 : me_arg = i->sym;
17825 : break;
17826 : }
17827 14 : c->tb->pass_arg_num++;
17828 : }
17829 :
17830 20 : if (!me_arg)
17831 : {
17832 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17833 : "at %L has no argument %qs", c->name,
17834 : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17835 1 : c->tb->error = 1;
17836 1 : return false;
17837 : }
17838 : }
17839 : else
17840 : {
17841 : /* Otherwise, take the first one; there should in fact be at least
17842 : one. */
17843 75 : c->tb->pass_arg_num = 1;
17844 75 : if (!c->ts.interface->formal)
17845 : {
17846 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17847 : "must have at least one argument",
17848 : c->name, &c->loc);
17849 3 : c->tb->error = 1;
17850 3 : return false;
17851 : }
17852 72 : me_arg = c->ts.interface->formal->sym;
17853 : }
17854 :
17855 : /* Now check that the argument-type matches. */
17856 72 : gcc_assert (me_arg);
17857 91 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17858 90 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17859 90 : || (me_arg->ts.type == BT_CLASS
17860 82 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17861 : {
17862 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17863 : " the derived type %qs", me_arg->name, c->name,
17864 : me_arg->name, &c->loc, sym->name);
17865 1 : c->tb->error = 1;
17866 1 : return false;
17867 : }
17868 :
17869 : /* Check for F03:C453. */
17870 90 : if (CLASS_DATA (me_arg)->attr.dimension)
17871 : {
17872 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17873 : "must be scalar", me_arg->name, c->name, me_arg->name,
17874 : &c->loc);
17875 1 : c->tb->error = 1;
17876 1 : return false;
17877 : }
17878 :
17879 89 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17880 : {
17881 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17882 : "may not have the POINTER attribute", me_arg->name,
17883 : c->name, me_arg->name, &c->loc);
17884 1 : c->tb->error = 1;
17885 1 : return false;
17886 : }
17887 :
17888 88 : if (CLASS_DATA (me_arg)->attr.allocatable)
17889 : {
17890 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17891 : "may not be ALLOCATABLE", me_arg->name, c->name,
17892 : me_arg->name, &c->loc);
17893 1 : c->tb->error = 1;
17894 1 : return false;
17895 : }
17896 :
17897 87 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17898 : {
17899 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17900 : " at %L", c->name, &c->loc);
17901 2 : return false;
17902 : }
17903 :
17904 : }
17905 :
17906 : /* Check type-spec if this is not the parent-type component. */
17907 296019 : if (((sym->attr.is_class
17908 13053 : && (!sym->components->ts.u.derived->attr.extension
17909 2412 : || c != CLASS_DATA (sym->components)))
17910 284323 : || (!sym->attr.is_class
17911 282966 : && (!sym->attr.extension || c != sym->components)))
17912 287160 : && !sym->attr.vtype
17913 469561 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17914 : return false;
17915 :
17916 296018 : super_type = gfc_get_derived_super_type (sym);
17917 :
17918 : /* If this type is an extension, set the accessibility of the parent
17919 : component. */
17920 296018 : if (super_type
17921 28840 : && ((sym->attr.is_class
17922 13053 : && c == CLASS_DATA (sym->components))
17923 19802 : || (!sym->attr.is_class && c == sym->components))
17924 16540 : && strcmp (super_type->name, c->name) == 0)
17925 7088 : c->attr.access = super_type->attr.access;
17926 :
17927 : /* If this type is an extension, see if this component has the same name
17928 : as an inherited type-bound procedure. */
17929 28840 : if (super_type && !sym->attr.is_class
17930 15787 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17931 : {
17932 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17933 : " inherited type-bound procedure",
17934 : c->name, sym->name, &c->loc);
17935 1 : return false;
17936 : }
17937 :
17938 296017 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17939 9944 : && !c->ts.deferred)
17940 : {
17941 7661 : if (sym->attr.pdt_template || c->attr.pdt_string)
17942 495 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17943 :
17944 7661 : if (c->ts.u.cl->length == NULL
17945 7655 : || !resolve_charlen(c->ts.u.cl)
17946 15315 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17947 : {
17948 9 : gfc_error ("Character length of component %qs needs to "
17949 : "be a constant specification expression at %L",
17950 : c->name,
17951 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17952 9 : return false;
17953 : }
17954 :
17955 7652 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17956 : {
17957 2 : if (!c->ts.u.cl->length->error)
17958 : {
17959 1 : gfc_error ("Character length expression of component %qs at %L "
17960 : "must be of INTEGER type, found %s",
17961 1 : c->name, &c->ts.u.cl->length->where,
17962 : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17963 1 : c->ts.u.cl->length->error = 1;
17964 : }
17965 : return false;
17966 : }
17967 : }
17968 :
17969 296006 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17970 2319 : && !c->attr.pointer && !c->attr.allocatable)
17971 : {
17972 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17973 : "length must be a POINTER or ALLOCATABLE",
17974 : c->name, sym->name, &c->loc);
17975 1 : return false;
17976 : }
17977 :
17978 : /* Add the hidden deferred length field. */
17979 296005 : if (c->ts.type == BT_CHARACTER
17980 10444 : && (c->ts.deferred || c->attr.pdt_string)
17981 2598 : && !c->attr.function
17982 2562 : && !sym->attr.is_class)
17983 : {
17984 2415 : char name[GFC_MAX_SYMBOL_LEN+9];
17985 2415 : gfc_component *strlen;
17986 2415 : sprintf (name, "_%s_length", c->name);
17987 2415 : strlen = gfc_find_component (sym, name, true, true, NULL);
17988 2415 : if (strlen == NULL)
17989 : {
17990 556 : if (!gfc_add_component (sym, name, &strlen))
17991 0 : return false;
17992 556 : strlen->ts.type = BT_INTEGER;
17993 556 : strlen->ts.kind = gfc_charlen_int_kind;
17994 556 : strlen->attr.access = ACCESS_PRIVATE;
17995 556 : strlen->attr.artificial = 1;
17996 : }
17997 : }
17998 :
17999 296005 : if (c->ts.type == BT_DERIVED
18000 55551 : && sym->component_access != ACCESS_PRIVATE
18001 54531 : && gfc_check_symbol_access (sym)
18002 107026 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
18003 53454 : && !c->ts.u.derived->attr.use_assoc
18004 28821 : && !gfc_check_symbol_access (c->ts.u.derived)
18005 296202 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
18006 : "PRIVATE type and cannot be a component of "
18007 : "%qs, which is PUBLIC at %L", c->name,
18008 : sym->name, &sym->declared_at))
18009 : return false;
18010 :
18011 296004 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
18012 : {
18013 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
18014 : "type %s", c->name, &c->loc, sym->name);
18015 2 : return false;
18016 : }
18017 :
18018 296002 : if (sym->attr.sequence)
18019 : {
18020 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
18021 : {
18022 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
18023 : "not have the SEQUENCE attribute",
18024 : c->ts.u.derived->name, &sym->declared_at);
18025 0 : return false;
18026 : }
18027 : }
18028 :
18029 296002 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
18030 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
18031 296002 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
18032 7698 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
18033 0 : CLASS_DATA (c)->ts.u.derived
18034 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
18035 :
18036 : /* If an allocatable component derived type is of the same type as
18037 : the enclosing derived type, we need a vtable generating so that
18038 : the __deallocate procedure is created. */
18039 296002 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
18040 63259 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
18041 519 : gfc_find_vtab (&c->ts);
18042 :
18043 : /* Ensure that all the derived type components are put on the
18044 : derived type list; even in formal namespaces, where derived type
18045 : pointer components might not have been declared. */
18046 296002 : if (c->ts.type == BT_DERIVED
18047 55550 : && c->ts.u.derived
18048 55550 : && c->ts.u.derived->components
18049 52222 : && c->attr.pointer
18050 35117 : && sym != c->ts.u.derived)
18051 4458 : add_dt_to_dt_list (c->ts.u.derived);
18052 :
18053 296002 : if (c->as && c->as->type != AS_DEFERRED
18054 7817 : && (c->attr.pointer || c->attr.allocatable))
18055 : return false;
18056 :
18057 295988 : if (!gfc_resolve_array_spec (c->as,
18058 295988 : !(c->attr.pointer || c->attr.proc_pointer
18059 241997 : || c->attr.allocatable)))
18060 : return false;
18061 :
18062 113691 : if (c->initializer && !sym->attr.vtype
18063 36610 : && !c->attr.pdt_kind && !c->attr.pdt_len
18064 327528 : && !gfc_check_assign_symbol (sym, c, c->initializer))
18065 : return false;
18066 :
18067 : return true;
18068 : }
18069 :
18070 :
18071 : /* Be nice about the locus for a structure expression - show the locus of the
18072 : first non-null sub-expression if we can. */
18073 :
18074 : static locus *
18075 4 : cons_where (gfc_expr *struct_expr)
18076 : {
18077 4 : gfc_constructor *cons;
18078 :
18079 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
18080 :
18081 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
18082 12 : for (; cons; cons = gfc_constructor_next (cons))
18083 : {
18084 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
18085 4 : return &cons->expr->where;
18086 : }
18087 :
18088 0 : return &struct_expr->where;
18089 : }
18090 :
18091 : /* Resolve the components of a structure type. Much less work than derived
18092 : types. */
18093 :
18094 : static bool
18095 913 : resolve_fl_struct (gfc_symbol *sym)
18096 : {
18097 913 : gfc_component *c;
18098 913 : gfc_expr *init = NULL;
18099 913 : bool success;
18100 :
18101 : /* Make sure UNIONs do not have overlapping initializers. */
18102 913 : if (sym->attr.flavor == FL_UNION)
18103 : {
18104 498 : for (c = sym->components; c; c = c->next)
18105 : {
18106 331 : if (init && c->initializer)
18107 : {
18108 2 : gfc_error ("Conflicting initializers in union at %L and %L",
18109 : cons_where (init), cons_where (c->initializer));
18110 2 : gfc_free_expr (c->initializer);
18111 2 : c->initializer = NULL;
18112 : }
18113 : if (init == NULL)
18114 291 : init = c->initializer;
18115 : }
18116 : }
18117 :
18118 913 : success = true;
18119 2830 : for (c = sym->components; c; c = c->next)
18120 1917 : if (!resolve_component (c, sym))
18121 0 : success = false;
18122 :
18123 913 : if (!success)
18124 : return false;
18125 :
18126 913 : if (sym->components)
18127 862 : add_dt_to_dt_list (sym);
18128 :
18129 : return true;
18130 : }
18131 :
18132 : /* Figure if the derived type is using itself directly in one of its components
18133 : or through referencing other derived types. The information is required to
18134 : generate the __deallocate and __final type bound procedures to ensure
18135 : freeing larger hierarchies of derived types with allocatable objects. */
18136 :
18137 : static void
18138 144243 : resolve_cyclic_derived_type (gfc_symbol *derived)
18139 : {
18140 144243 : hash_set<gfc_symbol *> seen, to_examin;
18141 144243 : gfc_component *c;
18142 144243 : seen.add (derived);
18143 144243 : to_examin.add (derived);
18144 484236 : while (!to_examin.is_empty ())
18145 : {
18146 198062 : gfc_symbol *cand = *to_examin.begin ();
18147 198062 : to_examin.remove (cand);
18148 537092 : for (c = cand->components; c; c = c->next)
18149 341342 : if (c->ts.type == BT_DERIVED)
18150 : {
18151 75036 : if (c->ts.u.derived == derived)
18152 : {
18153 1240 : derived->attr.recursive = 1;
18154 2312 : return;
18155 : }
18156 73796 : else if (!seen.contains (c->ts.u.derived))
18157 : {
18158 49097 : seen.add (c->ts.u.derived);
18159 49097 : to_examin.add (c->ts.u.derived);
18160 : }
18161 : }
18162 266306 : else if (c->ts.type == BT_CLASS)
18163 : {
18164 9966 : if (!c->attr.class_ok)
18165 7 : continue;
18166 9959 : if (CLASS_DATA (c)->ts.u.derived == derived)
18167 : {
18168 1072 : derived->attr.recursive = 1;
18169 1072 : return;
18170 : }
18171 8887 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
18172 : {
18173 5043 : seen.add (CLASS_DATA (c)->ts.u.derived);
18174 5043 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
18175 : }
18176 : }
18177 : }
18178 144243 : }
18179 :
18180 : /* Resolve the components of a derived type. This does not have to wait until
18181 : resolution stage, but can be done as soon as the dt declaration has been
18182 : parsed. */
18183 :
18184 : static bool
18185 177986 : resolve_fl_derived0 (gfc_symbol *sym)
18186 : {
18187 177986 : gfc_symbol* super_type;
18188 177986 : gfc_component *c;
18189 177986 : gfc_formal_arglist *f;
18190 177986 : bool success;
18191 :
18192 177986 : if (sym->attr.unlimited_polymorphic)
18193 : return true;
18194 :
18195 177986 : super_type = gfc_get_derived_super_type (sym);
18196 :
18197 : /* F2008, C432. */
18198 177986 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
18199 : {
18200 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
18201 : "parent type %qs shall also have one", sym->name,
18202 : &sym->declared_at, super_type->name);
18203 2 : return false;
18204 : }
18205 :
18206 : /* Ensure the extended type gets resolved before we do. */
18207 18616 : if (super_type && !resolve_fl_derived0 (super_type))
18208 : return false;
18209 :
18210 : /* An ABSTRACT type must be extensible. */
18211 177978 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
18212 : {
18213 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
18214 : sym->name, &sym->declared_at);
18215 2 : return false;
18216 : }
18217 :
18218 : /* Resolving components below, may create vtabs for which the cyclic type
18219 : information needs to be present. */
18220 177976 : if (!sym->attr.vtype)
18221 144243 : resolve_cyclic_derived_type (sym);
18222 :
18223 177976 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
18224 : : sym->components;
18225 :
18226 177976 : success = true;
18227 608671 : for ( ; c != NULL; c = c->next)
18228 430695 : if (!resolve_component (c, sym))
18229 96 : success = false;
18230 :
18231 177976 : if (!success)
18232 : return false;
18233 :
18234 : /* Now add the caf token field, where needed. */
18235 177890 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
18236 1055 : && !sym->attr.vtype)
18237 : {
18238 2323 : for (c = sym->components; c; c = c->next)
18239 1477 : if (!c->attr.dimension && !c->attr.codimension
18240 809 : && (c->attr.allocatable || c->attr.pointer))
18241 : {
18242 146 : char name[GFC_MAX_SYMBOL_LEN+9];
18243 146 : gfc_component *token;
18244 146 : sprintf (name, "_caf_%s", c->name);
18245 146 : token = gfc_find_component (sym, name, true, true, NULL);
18246 146 : if (token == NULL)
18247 : {
18248 82 : if (!gfc_add_component (sym, name, &token))
18249 0 : return false;
18250 82 : token->ts.type = BT_VOID;
18251 82 : token->ts.kind = gfc_default_integer_kind;
18252 82 : token->attr.access = ACCESS_PRIVATE;
18253 82 : token->attr.artificial = 1;
18254 82 : token->attr.caf_token = 1;
18255 : }
18256 146 : c->caf_token = token;
18257 : }
18258 : }
18259 :
18260 177890 : check_defined_assignments (sym);
18261 :
18262 177890 : if (!sym->attr.defined_assign_comp && super_type)
18263 17609 : sym->attr.defined_assign_comp
18264 17609 : = super_type->attr.defined_assign_comp;
18265 :
18266 : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
18267 : all DEFERRED bindings are overridden. */
18268 18609 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
18269 1523 : && !sym->attr.is_class
18270 3303 : && !ensure_not_abstract (sym, super_type))
18271 : return false;
18272 :
18273 : /* Check that there is a component for every PDT parameter. */
18274 177884 : if (sym->attr.pdt_template)
18275 : {
18276 4266 : for (f = sym->formal; f; f = f->next)
18277 : {
18278 2602 : if (!f->sym)
18279 1 : continue;
18280 2601 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
18281 2601 : if (c == NULL)
18282 : {
18283 9 : gfc_error ("Parameterized type %qs does not have a component "
18284 : "corresponding to parameter %qs at %L", sym->name,
18285 9 : f->sym->name, &sym->declared_at);
18286 9 : break;
18287 : }
18288 : }
18289 : }
18290 :
18291 : /* Add derived type to the derived type list. */
18292 177884 : add_dt_to_dt_list (sym);
18293 :
18294 177884 : return true;
18295 : }
18296 :
18297 : /* The following procedure does the full resolution of a derived type,
18298 : including resolution of all type-bound procedures (if present). In contrast
18299 : to 'resolve_fl_derived0' this can only be done after the module has been
18300 : parsed completely. */
18301 :
18302 : static bool
18303 92514 : resolve_fl_derived (gfc_symbol *sym)
18304 : {
18305 92514 : gfc_symbol *gen_dt = NULL;
18306 :
18307 92514 : if (sym->attr.unlimited_polymorphic)
18308 : return true;
18309 :
18310 92514 : if (!sym->attr.is_class)
18311 79214 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
18312 59440 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
18313 2315 : && (!gen_dt->generic->sym->attr.use_assoc
18314 2166 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
18315 92696 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
18316 : "%qs at %L being the same name as derived "
18317 : "type at %L", sym->name,
18318 : gen_dt->generic->sym == sym
18319 11 : ? gen_dt->generic->next->sym->name
18320 : : gen_dt->generic->sym->name,
18321 : gen_dt->generic->sym == sym
18322 11 : ? &gen_dt->generic->next->sym->declared_at
18323 : : &gen_dt->generic->sym->declared_at,
18324 : &sym->declared_at))
18325 : return false;
18326 :
18327 92510 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
18328 : {
18329 13 : gfc_error ("Derived type %qs at %L has not been declared",
18330 : sym->name, &sym->declared_at);
18331 13 : return false;
18332 : }
18333 :
18334 : /* Resolve the finalizer procedures. */
18335 92497 : if (!gfc_resolve_finalizers (sym, NULL))
18336 : return false;
18337 :
18338 92494 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
18339 : {
18340 : /* Fix up incomplete CLASS symbols. */
18341 13300 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
18342 13300 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18343 :
18344 13300 : if (data->ts.u.derived->attr.pdt_template)
18345 : {
18346 0 : match m;
18347 0 : m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
18348 : &data->param_list);
18349 0 : if (m != MATCH_YES
18350 0 : || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
18351 : {
18352 0 : gfc_error ("Failed to build PDT class component at %L",
18353 : &sym->declared_at);
18354 0 : return false;
18355 : }
18356 0 : data = gfc_find_component (sym, "_data", true, true, NULL);
18357 0 : vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18358 : }
18359 :
18360 : /* Nothing more to do for unlimited polymorphic entities. */
18361 13300 : if (data->ts.u.derived->attr.unlimited_polymorphic)
18362 : {
18363 2187 : add_dt_to_dt_list (sym);
18364 2187 : return true;
18365 : }
18366 11113 : else if (vptr->ts.u.derived == NULL)
18367 : {
18368 6615 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
18369 6615 : gcc_assert (vtab);
18370 6615 : vptr->ts.u.derived = vtab->ts.u.derived;
18371 6615 : if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
18372 : return false;
18373 : }
18374 : }
18375 :
18376 90307 : if (!resolve_fl_derived0 (sym))
18377 : return false;
18378 :
18379 : /* Resolve the type-bound procedures. */
18380 90223 : if (!resolve_typebound_procedures (sym))
18381 : return false;
18382 :
18383 : /* Generate module vtables subject to their accessibility and their not
18384 : being vtables or pdt templates. If this is not done class declarations
18385 : in external procedures wind up with their own version and so SELECT TYPE
18386 : fails because the vptrs do not have the same address. */
18387 90182 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
18388 90121 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
18389 67524 : || (sym->attr.recursive && sym->attr.alloc_comp))
18390 22775 : && sym->attr.access != ACCESS_PRIVATE
18391 22742 : && !(sym->attr.vtype || sym->attr.pdt_template))
18392 : {
18393 20264 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
18394 20264 : gfc_set_sym_referenced (vtab);
18395 : }
18396 :
18397 : return true;
18398 : }
18399 :
18400 :
18401 : static bool
18402 881 : resolve_fl_namelist (gfc_symbol *sym)
18403 : {
18404 881 : gfc_namelist *nl;
18405 881 : gfc_symbol *nlsym;
18406 :
18407 3082 : for (nl = sym->namelist; nl; nl = nl->next)
18408 : {
18409 : /* Check again, the check in match only works if NAMELIST comes
18410 : after the decl. */
18411 2206 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
18412 : {
18413 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
18414 : "allowed", nl->sym->name, sym->name, &sym->declared_at);
18415 1 : return false;
18416 : }
18417 :
18418 678 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
18419 2213 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18420 : "with assumed shape in namelist %qs at %L",
18421 : nl->sym->name, sym->name, &sym->declared_at))
18422 : return false;
18423 :
18424 2204 : if (is_non_constant_shape_array (nl->sym)
18425 2254 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18426 : "with nonconstant shape in namelist %qs at %L",
18427 50 : nl->sym->name, sym->name, &sym->declared_at))
18428 : return false;
18429 :
18430 2203 : if (nl->sym->ts.type == BT_CHARACTER
18431 605 : && (nl->sym->ts.u.cl->length == NULL
18432 566 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
18433 2285 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
18434 : "nonconstant character length in "
18435 82 : "namelist %qs at %L", nl->sym->name,
18436 : sym->name, &sym->declared_at))
18437 : return false;
18438 :
18439 : }
18440 :
18441 : /* Reject PRIVATE objects in a PUBLIC namelist. */
18442 876 : if (gfc_check_symbol_access (sym))
18443 : {
18444 3063 : for (nl = sym->namelist; nl; nl = nl->next)
18445 : {
18446 2200 : if (!nl->sym->attr.use_assoc
18447 4104 : && !is_sym_host_assoc (nl->sym, sym->ns)
18448 4230 : && !gfc_check_symbol_access (nl->sym))
18449 : {
18450 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
18451 : "cannot be member of PUBLIC namelist %qs at %L",
18452 2 : nl->sym->name, sym->name, &sym->declared_at);
18453 2 : return false;
18454 : }
18455 :
18456 2198 : if (nl->sym->ts.type == BT_DERIVED
18457 478 : && (nl->sym->ts.u.derived->attr.alloc_comp
18458 476 : || nl->sym->ts.u.derived->attr.pointer_comp))
18459 : {
18460 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
18461 : "namelist %qs at %L with ALLOCATABLE "
18462 : "or POINTER components", nl->sym->name,
18463 : sym->name, &sym->declared_at))
18464 : return false;
18465 : return true;
18466 : }
18467 :
18468 : /* Types with private components that came here by USE-association. */
18469 2193 : if (nl->sym->ts.type == BT_DERIVED
18470 2193 : && derived_inaccessible (nl->sym->ts.u.derived))
18471 : {
18472 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
18473 : "components and cannot be member of namelist %qs at %L",
18474 : nl->sym->name, sym->name, &sym->declared_at);
18475 6 : return false;
18476 : }
18477 :
18478 : /* Types with private components that are defined in the same module. */
18479 2187 : if (nl->sym->ts.type == BT_DERIVED
18480 934 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
18481 2477 : && nl->sym->ts.u.derived->attr.private_comp)
18482 : {
18483 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
18484 : "cannot be a member of PUBLIC namelist %qs at %L",
18485 : nl->sym->name, sym->name, &sym->declared_at);
18486 0 : return false;
18487 : }
18488 : }
18489 : }
18490 :
18491 :
18492 : /* 14.1.2 A module or internal procedure represent local entities
18493 : of the same type as a namelist member and so are not allowed. */
18494 3047 : for (nl = sym->namelist; nl; nl = nl->next)
18495 : {
18496 2187 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
18497 1616 : continue;
18498 :
18499 571 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
18500 7 : if ((nl->sym == sym->ns->proc_name)
18501 1 : ||
18502 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
18503 6 : continue;
18504 :
18505 565 : nlsym = NULL;
18506 565 : if (nl->sym->name)
18507 565 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
18508 565 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
18509 : {
18510 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
18511 : "attribute in %qs at %L", nlsym->name,
18512 : &sym->declared_at);
18513 3 : return false;
18514 : }
18515 : }
18516 :
18517 : return true;
18518 : }
18519 :
18520 :
18521 : static bool
18522 411951 : resolve_fl_parameter (gfc_symbol *sym)
18523 : {
18524 : /* A parameter array's shape needs to be constant. */
18525 411951 : if (sym->as != NULL
18526 411951 : && (sym->as->type == AS_DEFERRED
18527 6369 : || is_non_constant_shape_array (sym)))
18528 : {
18529 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
18530 : "or of deferred shape", sym->name, &sym->declared_at);
18531 17 : return false;
18532 : }
18533 :
18534 : /* Constraints on deferred type parameter. */
18535 411934 : if (!deferred_requirements (sym))
18536 : return false;
18537 :
18538 : /* Make sure a parameter that has been implicitly typed still
18539 : matches the implicit type, since PARAMETER statements can precede
18540 : IMPLICIT statements. */
18541 411933 : if (sym->attr.implicit_type
18542 412646 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
18543 713 : sym->ns)))
18544 : {
18545 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
18546 : "later IMPLICIT type", sym->name, &sym->declared_at);
18547 0 : return false;
18548 : }
18549 :
18550 : /* Make sure the types of derived parameters are consistent. This
18551 : type checking is deferred until resolution because the type may
18552 : refer to a derived type from the host. */
18553 411933 : if (sym->ts.type == BT_DERIVED
18554 411933 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
18555 : {
18556 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
18557 0 : &sym->value->where);
18558 0 : return false;
18559 : }
18560 :
18561 : /* F03:C509,C514. */
18562 411933 : if (sym->ts.type == BT_CLASS)
18563 : {
18564 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
18565 : sym->name, &sym->declared_at);
18566 0 : return false;
18567 : }
18568 :
18569 : /* Some programmers can have a typo when using an implied-do loop to
18570 : initialize an array constant. For example,
18571 : INTEGER I,J
18572 : INTEGER, PARAMETER :: A(3) = [(I, I = 1, 3)] ! OK
18573 : INTEGER, PARAMETER :: B(3) = [(A(J), I = 1, 3)] ! Not OK, J undefined
18574 : This check catches the typo. */
18575 411933 : if (sym->attr.dimension
18576 6362 : && sym->value && sym->value->expr_type == EXPR_ARRAY
18577 418289 : && !gfc_is_constant_expr (sym->value))
18578 : {
18579 : /* PR fortran/117070 argues a nonconstant proc pointer can appear in
18580 : the array constructor of a parameter. This seems inconsistent with
18581 : the concept of a parameter. TODO: Needs an interpretation. */
18582 20 : if (sym->value->ts.type == BT_DERIVED
18583 18 : && sym->value->ts.u.derived
18584 18 : && sym->value->ts.u.derived->attr.proc_pointer_comp)
18585 : return true;
18586 2 : gfc_error ("Expecting constant expression near %L", &sym->value->where);
18587 2 : return false;
18588 : }
18589 :
18590 : return true;
18591 : }
18592 :
18593 :
18594 : /* Called by resolve_symbol to check PDTs. */
18595 :
18596 : static void
18597 1840 : resolve_pdt (gfc_symbol* sym)
18598 : {
18599 1840 : gfc_symbol *derived = NULL;
18600 1840 : gfc_actual_arglist *param;
18601 1840 : gfc_component *c;
18602 1840 : bool const_len_exprs = true;
18603 1840 : bool assumed_len_exprs = false;
18604 1840 : symbol_attribute *attr;
18605 :
18606 1840 : if (sym->ts.type == BT_DERIVED)
18607 : {
18608 1589 : derived = sym->ts.u.derived;
18609 1589 : attr = &(sym->attr);
18610 : }
18611 251 : else if (sym->ts.type == BT_CLASS)
18612 : {
18613 251 : derived = CLASS_DATA (sym)->ts.u.derived;
18614 251 : attr = &(CLASS_DATA (sym)->attr);
18615 : }
18616 : else
18617 0 : gcc_unreachable ();
18618 :
18619 1840 : gcc_assert (derived->attr.pdt_type);
18620 :
18621 4467 : for (param = sym->param_list; param; param = param->next)
18622 : {
18623 2627 : c = gfc_find_component (derived, param->name, false, true, NULL);
18624 2627 : gcc_assert (c);
18625 2627 : if (c->attr.pdt_kind)
18626 1372 : continue;
18627 :
18628 866 : if (param->expr && !gfc_is_constant_expr (param->expr)
18629 1381 : && c->attr.pdt_len)
18630 : const_len_exprs = false;
18631 1129 : else if (param->spec_type == SPEC_ASSUMED)
18632 405 : assumed_len_exprs = true;
18633 :
18634 1255 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
18635 18 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
18636 16 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
18637 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
18638 : "parameter %qs and requires either the POINTER "
18639 : "or ALLOCATABLE attribute",
18640 : sym->name, &sym->declared_at,
18641 : param->name);
18642 :
18643 : }
18644 :
18645 1840 : if (!const_len_exprs
18646 120 : && (sym->ns->proc_name->attr.is_main_program
18647 119 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18648 118 : || sym->attr.save != SAVE_NONE))
18649 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
18650 : "SAVE attribute or be a variable declared in the "
18651 : "main program, a module or a submodule(F08/C513)",
18652 : sym->name, &sym->declared_at);
18653 :
18654 1840 : if (assumed_len_exprs && !(sym->attr.dummy
18655 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
18656 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
18657 : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
18658 : sym->name, &sym->declared_at);
18659 1840 : }
18660 :
18661 :
18662 : /* Resolve the symbol's array spec. */
18663 :
18664 : static bool
18665 1793049 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
18666 : {
18667 1793049 : gfc_namespace *orig_current_ns = gfc_current_ns;
18668 1793049 : gfc_current_ns = gfc_get_spec_ns (sym);
18669 :
18670 1793049 : bool saved_specification_expr = specification_expr;
18671 1793049 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
18672 1793049 : specification_expr = true;
18673 1793049 : specification_expr_symbol = sym;
18674 :
18675 1793049 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
18676 :
18677 1793049 : specification_expr = saved_specification_expr;
18678 1793049 : specification_expr_symbol = saved_specification_expr_symbol;
18679 1793049 : gfc_current_ns = orig_current_ns;
18680 :
18681 1793049 : return result;
18682 : }
18683 :
18684 :
18685 : /* Do anything necessary to resolve a symbol. Right now, we just
18686 : assume that an otherwise unknown symbol is a variable. This sort
18687 : of thing commonly happens for symbols in module. */
18688 :
18689 : static void
18690 1958607 : resolve_symbol (gfc_symbol *sym)
18691 : {
18692 1958607 : int check_constant, mp_flag;
18693 1958607 : gfc_symtree *symtree;
18694 1958607 : gfc_symtree *this_symtree;
18695 1958607 : gfc_namespace *ns;
18696 1958607 : gfc_component *c;
18697 1958607 : symbol_attribute class_attr;
18698 1958607 : gfc_array_spec *as;
18699 1958607 : bool declared_has_coarray_comp = false;
18700 :
18701 1958607 : if (sym->resolve_symbol_called >= 1)
18702 197133 : return;
18703 1867930 : sym->resolve_symbol_called = 1;
18704 :
18705 : /* No symbol will ever have union type; only components can be unions.
18706 : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
18707 : (just like derived type declaration symbols have flavor FL_DERIVED). */
18708 1867930 : gcc_assert (sym->ts.type != BT_UNION);
18709 :
18710 : /* Coarrayed polymorphic objects with allocatable or pointer components are
18711 : yet unsupported for -fcoarray=lib. */
18712 1867930 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
18713 116 : && sym->ts.u.derived && CLASS_DATA (sym)
18714 116 : && CLASS_DATA (sym)->attr.codimension
18715 98 : && CLASS_DATA (sym)->ts.u.derived
18716 97 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
18717 94 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
18718 : {
18719 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
18720 : "type coarrays at %L are unsupported", &sym->declared_at);
18721 6 : return;
18722 : }
18723 :
18724 1867924 : if (sym->attr.artificial)
18725 : return;
18726 :
18727 1764302 : if (sym->attr.unlimited_polymorphic)
18728 : return;
18729 :
18730 1762727 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
18731 : {
18732 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
18733 : "the OpenMP DEPEND clause", &sym->declared_at);
18734 4 : return;
18735 : }
18736 :
18737 1762723 : if (sym->attr.flavor == FL_UNKNOWN
18738 1741086 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
18739 467294 : && !sym->attr.generic && !sym->attr.external
18740 185861 : && sym->attr.if_source == IFSRC_UNKNOWN
18741 84052 : && sym->ts.type == BT_UNKNOWN))
18742 : {
18743 : /* A symbol in a common block might not have been resolved yet properly.
18744 : Do not try to find an interface with the same name. */
18745 96997 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
18746 21633 : && !sym->attr.generic && !sym->attr.external
18747 21582 : && sym->attr.in_common)
18748 2595 : goto skip_interfaces;
18749 :
18750 : /* If we find that a flavorless symbol is an interface in one of the
18751 : parent namespaces, find its symtree in this namespace, free the
18752 : symbol and set the symtree to point to the interface symbol. */
18753 135104 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
18754 : {
18755 41412 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
18756 41412 : if (symtree && (symtree->n.sym->generic ||
18757 791 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
18758 689 : && sym->ns->construct_entities)))
18759 : {
18760 718 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
18761 : sym->name);
18762 718 : if (this_symtree->n.sym == sym)
18763 : {
18764 710 : symtree->n.sym->refs++;
18765 710 : gfc_release_symbol (sym);
18766 710 : this_symtree->n.sym = symtree->n.sym;
18767 710 : return;
18768 : }
18769 : }
18770 : }
18771 :
18772 93692 : skip_interfaces:
18773 : /* Otherwise give it a flavor according to such attributes as
18774 : it has. */
18775 96287 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
18776 21452 : && sym->attr.intrinsic == 0)
18777 21448 : sym->attr.flavor = FL_VARIABLE;
18778 74839 : else if (sym->attr.flavor == FL_UNKNOWN)
18779 : {
18780 55 : sym->attr.flavor = FL_PROCEDURE;
18781 55 : if (sym->attr.dimension)
18782 0 : sym->attr.function = 1;
18783 : }
18784 : }
18785 :
18786 1762013 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
18787 2384 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
18788 :
18789 1532 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
18790 1763545 : && !resolve_procedure_interface (sym))
18791 : return;
18792 :
18793 1762002 : if (sym->attr.is_protected && !sym->attr.proc_pointer
18794 130 : && (sym->attr.procedure || sym->attr.external))
18795 : {
18796 0 : if (sym->attr.external)
18797 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18798 : "at %L", &sym->declared_at);
18799 : else
18800 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18801 : "at %L", &sym->declared_at);
18802 :
18803 : return;
18804 : }
18805 :
18806 : /* Ensure that variables of derived or class type having a finalizer are
18807 : marked used even when the variable is not used anything else in the scope.
18808 : This fixes PR118730. */
18809 681279 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18810 469682 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18811 1812846 : && gfc_may_be_finalized (sym->ts))
18812 8930 : gfc_set_sym_referenced (sym);
18813 :
18814 1762002 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18815 : return;
18816 :
18817 1761857 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18818 1761857 : && !resolve_fl_struct (sym))
18819 : return;
18820 :
18821 : /* Symbols that are module procedures with results (functions) have
18822 : the types and array specification copied for type checking in
18823 : procedures that call them, as well as for saving to a module
18824 : file. These symbols can't stand the scrutiny that their results
18825 : can. */
18826 1761857 : mp_flag = (sym->result != NULL && sym->result != sym);
18827 :
18828 : /* Make sure that the intrinsic is consistent with its internal
18829 : representation. This needs to be done before assigning a default
18830 : type to avoid spurious warnings. */
18831 1725866 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18832 1799265 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18833 : return;
18834 :
18835 : /* Resolve associate names. */
18836 1761821 : if (sym->assoc)
18837 7246 : resolve_assoc_var (sym, true);
18838 :
18839 : /* Assign default type to symbols that need one and don't have one. */
18840 1761821 : if (sym->ts.type == BT_UNKNOWN)
18841 : {
18842 425015 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18843 : {
18844 11853 : gfc_set_default_type (sym, 1, NULL);
18845 : }
18846 :
18847 275778 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18848 65840 : && !sym->attr.function && !sym->attr.subroutine
18849 426688 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18850 622 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18851 :
18852 425015 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18853 : {
18854 : /* The specific case of an external procedure should emit an error
18855 : in the case that there is no implicit type. */
18856 106910 : if (!mp_flag)
18857 : {
18858 100591 : if (!sym->attr.mixed_entry_master)
18859 100483 : gfc_set_default_type (sym, sym->attr.external, NULL);
18860 : }
18861 : else
18862 : {
18863 : /* Result may be in another namespace. */
18864 6319 : resolve_symbol (sym->result);
18865 :
18866 6319 : if (!sym->result->attr.proc_pointer)
18867 : {
18868 6139 : sym->ts = sym->result->ts;
18869 6139 : sym->as = gfc_copy_array_spec (sym->result->as);
18870 6139 : sym->attr.dimension = sym->result->attr.dimension;
18871 6139 : sym->attr.codimension = sym->result->attr.codimension;
18872 6139 : sym->attr.pointer = sym->result->attr.pointer;
18873 6139 : sym->attr.allocatable = sym->result->attr.allocatable;
18874 6139 : sym->attr.contiguous = sym->result->attr.contiguous;
18875 : }
18876 : }
18877 : }
18878 : }
18879 1336806 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18880 31572 : resolve_symbol_array_spec (sym->result, false);
18881 :
18882 : /* For a CLASS-valued function with a result variable, affirm that it has
18883 : been resolved also when looking at the symbol 'sym'. */
18884 456587 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18885 751 : sym->attr.class_ok = sym->result->attr.class_ok;
18886 :
18887 1761821 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18888 20312 : && CLASS_DATA (sym))
18889 : {
18890 20312 : as = CLASS_DATA (sym)->as;
18891 20312 : class_attr = CLASS_DATA (sym)->attr;
18892 20312 : class_attr.pointer = class_attr.class_pointer;
18893 20312 : declared_has_coarray_comp = CLASS_DATA (sym)->ts.u.derived
18894 20312 : && CLASS_DATA (sym)->ts.u.derived->attr.coarray_comp;
18895 : }
18896 : else
18897 : {
18898 1741509 : class_attr = sym->attr;
18899 1741509 : as = sym->as;
18900 : }
18901 :
18902 : /* F2008, C530. */
18903 1761821 : if (sym->attr.contiguous
18904 8565 : && !sym->attr.associate_var
18905 8564 : && (!class_attr.dimension
18906 8561 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18907 143 : && !class_attr.pointer)))
18908 : {
18909 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18910 : "array pointer or an assumed-shape or assumed-rank array",
18911 : sym->name, &sym->declared_at);
18912 7 : return;
18913 : }
18914 :
18915 : /* Assumed size arrays and assumed shape arrays must be dummy
18916 : arguments. Array-spec's of implied-shape should have been resolved to
18917 : AS_EXPLICIT already. */
18918 :
18919 1753396 : if (as)
18920 : {
18921 : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18922 : specification expression. */
18923 153466 : if (as->type == AS_IMPLIED_SHAPE)
18924 : {
18925 : int i;
18926 1 : for (i=0; i<as->rank; i++)
18927 : {
18928 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18929 : {
18930 1 : gfc_error ("Bad specification for assumed size array at %L",
18931 : &as->lower[i]->where);
18932 1 : return;
18933 : }
18934 : }
18935 0 : gcc_unreachable();
18936 : }
18937 :
18938 153465 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18939 118317 : || as->type == AS_ASSUMED_SHAPE)
18940 47710 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18941 8 : && !sym->attr.associate_var)
18942 : {
18943 7 : if (as->type == AS_ASSUMED_SIZE)
18944 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18945 : &sym->declared_at);
18946 : else
18947 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18948 : &sym->declared_at);
18949 : return;
18950 : }
18951 : /* TS 29113, C535a. */
18952 153458 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18953 60 : && !sym->attr.select_type_temporary
18954 60 : && !(cs_base && cs_base->current
18955 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18956 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18957 0 : && cs_base->current->op == EXEC_BLOCK))))
18958 : {
18959 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18960 : &sym->declared_at);
18961 18 : return;
18962 : }
18963 153440 : if (as->type == AS_ASSUMED_RANK
18964 27385 : && (sym->attr.codimension || sym->attr.value))
18965 : {
18966 5 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18967 : "CODIMENSION attribute", &sym->declared_at);
18968 5 : return;
18969 : }
18970 :
18971 : /* F2008, C557 (F2018, C862; F2023, C867). Assumed-shape and
18972 : explicit-shape array dummies may have the VALUE attribute, but
18973 : assumed-size arrays may not. */
18974 153435 : if (as->type == AS_ASSUMED_SIZE && sym->attr.value)
18975 : {
18976 1 : gfc_error ("Assumed-size array %qs at %L may not have the VALUE "
18977 : "attribute", sym->name, &sym->declared_at);
18978 1 : return;
18979 : }
18980 153434 : else if (sym->attr.value && sym->attr.dummy
18981 144 : && (as->type == AS_EXPLICIT || as->type == AS_ASSUMED_SHAPE))
18982 : {
18983 144 : if (!gfc_notify_std (GFC_STD_F2008, "Array dummy argument %qs at "
18984 : "%L with VALUE attribute", sym->name,
18985 : &sym->declared_at))
18986 : return;
18987 :
18988 : /* F2023, 18.3.6 (4): only a scalar VALUE dummy is interoperable
18989 : with a formal parameter of the C prototype. */
18990 143 : if (sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
18991 : {
18992 2 : gfc_error ("Array dummy argument %qs at %L with VALUE attribute "
18993 : "not allowed in BIND(C) procedure %qs", sym->name,
18994 : &sym->declared_at, sym->ns->proc_name->name);
18995 2 : return;
18996 : }
18997 :
18998 141 : if (sym->ts.type == BT_CLASS)
18999 : {
19000 1 : gfc_error ("Sorry, polymorphic array dummy argument %qs at %L "
19001 : "with VALUE attribute is not yet implemented",
19002 : sym->name, &sym->declared_at);
19003 1 : return;
19004 : }
19005 : }
19006 : }
19007 :
19008 : /* Make sure symbols with known intent or optional are really dummy
19009 : variable. Because of ENTRY statement, this has to be deferred
19010 : until resolution time. */
19011 :
19012 1761778 : if (!sym->attr.dummy
19013 1267339 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
19014 : {
19015 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
19016 2 : return;
19017 : }
19018 :
19019 1761776 : if (sym->attr.value && !sym->attr.dummy)
19020 : {
19021 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
19022 : "it is not a dummy argument", sym->name, &sym->declared_at);
19023 2 : return;
19024 : }
19025 :
19026 1761774 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
19027 : {
19028 707 : gfc_charlen *cl = sym->ts.u.cl;
19029 707 : if (!cl)
19030 : {
19031 0 : gfc_error ("Character dummy variable %qs at %L with VALUE "
19032 : "attribute must have a length specification",
19033 : sym->name, &sym->declared_at);
19034 0 : return;
19035 : }
19036 :
19037 : /* C interoperable character dummies must have length one. */
19038 707 : if (sym->ts.is_c_interop
19039 394 : && (!cl->length
19040 393 : || cl->length->expr_type != EXPR_CONSTANT
19041 393 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
19042 : {
19043 2 : gfc_error ("C interoperable character dummy variable %qs at %L "
19044 : "with VALUE attribute must have length one",
19045 : sym->name, &sym->declared_at);
19046 2 : return;
19047 : }
19048 :
19049 : /* Assumed-length character dummy with VALUE, valid since F2008. */
19050 705 : if (!cl->length
19051 705 : && !gfc_notify_std (GFC_STD_F2008, "Assumed-length character "
19052 : "dummy variable %qs at %L with VALUE attribute",
19053 : sym->name, &sym->declared_at))
19054 : return;
19055 :
19056 : /* Likewise for a specified but non-constant length. */
19057 655 : if (cl->length && cl->length->expr_type != EXPR_CONSTANT
19058 727 : && !gfc_notify_std (GFC_STD_F2008, "Character dummy variable "
19059 : "%qs at %L with VALUE attribute and "
19060 : "non-constant length",
19061 24 : sym->name, &sym->declared_at))
19062 : return;
19063 : }
19064 :
19065 1761770 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
19066 127177 : && sym->ts.u.derived->attr.generic)
19067 : {
19068 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
19069 20 : if (!sym->ts.u.derived)
19070 : {
19071 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
19072 : "which has not been defined", sym->name,
19073 : &sym->declared_at, sym->ts.u.derived->name);
19074 0 : sym->ts.type = BT_UNKNOWN;
19075 0 : return;
19076 : }
19077 : }
19078 :
19079 : /* Use the same constraints as TYPE(*), except for the type check
19080 : and that only scalars and assumed-size arrays are permitted. */
19081 1761770 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
19082 : {
19083 14556 : if (!sym->attr.dummy)
19084 : {
19085 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
19086 : "a dummy argument", sym->name, &sym->declared_at);
19087 1 : return;
19088 : }
19089 :
19090 14555 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
19091 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
19092 0 : && sym->ts.type != BT_COMPLEX)
19093 : {
19094 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
19095 : "of type TYPE(*) or of an numeric intrinsic type",
19096 : sym->name, &sym->declared_at);
19097 0 : return;
19098 : }
19099 :
19100 14555 : if (sym->attr.allocatable || sym->attr.codimension
19101 14553 : || sym->attr.pointer || sym->attr.value)
19102 : {
19103 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
19104 : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
19105 : "attribute", sym->name, &sym->declared_at);
19106 4 : return;
19107 : }
19108 :
19109 14551 : if (sym->attr.intent == INTENT_OUT)
19110 : {
19111 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
19112 : "have the INTENT(OUT) attribute",
19113 : sym->name, &sym->declared_at);
19114 0 : return;
19115 : }
19116 14551 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
19117 : {
19118 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
19119 : "either be a scalar or an assumed-size array",
19120 : sym->name, &sym->declared_at);
19121 1 : return;
19122 : }
19123 :
19124 : /* Set the type to TYPE(*) and add a dimension(*) to ensure
19125 : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
19126 : packing. */
19127 14550 : sym->ts.type = BT_ASSUMED;
19128 14550 : sym->as = gfc_get_array_spec ();
19129 14550 : sym->as->type = AS_ASSUMED_SIZE;
19130 14550 : sym->as->rank = 1;
19131 14550 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
19132 : }
19133 1747214 : else if (sym->ts.type == BT_ASSUMED)
19134 : {
19135 : /* TS 29113, C407a. */
19136 12350 : if (!sym->attr.dummy)
19137 : {
19138 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
19139 : "for dummy variables", sym->name, &sym->declared_at);
19140 7 : return;
19141 : }
19142 12343 : if (sym->attr.allocatable || sym->attr.codimension
19143 12339 : || sym->attr.pointer || sym->attr.value)
19144 : {
19145 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
19146 : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
19147 : sym->name, &sym->declared_at);
19148 8 : return;
19149 : }
19150 12335 : if (sym->attr.intent == INTENT_OUT)
19151 : {
19152 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
19153 : "INTENT(OUT) attribute",
19154 : sym->name, &sym->declared_at);
19155 2 : return;
19156 : }
19157 12333 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
19158 : {
19159 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
19160 : "explicit-shape array", sym->name, &sym->declared_at);
19161 3 : return;
19162 : }
19163 : }
19164 :
19165 : /* If the symbol is marked as bind(c), that it is declared at module level
19166 : scope and verify its type and kind. Do not do the latter for symbols
19167 : that are implicitly typed because that is handled in
19168 : gfc_set_default_type. Handle dummy arguments and procedure definitions
19169 : separately. Also, anything that is use associated is not handled here
19170 : but instead is handled in the module it is declared in. Finally, derived
19171 : type definitions are allowed to be BIND(C) since that only implies that
19172 : they're interoperable, and they are checked fully for interoperability
19173 : when a variable is declared of that type. */
19174 1761744 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
19175 7820 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
19176 568 : && sym->attr.flavor != FL_DERIVED)
19177 : {
19178 168 : bool t = true;
19179 :
19180 : /* First, make sure the variable is declared at the
19181 : module-level scope (J3/04-007, Section 15.3). */
19182 168 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
19183 7 : && !sym->attr.in_common)
19184 : {
19185 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
19186 : "is neither a COMMON block nor declared at the "
19187 : "module level scope", sym->name, &(sym->declared_at));
19188 6 : t = false;
19189 : }
19190 162 : else if (sym->ts.type == BT_CHARACTER
19191 162 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
19192 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
19193 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
19194 : {
19195 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
19196 1 : sym->name, &sym->declared_at);
19197 1 : t = false;
19198 : }
19199 161 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
19200 : {
19201 1 : t = verify_com_block_vars_c_interop (sym->common_head);
19202 : }
19203 160 : else if (sym->attr.implicit_type == 0)
19204 : {
19205 : /* If type() declaration, we need to verify that the components
19206 : of the given type are all C interoperable, etc. */
19207 158 : if (sym->ts.type == BT_DERIVED &&
19208 24 : sym->ts.u.derived->attr.is_c_interop != 1)
19209 : {
19210 : /* Make sure the user marked the derived type as BIND(C). If
19211 : not, call the verify routine. This could print an error
19212 : for the derived type more than once if multiple variables
19213 : of that type are declared. */
19214 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
19215 1 : verify_bind_c_derived_type (sym->ts.u.derived);
19216 158 : t = false;
19217 : }
19218 :
19219 : /* Verify the variable itself as C interoperable if it
19220 : is BIND(C). It is not possible for this to succeed if
19221 : the verify_bind_c_derived_type failed, so don't have to handle
19222 : any error returned by verify_bind_c_derived_type. */
19223 158 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
19224 158 : sym->common_block);
19225 : }
19226 :
19227 166 : if (!t)
19228 : {
19229 : /* clear the is_bind_c flag to prevent reporting errors more than
19230 : once if something failed. */
19231 10 : sym->attr.is_bind_c = 0;
19232 10 : return;
19233 : }
19234 : }
19235 :
19236 : /* If a derived type symbol has reached this point, without its
19237 : type being declared, we have an error. Notice that most
19238 : conditions that produce undefined derived types have already
19239 : been dealt with. However, the likes of:
19240 : implicit type(t) (t) ..... call foo (t) will get us here if
19241 : the type is not declared in the scope of the implicit
19242 : statement. Change the type to BT_UNKNOWN, both because it is so
19243 : and to prevent an ICE. */
19244 1761734 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
19245 127175 : && sym->ts.u.derived->components == NULL
19246 1195 : && !sym->ts.u.derived->attr.zero_comp)
19247 : {
19248 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
19249 : "which has not been defined", sym->name,
19250 : &sym->declared_at, sym->ts.u.derived->name);
19251 3 : sym->ts.type = BT_UNKNOWN;
19252 3 : return;
19253 : }
19254 :
19255 : /* Make sure that the derived type has been resolved and that the
19256 : derived type is visible in the symbol's namespace, if it is a
19257 : module function and is not PRIVATE. */
19258 1761731 : if (sym->ts.type == BT_DERIVED
19259 134334 : && sym->ts.u.derived->attr.use_assoc
19260 115904 : && sym->ns->proc_name
19261 115896 : && sym->ns->proc_name->attr.flavor == FL_MODULE
19262 1767704 : && !resolve_fl_derived (sym->ts.u.derived))
19263 : return;
19264 :
19265 : /* Unless the derived-type declaration is use associated, Fortran 95
19266 : does not allow public entries of private derived types.
19267 : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
19268 : 161 in 95-006r3. */
19269 1761731 : if (sym->ts.type == BT_DERIVED
19270 134334 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
19271 8159 : && !sym->ts.u.derived->attr.use_assoc
19272 2186 : && gfc_check_symbol_access (sym)
19273 1973 : && !gfc_check_symbol_access (sym->ts.u.derived)
19274 1761745 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
19275 : "derived type %qs",
19276 14 : (sym->attr.flavor == FL_PARAMETER)
19277 : ? "parameter" : "variable",
19278 : sym->name, &sym->declared_at,
19279 14 : sym->ts.u.derived->name))
19280 : return;
19281 :
19282 : /* F2008, C1302. */
19283 1761724 : if (sym->ts.type == BT_DERIVED
19284 134327 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19285 198 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
19286 134296 : || sym->ts.u.derived->attr.lock_comp)
19287 44 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19288 : {
19289 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
19290 : "type LOCK_TYPE must be a coarray", sym->name,
19291 : &sym->declared_at);
19292 4 : return;
19293 : }
19294 :
19295 : /* TS18508, C702/C703. */
19296 1761720 : if (sym->ts.type == BT_DERIVED
19297 134323 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19298 197 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
19299 134306 : || sym->ts.u.derived->attr.event_comp)
19300 17 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19301 : {
19302 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
19303 : "type EVENT_TYPE must be a coarray", sym->name,
19304 : &sym->declared_at);
19305 1 : return;
19306 : }
19307 :
19308 : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
19309 : default initialization is defined (5.1.2.4.4). */
19310 1761719 : if (sym->ts.type == BT_DERIVED
19311 134322 : && sym->attr.dummy
19312 46029 : && sym->attr.intent == INTENT_OUT
19313 2417 : && sym->as
19314 406 : && sym->as->type == AS_ASSUMED_SIZE)
19315 : {
19316 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
19317 : {
19318 1 : if (c->initializer)
19319 : {
19320 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
19321 : "ASSUMED SIZE and so cannot have a default initializer",
19322 : sym->name, &sym->declared_at);
19323 1 : return;
19324 : }
19325 : }
19326 : }
19327 :
19328 : /* F2008, C542. */
19329 1761718 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19330 46028 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
19331 : {
19332 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
19333 : "INTENT(OUT)", sym->name, &sym->declared_at);
19334 0 : return;
19335 : }
19336 :
19337 : /* TS18508. */
19338 1761718 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19339 46028 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
19340 : {
19341 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
19342 : "INTENT(OUT)", sym->name, &sym->declared_at);
19343 0 : return;
19344 : }
19345 :
19346 : /* F2008, C525. */
19347 1761718 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19348 1761605 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19349 20314 : && sym->ts.u.derived && CLASS_DATA (sym)
19350 20309 : && CLASS_DATA (sym)->attr.coarray_comp))
19351 1761605 : || class_attr.codimension)
19352 1889 : && (sym->attr.result || sym->result == sym))
19353 : {
19354 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
19355 : "a coarray component", sym->name, &sym->declared_at);
19356 8 : return;
19357 : }
19358 :
19359 : /* F2008, C524. */
19360 1761710 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
19361 435 : && sym->ts.u.derived->ts.is_iso_c)
19362 : {
19363 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
19364 : "shall not be a coarray", sym->name, &sym->declared_at);
19365 3 : return;
19366 : }
19367 :
19368 : /* F2008, C525. */
19369 1761707 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19370 1761597 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19371 20313 : && sym->ts.u.derived && CLASS_DATA (sym)
19372 20308 : && CLASS_DATA (sym)->attr.coarray_comp))
19373 110 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
19374 106 : || class_attr.allocatable))
19375 : {
19376 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
19377 : "nonpointer, nonallocatable scalar, which is not a coarray",
19378 : sym->name, &sym->declared_at);
19379 4 : return;
19380 : }
19381 :
19382 : /* F2008, C526. The function-result case was handled above. */
19383 1761703 : if (class_attr.codimension
19384 1768 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
19385 379 : || sym->attr.select_type_temporary
19386 303 : || sym->attr.associate_var
19387 285 : || (sym->ns->save_all && !sym->attr.automatic)
19388 285 : || sym->ns->proc_name->attr.flavor == FL_MODULE
19389 285 : || sym->ns->proc_name->attr.is_main_program
19390 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
19391 : {
19392 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
19393 : "nor a dummy argument", sym->name, &sym->declared_at);
19394 4 : return;
19395 : }
19396 : /* F2008, C528. */
19397 1761699 : else if (class_attr.codimension && !sym->attr.select_type_temporary
19398 1688 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
19399 : {
19400 7 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
19401 : "deferred shape without allocatable", sym->name,
19402 : &sym->declared_at);
19403 7 : return;
19404 : }
19405 1761692 : else if (class_attr.codimension && class_attr.allocatable && as
19406 659 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
19407 : {
19408 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
19409 : "deferred shape", sym->name, &sym->declared_at);
19410 9 : return;
19411 : }
19412 :
19413 : /* F2008, C541. */
19414 1761683 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19415 1761577 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19416 20308 : && declared_has_coarray_comp))
19417 1761570 : || (class_attr.codimension && class_attr.allocatable))
19418 763 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
19419 : {
19420 4 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
19421 : "allocatable coarray or have coarray components",
19422 : sym->name, &sym->declared_at);
19423 4 : return;
19424 : }
19425 :
19426 1761679 : if (class_attr.codimension && sym->attr.dummy
19427 469 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
19428 : {
19429 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
19430 : "procedure %qs", sym->name, &sym->declared_at,
19431 : sym->ns->proc_name->name);
19432 2 : return;
19433 : }
19434 :
19435 1761677 : if (sym->ts.type == BT_LOGICAL
19436 114666 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
19437 114663 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
19438 32798 : && sym->ns->proc_name->attr.is_bind_c)))
19439 : {
19440 : int i;
19441 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
19442 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
19443 : break;
19444 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
19445 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
19446 : "%L with non-C_Bool kind in BIND(C) procedure "
19447 : "%qs", sym->name, &sym->declared_at,
19448 13 : sym->ns->proc_name->name))
19449 : return;
19450 167 : else if (!gfc_logical_kinds[i].c_bool
19451 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
19452 : "%qs at %L with non-C_Bool kind in "
19453 : "BIND(C) procedure %qs", sym->name,
19454 : &sym->declared_at,
19455 15 : sym->attr.function ? sym->name
19456 13 : : sym->ns->proc_name->name))
19457 : return;
19458 : }
19459 :
19460 1761674 : switch (sym->attr.flavor)
19461 : {
19462 681151 : case FL_VARIABLE:
19463 681151 : if (!resolve_fl_variable (sym, mp_flag))
19464 : return;
19465 : break;
19466 :
19467 504116 : case FL_PROCEDURE:
19468 504116 : if (sym->formal && !sym->formal_ns)
19469 : {
19470 : /* Check that none of the arguments are a namelist. */
19471 : gfc_formal_arglist *formal = sym->formal;
19472 :
19473 108517 : for (; formal; formal = formal->next)
19474 73420 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
19475 : {
19476 1 : gfc_error ("Namelist %qs cannot be an argument to "
19477 : "subroutine or function at %L",
19478 : formal->sym->name, &sym->declared_at);
19479 1 : return;
19480 : }
19481 : }
19482 :
19483 504115 : if (!resolve_fl_procedure (sym, mp_flag))
19484 : return;
19485 : break;
19486 :
19487 881 : case FL_NAMELIST:
19488 881 : if (!resolve_fl_namelist (sym))
19489 : return;
19490 : break;
19491 :
19492 411951 : case FL_PARAMETER:
19493 411951 : if (!resolve_fl_parameter (sym))
19494 : return;
19495 : break;
19496 :
19497 : default:
19498 : break;
19499 : }
19500 :
19501 : /* Resolve array specifier. Check as well some constraints
19502 : on COMMON blocks. */
19503 :
19504 1761477 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
19505 :
19506 1761477 : resolve_symbol_array_spec (sym, check_constant);
19507 :
19508 : /* Resolve formal namespaces. */
19509 1761477 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
19510 279983 : && !sym->attr.contained && !sym->attr.intrinsic)
19511 250091 : gfc_resolve (sym->formal_ns);
19512 :
19513 : /* Make sure the formal namespace is present. */
19514 1761477 : if (sym->formal && !sym->formal_ns)
19515 : {
19516 : gfc_formal_arglist *formal = sym->formal;
19517 35740 : while (formal && !formal->sym)
19518 11 : formal = formal->next;
19519 :
19520 35729 : if (formal)
19521 : {
19522 35718 : sym->formal_ns = formal->sym->ns;
19523 35718 : if (sym->formal_ns && sym->ns != formal->sym->ns)
19524 27246 : sym->formal_ns->refs++;
19525 : }
19526 : }
19527 :
19528 : /* Check threadprivate restrictions. */
19529 1761477 : if ((sym->attr.threadprivate || sym->attr.omp_groupprivate)
19530 387 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
19531 33 : && !(sym->ns->save_all && !sym->attr.automatic)
19532 32 : && sym->module == NULL
19533 17 : && (sym->ns->proc_name == NULL
19534 17 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19535 4 : && !sym->ns->proc_name->attr.is_main_program)))
19536 : {
19537 2 : if (sym->attr.threadprivate)
19538 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
19539 : else
19540 1 : gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE "
19541 : "attribute", sym->name, &sym->declared_at);
19542 : }
19543 :
19544 1761477 : if (sym->attr.omp_groupprivate && sym->value)
19545 2 : gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an "
19546 : "initializer", sym->name, &sym->declared_at);
19547 :
19548 : /* Check omp declare target restrictions. */
19549 1761477 : if ((sym->attr.omp_declare_target
19550 1760053 : || sym->attr.omp_declare_target_link
19551 1760004 : || sym->attr.omp_declare_target_local)
19552 1521 : && !sym->attr.omp_groupprivate /* already warned. */
19553 1471 : && sym->attr.flavor == FL_VARIABLE
19554 628 : && !sym->attr.save
19555 206 : && !(sym->ns->save_all && !sym->attr.automatic)
19556 206 : && (!sym->attr.in_common
19557 192 : && sym->module == NULL
19558 102 : && (sym->ns->proc_name == NULL
19559 102 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19560 12 : && !sym->ns->proc_name->attr.is_main_program))))
19561 4 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
19562 : sym->name, &sym->declared_at);
19563 :
19564 : /* If we have come this far we can apply default-initializers, as
19565 : described in 14.7.5, to those variables that have not already
19566 : been assigned one. */
19567 1761477 : if (sym->ts.type == BT_DERIVED
19568 134292 : && !sym->value
19569 108642 : && !sym->attr.allocatable
19570 105560 : && !sym->attr.alloc_comp)
19571 : {
19572 105483 : symbol_attribute *a = &sym->attr;
19573 :
19574 105483 : if ((!a->save && !a->dummy && !a->pointer
19575 58055 : && !a->in_common && !a->use_assoc
19576 10921 : && a->referenced
19577 8632 : && !((a->function || a->result)
19578 1711 : && (!a->dimension
19579 160 : || sym->ts.u.derived->attr.alloc_comp
19580 95 : || sym->ts.u.derived->attr.pointer_comp))
19581 7002 : && !(a->function && sym != sym->result))
19582 98501 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
19583 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
19584 8411 : apply_default_init (sym);
19585 97072 : else if (a->function && !a->pointer && !a->allocatable
19586 21060 : && !a->use_assoc && !a->used_in_submodule && sym->result)
19587 : /* Default initialization for function results. */
19588 2759 : apply_default_init (sym->result);
19589 94313 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
19590 12052 : && (sym->ts.u.derived->attr.alloc_comp
19591 11487 : || sym->ts.u.derived->attr.pointer_comp))
19592 : /* Mark the result symbol to be referenced, when it has allocatable
19593 : components. */
19594 624 : sym->result->attr.referenced = 1;
19595 : }
19596 :
19597 1761477 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
19598 19789 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
19599 1322 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
19600 1247 : && !CLASS_DATA (sym)->attr.class_pointer
19601 1221 : && !CLASS_DATA (sym)->attr.allocatable)
19602 913 : apply_default_init (sym);
19603 :
19604 : /* If this symbol has a type-spec, check it. */
19605 1761477 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
19606 668485 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
19607 1428179 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
19608 : return;
19609 :
19610 1761474 : if (sym->param_list)
19611 1840 : resolve_pdt (sym);
19612 : }
19613 :
19614 :
19615 4187 : void gfc_resolve_symbol (gfc_symbol *sym)
19616 : {
19617 4187 : resolve_symbol (sym);
19618 4187 : return;
19619 : }
19620 :
19621 :
19622 : /************* Resolve DATA statements *************/
19623 :
19624 : static struct
19625 : {
19626 : gfc_data_value *vnode;
19627 : mpz_t left;
19628 : }
19629 : values;
19630 :
19631 :
19632 : /* Advance the values structure to point to the next value in the data list. */
19633 :
19634 : static bool
19635 10928 : next_data_value (void)
19636 : {
19637 16696 : while (mpz_cmp_ui (values.left, 0) == 0)
19638 : {
19639 :
19640 8216 : if (values.vnode->next == NULL)
19641 : return false;
19642 :
19643 5768 : values.vnode = values.vnode->next;
19644 5768 : mpz_set (values.left, values.vnode->repeat);
19645 : }
19646 :
19647 : return true;
19648 : }
19649 :
19650 :
19651 : static bool
19652 3575 : check_data_variable (gfc_data_variable *var, locus *where)
19653 : {
19654 3575 : gfc_expr *e;
19655 3575 : mpz_t size;
19656 3575 : mpz_t offset;
19657 3575 : bool t;
19658 3575 : ar_type mark = AR_UNKNOWN;
19659 3575 : int i;
19660 3575 : mpz_t section_index[GFC_MAX_DIMENSIONS];
19661 3575 : int vector_offset[GFC_MAX_DIMENSIONS];
19662 3575 : gfc_ref *ref;
19663 3575 : gfc_array_ref *ar;
19664 3575 : gfc_symbol *sym;
19665 3575 : int has_pointer;
19666 :
19667 3575 : if (!gfc_resolve_expr (var->expr))
19668 : return false;
19669 :
19670 3575 : ar = NULL;
19671 3575 : e = var->expr;
19672 :
19673 3575 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
19674 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
19675 0 : e = e->value.function.actual->expr;
19676 :
19677 3575 : if (e->expr_type != EXPR_VARIABLE)
19678 : {
19679 0 : gfc_error ("Expecting definable entity near %L", where);
19680 0 : return false;
19681 : }
19682 :
19683 3575 : sym = e->symtree->n.sym;
19684 :
19685 3575 : if (sym->ns->is_block_data && !sym->attr.in_common)
19686 : {
19687 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
19688 : sym->name, &sym->declared_at);
19689 2 : return false;
19690 : }
19691 :
19692 3573 : if (e->ref == NULL && sym->as)
19693 : {
19694 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
19695 : " declaration", sym->name, where);
19696 1 : return false;
19697 : }
19698 :
19699 3572 : if (gfc_is_coindexed (e))
19700 : {
19701 7 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
19702 : where);
19703 7 : return false;
19704 : }
19705 :
19706 3565 : has_pointer = sym->attr.pointer;
19707 :
19708 6006 : for (ref = e->ref; ref; ref = ref->next)
19709 : {
19710 2445 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
19711 : has_pointer = 1;
19712 :
19713 2419 : if (has_pointer)
19714 : {
19715 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
19716 : {
19717 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
19718 : "be a full array", sym->name, where);
19719 1 : return false;
19720 : }
19721 :
19722 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
19723 : {
19724 1 : gfc_error ("DATA object near %L has the pointer attribute "
19725 : "and the corresponding DATA value is not a valid "
19726 : "initial-data-target", where);
19727 1 : return false;
19728 : }
19729 : }
19730 :
19731 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
19732 : {
19733 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
19734 : "attribute", ref->u.c.component->name, &e->where);
19735 1 : return false;
19736 : }
19737 :
19738 : /* Reject substrings of strings of non-constant length. */
19739 2442 : if (ref->type == REF_SUBSTRING
19740 73 : && ref->u.ss.length
19741 73 : && ref->u.ss.length->length
19742 2515 : && !gfc_is_constant_expr (ref->u.ss.length->length))
19743 1 : goto bad_charlen;
19744 : }
19745 :
19746 : /* Reject strings with deferred length or non-constant length. */
19747 3561 : if (e->ts.type == BT_CHARACTER
19748 3561 : && (e->ts.deferred
19749 380 : || (e->ts.u.cl->length
19750 379 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
19751 5 : goto bad_charlen;
19752 :
19753 3556 : mpz_init_set_si (offset, 0);
19754 :
19755 3556 : if (e->rank == 0 || has_pointer)
19756 : {
19757 2709 : mpz_init_set_ui (size, 1);
19758 2709 : ref = NULL;
19759 : }
19760 : else
19761 : {
19762 847 : ref = e->ref;
19763 :
19764 : /* Find the array section reference. */
19765 1030 : for (ref = e->ref; ref; ref = ref->next)
19766 : {
19767 1030 : if (ref->type != REF_ARRAY)
19768 92 : continue;
19769 938 : if (ref->u.ar.type == AR_ELEMENT)
19770 91 : continue;
19771 : break;
19772 : }
19773 847 : gcc_assert (ref);
19774 :
19775 : /* Set marks according to the reference pattern. */
19776 847 : switch (ref->u.ar.type)
19777 : {
19778 : case AR_FULL:
19779 : mark = AR_FULL;
19780 : break;
19781 :
19782 151 : case AR_SECTION:
19783 151 : ar = &ref->u.ar;
19784 : /* Get the start position of array section. */
19785 151 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
19786 151 : mark = AR_SECTION;
19787 151 : break;
19788 :
19789 0 : default:
19790 0 : gcc_unreachable ();
19791 : }
19792 :
19793 847 : if (!gfc_array_size (e, &size))
19794 : {
19795 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
19796 : where);
19797 1 : mpz_clear (offset);
19798 1 : return false;
19799 : }
19800 : }
19801 :
19802 3555 : t = true;
19803 :
19804 11973 : while (mpz_cmp_ui (size, 0) > 0)
19805 : {
19806 8481 : if (!next_data_value ())
19807 : {
19808 1 : gfc_error ("DATA statement at %L has more variables than values",
19809 : where);
19810 1 : t = false;
19811 1 : break;
19812 : }
19813 :
19814 8480 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
19815 8480 : if (!t)
19816 : break;
19817 :
19818 : /* If we have more than one element left in the repeat count,
19819 : and we have more than one element left in the target variable,
19820 : then create a range assignment. */
19821 : /* FIXME: Only done for full arrays for now, since array sections
19822 : seem tricky. */
19823 8461 : if (mark == AR_FULL && ref && ref->next == NULL
19824 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
19825 : {
19826 137 : mpz_t range;
19827 :
19828 137 : if (mpz_cmp (size, values.left) >= 0)
19829 : {
19830 126 : mpz_init_set (range, values.left);
19831 126 : mpz_sub (size, size, values.left);
19832 126 : mpz_set_ui (values.left, 0);
19833 : }
19834 : else
19835 : {
19836 11 : mpz_init_set (range, size);
19837 11 : mpz_sub (values.left, values.left, size);
19838 11 : mpz_set_ui (size, 0);
19839 : }
19840 :
19841 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19842 : offset, &range);
19843 :
19844 137 : mpz_add (offset, offset, range);
19845 137 : mpz_clear (range);
19846 :
19847 137 : if (!t)
19848 : break;
19849 129 : }
19850 :
19851 : /* Assign initial value to symbol. */
19852 : else
19853 : {
19854 8324 : mpz_sub_ui (values.left, values.left, 1);
19855 8324 : mpz_sub_ui (size, size, 1);
19856 :
19857 8324 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19858 : offset, NULL);
19859 8324 : if (!t)
19860 : break;
19861 :
19862 8289 : if (mark == AR_FULL)
19863 5259 : mpz_add_ui (offset, offset, 1);
19864 :
19865 : /* Modify the array section indexes and recalculate the offset
19866 : for next element. */
19867 3030 : else if (mark == AR_SECTION)
19868 366 : gfc_advance_section (section_index, ar, &offset, vector_offset);
19869 : }
19870 : }
19871 :
19872 3555 : if (mark == AR_SECTION)
19873 : {
19874 344 : for (i = 0; i < ar->dimen; i++)
19875 194 : mpz_clear (section_index[i]);
19876 : }
19877 :
19878 3555 : mpz_clear (size);
19879 3555 : mpz_clear (offset);
19880 :
19881 3555 : return t;
19882 :
19883 6 : bad_charlen:
19884 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19885 : &e->where);
19886 6 : return false;
19887 : }
19888 :
19889 :
19890 : static bool traverse_data_var (gfc_data_variable *, locus *);
19891 :
19892 : /* Iterate over a list of elements in a DATA statement. */
19893 :
19894 : static bool
19895 237 : traverse_data_list (gfc_data_variable *var, locus *where)
19896 : {
19897 237 : mpz_t trip;
19898 237 : iterator_stack frame;
19899 237 : gfc_expr *e, *start, *end, *step;
19900 237 : bool retval = true;
19901 :
19902 237 : mpz_init (frame.value);
19903 237 : mpz_init (trip);
19904 :
19905 237 : start = gfc_copy_expr (var->iter.start);
19906 237 : end = gfc_copy_expr (var->iter.end);
19907 237 : step = gfc_copy_expr (var->iter.step);
19908 :
19909 237 : if (!gfc_simplify_expr (start, 1)
19910 237 : || start->expr_type != EXPR_CONSTANT)
19911 : {
19912 0 : gfc_error ("start of implied-do loop at %L could not be "
19913 : "simplified to a constant value", &start->where);
19914 0 : retval = false;
19915 0 : goto cleanup;
19916 : }
19917 237 : if (!gfc_simplify_expr (end, 1)
19918 237 : || end->expr_type != EXPR_CONSTANT)
19919 : {
19920 0 : gfc_error ("end of implied-do loop at %L could not be "
19921 : "simplified to a constant value", &end->where);
19922 0 : retval = false;
19923 0 : goto cleanup;
19924 : }
19925 237 : if (!gfc_simplify_expr (step, 1)
19926 237 : || step->expr_type != EXPR_CONSTANT)
19927 : {
19928 0 : gfc_error ("step of implied-do loop at %L could not be "
19929 : "simplified to a constant value", &step->where);
19930 0 : retval = false;
19931 0 : goto cleanup;
19932 : }
19933 237 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19934 : {
19935 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19936 : &step->where);
19937 1 : retval = false;
19938 1 : goto cleanup;
19939 : }
19940 :
19941 236 : mpz_set (trip, end->value.integer);
19942 236 : mpz_sub (trip, trip, start->value.integer);
19943 236 : mpz_add (trip, trip, step->value.integer);
19944 :
19945 236 : mpz_div (trip, trip, step->value.integer);
19946 :
19947 236 : mpz_set (frame.value, start->value.integer);
19948 :
19949 236 : frame.prev = iter_stack;
19950 236 : frame.variable = var->iter.var->symtree;
19951 236 : iter_stack = &frame;
19952 :
19953 1127 : while (mpz_cmp_ui (trip, 0) > 0)
19954 : {
19955 905 : if (!traverse_data_var (var->list, where))
19956 : {
19957 14 : retval = false;
19958 14 : goto cleanup;
19959 : }
19960 :
19961 891 : e = gfc_copy_expr (var->expr);
19962 891 : if (!gfc_simplify_expr (e, 1))
19963 : {
19964 0 : gfc_free_expr (e);
19965 0 : retval = false;
19966 0 : goto cleanup;
19967 : }
19968 :
19969 891 : mpz_add (frame.value, frame.value, step->value.integer);
19970 :
19971 891 : mpz_sub_ui (trip, trip, 1);
19972 : }
19973 :
19974 222 : cleanup:
19975 237 : mpz_clear (frame.value);
19976 237 : mpz_clear (trip);
19977 :
19978 237 : gfc_free_expr (start);
19979 237 : gfc_free_expr (end);
19980 237 : gfc_free_expr (step);
19981 :
19982 237 : iter_stack = frame.prev;
19983 237 : return retval;
19984 : }
19985 :
19986 :
19987 : /* Type resolve variables in the variable list of a DATA statement. */
19988 :
19989 : static bool
19990 3436 : traverse_data_var (gfc_data_variable *var, locus *where)
19991 : {
19992 3436 : bool t;
19993 :
19994 7150 : for (; var; var = var->next)
19995 : {
19996 3812 : if (var->expr == NULL)
19997 237 : t = traverse_data_list (var, where);
19998 : else
19999 3575 : t = check_data_variable (var, where);
20000 :
20001 3812 : if (!t)
20002 : return false;
20003 : }
20004 :
20005 : return true;
20006 : }
20007 :
20008 :
20009 : /* Resolve the expressions and iterators associated with a data statement.
20010 : This is separate from the assignment checking because data lists should
20011 : only be resolved once. */
20012 :
20013 : static bool
20014 2686 : resolve_data_variables (gfc_data_variable *d)
20015 : {
20016 5743 : for (; d; d = d->next)
20017 : {
20018 3062 : if (d->list == NULL)
20019 : {
20020 2909 : if (!gfc_resolve_expr (d->expr))
20021 : return false;
20022 : }
20023 : else
20024 : {
20025 153 : if (!gfc_resolve_iterator (&d->iter, false, true))
20026 : return false;
20027 :
20028 150 : if (!resolve_data_variables (d->list))
20029 : return false;
20030 : }
20031 : }
20032 :
20033 : return true;
20034 : }
20035 :
20036 :
20037 : /* Resolve a single DATA statement. We implement this by storing a pointer to
20038 : the value list into static variables, and then recursively traversing the
20039 : variables list, expanding iterators and such. */
20040 :
20041 : static void
20042 2536 : resolve_data (gfc_data *d)
20043 : {
20044 2536 : gfc_data_value *v;
20045 :
20046 2536 : if (!resolve_data_variables (d->var))
20047 : return;
20048 :
20049 10851 : for (v = d->value; v; v = v->next)
20050 8320 : if (v->expr && !gfc_resolve_expr (v->expr))
20051 : return;
20052 :
20053 2531 : values.vnode = d->value;
20054 2531 : if (d->value == NULL)
20055 0 : mpz_set_ui (values.left, 0);
20056 : else
20057 2531 : mpz_set (values.left, d->value->repeat);
20058 :
20059 2531 : if (!traverse_data_var (d->var, &d->where))
20060 : return;
20061 :
20062 : /* At this point, we better not have any values left. */
20063 :
20064 2447 : if (next_data_value ())
20065 0 : gfc_error ("DATA statement at %L has more values than variables",
20066 : &d->where);
20067 : }
20068 :
20069 :
20070 : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
20071 : accessed by host or use association, is a dummy argument to a pure function,
20072 : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
20073 : is storage associated with any such variable, shall not be used in the
20074 : following contexts: (clients of this function). */
20075 :
20076 : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
20077 : procedure. Returns zero if assignment is OK, nonzero if there is a
20078 : problem. */
20079 : bool
20080 58103 : gfc_impure_variable (gfc_symbol *sym)
20081 : {
20082 58103 : gfc_symbol *proc;
20083 58103 : gfc_namespace *ns;
20084 :
20085 58103 : if (sym->attr.use_assoc || sym->attr.in_common)
20086 : return 1;
20087 :
20088 : /* The namespace of a module procedure interface holds the arguments and
20089 : symbols, and so the symbol namespace can be different to that of the
20090 : procedure. */
20091 57473 : if (sym->ns != gfc_current_ns
20092 6266 : && gfc_current_ns->proc_name->abr_modproc_decl
20093 48 : && sym->ns->proc_name->attr.function
20094 12 : && sym->attr.result
20095 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
20096 : return 0;
20097 :
20098 : /* Check if the symbol's ns is inside the pure procedure. */
20099 62331 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20100 : {
20101 62047 : if (ns == sym->ns)
20102 : break;
20103 6588 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
20104 5438 : && !(sym->attr.function || sym->attr.result))
20105 : return 1;
20106 : }
20107 :
20108 55743 : proc = sym->ns->proc_name;
20109 55743 : if (sym->attr.dummy
20110 6154 : && !sym->attr.value
20111 6032 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
20112 5826 : || proc->attr.function))
20113 700 : return 1;
20114 :
20115 : /* TODO: Sort out what can be storage associated, if anything, and include
20116 : it here. In principle equivalences should be scanned but it does not
20117 : seem to be possible to storage associate an impure variable this way. */
20118 : return 0;
20119 : }
20120 :
20121 :
20122 : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
20123 : current namespace is inside a pure procedure. */
20124 :
20125 : bool
20126 2399914 : gfc_pure (gfc_symbol *sym)
20127 : {
20128 2399914 : symbol_attribute attr;
20129 2399914 : gfc_namespace *ns;
20130 :
20131 2399914 : if (sym == NULL)
20132 : {
20133 : /* Check if the current namespace or one of its parents
20134 : belongs to a pure procedure. */
20135 3242899 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20136 : {
20137 1916011 : sym = ns->proc_name;
20138 1916011 : if (sym == NULL)
20139 : return 0;
20140 1914870 : attr = sym->attr;
20141 1914870 : if (attr.flavor == FL_PROCEDURE && attr.pure)
20142 : return 1;
20143 : }
20144 : return 0;
20145 : }
20146 :
20147 1064299 : attr = sym->attr;
20148 :
20149 1064299 : return attr.flavor == FL_PROCEDURE && attr.pure;
20150 : }
20151 :
20152 :
20153 : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
20154 : checks if the current namespace is implicitly pure. Note that this
20155 : function returns false for a PURE procedure. */
20156 :
20157 : bool
20158 737829 : gfc_implicit_pure (gfc_symbol *sym)
20159 : {
20160 737829 : gfc_namespace *ns;
20161 :
20162 737829 : if (sym == NULL)
20163 : {
20164 : /* Check if the current procedure is implicit_pure. Walk up
20165 : the procedure list until we find a procedure. */
20166 1017581 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20167 : {
20168 725575 : sym = ns->proc_name;
20169 725575 : if (sym == NULL)
20170 : return 0;
20171 :
20172 725502 : if (sym->attr.flavor == FL_PROCEDURE)
20173 : break;
20174 : }
20175 : }
20176 :
20177 445747 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
20178 766522 : && !sym->attr.pure;
20179 : }
20180 :
20181 :
20182 : void
20183 433944 : gfc_unset_implicit_pure (gfc_symbol *sym)
20184 : {
20185 433944 : gfc_namespace *ns;
20186 :
20187 433944 : if (sym == NULL)
20188 : {
20189 : /* Check if the current procedure is implicit_pure. Walk up
20190 : the procedure list until we find a procedure. */
20191 709723 : for (ns = gfc_current_ns; ns; ns = ns->parent)
20192 : {
20193 438948 : sym = ns->proc_name;
20194 438948 : if (sym == NULL)
20195 : return;
20196 :
20197 438115 : if (sym->attr.flavor == FL_PROCEDURE)
20198 : break;
20199 : }
20200 : }
20201 :
20202 433111 : if (sym->attr.flavor == FL_PROCEDURE)
20203 153733 : sym->attr.implicit_pure = 0;
20204 : else
20205 279378 : sym->attr.pure = 0;
20206 : }
20207 :
20208 :
20209 : /* Test whether the current procedure is elemental or not. */
20210 :
20211 : bool
20212 1435068 : gfc_elemental (gfc_symbol *sym)
20213 : {
20214 1435068 : symbol_attribute attr;
20215 :
20216 1435068 : if (sym == NULL)
20217 0 : sym = gfc_current_ns->proc_name;
20218 0 : if (sym == NULL)
20219 : return 0;
20220 1435068 : attr = sym->attr;
20221 :
20222 1435068 : return attr.flavor == FL_PROCEDURE && attr.elemental;
20223 : }
20224 :
20225 :
20226 : /* Warn about unused labels. */
20227 :
20228 : static void
20229 4843 : warn_unused_fortran_label (gfc_st_label *label)
20230 : {
20231 4869 : if (label == NULL)
20232 : return;
20233 :
20234 27 : warn_unused_fortran_label (label->left);
20235 :
20236 27 : if (label->defined == ST_LABEL_UNKNOWN)
20237 : return;
20238 :
20239 26 : switch (label->referenced)
20240 : {
20241 2 : case ST_LABEL_UNKNOWN:
20242 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
20243 : label->value, &label->where);
20244 2 : break;
20245 :
20246 1 : case ST_LABEL_BAD_TARGET:
20247 1 : gfc_warning (OPT_Wunused_label,
20248 : "Label %d at %L defined but cannot be used",
20249 : label->value, &label->where);
20250 1 : break;
20251 :
20252 : default:
20253 : break;
20254 : }
20255 :
20256 26 : warn_unused_fortran_label (label->right);
20257 : }
20258 :
20259 :
20260 : /* Returns the sequence type of a symbol or sequence. */
20261 :
20262 : static seq_type
20263 1076 : sequence_type (gfc_typespec ts)
20264 : {
20265 1076 : seq_type result;
20266 1076 : gfc_component *c;
20267 :
20268 1076 : switch (ts.type)
20269 : {
20270 49 : case BT_DERIVED:
20271 :
20272 49 : if (ts.u.derived->components == NULL)
20273 : return SEQ_NONDEFAULT;
20274 :
20275 49 : result = sequence_type (ts.u.derived->components->ts);
20276 103 : for (c = ts.u.derived->components->next; c; c = c->next)
20277 67 : if (sequence_type (c->ts) != result)
20278 : return SEQ_MIXED;
20279 :
20280 : return result;
20281 :
20282 129 : case BT_CHARACTER:
20283 129 : if (ts.kind != gfc_default_character_kind)
20284 0 : return SEQ_NONDEFAULT;
20285 :
20286 : return SEQ_CHARACTER;
20287 :
20288 240 : case BT_INTEGER:
20289 240 : if (ts.kind != gfc_default_integer_kind)
20290 25 : return SEQ_NONDEFAULT;
20291 :
20292 : return SEQ_NUMERIC;
20293 :
20294 559 : case BT_REAL:
20295 559 : if (!(ts.kind == gfc_default_real_kind
20296 269 : || ts.kind == gfc_default_double_kind))
20297 0 : return SEQ_NONDEFAULT;
20298 :
20299 : return SEQ_NUMERIC;
20300 :
20301 81 : case BT_COMPLEX:
20302 81 : if (ts.kind != gfc_default_complex_kind)
20303 48 : return SEQ_NONDEFAULT;
20304 :
20305 : return SEQ_NUMERIC;
20306 :
20307 17 : case BT_LOGICAL:
20308 17 : if (ts.kind != gfc_default_logical_kind)
20309 0 : return SEQ_NONDEFAULT;
20310 :
20311 : return SEQ_NUMERIC;
20312 :
20313 : default:
20314 : return SEQ_NONDEFAULT;
20315 : }
20316 : }
20317 :
20318 :
20319 : /* Resolve derived type EQUIVALENCE object. */
20320 :
20321 : static bool
20322 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
20323 : {
20324 80 : gfc_component *c = derived->components;
20325 :
20326 80 : if (!derived)
20327 : return true;
20328 :
20329 : /* Shall not be an object of nonsequence derived type. */
20330 80 : if (!derived->attr.sequence)
20331 : {
20332 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
20333 : "attribute to be an EQUIVALENCE object", sym->name,
20334 : &e->where);
20335 0 : return false;
20336 : }
20337 :
20338 : /* Shall not have allocatable components. */
20339 80 : if (derived->attr.alloc_comp)
20340 : {
20341 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
20342 : "components to be an EQUIVALENCE object",sym->name,
20343 : &e->where);
20344 1 : return false;
20345 : }
20346 :
20347 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
20348 : {
20349 1 : gfc_error ("Derived type variable %qs at %L with default "
20350 : "initialization cannot be in EQUIVALENCE with a variable "
20351 : "in COMMON", sym->name, &e->where);
20352 1 : return false;
20353 : }
20354 :
20355 245 : for (; c ; c = c->next)
20356 : {
20357 167 : if (gfc_bt_struct (c->ts.type)
20358 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
20359 : return false;
20360 :
20361 : /* Shall not be an object of sequence derived type containing a pointer
20362 : in the structure. */
20363 167 : if (c->attr.pointer)
20364 : {
20365 0 : gfc_error ("Derived type variable %qs at %L with pointer "
20366 : "component(s) cannot be an EQUIVALENCE object",
20367 : sym->name, &e->where);
20368 0 : return false;
20369 : }
20370 : }
20371 : return true;
20372 : }
20373 :
20374 :
20375 : /* Resolve equivalence object.
20376 : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
20377 : an allocatable array, an object of nonsequence derived type, an object of
20378 : sequence derived type containing a pointer at any level of component
20379 : selection, an automatic object, a function name, an entry name, a result
20380 : name, a named constant, a structure component, or a subobject of any of
20381 : the preceding objects. A substring shall not have length zero. A
20382 : derived type shall not have components with default initialization nor
20383 : shall two objects of an equivalence group be initialized.
20384 : Either all or none of the objects shall have an protected attribute.
20385 : The simple constraints are done in symbol.cc(check_conflict) and the rest
20386 : are implemented here. */
20387 :
20388 : static void
20389 1565 : resolve_equivalence (gfc_equiv *eq)
20390 : {
20391 1565 : gfc_symbol *sym;
20392 1565 : gfc_symbol *first_sym;
20393 1565 : gfc_expr *e;
20394 1565 : gfc_ref *r;
20395 1565 : locus *last_where = NULL;
20396 1565 : seq_type eq_type, last_eq_type;
20397 1565 : gfc_typespec *last_ts;
20398 1565 : int object, cnt_protected;
20399 1565 : const char *msg;
20400 :
20401 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
20402 :
20403 1565 : first_sym = eq->expr->symtree->n.sym;
20404 :
20405 1565 : cnt_protected = 0;
20406 :
20407 4727 : for (object = 1; eq; eq = eq->eq, object++)
20408 : {
20409 3171 : e = eq->expr;
20410 :
20411 3171 : e->ts = e->symtree->n.sym->ts;
20412 : /* match_varspec might not know yet if it is seeing
20413 : array reference or substring reference, as it doesn't
20414 : know the types. */
20415 3171 : if (e->ref && e->ref->type == REF_ARRAY)
20416 : {
20417 2152 : gfc_ref *ref = e->ref;
20418 2152 : sym = e->symtree->n.sym;
20419 :
20420 2152 : if (sym->attr.dimension)
20421 : {
20422 1855 : ref->u.ar.as = sym->as;
20423 1855 : ref = ref->next;
20424 : }
20425 :
20426 : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
20427 2152 : if (e->ts.type == BT_CHARACTER
20428 592 : && ref
20429 371 : && ref->type == REF_ARRAY
20430 371 : && ref->u.ar.dimen == 1
20431 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
20432 371 : && ref->u.ar.stride[0] == NULL)
20433 : {
20434 370 : gfc_expr *start = ref->u.ar.start[0];
20435 370 : gfc_expr *end = ref->u.ar.end[0];
20436 370 : void *mem = NULL;
20437 :
20438 : /* Optimize away the (:) reference. */
20439 370 : if (start == NULL && end == NULL)
20440 : {
20441 9 : if (e->ref == ref)
20442 0 : e->ref = ref->next;
20443 : else
20444 9 : e->ref->next = ref->next;
20445 : mem = ref;
20446 : }
20447 : else
20448 : {
20449 361 : ref->type = REF_SUBSTRING;
20450 361 : if (start == NULL)
20451 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
20452 : NULL, 1);
20453 361 : ref->u.ss.start = start;
20454 361 : if (end == NULL && e->ts.u.cl)
20455 27 : end = gfc_copy_expr (e->ts.u.cl->length);
20456 361 : ref->u.ss.end = end;
20457 361 : ref->u.ss.length = e->ts.u.cl;
20458 361 : e->ts.u.cl = NULL;
20459 : }
20460 370 : ref = ref->next;
20461 370 : free (mem);
20462 : }
20463 :
20464 : /* Any further ref is an error. */
20465 1930 : if (ref)
20466 : {
20467 1 : gcc_assert (ref->type == REF_ARRAY);
20468 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
20469 : &ref->u.ar.where);
20470 1 : continue;
20471 : }
20472 : }
20473 :
20474 3170 : if (!gfc_resolve_expr (e))
20475 2 : continue;
20476 :
20477 3168 : sym = e->symtree->n.sym;
20478 :
20479 3168 : if (sym->attr.is_protected)
20480 2 : cnt_protected++;
20481 3168 : if (cnt_protected > 0 && cnt_protected != object)
20482 : {
20483 2 : gfc_error ("Either all or none of the objects in the "
20484 : "EQUIVALENCE set at %L shall have the "
20485 : "PROTECTED attribute",
20486 : &e->where);
20487 2 : break;
20488 : }
20489 :
20490 : /* Shall not equivalence common block variables in a PURE procedure. */
20491 3166 : if (sym->ns->proc_name
20492 3150 : && sym->ns->proc_name->attr.pure
20493 7 : && sym->attr.in_common)
20494 : {
20495 : /* Need to check for symbols that may have entered the pure
20496 : procedure via a USE statement. */
20497 7 : bool saw_sym = false;
20498 7 : if (sym->ns->use_stmts)
20499 : {
20500 6 : gfc_use_rename *r;
20501 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
20502 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
20503 : }
20504 : else
20505 : saw_sym = true;
20506 :
20507 6 : if (saw_sym)
20508 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
20509 : "EQUIVALENCE object in the pure procedure %qs",
20510 : sym->name, &e->where, sym->ns->proc_name->name);
20511 : break;
20512 : }
20513 :
20514 : /* Shall not be a named constant. */
20515 3159 : if (e->expr_type == EXPR_CONSTANT)
20516 : {
20517 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
20518 : "object", sym->name, &e->where);
20519 0 : continue;
20520 : }
20521 :
20522 3161 : if (e->ts.type == BT_DERIVED
20523 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
20524 2 : continue;
20525 :
20526 : /* Check that the types correspond correctly:
20527 : Note 5.28:
20528 : A numeric sequence structure may be equivalenced to another sequence
20529 : structure, an object of default integer type, default real type, double
20530 : precision real type, default logical type such that components of the
20531 : structure ultimately only become associated to objects of the same
20532 : kind. A character sequence structure may be equivalenced to an object
20533 : of default character kind or another character sequence structure.
20534 : Other objects may be equivalenced only to objects of the same type and
20535 : kind parameters. */
20536 :
20537 : /* Identical types are unconditionally OK. */
20538 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
20539 2677 : goto identical_types;
20540 :
20541 480 : last_eq_type = sequence_type (*last_ts);
20542 480 : eq_type = sequence_type (sym->ts);
20543 :
20544 : /* Since the pair of objects is not of the same type, mixed or
20545 : non-default sequences can be rejected. */
20546 :
20547 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
20548 : "statement at %L with different type objects");
20549 481 : if ((object ==2
20550 480 : && last_eq_type == SEQ_MIXED
20551 7 : && last_where
20552 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20553 486 : || (eq_type == SEQ_MIXED
20554 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20555 1 : continue;
20556 :
20557 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
20558 : "statement at %L with objects of different type");
20559 483 : if ((object ==2
20560 479 : && last_eq_type == SEQ_NONDEFAULT
20561 50 : && last_where
20562 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20563 525 : || (eq_type == SEQ_NONDEFAULT
20564 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20565 4 : continue;
20566 :
20567 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
20568 : "EQUIVALENCE statement at %L");
20569 479 : if (last_eq_type == SEQ_CHARACTER
20570 475 : && eq_type != SEQ_CHARACTER
20571 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20572 4 : continue;
20573 :
20574 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
20575 : "EQUIVALENCE statement at %L");
20576 473 : if (last_eq_type == SEQ_NUMERIC
20577 471 : && eq_type != SEQ_NUMERIC
20578 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20579 2 : continue;
20580 :
20581 3146 : identical_types:
20582 :
20583 3146 : last_ts =&sym->ts;
20584 3146 : last_where = &e->where;
20585 :
20586 3146 : if (!e->ref)
20587 1003 : continue;
20588 :
20589 : /* Shall not be an automatic array. */
20590 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
20591 : {
20592 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
20593 : "an EQUIVALENCE object", sym->name, &e->where);
20594 3 : continue;
20595 : }
20596 :
20597 2140 : r = e->ref;
20598 4326 : while (r)
20599 : {
20600 : /* Shall not be a structure component. */
20601 2187 : if (r->type == REF_COMPONENT)
20602 : {
20603 0 : gfc_error ("Structure component %qs at %L cannot be an "
20604 : "EQUIVALENCE object",
20605 0 : r->u.c.component->name, &e->where);
20606 0 : break;
20607 : }
20608 :
20609 : /* A substring shall not have length zero. */
20610 2187 : if (r->type == REF_SUBSTRING)
20611 : {
20612 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
20613 : {
20614 1 : gfc_error ("Substring at %L has length zero",
20615 : &r->u.ss.start->where);
20616 1 : break;
20617 : }
20618 : }
20619 2186 : r = r->next;
20620 : }
20621 : }
20622 1565 : }
20623 :
20624 :
20625 : /* Function called by resolve_fntype to flag other symbols used in the
20626 : length type parameter specification of function results. */
20627 :
20628 : static bool
20629 4297 : flag_fn_result_spec (gfc_expr *expr,
20630 : gfc_symbol *sym,
20631 : int *f ATTRIBUTE_UNUSED)
20632 : {
20633 4297 : gfc_namespace *ns;
20634 4297 : gfc_symbol *s;
20635 :
20636 4297 : if (expr->expr_type == EXPR_VARIABLE)
20637 : {
20638 1400 : s = expr->symtree->n.sym;
20639 2193 : for (ns = s->ns; ns; ns = ns->parent)
20640 2193 : if (!ns->parent)
20641 : break;
20642 :
20643 1400 : if (sym == s)
20644 : {
20645 1 : gfc_error ("Self reference in character length expression "
20646 : "for %qs at %L", sym->name, &expr->where);
20647 1 : return true;
20648 : }
20649 :
20650 1399 : if (!s->fn_result_spec
20651 1399 : && s->attr.flavor == FL_PARAMETER)
20652 : {
20653 : /* Function contained in a module.... */
20654 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
20655 : {
20656 32 : gfc_symtree *st;
20657 32 : s->fn_result_spec = 1;
20658 : /* Make sure that this symbol is translated as a module
20659 : variable. */
20660 32 : st = gfc_get_unique_symtree (ns);
20661 32 : st->n.sym = s;
20662 32 : s->refs++;
20663 32 : }
20664 : /* ... which is use associated and called. */
20665 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
20666 0 : ||
20667 : /* External function matched with an interface. */
20668 0 : (s->ns->proc_name
20669 0 : && ((s->ns == ns
20670 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
20671 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
20672 0 : && s->ns->proc_name->attr.function))
20673 31 : s->fn_result_spec = 1;
20674 : }
20675 : }
20676 : return false;
20677 : }
20678 :
20679 :
20680 : /* Resolve function and ENTRY types, issue diagnostics if needed. */
20681 :
20682 : static void
20683 364147 : resolve_fntype (gfc_namespace *ns)
20684 : {
20685 364147 : gfc_entry_list *el;
20686 364147 : gfc_symbol *sym;
20687 :
20688 364147 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
20689 : return;
20690 :
20691 : /* If there are any entries, ns->proc_name is the entry master
20692 : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
20693 189905 : if (ns->entries)
20694 596 : sym = ns->entries->sym;
20695 : else
20696 : sym = ns->proc_name;
20697 189905 : if (sym->result == sym
20698 154043 : && sym->ts.type == BT_UNKNOWN
20699 6 : && !gfc_set_default_type (sym, 0, NULL)
20700 189909 : && !sym->attr.untyped)
20701 : {
20702 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
20703 : sym->name, &sym->declared_at);
20704 3 : sym->attr.untyped = 1;
20705 : }
20706 :
20707 14046 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
20708 1874 : && !sym->attr.contained
20709 299 : && !gfc_check_symbol_access (sym->ts.u.derived)
20710 189905 : && gfc_check_symbol_access (sym))
20711 : {
20712 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
20713 : "%L of PRIVATE type %qs", sym->name,
20714 0 : &sym->declared_at, sym->ts.u.derived->name);
20715 : }
20716 :
20717 189905 : if (ns->entries)
20718 1253 : for (el = ns->entries->next; el; el = el->next)
20719 : {
20720 657 : if (el->sym->result == el->sym
20721 445 : && el->sym->ts.type == BT_UNKNOWN
20722 2 : && !gfc_set_default_type (el->sym, 0, NULL)
20723 659 : && !el->sym->attr.untyped)
20724 : {
20725 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
20726 : el->sym->name, &el->sym->declared_at);
20727 2 : el->sym->attr.untyped = 1;
20728 : }
20729 : }
20730 :
20731 189905 : if (sym->ts.type == BT_CHARACTER
20732 7140 : && sym->ts.u.cl->length
20733 1931 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
20734 1926 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
20735 : }
20736 :
20737 :
20738 : /* 12.3.2.1.1 Defined operators. */
20739 :
20740 : static bool
20741 508 : check_uop_procedure (gfc_symbol *sym, locus where)
20742 : {
20743 508 : gfc_formal_arglist *formal;
20744 :
20745 508 : if (!sym->attr.function)
20746 : {
20747 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
20748 : sym->name, &where);
20749 4 : return false;
20750 : }
20751 :
20752 504 : if (sym->ts.type == BT_CHARACTER
20753 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
20754 2 : && !(sym->result && ((sym->result->ts.u.cl
20755 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
20756 : {
20757 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
20758 : "character length", sym->name, &where);
20759 2 : return false;
20760 : }
20761 :
20762 502 : formal = gfc_sym_get_dummy_args (sym);
20763 502 : if (!formal || !formal->sym)
20764 : {
20765 1 : gfc_error ("User operator procedure %qs at %L must have at least "
20766 : "one argument", sym->name, &where);
20767 1 : return false;
20768 : }
20769 :
20770 501 : if (formal->sym->attr.intent != INTENT_IN)
20771 : {
20772 0 : gfc_error ("First argument of operator interface at %L must be "
20773 : "INTENT(IN)", &where);
20774 0 : return false;
20775 : }
20776 :
20777 501 : if (formal->sym->attr.optional)
20778 : {
20779 0 : gfc_error ("First argument of operator interface at %L cannot be "
20780 : "optional", &where);
20781 0 : return false;
20782 : }
20783 :
20784 501 : formal = formal->next;
20785 501 : if (!formal || !formal->sym)
20786 : return true;
20787 :
20788 297 : if (formal->sym->attr.intent != INTENT_IN)
20789 : {
20790 0 : gfc_error ("Second argument of operator interface at %L must be "
20791 : "INTENT(IN)", &where);
20792 0 : return false;
20793 : }
20794 :
20795 297 : if (formal->sym->attr.optional)
20796 : {
20797 1 : gfc_error ("Second argument of operator interface at %L cannot be "
20798 : "optional", &where);
20799 1 : return false;
20800 : }
20801 :
20802 296 : if (formal->next)
20803 : {
20804 2 : gfc_error ("Operator interface at %L must have, at most, two "
20805 : "arguments", &where);
20806 2 : return false;
20807 : }
20808 :
20809 : return true;
20810 : }
20811 :
20812 : static void
20813 364953 : gfc_resolve_uops (gfc_symtree *symtree)
20814 : {
20815 364953 : gfc_interface *itr;
20816 :
20817 364953 : if (symtree == NULL)
20818 : return;
20819 :
20820 403 : gfc_resolve_uops (symtree->left);
20821 403 : gfc_resolve_uops (symtree->right);
20822 :
20823 798 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
20824 395 : check_uop_procedure (itr->sym, itr->sym->declared_at);
20825 : }
20826 :
20827 : /* Mark all lhs in assignment statement as used. It is better to put this into
20828 : its own function rather than into the different switch cases in
20829 : gfc_resolve_code. */
20830 :
20831 : static void
20832 704491 : mark_lhs_assignments_set (gfc_code *code)
20833 : {
20834 :
20835 1865416 : for (; code; code = code->next)
20836 : {
20837 1160925 : gfc_expr *lvalue = code->expr1, *rvalue = code->expr2;
20838 :
20839 1160925 : if (lvalue == NULL || lvalue->symtree == NULL || rvalue == NULL)
20840 858738 : continue;
20841 :
20842 302187 : switch (code->op)
20843 : {
20844 290280 : case EXEC_ASSIGN:
20845 290280 : if (gfc_is_reallocatable_lhs (lvalue) && lvalue->rank == rvalue->rank)
20846 8545 : gfc_lvalue_allocated_at (lvalue->symtree->n.sym, &lvalue->where);
20847 :
20848 300697 : gcc_fallthrough();
20849 300697 : case EXEC_POINTER_ASSIGN:
20850 300697 : gfc_expr_set_at (lvalue, &rvalue->where, VALUE_VARDEF);
20851 : default:
20852 : break;
20853 : }
20854 : }
20855 704491 : }
20856 :
20857 : /* Examine all of the expressions associated with a program unit,
20858 : assign types to all intermediate expressions, make sure that all
20859 : assignments are to compatible types and figure out which names
20860 : refer to which functions or subroutines. It doesn't check code
20861 : block, which is handled by gfc_resolve_code. */
20862 :
20863 : static void
20864 366763 : resolve_types (gfc_namespace *ns)
20865 : {
20866 366763 : gfc_namespace *n;
20867 366763 : gfc_charlen *cl;
20868 366763 : gfc_data *d;
20869 366763 : gfc_equiv *eq;
20870 366763 : gfc_namespace* old_ns = gfc_current_ns;
20871 366763 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
20872 :
20873 366763 : if (ns->types_resolved)
20874 : return;
20875 :
20876 : /* Check that all IMPLICIT types are ok. */
20877 364148 : if (!ns->seen_implicit_none)
20878 : {
20879 : unsigned letter;
20880 9168931 : for (letter = 0; letter != GFC_LETTERS; ++letter)
20881 8829341 : if (ns->set_flag[letter]
20882 8829341 : && !resolve_typespec_used (&ns->default_type[letter],
20883 : &ns->implicit_loc[letter], NULL))
20884 : return;
20885 : }
20886 :
20887 364147 : gfc_current_ns = ns;
20888 :
20889 364147 : resolve_entries (ns);
20890 :
20891 364147 : resolve_common_vars (&ns->blank_common, false);
20892 364147 : resolve_common_blocks (ns->common_root);
20893 :
20894 364147 : resolve_contained_functions (ns);
20895 :
20896 364147 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
20897 311703 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
20898 206457 : gfc_resolve_formal_arglist (ns->proc_name);
20899 :
20900 364147 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
20901 :
20902 460429 : for (cl = ns->cl_list; cl; cl = cl->next)
20903 96282 : resolve_charlen (cl);
20904 :
20905 364147 : gfc_traverse_ns (ns, resolve_symbol);
20906 :
20907 364147 : resolve_fntype (ns);
20908 :
20909 414524 : for (n = ns->contained; n; n = n->sibling)
20910 : {
20911 : /* Exclude final wrappers with the test for the artificial attribute. */
20912 50377 : if (gfc_pure (ns->proc_name)
20913 5 : && !gfc_pure (n->proc_name)
20914 50377 : && !n->proc_name->attr.artificial)
20915 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20916 : "also be PURE", n->proc_name->name,
20917 : &n->proc_name->declared_at);
20918 :
20919 50377 : resolve_types (n);
20920 : }
20921 :
20922 364147 : forall_flag = 0;
20923 364147 : gfc_do_concurrent_flag = 0;
20924 364147 : gfc_check_interfaces (ns);
20925 :
20926 364147 : gfc_traverse_ns (ns, resolve_values);
20927 :
20928 364147 : if (ns->save_all || (!flag_automatic && !recursive))
20929 315 : gfc_save_all (ns);
20930 :
20931 364147 : iter_stack = NULL;
20932 366683 : for (d = ns->data; d; d = d->next)
20933 2536 : resolve_data (d);
20934 :
20935 364147 : iter_stack = NULL;
20936 364147 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20937 :
20938 364147 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20939 :
20940 365712 : for (eq = ns->equiv; eq; eq = eq->next)
20941 1565 : resolve_equivalence (eq);
20942 :
20943 : /* Warn about unused labels. */
20944 364147 : if (warn_unused_label)
20945 4816 : warn_unused_fortran_label (ns->st_labels);
20946 :
20947 364147 : gfc_resolve_uops (ns->uop_root);
20948 :
20949 364147 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20950 :
20951 364147 : gfc_resolve_omp_declare (ns);
20952 :
20953 364147 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20954 :
20955 364147 : gfc_resolve_omp_udms (ns->omp_udm_root);
20956 :
20957 364147 : ns->types_resolved = 1;
20958 :
20959 364147 : gfc_current_ns = old_ns;
20960 : }
20961 :
20962 :
20963 : /* Call gfc_resolve_code recursively. */
20964 :
20965 : static void
20966 366825 : resolve_codes (gfc_namespace *ns)
20967 : {
20968 366825 : gfc_namespace *n;
20969 366825 : bitmap_obstack old_obstack;
20970 :
20971 366825 : if (ns->resolved == 1)
20972 14975 : return;
20973 :
20974 402289 : for (n = ns->contained; n; n = n->sibling)
20975 50439 : resolve_codes (n);
20976 :
20977 351850 : gfc_current_ns = ns;
20978 :
20979 : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20980 351850 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20981 338877 : cs_base = NULL;
20982 :
20983 : /* Set to an out of range value. */
20984 351850 : current_entry_id = -1;
20985 :
20986 351850 : old_obstack = labels_obstack;
20987 351850 : bitmap_obstack_initialize (&labels_obstack);
20988 :
20989 351850 : gfc_resolve_oacc_declare (ns);
20990 351850 : gfc_resolve_oacc_routines (ns);
20991 351850 : gfc_resolve_omp_local_vars (ns);
20992 351850 : if (ns->omp_allocate)
20993 62 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20994 351850 : gfc_resolve_code (ns->code, ns);
20995 :
20996 351849 : bitmap_obstack_release (&labels_obstack);
20997 351849 : labels_obstack = old_obstack;
20998 : }
20999 :
21000 : /* Return true if the value of a variable can be considered used, either
21001 : through the value_used flag or because it is a suitable dummy argument. */
21002 :
21003 : static bool
21004 453 : var_value_is_used (gfc_symbol *sym)
21005 : {
21006 453 : if (sym->attr.value_used != VALUE_UNUSED)
21007 : return true;
21008 :
21009 107 : if (!sym->attr.dummy)
21010 : return false;
21011 :
21012 90 : if (sym->attr.value)
21013 : return false;
21014 :
21015 90 : switch (sym->attr.intent)
21016 : {
21017 : case INTENT_UNKNOWN:
21018 : case INTENT_INOUT:
21019 : case INTENT_OUT:
21020 : return true;
21021 :
21022 : case INTENT_IN:
21023 : default:
21024 : return false;
21025 : }
21026 : }
21027 :
21028 : /* Similar, see if the variable could have gotten its value from somewhere. */
21029 :
21030 : static bool
21031 2381 : var_value_is_set (gfc_symbol *sym)
21032 : {
21033 2381 : if (sym->attr.value_set != VALUE_UNSET)
21034 : return true;
21035 :
21036 1684 : if (sym->value)
21037 : return true;
21038 :
21039 1669 : if (sym->ts.type == BT_DERIVED
21040 1669 : && gfc_has_default_initializer (sym->ts.u.derived))
21041 : return true;
21042 :
21043 1669 : if (!sym->attr.dummy)
21044 : return false;
21045 :
21046 1624 : if (sym->attr.value)
21047 : return true;
21048 :
21049 1591 : if (sym->attr.intent == INTENT_OUT)
21050 3 : return false;
21051 :
21052 : return true;
21053 : }
21054 :
21055 : /* Callback function to catch set but never used variables. */
21056 :
21057 : static void
21058 34279 : find_unused_vs_set (gfc_symbol *sym)
21059 : {
21060 34279 : symbol_attribute *attr = &sym->attr;
21061 :
21062 34279 : if (attr->flavor != FL_VARIABLE)
21063 : return;
21064 :
21065 : /* Do not warn about anything too far out of the ordinary. This might be
21066 : tightened later. */
21067 8605 : if (attr->in_common || attr->in_equivalence || attr->artificial
21068 8199 : || attr->cray_pointer || attr->cray_pointee || attr->associate_var
21069 8196 : || attr->target || attr->fe_temp || attr->omp_declare_target
21070 8193 : || attr->omp_declare_target_link || attr->omp_declare_target_local
21071 8184 : || attr->omp_declare_target_indirect || attr->oacc_declare_create
21072 8184 : || attr->oacc_declare_copyin || attr->oacc_declare_deviceptr
21073 8184 : || attr->oacc_declare_device_resident || attr->oacc_declare_link
21074 8184 : || attr->result || attr->warning_emitted || attr->use_assoc
21075 5645 : || attr->volatile_ || attr->asynchronous || !attr->referenced)
21076 : return;
21077 :
21078 2449 : if (attr->host_assoc && attr->access != ACCESS_PRIVATE)
21079 : return;
21080 :
21081 : /* There is no allocation in sight, but the variable is used anyway. This
21082 : might be hidden behind PRESENT, but issue a warning nonetheless. If
21083 : people complain, we might want to make this to an extra option to be
21084 : included with -Wextra. */
21085 :
21086 2383 : if (warn_undefined_vars && attr->allocatable && !attr->allocated
21087 2435 : && var_value_is_used (sym))
21088 : {
21089 3 : if (attr->dummy && attr->intent == INTENT_OUT)
21090 : {
21091 0 : gfc_warning (OPT_Wundefined_vars, "Unallocated INTENT(OUT) variable "
21092 : "%qs referenced at %L", sym->name, &sym->other_loc);
21093 0 : attr->warning_emitted = 1;
21094 0 : return;
21095 : }
21096 :
21097 3 : if (!attr->dummy)
21098 : {
21099 2 : gfc_warning (OPT_Wundefined_vars, "Unallocated variable %qs "
21100 : "referenced at %L", sym->name, &sym->other_loc);
21101 2 : attr->warning_emitted = 1;
21102 2 : return;
21103 : }
21104 : }
21105 :
21106 2424 : if (warn_undefined_vars && !var_value_is_set (sym))
21107 : {
21108 : /* Warn about variables which have been allocated and used, but never
21109 : set. */
21110 48 : if (attr->allocated && sym->attr.value_used > VALUE_MAYBE_USED)
21111 : {
21112 3 : switch (sym->attr.value_used)
21113 : {
21114 1 : case VALUE_INTENT_IN:
21115 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
21116 : "undefined to INTENT(IN) argument at %L", sym->name,
21117 : &sym->other_loc);
21118 1 : break;
21119 :
21120 1 : case VALUE_VALUE_ARG:
21121 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
21122 : "undefined to VALUE argument at %L", sym->name,
21123 : &sym->other_loc);
21124 1 : break;
21125 1 : case VALUE_USED:
21126 1 : gfc_warning (OPT_Wundefined_vars, "Allocated undefined variable "
21127 : "%qs used at %L", sym->name, &sym->other_loc);
21128 1 : break;
21129 0 : default:
21130 0 : gfc_internal_error ("Wrong value_set");
21131 3 : break;
21132 : }
21133 3 : attr->warning_emitted = 1;
21134 3 : return;
21135 : }
21136 :
21137 : /* Similar, when undefined variables are passed to INTENT(IN), VALUE
21138 : arguments or are used in general. */
21139 :
21140 45 : if (attr->value_used == VALUE_INTENT_IN)
21141 : {
21142 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
21143 : "to INTENT(IN) argument at %L", sym->name, &sym->other_loc);
21144 1 : attr->warning_emitted = 1;
21145 1 : return;
21146 : }
21147 44 : else if (attr->value_used == VALUE_VALUE_ARG)
21148 : {
21149 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
21150 : "to VALUE argument at %L", sym->name, &sym->other_loc);
21151 1 : attr->warning_emitted = 1;
21152 1 : return;
21153 : }
21154 43 : else if (attr->value_used == VALUE_USED)
21155 : {
21156 9 : if (attr->dummy && attr->intent == INTENT_OUT)
21157 1 : gfc_warning (OPT_Wundefined_vars, "Undefined INTENT(OUT) variable %qs "
21158 : "used at %L", sym->name, &sym->other_loc);
21159 : else
21160 8 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs used at "
21161 : "%L", sym->name, &sym->other_loc);
21162 :
21163 9 : attr->warning_emitted = 1;
21164 9 : return;
21165 : }
21166 :
21167 : /* PR 28004 - warn about INTENT(OUT) variables that are never set. If
21168 : the variable or a component are allocatable, do not warn since this is
21169 : a frequent shortcut for deallocation. */
21170 :
21171 34 : if (sym->attr.dummy && sym->attr.intent == INTENT_OUT
21172 2 : && !(attr->allocatable || attr->alloc_comp))
21173 : {
21174 0 : gfc_warning (OPT_Wundefined_vars, "INTENT(OUT) variable %qs "
21175 : "declared at %L is not assigned a value", sym->name,
21176 : &sym->declared_at);
21177 0 : attr->warning_emitted = 1;
21178 0 : return;
21179 : }
21180 : }
21181 :
21182 : /* Warn for unused but defined variables. */
21183 :
21184 2410 : if (warn_unused_but_set_variable)
21185 : {
21186 2302 : if (attr->value_set == VALUE_VARDEF && !var_value_is_used (sym))
21187 : {
21188 7 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs defined at "
21189 : "%L but never used", sym->name, &sym->other_loc);
21190 7 : attr->warning_emitted = 1;
21191 7 : return;
21192 : }
21193 2295 : if (attr->allocatable && !var_value_is_used (sym))
21194 : {
21195 2 : if (attr->allocated == ALLOCATED_ALLOCATE_STMT)
21196 : {
21197 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs "
21198 : "allocated at %L but never used", sym->name,
21199 : &sym->extra_loc);
21200 1 : attr->warning_emitted = 1;
21201 1 : return;
21202 : }
21203 1 : else if (attr->allocated == ALLOCATED_ARG)
21204 : {
21205 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs maybe "
21206 : "allocated as argument at %L but never used",
21207 : sym->name, &sym->extra_loc);
21208 1 : attr->warning_emitted = 1;
21209 1 : return;
21210 : }
21211 : }
21212 : }
21213 :
21214 : /* -Wunused-intent-out and -Wunused-read are enabled with -Wextra, so
21215 : check for these conditions at the end. If one of the warnings
21216 : with -Wall triggered, we do not want to issue a different warrning
21217 : for the same variable if the user supplies -Wall -Wextra instead
21218 : of only -Wall. */
21219 :
21220 39 : if (warn_unused_intent_out && attr->value_set == VALUE_INTENT_OUT
21221 2406 : && !var_value_is_used (sym))
21222 : {
21223 1 : gfc_warning (OPT_Wunused_intent_out, "Variable %qs passed to "
21224 : "INTENT(OUT) argument at %L but value never used",
21225 : sym->name, &sym->other_loc);
21226 1 : attr->warning_emitted = 1;
21227 1 : return;
21228 : }
21229 :
21230 2400 : if (warn_unused_read && attr->value_set == VALUE_READ && !var_value_is_used (sym))
21231 : {
21232 1 : gfc_warning (OPT_Wunused_read, "Variable %qs read at %L but never "
21233 : "used", sym->name, &sym->other_loc);
21234 1 : attr->warning_emitted = 1;
21235 1 : return;
21236 : }
21237 : }
21238 :
21239 : /* Run warn_unused_vs_set over a namespace recursively. */
21240 :
21241 : static void
21242 4845 : warn_unused_vs_set (gfc_namespace *ns)
21243 : {
21244 4845 : gfc_traverse_ns (ns, find_unused_vs_set);
21245 :
21246 5368 : for (gfc_namespace *n = ns->contained; n; n = n->sibling)
21247 523 : warn_unused_vs_set (n);
21248 4845 : }
21249 :
21250 : /* This function is called after a complete program unit has been compiled.
21251 : Its purpose is to examine all of the expressions associated with a program
21252 : unit, assign types to all intermediate expressions, make sure that all
21253 : assignments are to compatible types and figure out which names refer to
21254 : which functions or subroutines. */
21255 :
21256 : void
21257 321341 : gfc_resolve (gfc_namespace *ns, gfc_association_list *a)
21258 : {
21259 321341 : gfc_namespace *old_ns;
21260 321341 : code_stack *old_cs_base;
21261 321341 : struct gfc_omp_saved_state old_omp_state;
21262 :
21263 321341 : if (ns->resolved)
21264 4955 : return;
21265 :
21266 316386 : ns->resolved = -1;
21267 316386 : old_ns = gfc_current_ns;
21268 316386 : old_cs_base = cs_base;
21269 :
21270 : /* As gfc_resolve can be called during resolution of an OpenMP construct
21271 : body, we should clear any state associated to it, so that say NS's
21272 : DO loops are not interpreted as OpenMP loops. */
21273 316386 : if (!ns->construct_entities)
21274 303413 : gfc_omp_save_and_clear_state (&old_omp_state);
21275 :
21276 316386 : resolve_types (ns);
21277 316386 : component_assignment_level = 0;
21278 316386 : resolve_codes (ns);
21279 316385 : mark_assoc_used (a);
21280 :
21281 316385 : if (warn_unused_but_set_variable || warn_unused_intent_out
21282 312121 : || warn_unused_read || warn_undefined_vars)
21283 : {
21284 4346 : int error_count;
21285 4346 : gfc_get_errors (NULL, &error_count);
21286 4346 : if (error_count == 0)
21287 4322 : warn_unused_vs_set (ns);
21288 : }
21289 :
21290 316385 : if (ns->omp_assumes)
21291 16 : gfc_resolve_omp_assumptions (ns->omp_assumes);
21292 :
21293 316385 : gfc_current_ns = old_ns;
21294 316385 : cs_base = old_cs_base;
21295 316385 : ns->resolved = 1;
21296 :
21297 316385 : gfc_run_passes (ns);
21298 :
21299 316385 : if (!ns->construct_entities)
21300 303412 : gfc_omp_restore_state (&old_omp_state);
21301 : }
|
