Line data Source code
1 : /* Perform type resolution on the various structures.
2 : Copyright (C) 2001-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : #include "config.h"
22 : #include "system.h"
23 : #include "coretypes.h"
24 : #include "options.h"
25 : #include "bitmap.h"
26 : #include "gfortran.h"
27 : #include "arith.h" /* For gfc_compare_expr(). */
28 : #include "dependency.h"
29 : #include "data.h"
30 : #include "target-memory.h" /* for gfc_simplify_transfer */
31 : #include "constructor.h"
32 :
33 : /* Types used in equivalence statements. */
34 :
35 : enum seq_type
36 : {
37 : SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 : };
39 :
40 : /* Stack to keep track of the nesting of blocks as we move through the
41 : code. See resolve_branch() and gfc_resolve_code(). */
42 :
43 : typedef struct code_stack
44 : {
45 : struct gfc_code *head, *current;
46 : struct code_stack *prev;
47 :
48 : /* This bitmap keeps track of the targets valid for a branch from
49 : inside this block except for END {IF|SELECT}s of enclosing
50 : blocks. */
51 : bitmap reachable_labels;
52 : }
53 : code_stack;
54 :
55 : static code_stack *cs_base = NULL;
56 :
57 : struct check_default_none_data
58 : {
59 : gfc_code *code;
60 : hash_set<gfc_symbol *> *sym_hash;
61 : gfc_namespace *ns;
62 : bool default_none;
63 : };
64 :
65 : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
66 :
67 : static int forall_flag;
68 : int gfc_do_concurrent_flag;
69 :
70 : /* True when we are resolving an expression that is an actual argument to
71 : a procedure. */
72 : static bool actual_arg = false;
73 : /* True when we are resolving an expression that is the first actual argument
74 : to a procedure. */
75 : static bool first_actual_arg = false;
76 :
77 :
78 : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
79 :
80 : static int omp_workshare_flag;
81 :
82 :
83 : /* True if we are resolving a specification expression. */
84 : static bool specification_expr = false;
85 :
86 : /* The id of the last entry seen. */
87 : static int current_entry_id;
88 :
89 : /* We use bitmaps to determine if a branch target is valid. */
90 : static bitmap_obstack labels_obstack;
91 :
92 : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 : static bool inquiry_argument = false;
94 :
95 :
96 : /* Is the symbol host associated? */
97 : static bool
98 51566 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
99 : {
100 56053 : for (ns = ns->parent; ns; ns = ns->parent)
101 : {
102 4738 : if (sym->ns == ns)
103 : return true;
104 : }
105 :
106 : return false;
107 : }
108 :
109 : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
110 : an ABSTRACT derived-type. If where is not NULL, an error message with that
111 : locus is printed, optionally using name. */
112 :
113 : static bool
114 1508640 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
115 : {
116 1508640 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
117 : {
118 5 : if (where)
119 : {
120 5 : if (name)
121 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
122 : name, where, ts->u.derived->name);
123 : else
124 1 : gfc_error ("ABSTRACT type %qs used at %L",
125 : ts->u.derived->name, where);
126 : }
127 :
128 5 : return false;
129 : }
130 :
131 : return true;
132 : }
133 :
134 :
135 : static bool
136 5503 : check_proc_interface (gfc_symbol *ifc, locus *where)
137 : {
138 : /* Several checks for F08:C1216. */
139 5503 : if (ifc->attr.procedure)
140 : {
141 2 : gfc_error ("Interface %qs at %L is declared "
142 : "in a later PROCEDURE statement", ifc->name, where);
143 2 : return false;
144 : }
145 5501 : if (ifc->generic)
146 : {
147 : /* For generic interfaces, check if there is
148 : a specific procedure with the same name. */
149 : gfc_interface *gen = ifc->generic;
150 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
151 5 : gen = gen->next;
152 7 : if (!gen)
153 : {
154 4 : gfc_error ("Interface %qs at %L may not be generic",
155 : ifc->name, where);
156 4 : return false;
157 : }
158 : }
159 5497 : if (ifc->attr.proc == PROC_ST_FUNCTION)
160 : {
161 4 : gfc_error ("Interface %qs at %L may not be a statement function",
162 : ifc->name, where);
163 4 : return false;
164 : }
165 5493 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
166 5493 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
167 17 : ifc->attr.intrinsic = 1;
168 5493 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
169 : {
170 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
171 : "PROCEDURE statement at %L", ifc->name, where);
172 3 : return false;
173 : }
174 5490 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
175 : {
176 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
177 7 : return false;
178 : }
179 : return true;
180 : }
181 :
182 :
183 : static void resolve_symbol (gfc_symbol *sym);
184 :
185 :
186 : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
187 :
188 : static bool
189 2008 : resolve_procedure_interface (gfc_symbol *sym)
190 : {
191 2008 : gfc_symbol *ifc = sym->ts.interface;
192 :
193 2008 : if (!ifc)
194 : return true;
195 :
196 1852 : if (ifc == sym)
197 : {
198 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
199 : sym->name, &sym->declared_at);
200 2 : return false;
201 : }
202 1850 : if (!check_proc_interface (ifc, &sym->declared_at))
203 : return false;
204 :
205 1841 : if (ifc->attr.if_source || ifc->attr.intrinsic)
206 : {
207 : /* Resolve interface and copy attributes. */
208 1562 : resolve_symbol (ifc);
209 1562 : if (ifc->attr.intrinsic)
210 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
211 :
212 1562 : if (ifc->result)
213 : {
214 681 : sym->ts = ifc->result->ts;
215 681 : sym->attr.allocatable = ifc->result->attr.allocatable;
216 681 : sym->attr.pointer = ifc->result->attr.pointer;
217 681 : sym->attr.dimension = ifc->result->attr.dimension;
218 681 : sym->attr.class_ok = ifc->result->attr.class_ok;
219 681 : sym->as = gfc_copy_array_spec (ifc->result->as);
220 681 : sym->result = sym;
221 : }
222 : else
223 : {
224 881 : sym->ts = ifc->ts;
225 881 : sym->attr.allocatable = ifc->attr.allocatable;
226 881 : sym->attr.pointer = ifc->attr.pointer;
227 881 : sym->attr.dimension = ifc->attr.dimension;
228 881 : sym->attr.class_ok = ifc->attr.class_ok;
229 881 : sym->as = gfc_copy_array_spec (ifc->as);
230 : }
231 1562 : sym->ts.interface = ifc;
232 1562 : sym->attr.function = ifc->attr.function;
233 1562 : sym->attr.subroutine = ifc->attr.subroutine;
234 :
235 1562 : sym->attr.pure = ifc->attr.pure;
236 1562 : sym->attr.elemental = ifc->attr.elemental;
237 1562 : sym->attr.contiguous = ifc->attr.contiguous;
238 1562 : sym->attr.recursive = ifc->attr.recursive;
239 1562 : sym->attr.always_explicit = ifc->attr.always_explicit;
240 1562 : sym->attr.ext_attr |= ifc->attr.ext_attr;
241 1562 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
242 : /* Copy char length. */
243 1562 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
244 : {
245 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
246 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
247 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
248 : return false;
249 : }
250 : }
251 :
252 : return true;
253 : }
254 :
255 :
256 : /* Resolve types of formal argument lists. These have to be done early so that
257 : the formal argument lists of module procedures can be copied to the
258 : containing module before the individual procedures are resolved
259 : individually. We also resolve argument lists of procedures in interface
260 : blocks because they are self-contained scoping units.
261 :
262 : Since a dummy argument cannot be a non-dummy procedure, the only
263 : resort left for untyped names are the IMPLICIT types. */
264 :
265 : void
266 517866 : gfc_resolve_formal_arglist (gfc_symbol *proc)
267 : {
268 517866 : gfc_formal_arglist *f;
269 517866 : gfc_symbol *sym;
270 517866 : bool saved_specification_expr;
271 517866 : int i;
272 :
273 517866 : if (proc->result != NULL)
274 322557 : sym = proc->result;
275 : else
276 : sym = proc;
277 :
278 517866 : if (gfc_elemental (proc)
279 355906 : || sym->attr.pointer || sym->attr.allocatable
280 861763 : || (sym->as && sym->as->rank != 0))
281 : {
282 176263 : proc->attr.always_explicit = 1;
283 176263 : sym->attr.always_explicit = 1;
284 : }
285 :
286 517866 : gfc_namespace *orig_current_ns = gfc_current_ns;
287 517866 : gfc_current_ns = gfc_get_procedure_ns (proc);
288 :
289 1340170 : for (f = proc->formal; f; f = f->next)
290 : {
291 822306 : gfc_array_spec *as;
292 :
293 822306 : sym = f->sym;
294 :
295 822306 : if (sym == NULL)
296 : {
297 : /* Alternate return placeholder. */
298 171 : if (gfc_elemental (proc))
299 1 : gfc_error ("Alternate return specifier in elemental subroutine "
300 : "%qs at %L is not allowed", proc->name,
301 : &proc->declared_at);
302 171 : if (proc->attr.function)
303 1 : gfc_error ("Alternate return specifier in function "
304 : "%qs at %L is not allowed", proc->name,
305 : &proc->declared_at);
306 171 : continue;
307 : }
308 :
309 560 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310 822695 : && !resolve_procedure_interface (sym))
311 : break;
312 :
313 822135 : if (strcmp (proc->name, sym->name) == 0)
314 : {
315 2 : gfc_error ("Self-referential argument "
316 : "%qs at %L is not allowed", sym->name,
317 : &proc->declared_at);
318 2 : break;
319 : }
320 :
321 822133 : if (sym->attr.if_source != IFSRC_UNKNOWN)
322 824 : gfc_resolve_formal_arglist (sym);
323 :
324 822133 : if (sym->attr.subroutine || sym->attr.external)
325 : {
326 830 : if (sym->attr.flavor == FL_UNKNOWN)
327 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328 : }
329 : else
330 : {
331 821303 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 3662 : && (!sym->attr.function || sym->result == sym))
333 3624 : gfc_set_default_type (sym, 1, sym->ns);
334 : }
335 :
336 822133 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 835720 : ? CLASS_DATA (sym)->as : sym->as;
338 :
339 822133 : saved_specification_expr = specification_expr;
340 822133 : specification_expr = true;
341 822133 : gfc_resolve_array_spec (as, 0);
342 822133 : specification_expr = saved_specification_expr;
343 :
344 : /* We can't tell if an array with dimension (:) is assumed or deferred
345 : shape until we know if it has the pointer or allocatable attributes.
346 : */
347 822133 : if (as && as->rank > 0 && as->type == AS_DEFERRED
348 12142 : && ((sym->ts.type != BT_CLASS
349 11058 : && !(sym->attr.pointer || sym->attr.allocatable))
350 5287 : || (sym->ts.type == BT_CLASS
351 1084 : && !(CLASS_DATA (sym)->attr.class_pointer
352 884 : || CLASS_DATA (sym)->attr.allocatable)))
353 7324 : && sym->attr.flavor != FL_PROCEDURE)
354 : {
355 7323 : as->type = AS_ASSUMED_SHAPE;
356 17007 : for (i = 0; i < as->rank; i++)
357 9684 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
358 : }
359 :
360 127756 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361 114276 : || (as && as->type == AS_ASSUMED_RANK)
362 771328 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363 761245 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 11492 : && (CLASS_DATA (sym)->attr.class_pointer
365 11009 : || CLASS_DATA (sym)->attr.allocatable
366 10111 : || CLASS_DATA (sym)->attr.target))
367 759864 : || sym->attr.optional)
368 : {
369 77431 : proc->attr.always_explicit = 1;
370 77431 : if (proc->result)
371 36026 : proc->result->attr.always_explicit = 1;
372 : }
373 :
374 : /* If the flavor is unknown at this point, it has to be a variable.
375 : A procedure specification would have already set the type. */
376 :
377 822133 : if (sym->attr.flavor == FL_UNKNOWN)
378 50239 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379 :
380 822133 : if (gfc_pure (proc))
381 : {
382 326763 : if (sym->attr.flavor == FL_PROCEDURE)
383 : {
384 : /* F08:C1279. */
385 29 : if (!gfc_pure (sym))
386 : {
387 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 : "also be PURE", sym->name, &sym->declared_at);
389 1 : continue;
390 : }
391 : }
392 326734 : else if (!sym->attr.pointer)
393 : {
394 326720 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 : {
396 111 : if (sym->attr.value)
397 110 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398 : " of pure function %qs at %L with VALUE "
399 : "attribute but without INTENT(IN)",
400 : sym->name, proc->name, &sym->declared_at);
401 : else
402 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
403 : "be INTENT(IN) or VALUE", sym->name, proc->name,
404 : &sym->declared_at);
405 : }
406 :
407 326720 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 : {
409 159 : if (sym->attr.value)
410 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411 : " of pure subroutine %qs at %L with VALUE "
412 : "attribute but without INTENT", sym->name,
413 : proc->name, &sym->declared_at);
414 : else
415 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 : "must have its INTENT specified or have the "
417 : "VALUE attribute", sym->name, proc->name,
418 : &sym->declared_at);
419 : }
420 : }
421 :
422 : /* F08:C1278a. */
423 326762 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 : {
425 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 : " may not be polymorphic", sym->name, proc->name,
427 : &sym->declared_at);
428 1 : continue;
429 : }
430 : }
431 :
432 822131 : if (proc->attr.implicit_pure)
433 : {
434 24590 : if (sym->attr.flavor == FL_PROCEDURE)
435 : {
436 296 : if (!gfc_pure (sym))
437 276 : proc->attr.implicit_pure = 0;
438 : }
439 24294 : else if (!sym->attr.pointer)
440 : {
441 23514 : if (proc->attr.function && sym->attr.intent != INTENT_IN
442 2718 : && !sym->value)
443 2718 : proc->attr.implicit_pure = 0;
444 :
445 23514 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 4169 : && !sym->value)
447 4169 : proc->attr.implicit_pure = 0;
448 : }
449 : }
450 :
451 822131 : if (gfc_elemental (proc))
452 : {
453 : /* F08:C1289. */
454 301266 : if (sym->attr.codimension
455 301265 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456 905 : && CLASS_DATA (sym)->attr.codimension))
457 : {
458 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 : "procedure", sym->name, &sym->declared_at);
460 3 : continue;
461 : }
462 :
463 301263 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464 903 : && CLASS_DATA (sym)->as))
465 : {
466 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
467 : "be scalar", sym->name, &sym->declared_at);
468 2 : continue;
469 : }
470 :
471 301261 : if (sym->attr.allocatable
472 301260 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473 902 : && CLASS_DATA (sym)->attr.allocatable))
474 : {
475 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 : "have the ALLOCATABLE attribute", sym->name,
477 : &sym->declared_at);
478 2 : continue;
479 : }
480 :
481 301259 : if (sym->attr.pointer
482 301258 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483 901 : && CLASS_DATA (sym)->attr.class_pointer))
484 : {
485 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 : "have the POINTER attribute", sym->name,
487 : &sym->declared_at);
488 2 : continue;
489 : }
490 :
491 301257 : if (sym->attr.flavor == FL_PROCEDURE)
492 : {
493 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
494 : "procedure %qs at %L", sym->name, proc->name,
495 : &sym->declared_at);
496 2 : continue;
497 : }
498 :
499 : /* Fortran 2008 Corrigendum 1, C1290a. */
500 301255 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501 : {
502 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 : "have its INTENT specified or have the VALUE "
504 : "attribute", sym->name, proc->name,
505 : &sym->declared_at);
506 2 : continue;
507 : }
508 : }
509 :
510 : /* Each dummy shall be specified to be scalar. */
511 822118 : if (proc->attr.proc == PROC_ST_FUNCTION)
512 : {
513 305 : if (sym->as != NULL)
514 : {
515 : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 : shall be specified, explicitly or implicitly, to be scalar. */
517 1 : gfc_error ("Argument %qs of statement function %qs at %L "
518 : "must be scalar", sym->name, proc->name,
519 : &proc->declared_at);
520 1 : continue;
521 : }
522 :
523 304 : if (sym->ts.type == BT_CHARACTER)
524 : {
525 48 : gfc_charlen *cl = sym->ts.u.cl;
526 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 : {
528 0 : gfc_error ("Character-valued argument %qs of statement "
529 : "function at %L must have constant length",
530 : sym->name, &sym->declared_at);
531 0 : continue;
532 : }
533 : }
534 : }
535 : }
536 517866 : if (sym)
537 517774 : sym->formal_resolved = 1;
538 517866 : gfc_current_ns = orig_current_ns;
539 517866 : }
540 :
541 :
542 : /* Work function called when searching for symbols that have argument lists
543 : associated with them. */
544 :
545 : static void
546 1809576 : find_arglists (gfc_symbol *sym)
547 : {
548 1809576 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
549 327775 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
550 : return;
551 :
552 325783 : gfc_resolve_formal_arglist (sym);
553 : }
554 :
555 :
556 : /* Given a namespace, resolve all formal argument lists within the namespace.
557 : */
558 :
559 : static void
560 341858 : resolve_formal_arglists (gfc_namespace *ns)
561 : {
562 0 : if (ns == NULL)
563 : return;
564 :
565 341858 : gfc_traverse_ns (ns, find_arglists);
566 : }
567 :
568 :
569 : static void
570 36735 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
571 : {
572 36735 : bool t;
573 :
574 36735 : if (sym && sym->attr.flavor == FL_PROCEDURE
575 36735 : && sym->ns->parent
576 1064 : && sym->ns->parent->proc_name
577 1064 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
578 1 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
579 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
580 : "encompassing procedure", sym->name, &sym->declared_at);
581 :
582 : /* If this namespace is not a function or an entry master function,
583 : ignore it. */
584 36735 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
585 10788 : || sym->attr.entry_master)
586 26135 : return;
587 :
588 10600 : if (!sym->result)
589 : return;
590 :
591 : /* Try to find out of what the return type is. */
592 10600 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
593 : {
594 57 : t = gfc_set_default_type (sym->result, 0, ns);
595 :
596 57 : if (!t && !sym->result->attr.untyped)
597 : {
598 19 : if (sym->result == sym)
599 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
600 : sym->name, &sym->declared_at);
601 18 : else if (!sym->result->attr.proc_pointer)
602 0 : gfc_error ("Result %qs of contained function %qs at %L has "
603 : "no IMPLICIT type", sym->result->name, sym->name,
604 : &sym->result->declared_at);
605 19 : sym->result->attr.untyped = 1;
606 : }
607 : }
608 :
609 : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
610 : type, lists the only ways a character length value of * can be used:
611 : dummy arguments of procedures, named constants, function results and
612 : in allocate statements if the allocate_object is an assumed length dummy
613 : in external functions. Internal function results and results of module
614 : procedures are not on this list, ergo, not permitted. */
615 :
616 10600 : if (sym->result->ts.type == BT_CHARACTER)
617 : {
618 1187 : gfc_charlen *cl = sym->result->ts.u.cl;
619 1187 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
620 : {
621 : /* See if this is a module-procedure and adapt error message
622 : accordingly. */
623 4 : bool module_proc;
624 4 : gcc_assert (ns->parent && ns->parent->proc_name);
625 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
626 :
627 7 : gfc_error (module_proc
628 : ? G_("Character-valued module procedure %qs at %L"
629 : " must not be assumed length")
630 : : G_("Character-valued internal function %qs at %L"
631 : " must not be assumed length"),
632 : sym->name, &sym->declared_at);
633 : }
634 : }
635 : }
636 :
637 :
638 : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
639 : introduce duplicates. */
640 :
641 : static void
642 1420 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
643 : {
644 1420 : gfc_formal_arglist *f, *new_arglist;
645 1420 : gfc_symbol *new_sym;
646 :
647 2561 : for (; new_args != NULL; new_args = new_args->next)
648 : {
649 1141 : new_sym = new_args->sym;
650 : /* See if this arg is already in the formal argument list. */
651 2165 : for (f = proc->formal; f; f = f->next)
652 : {
653 1470 : if (new_sym == f->sym)
654 : break;
655 : }
656 :
657 1141 : if (f)
658 446 : continue;
659 :
660 : /* Add a new argument. Argument order is not important. */
661 695 : new_arglist = gfc_get_formal_arglist ();
662 695 : new_arglist->sym = new_sym;
663 695 : new_arglist->next = proc->formal;
664 695 : proc->formal = new_arglist;
665 : }
666 1420 : }
667 :
668 :
669 : /* Flag the arguments that are not present in all entries. */
670 :
671 : static void
672 1420 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
673 : {
674 1420 : gfc_formal_arglist *f, *head;
675 1420 : head = new_args;
676 :
677 2994 : for (f = proc->formal; f; f = f->next)
678 : {
679 1574 : if (f->sym == NULL)
680 36 : continue;
681 :
682 2704 : for (new_args = head; new_args; new_args = new_args->next)
683 : {
684 2262 : if (new_args->sym == f->sym)
685 : break;
686 : }
687 :
688 1538 : if (new_args)
689 1096 : continue;
690 :
691 442 : f->sym->attr.not_always_present = 1;
692 : }
693 1420 : }
694 :
695 :
696 : /* Resolve alternate entry points. If a symbol has multiple entry points we
697 : create a new master symbol for the main routine, and turn the existing
698 : symbol into an entry point. */
699 :
700 : static void
701 378088 : resolve_entries (gfc_namespace *ns)
702 : {
703 378088 : gfc_namespace *old_ns;
704 378088 : gfc_code *c;
705 378088 : gfc_symbol *proc;
706 378088 : gfc_entry_list *el;
707 : /* Provide sufficient space to hold "master.%d.%s". */
708 378088 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
709 378088 : static int master_count = 0;
710 :
711 378088 : if (ns->proc_name == NULL)
712 377420 : return;
713 :
714 : /* No need to do anything if this procedure doesn't have alternate entry
715 : points. */
716 378039 : if (!ns->entries)
717 : return;
718 :
719 : /* We may already have resolved alternate entry points. */
720 918 : if (ns->proc_name->attr.entry_master)
721 : return;
722 :
723 : /* If this isn't a procedure something has gone horribly wrong. */
724 668 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
725 :
726 : /* Remember the current namespace. */
727 668 : old_ns = gfc_current_ns;
728 :
729 668 : gfc_current_ns = ns;
730 :
731 : /* Add the main entry point to the list of entry points. */
732 668 : el = gfc_get_entry_list ();
733 668 : el->sym = ns->proc_name;
734 668 : el->id = 0;
735 668 : el->next = ns->entries;
736 668 : ns->entries = el;
737 668 : ns->proc_name->attr.entry = 1;
738 :
739 : /* If it is a module function, it needs to be in the right namespace
740 : so that gfc_get_fake_result_decl can gather up the results. The
741 : need for this arose in get_proc_name, where these beasts were
742 : left in their own namespace, to keep prior references linked to
743 : the entry declaration.*/
744 668 : if (ns->proc_name->attr.function
745 564 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
746 188 : el->sym->ns = ns;
747 :
748 : /* Do the same for entries where the master is not a module
749 : procedure. These are retained in the module namespace because
750 : of the module procedure declaration. */
751 1420 : for (el = el->next; el; el = el->next)
752 752 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
753 0 : && el->sym->attr.mod_proc)
754 0 : el->sym->ns = ns;
755 668 : el = ns->entries;
756 :
757 : /* Add an entry statement for it. */
758 668 : c = gfc_get_code (EXEC_ENTRY);
759 668 : c->ext.entry = el;
760 668 : c->next = ns->code;
761 668 : ns->code = c;
762 :
763 : /* Create a new symbol for the master function. */
764 : /* Give the internal function a unique name (within this file).
765 : Also include the function name so the user has some hope of figuring
766 : out what is going on. */
767 668 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
768 668 : master_count++, ns->proc_name->name);
769 668 : gfc_get_ha_symbol (name, &proc);
770 668 : gcc_assert (proc != NULL);
771 :
772 668 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
773 668 : if (ns->proc_name->attr.subroutine)
774 104 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
775 : else
776 : {
777 564 : gfc_symbol *sym;
778 564 : gfc_typespec *ts, *fts;
779 564 : gfc_array_spec *as, *fas;
780 564 : gfc_add_function (&proc->attr, proc->name, NULL);
781 564 : proc->result = proc;
782 564 : fas = ns->entries->sym->as;
783 564 : fas = fas ? fas : ns->entries->sym->result->as;
784 564 : fts = &ns->entries->sym->result->ts;
785 564 : if (fts->type == BT_UNKNOWN)
786 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
787 1058 : for (el = ns->entries->next; el; el = el->next)
788 : {
789 603 : ts = &el->sym->result->ts;
790 603 : as = el->sym->as;
791 603 : as = as ? as : el->sym->result->as;
792 603 : if (ts->type == BT_UNKNOWN)
793 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
794 :
795 603 : if (! gfc_compare_types (ts, fts)
796 497 : || (el->sym->result->attr.dimension
797 497 : != ns->entries->sym->result->attr.dimension)
798 603 : || (el->sym->result->attr.pointer
799 497 : != ns->entries->sym->result->attr.pointer))
800 : break;
801 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
802 559 : && gfc_compare_array_spec (as, fas) == 0)
803 5 : gfc_error ("Function %s at %L has entries with mismatched "
804 : "array specifications", ns->entries->sym->name,
805 5 : &ns->entries->sym->declared_at);
806 : /* The characteristics need to match and thus both need to have
807 : the same string length, i.e. both len=*, or both len=4.
808 : Having both len=<variable> is also possible, but difficult to
809 : check at compile time. */
810 492 : else if (ts->type == BT_CHARACTER
811 89 : && (el->sym->result->attr.allocatable
812 89 : != ns->entries->sym->result->attr.allocatable))
813 : {
814 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
815 : "characteristics", ns->entries->sym->name,
816 : &ns->entries->sym->declared_at, el->sym->name);
817 3 : goto cleanup;
818 : }
819 489 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
820 86 : && (((ts->u.cl->length && !fts->u.cl->length)
821 85 : ||(!ts->u.cl->length && fts->u.cl->length))
822 66 : || (ts->u.cl->length
823 29 : && ts->u.cl->length->expr_type
824 29 : != fts->u.cl->length->expr_type)
825 66 : || (ts->u.cl->length
826 29 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
827 28 : && mpz_cmp (ts->u.cl->length->value.integer,
828 28 : fts->u.cl->length->value.integer) != 0)))
829 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
830 : "entries returning variables of different "
831 : "string lengths", ns->entries->sym->name,
832 21 : &ns->entries->sym->declared_at);
833 468 : else if (el->sym->result->attr.allocatable
834 468 : != ns->entries->sym->result->attr.allocatable)
835 : break;
836 : }
837 :
838 561 : if (el == NULL)
839 : {
840 455 : sym = ns->entries->sym->result;
841 : /* All result types the same. */
842 455 : proc->ts = *fts;
843 455 : if (sym->attr.dimension)
844 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
845 455 : if (sym->attr.pointer)
846 78 : gfc_add_pointer (&proc->attr, NULL);
847 455 : if (sym->attr.allocatable)
848 24 : gfc_add_allocatable (&proc->attr, NULL);
849 : }
850 : else
851 : {
852 : /* Otherwise the result will be passed through a union by
853 : reference. */
854 106 : proc->attr.mixed_entry_master = 1;
855 340 : for (el = ns->entries; el; el = el->next)
856 : {
857 234 : sym = el->sym->result;
858 234 : if (sym->attr.dimension)
859 : {
860 1 : if (el == ns->entries)
861 0 : gfc_error ("FUNCTION result %s cannot be an array in "
862 : "FUNCTION %s at %L", sym->name,
863 0 : ns->entries->sym->name, &sym->declared_at);
864 : else
865 1 : gfc_error ("ENTRY result %s cannot be an array in "
866 : "FUNCTION %s at %L", sym->name,
867 1 : ns->entries->sym->name, &sym->declared_at);
868 : }
869 233 : else if (sym->attr.pointer)
870 : {
871 1 : if (el == ns->entries)
872 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
873 : "FUNCTION %s at %L", sym->name,
874 1 : ns->entries->sym->name, &sym->declared_at);
875 : else
876 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
877 : "FUNCTION %s at %L", sym->name,
878 0 : ns->entries->sym->name, &sym->declared_at);
879 : }
880 232 : else if (sym->attr.allocatable)
881 : {
882 0 : if (el == ns->entries)
883 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
884 : "FUNCTION %s at %L", sym->name,
885 0 : ns->entries->sym->name, &sym->declared_at);
886 : else
887 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
888 : "FUNCTION %s at %L", sym->name,
889 0 : ns->entries->sym->name, &sym->declared_at);
890 : }
891 : else
892 : {
893 232 : ts = &sym->ts;
894 232 : if (ts->type == BT_UNKNOWN)
895 9 : ts = gfc_get_default_type (sym->name, NULL);
896 232 : switch (ts->type)
897 : {
898 84 : case BT_INTEGER:
899 84 : if (ts->kind == gfc_default_integer_kind)
900 : sym = NULL;
901 : break;
902 99 : case BT_REAL:
903 99 : if (ts->kind == gfc_default_real_kind
904 18 : || ts->kind == gfc_default_double_kind)
905 : sym = NULL;
906 : break;
907 19 : case BT_COMPLEX:
908 19 : if (ts->kind == gfc_default_complex_kind)
909 : sym = NULL;
910 : break;
911 27 : case BT_LOGICAL:
912 27 : if (ts->kind == gfc_default_logical_kind)
913 : sym = NULL;
914 : break;
915 : case BT_UNKNOWN:
916 : /* We will issue error elsewhere. */
917 : sym = NULL;
918 : break;
919 : default:
920 : break;
921 : }
922 3 : if (sym)
923 : {
924 3 : if (el == ns->entries)
925 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
926 : "in FUNCTION %s at %L", sym->name,
927 1 : gfc_typename (ts), ns->entries->sym->name,
928 : &sym->declared_at);
929 : else
930 2 : gfc_error ("ENTRY result %s cannot be of type %s "
931 : "in FUNCTION %s at %L", sym->name,
932 2 : gfc_typename (ts), ns->entries->sym->name,
933 : &sym->declared_at);
934 : }
935 : }
936 : }
937 : }
938 : }
939 :
940 106 : cleanup:
941 668 : proc->attr.access = ACCESS_PRIVATE;
942 668 : proc->attr.entry_master = 1;
943 :
944 : /* Merge all the entry point arguments. */
945 2088 : for (el = ns->entries; el; el = el->next)
946 1420 : merge_argument_lists (proc, el->sym->formal);
947 :
948 : /* Check the master formal arguments for any that are not
949 : present in all entry points. */
950 2088 : for (el = ns->entries; el; el = el->next)
951 1420 : check_argument_lists (proc, el->sym->formal);
952 :
953 : /* Use the master function for the function body. */
954 668 : ns->proc_name = proc;
955 :
956 : /* Finalize the new symbols. */
957 668 : gfc_commit_symbols ();
958 :
959 : /* Restore the original namespace. */
960 668 : gfc_current_ns = old_ns;
961 : }
962 :
963 :
964 : /* Forward declaration. */
965 : static bool is_non_constant_shape_array (gfc_symbol *sym);
966 :
967 :
968 : /* Resolve common variables. */
969 : static void
970 343835 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
971 : {
972 343835 : gfc_symbol *csym = common_block->head;
973 343835 : gfc_gsymbol *gsym;
974 :
975 349886 : for (; csym; csym = csym->common_next)
976 : {
977 6051 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
978 6051 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
979 : {
980 3 : if (csym->common_block)
981 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
982 : "COMMON block at %L", gsym->name,
983 : &gsym->where, &csym->common_block->where);
984 : else
985 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
986 : "COMMON block", gsym->name, &gsym->where);
987 : }
988 :
989 : /* gfc_add_in_common may have been called before, but the reported errors
990 : have been ignored to continue parsing.
991 : We do the checks again here, unless the symbol is USE associated. */
992 6051 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
993 : {
994 5778 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
995 5778 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
996 : &common_block->where);
997 : }
998 :
999 6051 : if (csym->value || csym->attr.data)
1000 : {
1001 149 : if (!csym->ns->is_block_data)
1002 33 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1003 : "but only in BLOCK DATA initialization is "
1004 : "allowed", csym->name, &csym->declared_at);
1005 116 : else if (!named_common)
1006 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1007 : "in a blank COMMON but initialization is only "
1008 : "allowed in named common blocks", csym->name,
1009 : &csym->declared_at);
1010 : }
1011 :
1012 6051 : if (UNLIMITED_POLY (csym))
1013 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1014 : "[F2008:C5100]", csym->name, &csym->declared_at);
1015 :
1016 6051 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1017 : {
1018 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1019 : "COMMON at %L", csym->name, &csym->declared_at,
1020 : &common_block->where);
1021 : /* Avoid confusing follow-on error. */
1022 1 : csym->error = 1;
1023 : }
1024 :
1025 6051 : if (csym->ts.type != BT_DERIVED)
1026 6004 : continue;
1027 :
1028 47 : if (!(csym->ts.u.derived->attr.sequence
1029 3 : || csym->ts.u.derived->attr.is_bind_c))
1030 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1031 : "has neither the SEQUENCE nor the BIND(C) "
1032 : "attribute", csym->name, &csym->declared_at);
1033 47 : if (csym->ts.u.derived->attr.alloc_comp)
1034 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1035 : "has an ultimate component that is "
1036 : "allocatable", csym->name, &csym->declared_at);
1037 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1038 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1039 : "may not have default initializer", csym->name,
1040 : &csym->declared_at);
1041 :
1042 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1043 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1044 : }
1045 343835 : }
1046 :
1047 : /* Resolve common blocks. */
1048 : static void
1049 342388 : resolve_common_blocks (gfc_symtree *common_root)
1050 : {
1051 342388 : gfc_symbol *sym = NULL;
1052 342388 : gfc_gsymbol * gsym;
1053 :
1054 342388 : if (common_root == NULL)
1055 342266 : return;
1056 :
1057 1977 : if (common_root->left)
1058 246 : resolve_common_blocks (common_root->left);
1059 1977 : if (common_root->right)
1060 284 : resolve_common_blocks (common_root->right);
1061 :
1062 1977 : resolve_common_vars (common_root->n.common, true);
1063 :
1064 : /* The common name is a global name - in Fortran 2003 also if it has a
1065 : C binding name, since Fortran 2008 only the C binding name is a global
1066 : identifier. */
1067 1977 : if (!common_root->n.common->binding_label
1068 1977 : || gfc_notification_std (GFC_STD_F2008))
1069 : {
1070 3810 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1071 1905 : common_root->n.common->name);
1072 :
1073 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1074 14 : && gsym->type == GSYM_COMMON
1075 1918 : && ((common_root->n.common->binding_label
1076 6 : && (!gsym->binding_label
1077 0 : || strcmp (common_root->n.common->binding_label,
1078 : gsym->binding_label) != 0))
1079 7 : || (!common_root->n.common->binding_label
1080 7 : && gsym->binding_label)))
1081 : {
1082 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1083 : "identifier and must thus have the same binding name "
1084 : "as the same-named COMMON block at %L: %s vs %s",
1085 6 : common_root->n.common->name, &common_root->n.common->where,
1086 : &gsym->where,
1087 : common_root->n.common->binding_label
1088 : ? common_root->n.common->binding_label : "(blank)",
1089 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1090 6 : return;
1091 : }
1092 :
1093 1899 : if (gsym && gsym->type != GSYM_COMMON
1094 1 : && !common_root->n.common->binding_label)
1095 : {
1096 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1097 : "as entity at %L",
1098 0 : common_root->n.common->name, &common_root->n.common->where,
1099 : &gsym->where);
1100 0 : return;
1101 : }
1102 814 : if (gsym && gsym->type != GSYM_COMMON)
1103 : {
1104 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1105 : "%L sharing the identifier with global non-COMMON-block "
1106 1 : "entity at %L", common_root->n.common->name,
1107 1 : &common_root->n.common->where, &gsym->where);
1108 1 : return;
1109 : }
1110 1085 : if (!gsym)
1111 : {
1112 1085 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1113 1085 : gsym->type = GSYM_COMMON;
1114 1085 : gsym->where = common_root->n.common->where;
1115 1085 : gsym->defined = 1;
1116 : }
1117 1898 : gsym->used = 1;
1118 : }
1119 :
1120 1970 : if (common_root->n.common->binding_label)
1121 : {
1122 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1123 : common_root->n.common->binding_label);
1124 76 : if (gsym && gsym->type != GSYM_COMMON)
1125 : {
1126 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1127 : "global identifier as entity at %L",
1128 : &common_root->n.common->where,
1129 1 : common_root->n.common->binding_label, &gsym->where);
1130 1 : return;
1131 : }
1132 57 : if (!gsym)
1133 : {
1134 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1135 57 : gsym->type = GSYM_COMMON;
1136 57 : gsym->where = common_root->n.common->where;
1137 57 : gsym->defined = 1;
1138 : }
1139 75 : gsym->used = 1;
1140 : }
1141 :
1142 1969 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1143 1969 : if (sym == NULL)
1144 : return;
1145 :
1146 122 : if (sym->attr.flavor == FL_PARAMETER)
1147 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1148 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1149 :
1150 122 : if (sym->attr.external)
1151 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1152 1 : sym->name, &common_root->n.common->where);
1153 :
1154 122 : if (sym->attr.intrinsic)
1155 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1156 2 : sym->name, &common_root->n.common->where);
1157 120 : else if (sym->attr.result
1158 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1159 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1160 : "that is also a function result", sym->name,
1161 1 : &common_root->n.common->where);
1162 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1163 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1164 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1165 : "that is also a global procedure", sym->name,
1166 3 : &common_root->n.common->where);
1167 : }
1168 :
1169 :
1170 : /* Resolve contained function types. Because contained functions can call one
1171 : another, they have to be worked out before any of the contained procedures
1172 : can be resolved.
1173 :
1174 : The good news is that if a function doesn't already have a type, the only
1175 : way it can get one is through an IMPLICIT type or a RESULT variable, because
1176 : by definition contained functions are contained namespace they're contained
1177 : in, not in a sibling or parent namespace. */
1178 :
1179 : static void
1180 341858 : resolve_contained_functions (gfc_namespace *ns)
1181 : {
1182 341858 : gfc_namespace *child;
1183 341858 : gfc_entry_list *el;
1184 :
1185 341858 : resolve_formal_arglists (ns);
1186 :
1187 378088 : for (child = ns->contained; child; child = child->sibling)
1188 : {
1189 : /* Resolve alternate entry points first. */
1190 36230 : resolve_entries (child);
1191 :
1192 : /* Then check function return types. */
1193 36230 : resolve_contained_fntype (child->proc_name, child);
1194 36735 : for (el = child->entries; el; el = el->next)
1195 505 : resolve_contained_fntype (el->sym, child);
1196 : }
1197 341858 : }
1198 :
1199 :
1200 :
1201 : /* A Parameterized Derived Type constructor must contain values for
1202 : the PDT KIND parameters or they must have a default initializer.
1203 : Go through the constructor picking out the KIND expressions,
1204 : storing them in 'param_list' and then call gfc_get_pdt_instance
1205 : to obtain the PDT instance. */
1206 :
1207 : static gfc_actual_arglist *param_list, *param_tail, *param;
1208 :
1209 : static bool
1210 290 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1211 : {
1212 290 : param = gfc_get_actual_arglist ();
1213 290 : if (!param_list)
1214 234 : param_list = param_tail = param;
1215 : else
1216 : {
1217 56 : param_tail->next = param;
1218 56 : param_tail = param_tail->next;
1219 : }
1220 :
1221 290 : param_tail->name = c->name;
1222 290 : if (expr)
1223 290 : param_tail->expr = gfc_copy_expr (expr);
1224 0 : else if (c->initializer)
1225 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1226 : else
1227 : {
1228 0 : param_tail->spec_type = SPEC_ASSUMED;
1229 0 : if (c->attr.pdt_kind)
1230 : {
1231 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1232 : "at %C has no value", param->name);
1233 0 : return false;
1234 : }
1235 : }
1236 :
1237 : return true;
1238 : }
1239 :
1240 : static bool
1241 270 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1242 : gfc_symbol *derived)
1243 : {
1244 270 : gfc_constructor *cons = NULL;
1245 270 : gfc_component *comp;
1246 270 : bool t = true;
1247 :
1248 270 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1249 234 : cons = gfc_constructor_first (expr->value.constructor);
1250 36 : else if (constr)
1251 36 : cons = *constr;
1252 270 : gcc_assert (cons);
1253 :
1254 270 : comp = derived->components;
1255 :
1256 826 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1257 : {
1258 556 : if (cons->expr
1259 556 : && cons->expr->expr_type == EXPR_STRUCTURE
1260 0 : && comp->ts.type == BT_DERIVED)
1261 : {
1262 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1263 0 : if (!t)
1264 : return t;
1265 : }
1266 556 : else if (comp->ts.type == BT_DERIVED)
1267 : {
1268 36 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1269 36 : if (!t)
1270 : return t;
1271 : }
1272 520 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1273 290 : && derived->attr.pdt_template)
1274 : {
1275 290 : t = get_pdt_spec_expr (comp, cons->expr);
1276 290 : if (!t)
1277 : return t;
1278 : }
1279 : }
1280 : return t;
1281 : }
1282 :
1283 :
1284 : static bool resolve_fl_derived0 (gfc_symbol *sym);
1285 : static bool resolve_fl_struct (gfc_symbol *sym);
1286 :
1287 :
1288 : /* Resolve all of the elements of a structure constructor and make sure that
1289 : the types are correct. The 'init' flag indicates that the given
1290 : constructor is an initializer. */
1291 :
1292 : static bool
1293 62146 : resolve_structure_cons (gfc_expr *expr, int init)
1294 : {
1295 62146 : gfc_constructor *cons;
1296 62146 : gfc_component *comp;
1297 62146 : bool t;
1298 62146 : symbol_attribute a;
1299 :
1300 62146 : t = true;
1301 :
1302 62146 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1303 : {
1304 59328 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1305 59178 : resolve_fl_derived0 (expr->ts.u.derived);
1306 : else
1307 150 : resolve_fl_struct (expr->ts.u.derived);
1308 :
1309 : /* If this is a Parameterized Derived Type template, find the
1310 : instance corresponding to the PDT kind parameters. */
1311 59328 : if (expr->ts.u.derived->attr.pdt_template)
1312 : {
1313 234 : param_list = NULL;
1314 234 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1315 234 : if (!t)
1316 : return t;
1317 234 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1318 :
1319 234 : expr->param_list = gfc_copy_actual_arglist (param_list);
1320 :
1321 234 : if (param_list)
1322 234 : gfc_free_actual_arglist (param_list);
1323 :
1324 234 : if (!expr->ts.u.derived->attr.pdt_type)
1325 : return false;
1326 : }
1327 : }
1328 :
1329 : /* A constructor may have references if it is the result of substituting a
1330 : parameter variable. In this case we just pull out the component we
1331 : want. */
1332 62146 : if (expr->ref)
1333 160 : comp = expr->ref->u.c.sym->components;
1334 61986 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1335 : || expr->ts.type == BT_UNION)
1336 61984 : && expr->ts.u.derived)
1337 61984 : comp = expr->ts.u.derived->components;
1338 : else
1339 : return false;
1340 :
1341 62144 : cons = gfc_constructor_first (expr->value.constructor);
1342 :
1343 206492 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1344 : {
1345 144350 : int rank;
1346 :
1347 144350 : if (!cons->expr)
1348 9619 : continue;
1349 :
1350 : /* Unions use an EXPR_NULL contrived expression to tell the translation
1351 : phase to generate an initializer of the appropriate length.
1352 : Ignore it here. */
1353 134731 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1354 15 : continue;
1355 :
1356 134716 : if (!gfc_resolve_expr (cons->expr))
1357 : {
1358 0 : t = false;
1359 0 : continue;
1360 : }
1361 :
1362 134716 : rank = comp->as ? comp->as->rank : 0;
1363 134716 : if (comp->ts.type == BT_CLASS
1364 1741 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1365 1740 : && CLASS_DATA (comp)->as)
1366 513 : rank = CLASS_DATA (comp)->as->rank;
1367 :
1368 134716 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1369 215 : gfc_find_vtab (&cons->expr->ts);
1370 :
1371 134716 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1372 462 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1373 : {
1374 4 : gfc_error ("The rank of the element in the structure "
1375 : "constructor at %L does not match that of the "
1376 : "component (%d/%d)", &cons->expr->where,
1377 : cons->expr->rank, rank);
1378 4 : t = false;
1379 : }
1380 :
1381 : /* If we don't have the right type, try to convert it. */
1382 :
1383 235642 : if (!comp->attr.proc_pointer &&
1384 100926 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1385 : {
1386 12285 : if (strcmp (comp->name, "_extends") == 0)
1387 : {
1388 : /* Can afford to be brutal with the _extends initializer.
1389 : The derived type can get lost because it is PRIVATE
1390 : but it is not usage constrained by the standard. */
1391 8951 : cons->expr->ts = comp->ts;
1392 : }
1393 3334 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1394 : {
1395 2 : gfc_error ("The element in the structure constructor at %L, "
1396 : "for pointer component %qs, is %s but should be %s",
1397 2 : &cons->expr->where, comp->name,
1398 2 : gfc_basic_typename (cons->expr->ts.type),
1399 : gfc_basic_typename (comp->ts.type));
1400 2 : t = false;
1401 : }
1402 3332 : else if (!UNLIMITED_POLY (comp))
1403 : {
1404 3270 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1405 3270 : if (t)
1406 134716 : t = t2;
1407 : }
1408 : }
1409 :
1410 : /* For strings, the length of the constructor should be the same as
1411 : the one of the structure, ensure this if the lengths are known at
1412 : compile time and when we are dealing with PARAMETER or structure
1413 : constructors. */
1414 134716 : if (cons->expr->ts.type == BT_CHARACTER
1415 3870 : && comp->ts.type == BT_CHARACTER
1416 3845 : && comp->ts.u.cl && comp->ts.u.cl->length
1417 2481 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1418 2446 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1419 926 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1420 926 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1421 926 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1422 926 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1423 926 : comp->ts.u.cl->length->value.integer) != 0)
1424 : {
1425 11 : if (comp->attr.pointer)
1426 : {
1427 3 : HOST_WIDE_INT la, lb;
1428 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1429 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1430 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1431 : "component %qs in constructor at %L",
1432 3 : la, lb, comp->name, &cons->expr->where);
1433 3 : t = false;
1434 : }
1435 :
1436 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1437 4 : && cons->expr->rank != 0
1438 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1439 : {
1440 : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1441 : to make use of the gfc_resolve_character_array_constructor
1442 : machinery. The expression is later simplified away to
1443 : an array of string literals. */
1444 1 : gfc_expr *para = cons->expr;
1445 1 : cons->expr = gfc_get_expr ();
1446 1 : cons->expr->ts = para->ts;
1447 1 : cons->expr->where = para->where;
1448 1 : cons->expr->expr_type = EXPR_ARRAY;
1449 1 : cons->expr->rank = para->rank;
1450 1 : cons->expr->corank = para->corank;
1451 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1452 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1453 1 : para, &cons->expr->where);
1454 : }
1455 :
1456 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1457 : {
1458 : /* Rely on the cleanup of the namespace to deal correctly with
1459 : the old charlen. (There was a block here that attempted to
1460 : remove the charlen but broke the chain in so doing.) */
1461 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1462 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1463 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1464 5 : gfc_resolve_character_array_constructor (cons->expr);
1465 : }
1466 : }
1467 :
1468 134716 : if (cons->expr->expr_type == EXPR_NULL
1469 40300 : && !(comp->attr.pointer || comp->attr.allocatable
1470 20101 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1471 1103 : || (comp->ts.type == BT_CLASS
1472 1101 : && (CLASS_DATA (comp)->attr.class_pointer
1473 884 : || CLASS_DATA (comp)->attr.allocatable))))
1474 : {
1475 2 : t = false;
1476 2 : gfc_error ("The NULL in the structure constructor at %L is "
1477 : "being applied to component %qs, which is neither "
1478 : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1479 : comp->name);
1480 : }
1481 :
1482 134716 : if (comp->attr.proc_pointer && comp->ts.interface)
1483 : {
1484 : /* Check procedure pointer interface. */
1485 15105 : gfc_symbol *s2 = NULL;
1486 15105 : gfc_component *c2;
1487 15105 : const char *name;
1488 15105 : char err[200];
1489 :
1490 15105 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1491 15105 : if (c2)
1492 : {
1493 12 : s2 = c2->ts.interface;
1494 12 : name = c2->name;
1495 : }
1496 15093 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1497 : {
1498 0 : s2 = cons->expr->symtree->n.sym->result;
1499 0 : name = cons->expr->symtree->n.sym->result->name;
1500 : }
1501 15093 : else if (cons->expr->expr_type != EXPR_NULL)
1502 : {
1503 14687 : s2 = cons->expr->symtree->n.sym;
1504 14687 : name = cons->expr->symtree->n.sym->name;
1505 : }
1506 :
1507 14699 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1508 : err, sizeof (err), NULL, NULL))
1509 : {
1510 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1511 : "component %qs in structure constructor at %L:"
1512 2 : " %s", comp->name, &cons->expr->where, err);
1513 2 : return false;
1514 : }
1515 : }
1516 :
1517 : /* Validate shape, except for dynamic or PDT arrays. */
1518 134714 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1519 2217 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1520 1504 : && !comp->attr.pdt_array)
1521 : {
1522 1257 : mpz_t len;
1523 1257 : mpz_init (len);
1524 2611 : for (int n = 0; n < rank; n++)
1525 : {
1526 1355 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1527 1354 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1528 : {
1529 1 : gfc_error ("Bad array spec of component %qs referenced in "
1530 : "structure constructor at %L",
1531 1 : comp->name, &cons->expr->where);
1532 1 : t = false;
1533 1 : break;
1534 1354 : };
1535 1354 : if (cons->expr->shape == NULL)
1536 12 : continue;
1537 1342 : mpz_set_ui (len, 1);
1538 1342 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1539 1342 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1540 1342 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1541 : {
1542 9 : gfc_error ("The shape of component %qs in the structure "
1543 : "constructor at %L differs from the shape of the "
1544 : "declared component for dimension %d (%ld/%ld)",
1545 : comp->name, &cons->expr->where, n+1,
1546 : mpz_get_si (cons->expr->shape[n]),
1547 : mpz_get_si (len));
1548 9 : t = false;
1549 : }
1550 : }
1551 1257 : mpz_clear (len);
1552 : }
1553 :
1554 134714 : if (!comp->attr.pointer || comp->attr.proc_pointer
1555 21611 : || cons->expr->expr_type == EXPR_NULL)
1556 124804 : continue;
1557 :
1558 9910 : a = gfc_expr_attr (cons->expr);
1559 :
1560 9910 : if (!a.pointer && !a.target)
1561 : {
1562 1 : t = false;
1563 1 : gfc_error ("The element in the structure constructor at %L, "
1564 : "for pointer component %qs should be a POINTER or "
1565 1 : "a TARGET", &cons->expr->where, comp->name);
1566 : }
1567 :
1568 9910 : if (init)
1569 : {
1570 : /* F08:C461. Additional checks for pointer initialization. */
1571 9842 : if (a.allocatable)
1572 : {
1573 0 : t = false;
1574 0 : gfc_error ("Pointer initialization target at %L "
1575 0 : "must not be ALLOCATABLE", &cons->expr->where);
1576 : }
1577 9842 : if (!a.save)
1578 : {
1579 0 : t = false;
1580 0 : gfc_error ("Pointer initialization target at %L "
1581 0 : "must have the SAVE attribute", &cons->expr->where);
1582 : }
1583 : }
1584 :
1585 : /* F2023:C770: A designator that is an initial-data-target shall ...
1586 : not have a vector subscript. */
1587 9910 : if (comp->attr.pointer && (a.pointer || a.target)
1588 19819 : && gfc_has_vector_index (cons->expr))
1589 : {
1590 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1591 1 : &cons->expr->where);
1592 1 : t = false;
1593 : }
1594 :
1595 : /* F2003, C1272 (3). */
1596 9910 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1597 9910 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1598 9874 : || gfc_is_coindexed (cons->expr));
1599 33 : if (impure && gfc_pure (NULL))
1600 : {
1601 1 : t = false;
1602 1 : gfc_error ("Invalid expression in the structure constructor for "
1603 : "pointer component %qs at %L in PURE procedure",
1604 1 : comp->name, &cons->expr->where);
1605 : }
1606 :
1607 9910 : if (impure)
1608 33 : gfc_unset_implicit_pure (NULL);
1609 : }
1610 :
1611 : return t;
1612 : }
1613 :
1614 :
1615 : /****************** Expression name resolution ******************/
1616 :
1617 : /* Returns 0 if a symbol was not declared with a type or
1618 : attribute declaration statement, nonzero otherwise. */
1619 :
1620 : static bool
1621 739026 : was_declared (gfc_symbol *sym)
1622 : {
1623 739026 : symbol_attribute a;
1624 :
1625 739026 : a = sym->attr;
1626 :
1627 739026 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1628 : return 1;
1629 :
1630 626561 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1631 618065 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1632 618063 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1633 618009 : || a.asynchronous || a.codimension || a.subroutine)
1634 94006 : return 1;
1635 :
1636 : return 0;
1637 : }
1638 :
1639 :
1640 : /* Determine if a symbol is generic or not. */
1641 :
1642 : static int
1643 410276 : generic_sym (gfc_symbol *sym)
1644 : {
1645 410276 : gfc_symbol *s;
1646 :
1647 410276 : if (sym->attr.generic ||
1648 381185 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1649 30154 : return 1;
1650 :
1651 380122 : if (was_declared (sym) || sym->ns->parent == NULL)
1652 : return 0;
1653 :
1654 76803 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1655 :
1656 76803 : if (s != NULL)
1657 : {
1658 133 : if (s == sym)
1659 : return 0;
1660 : else
1661 132 : return generic_sym (s);
1662 : }
1663 :
1664 : return 0;
1665 : }
1666 :
1667 :
1668 : /* Determine if a symbol is specific or not. */
1669 :
1670 : static int
1671 380034 : specific_sym (gfc_symbol *sym)
1672 : {
1673 380034 : gfc_symbol *s;
1674 :
1675 380034 : if (sym->attr.if_source == IFSRC_IFBODY
1676 368927 : || sym->attr.proc == PROC_MODULE
1677 : || sym->attr.proc == PROC_INTERNAL
1678 : || sym->attr.proc == PROC_ST_FUNCTION
1679 293357 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1680 672660 : || sym->attr.external)
1681 89793 : return 1;
1682 :
1683 290241 : if (was_declared (sym) || sym->ns->parent == NULL)
1684 : return 0;
1685 :
1686 76701 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1687 :
1688 76701 : return (s == NULL) ? 0 : specific_sym (s);
1689 : }
1690 :
1691 :
1692 : /* Figure out if the procedure is specific, generic or unknown. */
1693 :
1694 : enum proc_type
1695 : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1696 :
1697 : static proc_type
1698 409998 : procedure_kind (gfc_symbol *sym)
1699 : {
1700 409998 : if (generic_sym (sym))
1701 : return PTYPE_GENERIC;
1702 :
1703 379987 : if (specific_sym (sym))
1704 89793 : return PTYPE_SPECIFIC;
1705 :
1706 : return PTYPE_UNKNOWN;
1707 : }
1708 :
1709 : /* Check references to assumed size arrays. The flag need_full_assumed_size
1710 : is nonzero when matching actual arguments. */
1711 :
1712 : static int need_full_assumed_size = 0;
1713 :
1714 : static bool
1715 1413392 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1716 : {
1717 1413392 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1718 : return false;
1719 :
1720 : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1721 : What should it be? */
1722 3788 : if (e->ref
1723 3786 : && e->ref->u.ar.as
1724 3785 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1725 3290 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1726 3290 : && (e->ref->u.ar.type == AR_FULL))
1727 : {
1728 25 : gfc_error ("The upper bound in the last dimension must "
1729 : "appear in the reference to the assumed size "
1730 : "array %qs at %L", sym->name, &e->where);
1731 25 : return true;
1732 : }
1733 : return false;
1734 : }
1735 :
1736 :
1737 : /* Look for bad assumed size array references in argument expressions
1738 : of elemental and array valued intrinsic procedures. Since this is
1739 : called from procedure resolution functions, it only recurses at
1740 : operators. */
1741 :
1742 : static bool
1743 226800 : resolve_assumed_size_actual (gfc_expr *e)
1744 : {
1745 226800 : if (e == NULL)
1746 : return false;
1747 :
1748 226305 : switch (e->expr_type)
1749 : {
1750 109283 : case EXPR_VARIABLE:
1751 109283 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1752 : return true;
1753 : break;
1754 :
1755 47885 : case EXPR_OP:
1756 47885 : if (resolve_assumed_size_actual (e->value.op.op1)
1757 47885 : || resolve_assumed_size_actual (e->value.op.op2))
1758 0 : return true;
1759 : break;
1760 :
1761 : default:
1762 : break;
1763 : }
1764 : return false;
1765 : }
1766 :
1767 :
1768 : /* Check a generic procedure, passed as an actual argument, to see if
1769 : there is a matching specific name. If none, it is an error, and if
1770 : more than one, the reference is ambiguous. */
1771 : static int
1772 8 : count_specific_procs (gfc_expr *e)
1773 : {
1774 8 : int n;
1775 8 : gfc_interface *p;
1776 8 : gfc_symbol *sym;
1777 :
1778 8 : n = 0;
1779 8 : sym = e->symtree->n.sym;
1780 :
1781 22 : for (p = sym->generic; p; p = p->next)
1782 14 : if (strcmp (sym->name, p->sym->name) == 0)
1783 : {
1784 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1785 : sym->name);
1786 8 : n++;
1787 : }
1788 :
1789 8 : if (n > 1)
1790 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1791 : &e->where);
1792 :
1793 8 : if (n == 0)
1794 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1795 : "argument at %L", sym->name, &e->where);
1796 :
1797 8 : return n;
1798 : }
1799 :
1800 :
1801 : /* See if a call to sym could possibly be a not allowed RECURSION because of
1802 : a missing RECURSIVE declaration. This means that either sym is the current
1803 : context itself, or sym is the parent of a contained procedure calling its
1804 : non-RECURSIVE containing procedure.
1805 : This also works if sym is an ENTRY. */
1806 :
1807 : static bool
1808 150153 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1809 : {
1810 150153 : gfc_symbol* proc_sym;
1811 150153 : gfc_symbol* context_proc;
1812 150153 : gfc_namespace* real_context;
1813 :
1814 150153 : if (sym->attr.flavor == FL_PROGRAM
1815 : || gfc_fl_struct (sym->attr.flavor))
1816 : return false;
1817 :
1818 : /* If we've got an ENTRY, find real procedure. */
1819 150152 : if (sym->attr.entry && sym->ns->entries)
1820 45 : proc_sym = sym->ns->entries->sym;
1821 : else
1822 : proc_sym = sym;
1823 :
1824 : /* If sym is RECURSIVE, all is well of course. */
1825 150152 : if (proc_sym->attr.recursive || flag_recursive)
1826 : return false;
1827 :
1828 : /* Find the context procedure's "real" symbol if it has entries.
1829 : We look for a procedure symbol, so recurse on the parents if we don't
1830 : find one (like in case of a BLOCK construct). */
1831 1821 : for (real_context = context; ; real_context = real_context->parent)
1832 : {
1833 : /* We should find something, eventually! */
1834 127268 : gcc_assert (real_context);
1835 :
1836 127268 : context_proc = (real_context->entries ? real_context->entries->sym
1837 : : real_context->proc_name);
1838 :
1839 : /* In some special cases, there may not be a proc_name, like for this
1840 : invalid code:
1841 : real(bad_kind()) function foo () ...
1842 : when checking the call to bad_kind ().
1843 : In these cases, we simply return here and assume that the
1844 : call is ok. */
1845 127268 : if (!context_proc)
1846 : return false;
1847 :
1848 127004 : if (context_proc->attr.flavor != FL_LABEL)
1849 : break;
1850 : }
1851 :
1852 : /* A call from sym's body to itself is recursion, of course. */
1853 125183 : if (context_proc == proc_sym)
1854 : return true;
1855 :
1856 : /* The same is true if context is a contained procedure and sym the
1857 : containing one. */
1858 125168 : if (context_proc->attr.contained)
1859 : {
1860 20677 : gfc_symbol* parent_proc;
1861 :
1862 20677 : gcc_assert (context->parent);
1863 20677 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1864 : : context->parent->proc_name);
1865 :
1866 20677 : if (parent_proc == proc_sym)
1867 9 : return true;
1868 : }
1869 :
1870 : return false;
1871 : }
1872 :
1873 :
1874 : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1875 : its typespec and formal argument list. */
1876 :
1877 : bool
1878 42105 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1879 : {
1880 42105 : gfc_intrinsic_sym* isym = NULL;
1881 42105 : const char* symstd;
1882 :
1883 42105 : if (sym->resolve_symbol_called >= 2)
1884 : return true;
1885 :
1886 32378 : sym->resolve_symbol_called = 2;
1887 :
1888 : /* Already resolved. */
1889 32378 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1890 : return true;
1891 :
1892 : /* We already know this one is an intrinsic, so we don't call
1893 : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1894 : gfc_find_subroutine directly to check whether it is a function or
1895 : subroutine. */
1896 :
1897 24577 : if (sym->intmod_sym_id && sym->attr.subroutine)
1898 : {
1899 8835 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1900 8835 : isym = gfc_intrinsic_subroutine_by_id (id);
1901 8835 : }
1902 15742 : else if (sym->intmod_sym_id)
1903 : {
1904 12113 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1905 12113 : isym = gfc_intrinsic_function_by_id (id);
1906 : }
1907 3629 : else if (!sym->attr.subroutine)
1908 3542 : isym = gfc_find_function (sym->name);
1909 :
1910 24490 : if (isym && !sym->attr.subroutine)
1911 : {
1912 15610 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1913 24 : && !sym->attr.implicit_type)
1914 10 : gfc_warning (OPT_Wsurprising,
1915 : "Type specified for intrinsic function %qs at %L is"
1916 : " ignored", sym->name, &sym->declared_at);
1917 :
1918 19685 : if (!sym->attr.function &&
1919 4075 : !gfc_add_function(&sym->attr, sym->name, loc))
1920 : return false;
1921 :
1922 15610 : sym->ts = isym->ts;
1923 : }
1924 8967 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1925 : {
1926 8964 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1927 : {
1928 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1929 : " specifier", sym->name, &sym->declared_at);
1930 1 : return false;
1931 : }
1932 :
1933 9004 : if (!sym->attr.subroutine &&
1934 41 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1935 : return false;
1936 : }
1937 : else
1938 : {
1939 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1940 : &sym->declared_at);
1941 3 : return false;
1942 : }
1943 :
1944 24572 : gfc_copy_formal_args_intr (sym, isym, NULL);
1945 :
1946 24572 : sym->attr.pure = isym->pure;
1947 24572 : sym->attr.elemental = isym->elemental;
1948 :
1949 : /* Check it is actually available in the standard settings. */
1950 24572 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1951 : {
1952 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1953 : "available in the current standard settings but %s. Use "
1954 : "an appropriate %<-std=*%> option or enable "
1955 : "%<-fall-intrinsics%> in order to use it.",
1956 : sym->name, &sym->declared_at, symstd);
1957 31 : return false;
1958 : }
1959 :
1960 : return true;
1961 : }
1962 :
1963 :
1964 : /* Resolve a procedure expression, like passing it to a called procedure or as
1965 : RHS for a procedure pointer assignment. */
1966 :
1967 : static bool
1968 1316965 : resolve_procedure_expression (gfc_expr* expr)
1969 : {
1970 1316965 : gfc_symbol* sym;
1971 :
1972 1316965 : if (expr->expr_type != EXPR_VARIABLE)
1973 : return true;
1974 1316948 : gcc_assert (expr->symtree);
1975 :
1976 1316948 : sym = expr->symtree->n.sym;
1977 :
1978 1316948 : if (sym->attr.intrinsic)
1979 1346 : gfc_resolve_intrinsic (sym, &expr->where);
1980 :
1981 1316948 : if (sym->attr.flavor != FL_PROCEDURE
1982 31085 : || (sym->attr.function && sym->result == sym))
1983 : return true;
1984 :
1985 : /* A non-RECURSIVE procedure that is used as procedure expression within its
1986 : own body is in danger of being called recursively. */
1987 16796 : if (is_illegal_recursion (sym, gfc_current_ns))
1988 : {
1989 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
1990 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
1991 : " possibly calling itself recursively in procedure %qs. "
1992 : " Declare it RECURSIVE or use %<-frecursive%>",
1993 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
1994 : else
1995 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1996 : " itself recursively. Declare it RECURSIVE or use"
1997 : " %<-frecursive%>", sym->name, &expr->where);
1998 : }
1999 :
2000 : return true;
2001 : }
2002 :
2003 :
2004 : /* Check that name is not a derived type. */
2005 :
2006 : static bool
2007 3227 : is_dt_name (const char *name)
2008 : {
2009 3227 : gfc_symbol *dt_list, *dt_first;
2010 :
2011 3227 : dt_list = dt_first = gfc_derived_types;
2012 5662 : for (; dt_list; dt_list = dt_list->dt_next)
2013 : {
2014 3547 : if (strcmp(dt_list->name, name) == 0)
2015 : return true;
2016 3544 : if (dt_first == dt_list->dt_next)
2017 : break;
2018 : }
2019 : return false;
2020 : }
2021 :
2022 :
2023 : /* Resolve an actual argument list. Most of the time, this is just
2024 : resolving the expressions in the list.
2025 : The exception is that we sometimes have to decide whether arguments
2026 : that look like procedure arguments are really simple variable
2027 : references. */
2028 :
2029 : static bool
2030 424043 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2031 : bool no_formal_args)
2032 : {
2033 424043 : gfc_symbol *sym = NULL;
2034 424043 : gfc_symtree *parent_st;
2035 424043 : gfc_expr *e;
2036 424043 : gfc_component *comp;
2037 424043 : int save_need_full_assumed_size;
2038 424043 : bool return_value = false;
2039 424043 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2040 :
2041 424043 : actual_arg = true;
2042 424043 : first_actual_arg = true;
2043 :
2044 1089466 : for (; arg; arg = arg->next)
2045 : {
2046 665524 : e = arg->expr;
2047 665524 : if (e == NULL)
2048 : {
2049 : /* Check the label is a valid branching target. */
2050 2401 : if (arg->label)
2051 : {
2052 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2053 : {
2054 0 : gfc_error ("Label %d referenced at %L is never defined",
2055 : arg->label->value, &arg->label->where);
2056 0 : goto cleanup;
2057 : }
2058 : }
2059 2401 : first_actual_arg = false;
2060 2401 : continue;
2061 : }
2062 :
2063 663123 : if (e->expr_type == EXPR_VARIABLE
2064 292106 : && e->symtree->n.sym->attr.generic
2065 8 : && no_formal_args
2066 663128 : && count_specific_procs (e) != 1)
2067 2 : goto cleanup;
2068 :
2069 663121 : if (e->ts.type != BT_PROCEDURE)
2070 : {
2071 591231 : save_need_full_assumed_size = need_full_assumed_size;
2072 591231 : if (e->expr_type != EXPR_VARIABLE)
2073 371017 : need_full_assumed_size = 0;
2074 591231 : if (!gfc_resolve_expr (e))
2075 60 : goto cleanup;
2076 591171 : need_full_assumed_size = save_need_full_assumed_size;
2077 591171 : goto argument_list;
2078 : }
2079 :
2080 : /* See if the expression node should really be a variable reference. */
2081 :
2082 71890 : sym = e->symtree->n.sym;
2083 :
2084 71890 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2085 : {
2086 3 : gfc_error ("Derived type %qs is used as an actual "
2087 : "argument at %L", sym->name, &e->where);
2088 3 : goto cleanup;
2089 : }
2090 :
2091 71887 : if (sym->attr.flavor == FL_PROCEDURE
2092 68663 : || sym->attr.intrinsic
2093 68663 : || sym->attr.external)
2094 : {
2095 3224 : int actual_ok;
2096 :
2097 : /* If a procedure is not already determined to be something else
2098 : check if it is intrinsic. */
2099 3224 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2100 1254 : sym->attr.intrinsic = 1;
2101 :
2102 3224 : if (sym->attr.proc == PROC_ST_FUNCTION)
2103 : {
2104 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2105 : "actual argument", sym->name, &e->where);
2106 : }
2107 :
2108 6448 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2109 3224 : sym->attr.subroutine);
2110 3224 : if (sym->attr.intrinsic && actual_ok == 0)
2111 : {
2112 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2113 : "actual argument", sym->name, &e->where);
2114 : }
2115 :
2116 3224 : if (sym->attr.contained && !sym->attr.use_assoc
2117 414 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2118 : {
2119 226 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2120 : " used as actual argument at %L",
2121 : sym->name, &e->where))
2122 3 : goto cleanup;
2123 : }
2124 :
2125 3221 : if (sym->attr.elemental && !sym->attr.intrinsic)
2126 : {
2127 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2128 : "allowed as an actual argument at %L", sym->name,
2129 : &e->where);
2130 : }
2131 :
2132 : /* Check if a generic interface has a specific procedure
2133 : with the same name before emitting an error. */
2134 3221 : if (sym->attr.generic && count_specific_procs (e) != 1)
2135 0 : goto cleanup;
2136 :
2137 : /* Just in case a specific was found for the expression. */
2138 3221 : sym = e->symtree->n.sym;
2139 :
2140 : /* If the symbol is the function that names the current (or
2141 : parent) scope, then we really have a variable reference. */
2142 :
2143 3221 : if (gfc_is_function_return_value (sym, sym->ns))
2144 0 : goto got_variable;
2145 :
2146 : /* If all else fails, see if we have a specific intrinsic. */
2147 3221 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2148 : {
2149 0 : gfc_intrinsic_sym *isym;
2150 :
2151 0 : isym = gfc_find_function (sym->name);
2152 0 : if (isym == NULL || !isym->specific)
2153 : {
2154 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2155 : "for the reference %qs at %L", sym->name,
2156 : &e->where);
2157 0 : goto cleanup;
2158 : }
2159 0 : sym->ts = isym->ts;
2160 0 : sym->attr.intrinsic = 1;
2161 0 : sym->attr.function = 1;
2162 : }
2163 :
2164 3221 : if (!gfc_resolve_expr (e))
2165 0 : goto cleanup;
2166 3221 : goto argument_list;
2167 : }
2168 :
2169 : /* See if the name is a module procedure in a parent unit. */
2170 :
2171 68663 : if (was_declared (sym) || sym->ns->parent == NULL)
2172 68570 : goto got_variable;
2173 :
2174 93 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2175 : {
2176 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2177 0 : goto cleanup;
2178 : }
2179 :
2180 93 : if (parent_st == NULL)
2181 93 : goto got_variable;
2182 :
2183 0 : sym = parent_st->n.sym;
2184 0 : e->symtree = parent_st; /* Point to the right thing. */
2185 :
2186 0 : if (sym->attr.flavor == FL_PROCEDURE
2187 0 : || sym->attr.intrinsic
2188 0 : || sym->attr.external)
2189 : {
2190 0 : if (!gfc_resolve_expr (e))
2191 0 : goto cleanup;
2192 0 : goto argument_list;
2193 : }
2194 :
2195 0 : got_variable:
2196 68663 : e->expr_type = EXPR_VARIABLE;
2197 68663 : e->ts = sym->ts;
2198 68663 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2199 35618 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2200 3816 : && CLASS_DATA (sym)->as))
2201 : {
2202 38549 : gfc_array_spec *as
2203 35797 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2204 35797 : e->rank = as->rank;
2205 35797 : e->corank = as->corank;
2206 35797 : e->ref = gfc_get_ref ();
2207 35797 : e->ref->type = REF_ARRAY;
2208 35797 : e->ref->u.ar.type = AR_FULL;
2209 35797 : e->ref->u.ar.as = as;
2210 : }
2211 :
2212 : /* These symbols are set untyped by calls to gfc_set_default_type
2213 : with 'error_flag' = false. Reset the untyped attribute so that
2214 : the error will be generated in gfc_resolve_expr. */
2215 68663 : if (e->expr_type == EXPR_VARIABLE
2216 68663 : && sym->ts.type == BT_UNKNOWN
2217 36 : && sym->attr.untyped)
2218 5 : sym->attr.untyped = 0;
2219 :
2220 : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2221 : primary.cc (match_actual_arg). If above code determines that it
2222 : is a variable instead, it needs to be resolved as it was not
2223 : done at the beginning of this function. */
2224 68663 : save_need_full_assumed_size = need_full_assumed_size;
2225 68663 : if (e->expr_type != EXPR_VARIABLE)
2226 0 : need_full_assumed_size = 0;
2227 68663 : if (!gfc_resolve_expr (e))
2228 22 : goto cleanup;
2229 68641 : need_full_assumed_size = save_need_full_assumed_size;
2230 :
2231 663033 : argument_list:
2232 : /* Check argument list functions %VAL, %LOC and %REF. There is
2233 : nothing to do for %REF. */
2234 663033 : if (arg->name && arg->name[0] == '%')
2235 : {
2236 42 : if (strcmp ("%VAL", arg->name) == 0)
2237 : {
2238 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2239 : {
2240 2 : gfc_error ("By-value argument at %L is not of numeric "
2241 : "type", &e->where);
2242 2 : goto cleanup;
2243 : }
2244 :
2245 26 : if (e->rank)
2246 : {
2247 1 : gfc_error ("By-value argument at %L cannot be an array or "
2248 : "an array section", &e->where);
2249 1 : goto cleanup;
2250 : }
2251 :
2252 : /* Intrinsics are still PROC_UNKNOWN here. However,
2253 : since same file external procedures are not resolvable
2254 : in gfortran, it is a good deal easier to leave them to
2255 : intrinsic.cc. */
2256 25 : if (ptype != PROC_UNKNOWN
2257 25 : && ptype != PROC_DUMMY
2258 9 : && ptype != PROC_EXTERNAL
2259 9 : && ptype != PROC_MODULE)
2260 : {
2261 3 : gfc_error ("By-value argument at %L is not allowed "
2262 : "in this context", &e->where);
2263 3 : goto cleanup;
2264 : }
2265 : }
2266 :
2267 : /* Statement functions have already been excluded above. */
2268 14 : else if (strcmp ("%LOC", arg->name) == 0
2269 8 : && e->ts.type == BT_PROCEDURE)
2270 : {
2271 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2272 : {
2273 0 : gfc_error ("Passing internal procedure at %L by location "
2274 : "not allowed", &e->where);
2275 0 : goto cleanup;
2276 : }
2277 : }
2278 : }
2279 :
2280 663027 : comp = gfc_get_proc_ptr_comp(e);
2281 663027 : if (e->expr_type == EXPR_VARIABLE
2282 290728 : && comp && comp->attr.elemental)
2283 : {
2284 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2285 : "allowed as an actual argument at %L", comp->name,
2286 : &e->where);
2287 : }
2288 :
2289 : /* Fortran 2008, C1237. */
2290 290728 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2291 663472 : && gfc_has_ultimate_pointer (e))
2292 : {
2293 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2294 : "component", &e->where);
2295 3 : goto cleanup;
2296 : }
2297 :
2298 663024 : if (e->expr_type == EXPR_VARIABLE
2299 290725 : && e->ts.type == BT_PROCEDURE
2300 3221 : && no_formal_args
2301 1505 : && sym->attr.flavor == FL_PROCEDURE
2302 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2303 142 : && !sym->attr.external
2304 2 : && !sym->attr.intrinsic
2305 2 : && !sym->attr.artificial
2306 2 : && !sym->ts.interface)
2307 : {
2308 : /* Emit a warning for -std=legacy and an error otherwise. */
2309 2 : if (gfc_option.warn_std == 0)
2310 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2311 : "does neither have an explicit interface nor the "
2312 : "EXTERNAL attribute", sym->name, &e->where);
2313 : else
2314 : {
2315 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2316 : "does neither have an explicit interface nor the "
2317 : "EXTERNAL attribute", sym->name, &e->where);
2318 2 : goto cleanup;
2319 : }
2320 : }
2321 :
2322 663022 : first_actual_arg = false;
2323 : }
2324 :
2325 : return_value = true;
2326 :
2327 424043 : cleanup:
2328 424043 : actual_arg = actual_arg_sav;
2329 424043 : first_actual_arg = first_actual_arg_sav;
2330 :
2331 424043 : return return_value;
2332 : }
2333 :
2334 :
2335 : /* Do the checks of the actual argument list that are specific to elemental
2336 : procedures. If called with c == NULL, we have a function, otherwise if
2337 : expr == NULL, we have a subroutine. */
2338 :
2339 : static bool
2340 322477 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2341 : {
2342 322477 : gfc_actual_arglist *arg0;
2343 322477 : gfc_actual_arglist *arg;
2344 322477 : gfc_symbol *esym = NULL;
2345 322477 : gfc_intrinsic_sym *isym = NULL;
2346 322477 : gfc_expr *e = NULL;
2347 322477 : gfc_intrinsic_arg *iformal = NULL;
2348 322477 : gfc_formal_arglist *eformal = NULL;
2349 322477 : bool formal_optional = false;
2350 322477 : bool set_by_optional = false;
2351 322477 : int i;
2352 322477 : int rank = 0;
2353 :
2354 : /* Is this an elemental procedure? */
2355 322477 : if (expr && expr->value.function.actual != NULL)
2356 : {
2357 233975 : if (expr->value.function.esym != NULL
2358 43655 : && expr->value.function.esym->attr.elemental)
2359 : {
2360 : arg0 = expr->value.function.actual;
2361 : esym = expr->value.function.esym;
2362 : }
2363 217691 : else if (expr->value.function.isym != NULL
2364 189274 : && expr->value.function.isym->elemental)
2365 : {
2366 : arg0 = expr->value.function.actual;
2367 : isym = expr->value.function.isym;
2368 : }
2369 : else
2370 : return true;
2371 : }
2372 88502 : else if (c && c->ext.actual != NULL)
2373 : {
2374 70158 : arg0 = c->ext.actual;
2375 :
2376 70158 : if (c->resolved_sym)
2377 : esym = c->resolved_sym;
2378 : else
2379 313 : esym = c->symtree->n.sym;
2380 70158 : gcc_assert (esym);
2381 :
2382 70158 : if (!esym->attr.elemental)
2383 : return true;
2384 : }
2385 : else
2386 : return true;
2387 :
2388 : /* The rank of an elemental is the rank of its array argument(s). */
2389 173338 : for (arg = arg0; arg; arg = arg->next)
2390 : {
2391 112291 : if (arg->expr != NULL && arg->expr->rank != 0)
2392 : {
2393 10428 : rank = arg->expr->rank;
2394 10428 : if (arg->expr->expr_type == EXPR_VARIABLE
2395 5238 : && arg->expr->symtree->n.sym->attr.optional)
2396 10428 : set_by_optional = true;
2397 :
2398 : /* Function specific; set the result rank and shape. */
2399 10428 : if (expr)
2400 : {
2401 8242 : expr->rank = rank;
2402 8242 : expr->corank = arg->expr->corank;
2403 8242 : if (!expr->shape && arg->expr->shape)
2404 : {
2405 3932 : expr->shape = gfc_get_shape (rank);
2406 8659 : for (i = 0; i < rank; i++)
2407 4727 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2408 : }
2409 : }
2410 : break;
2411 : }
2412 : }
2413 :
2414 : /* If it is an array, it shall not be supplied as an actual argument
2415 : to an elemental procedure unless an array of the same rank is supplied
2416 : as an actual argument corresponding to a nonoptional dummy argument of
2417 : that elemental procedure(12.4.1.5). */
2418 71475 : formal_optional = false;
2419 71475 : if (isym)
2420 49200 : iformal = isym->formal;
2421 : else
2422 22275 : eformal = esym->formal;
2423 :
2424 189060 : for (arg = arg0; arg; arg = arg->next)
2425 : {
2426 117585 : if (eformal)
2427 : {
2428 39943 : if (eformal->sym && eformal->sym->attr.optional)
2429 39943 : formal_optional = true;
2430 39943 : eformal = eformal->next;
2431 : }
2432 77642 : else if (isym && iformal)
2433 : {
2434 67420 : if (iformal->optional)
2435 13386 : formal_optional = true;
2436 67420 : iformal = iformal->next;
2437 : }
2438 10222 : else if (isym)
2439 10214 : formal_optional = true;
2440 :
2441 117585 : if (pedantic && arg->expr != NULL
2442 68413 : && arg->expr->expr_type == EXPR_VARIABLE
2443 32170 : && arg->expr->symtree->n.sym->attr.optional
2444 572 : && formal_optional
2445 479 : && arg->expr->rank
2446 153 : && (set_by_optional || arg->expr->rank != rank)
2447 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2448 : {
2449 114 : bool t = false;
2450 : gfc_actual_arglist *a;
2451 :
2452 : /* Scan the argument list for a non-optional argument with the
2453 : same rank as arg. */
2454 114 : for (a = arg0; a; a = a->next)
2455 87 : if (a != arg
2456 45 : && a->expr->rank == arg->expr->rank
2457 39 : && (a->expr->expr_type != EXPR_VARIABLE
2458 37 : || (a->expr->expr_type == EXPR_VARIABLE
2459 37 : && !a->expr->symtree->n.sym->attr.optional)))
2460 : {
2461 : t = true;
2462 : break;
2463 : }
2464 :
2465 42 : if (!t)
2466 27 : gfc_warning (OPT_Wpedantic,
2467 : "%qs at %L is an array and OPTIONAL; If it is not "
2468 : "present, then it cannot be the actual argument of "
2469 : "an ELEMENTAL procedure unless there is a non-optional"
2470 : " argument with the same rank "
2471 : "(Fortran 2018, 15.5.2.12)",
2472 : arg->expr->symtree->n.sym->name, &arg->expr->where);
2473 : }
2474 : }
2475 :
2476 189049 : for (arg = arg0; arg; arg = arg->next)
2477 : {
2478 117583 : if (arg->expr == NULL || arg->expr->rank == 0)
2479 104489 : continue;
2480 :
2481 : /* Being elemental, the last upper bound of an assumed size array
2482 : argument must be present. */
2483 13094 : if (resolve_assumed_size_actual (arg->expr))
2484 : return false;
2485 :
2486 : /* Elemental procedure's array actual arguments must conform. */
2487 13091 : if (e != NULL)
2488 : {
2489 2666 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2490 : return false;
2491 : }
2492 : else
2493 10425 : e = arg->expr;
2494 : }
2495 :
2496 : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2497 : is an array, the intent inout/out variable needs to be also an array. */
2498 71466 : if (rank > 0 && esym && expr == NULL)
2499 6673 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2500 4493 : arg = arg->next, eformal = eformal->next)
2501 4495 : if (eformal->sym
2502 4494 : && (eformal->sym->attr.intent == INTENT_OUT
2503 3412 : || eformal->sym->attr.intent == INTENT_INOUT)
2504 1494 : && arg->expr && arg->expr->rank == 0)
2505 : {
2506 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2507 : "ELEMENTAL subroutine %qs is a scalar, but another "
2508 : "actual argument is an array", &arg->expr->where,
2509 : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2510 : : "INOUT", eformal->sym->name, esym->name);
2511 2 : return false;
2512 : }
2513 : return true;
2514 : }
2515 :
2516 :
2517 : /* This function does the checking of references to global procedures
2518 : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2519 : 77 and 95 standards. It checks for a gsymbol for the name, making
2520 : one if it does not already exist. If it already exists, then the
2521 : reference being resolved must correspond to the type of gsymbol.
2522 : Otherwise, the new symbol is equipped with the attributes of the
2523 : reference. The corresponding code that is called in creating
2524 : global entities is parse.cc.
2525 :
2526 : In addition, for all but -std=legacy, the gsymbols are used to
2527 : check the interfaces of external procedures from the same file.
2528 : The namespace of the gsymbol is resolved and then, once this is
2529 : done the interface is checked. */
2530 :
2531 :
2532 : static bool
2533 14843 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2534 : {
2535 14843 : if (!gsym_ns->proc_name->attr.recursive)
2536 : return true;
2537 :
2538 151 : if (sym->ns == gsym_ns)
2539 : return false;
2540 :
2541 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2542 0 : return false;
2543 :
2544 : return true;
2545 : }
2546 :
2547 : static bool
2548 14843 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2549 : {
2550 14843 : if (gsym_ns->entries)
2551 : {
2552 : gfc_entry_list *entry = gsym_ns->entries;
2553 :
2554 3234 : for (; entry; entry = entry->next)
2555 : {
2556 2281 : if (strcmp (sym->name, entry->sym->name) == 0)
2557 : {
2558 946 : if (strcmp (gsym_ns->proc_name->name,
2559 946 : sym->ns->proc_name->name) == 0)
2560 : return false;
2561 :
2562 946 : if (sym->ns->parent
2563 0 : && strcmp (gsym_ns->proc_name->name,
2564 0 : sym->ns->parent->proc_name->name) == 0)
2565 : return false;
2566 : }
2567 : }
2568 : }
2569 : return true;
2570 : }
2571 :
2572 :
2573 : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2574 :
2575 : bool
2576 15675 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2577 : {
2578 15675 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2579 :
2580 58730 : for ( ; arg; arg = arg->next)
2581 : {
2582 27750 : if (!arg->sym)
2583 157 : continue;
2584 :
2585 27593 : if (arg->sym->attr.allocatable) /* (2a) */
2586 : {
2587 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2588 0 : return true;
2589 : }
2590 27593 : else if (arg->sym->attr.asynchronous)
2591 : {
2592 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2593 0 : return true;
2594 : }
2595 27593 : else if (arg->sym->attr.optional)
2596 : {
2597 75 : strncpy (errmsg, _("optional argument"), err_len);
2598 75 : return true;
2599 : }
2600 27518 : else if (arg->sym->attr.pointer)
2601 : {
2602 12 : strncpy (errmsg, _("pointer argument"), err_len);
2603 12 : return true;
2604 : }
2605 27506 : else if (arg->sym->attr.target)
2606 : {
2607 72 : strncpy (errmsg, _("target argument"), err_len);
2608 72 : return true;
2609 : }
2610 27434 : else if (arg->sym->attr.value)
2611 : {
2612 0 : strncpy (errmsg, _("value argument"), err_len);
2613 0 : return true;
2614 : }
2615 27434 : else if (arg->sym->attr.volatile_)
2616 : {
2617 1 : strncpy (errmsg, _("volatile argument"), err_len);
2618 1 : return true;
2619 : }
2620 27433 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2621 : {
2622 45 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2623 45 : return true;
2624 : }
2625 27388 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2626 : {
2627 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2628 1 : return true;
2629 : }
2630 27387 : else if (arg->sym->attr.codimension) /* (2c) */
2631 : {
2632 1 : strncpy (errmsg, _("coarray argument"), err_len);
2633 1 : return true;
2634 : }
2635 27386 : else if (false) /* (2d) TODO: parametrized derived type */
2636 : {
2637 : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2638 : return true;
2639 : }
2640 27386 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2641 : {
2642 162 : strncpy (errmsg, _("polymorphic argument"), err_len);
2643 162 : return true;
2644 : }
2645 27224 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2646 : {
2647 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2648 0 : return true;
2649 : }
2650 27224 : else if (arg->sym->ts.type == BT_ASSUMED)
2651 : {
2652 : /* As assumed-type is unlimited polymorphic (cf. above).
2653 : See also TS 29113, Note 6.1. */
2654 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2655 1 : return true;
2656 : }
2657 : }
2658 :
2659 15305 : if (sym->attr.function)
2660 : {
2661 3455 : gfc_symbol *res = sym->result ? sym->result : sym;
2662 :
2663 3455 : if (res->attr.dimension) /* (3a) */
2664 : {
2665 93 : strncpy (errmsg, _("array result"), err_len);
2666 93 : return true;
2667 : }
2668 3362 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2669 : {
2670 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2671 38 : return true;
2672 : }
2673 3324 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2674 347 : && res->ts.u.cl->length
2675 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2676 : {
2677 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2678 12 : return true;
2679 : }
2680 : }
2681 :
2682 15162 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2683 : {
2684 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2685 7 : return true;
2686 : }
2687 15155 : else if (sym->attr.is_bind_c) /* (5) */
2688 : {
2689 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2690 0 : return true;
2691 : }
2692 :
2693 : return false;
2694 : }
2695 :
2696 :
2697 : static void
2698 29211 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2699 : {
2700 29211 : gfc_gsymbol * gsym;
2701 29211 : gfc_namespace *ns;
2702 29211 : enum gfc_symbol_type type;
2703 29211 : char reason[200];
2704 :
2705 29211 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2706 :
2707 29211 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2708 29211 : sym->binding_label != NULL);
2709 :
2710 29211 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2711 10 : gfc_global_used (gsym, where);
2712 :
2713 29211 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2714 9124 : || sym->attr.if_source == IFSRC_IFBODY)
2715 24875 : && gsym->type != GSYM_UNKNOWN
2716 22715 : && !gsym->binding_label
2717 20452 : && gsym->ns
2718 14843 : && gsym->ns->proc_name
2719 14843 : && not_in_recursive (sym, gsym->ns)
2720 44054 : && not_entry_self_reference (sym, gsym->ns))
2721 : {
2722 14843 : gfc_symbol *def_sym;
2723 14843 : def_sym = gsym->ns->proc_name;
2724 :
2725 14843 : if (gsym->ns->resolved != -1)
2726 : {
2727 :
2728 : /* Resolve the gsymbol namespace if needed. */
2729 14822 : if (!gsym->ns->resolved)
2730 : {
2731 2767 : gfc_symbol *old_dt_list;
2732 :
2733 : /* Stash away derived types so that the backend_decls
2734 : do not get mixed up. */
2735 2767 : old_dt_list = gfc_derived_types;
2736 2767 : gfc_derived_types = NULL;
2737 :
2738 2767 : gfc_resolve (gsym->ns);
2739 :
2740 : /* Store the new derived types with the global namespace. */
2741 2767 : if (gfc_derived_types)
2742 306 : gsym->ns->derived_types = gfc_derived_types;
2743 :
2744 : /* Restore the derived types of this namespace. */
2745 2767 : gfc_derived_types = old_dt_list;
2746 : }
2747 :
2748 : /* Make sure that translation for the gsymbol occurs before
2749 : the procedure currently being resolved. */
2750 14822 : ns = gfc_global_ns_list;
2751 25145 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2752 : {
2753 16791 : if (ns->sibling == gsym->ns)
2754 : {
2755 6468 : ns->sibling = gsym->ns->sibling;
2756 6468 : gsym->ns->sibling = gfc_global_ns_list;
2757 6468 : gfc_global_ns_list = gsym->ns;
2758 6468 : break;
2759 : }
2760 : }
2761 :
2762 : /* This can happen if a binding name has been specified. */
2763 14822 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2764 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2765 :
2766 14822 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2767 : {
2768 953 : gfc_entry_list *entry;
2769 1659 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2770 1659 : if (strcmp (entry->sym->name, sym->name) == 0)
2771 : {
2772 953 : def_sym = entry->sym;
2773 953 : break;
2774 : }
2775 : }
2776 : }
2777 :
2778 14843 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2779 : {
2780 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2781 : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2782 6 : gfc_typename (&def_sym->ts));
2783 29 : goto done;
2784 : }
2785 :
2786 14837 : if (sym->attr.if_source == IFSRC_UNKNOWN
2787 14837 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2788 : {
2789 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2790 : sym->name, &sym->declared_at, reason);
2791 8 : goto done;
2792 : }
2793 :
2794 14829 : bool bad_result_characteristics;
2795 14829 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2796 : reason, sizeof(reason), NULL, NULL,
2797 : &bad_result_characteristics))
2798 : {
2799 : /* Turn erros into warnings with -std=gnu and -std=legacy,
2800 : unless a function returns a wrong type, which can lead
2801 : to all kinds of ICEs and wrong code. */
2802 :
2803 15 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2804 2 : && !bad_result_characteristics)
2805 2 : gfc_errors_to_warnings (true);
2806 :
2807 15 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2808 : sym->name, &sym->declared_at, reason);
2809 15 : sym->error = 1;
2810 15 : gfc_errors_to_warnings (false);
2811 15 : goto done;
2812 : }
2813 : }
2814 :
2815 29211 : done:
2816 :
2817 29211 : if (gsym->type == GSYM_UNKNOWN)
2818 : {
2819 3915 : gsym->type = type;
2820 3915 : gsym->where = *where;
2821 : }
2822 :
2823 29211 : gsym->used = 1;
2824 29211 : }
2825 :
2826 :
2827 : /************* Function resolution *************/
2828 :
2829 : /* Resolve a function call known to be generic.
2830 : Section 14.1.2.4.1. */
2831 :
2832 : static match
2833 27369 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2834 : {
2835 27369 : gfc_symbol *s;
2836 :
2837 27369 : if (sym->attr.generic)
2838 : {
2839 26264 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2840 26264 : if (s != NULL)
2841 : {
2842 19773 : expr->value.function.name = s->name;
2843 19773 : expr->value.function.esym = s;
2844 :
2845 19773 : if (s->ts.type != BT_UNKNOWN)
2846 19756 : expr->ts = s->ts;
2847 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2848 15 : expr->ts = s->result->ts;
2849 :
2850 19773 : if (s->as != NULL)
2851 : {
2852 55 : expr->rank = s->as->rank;
2853 55 : expr->corank = s->as->corank;
2854 : }
2855 19718 : else if (s->result != NULL && s->result->as != NULL)
2856 : {
2857 0 : expr->rank = s->result->as->rank;
2858 0 : expr->corank = s->result->as->corank;
2859 : }
2860 :
2861 19773 : gfc_set_sym_referenced (expr->value.function.esym);
2862 :
2863 19773 : return MATCH_YES;
2864 : }
2865 :
2866 : /* TODO: Need to search for elemental references in generic
2867 : interface. */
2868 : }
2869 :
2870 7596 : if (sym->attr.intrinsic)
2871 1062 : return gfc_intrinsic_func_interface (expr, 0);
2872 :
2873 : return MATCH_NO;
2874 : }
2875 :
2876 :
2877 : static bool
2878 27228 : resolve_generic_f (gfc_expr *expr)
2879 : {
2880 27228 : gfc_symbol *sym;
2881 27228 : match m;
2882 27228 : gfc_interface *intr = NULL;
2883 :
2884 27228 : sym = expr->symtree->n.sym;
2885 :
2886 27369 : for (;;)
2887 : {
2888 27369 : m = resolve_generic_f0 (expr, sym);
2889 27369 : if (m == MATCH_YES)
2890 : return true;
2891 6536 : else if (m == MATCH_ERROR)
2892 : return false;
2893 :
2894 6536 : generic:
2895 6539 : if (!intr)
2896 6510 : for (intr = sym->generic; intr; intr = intr->next)
2897 6426 : if (gfc_fl_struct (intr->sym->attr.flavor))
2898 : break;
2899 :
2900 6539 : if (sym->ns->parent == NULL)
2901 : break;
2902 271 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2903 :
2904 271 : if (sym == NULL)
2905 : break;
2906 144 : if (!generic_sym (sym))
2907 3 : goto generic;
2908 : }
2909 :
2910 : /* Last ditch attempt. See if the reference is to an intrinsic
2911 : that possesses a matching interface. 14.1.2.4 */
2912 6395 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2913 : {
2914 5 : if (gfc_init_expr_flag)
2915 1 : gfc_error ("Function %qs in initialization expression at %L "
2916 : "must be an intrinsic function",
2917 1 : expr->symtree->n.sym->name, &expr->where);
2918 : else
2919 4 : gfc_error ("There is no specific function for the generic %qs "
2920 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2921 5 : return false;
2922 : }
2923 :
2924 6390 : if (intr)
2925 : {
2926 6355 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2927 : NULL, false))
2928 : return false;
2929 6335 : if (!gfc_use_derived (expr->ts.u.derived))
2930 : return false;
2931 6335 : return resolve_structure_cons (expr, 0);
2932 : }
2933 :
2934 35 : m = gfc_intrinsic_func_interface (expr, 0);
2935 35 : if (m == MATCH_YES)
2936 : return true;
2937 :
2938 3 : if (m == MATCH_NO)
2939 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2940 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2941 : &expr->where);
2942 :
2943 : return false;
2944 : }
2945 :
2946 :
2947 : /* Resolve a function call known to be specific. */
2948 :
2949 : static match
2950 27792 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2951 : {
2952 27792 : match m;
2953 :
2954 27792 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2955 : {
2956 7953 : if (sym->attr.dummy)
2957 : {
2958 276 : sym->attr.proc = PROC_DUMMY;
2959 276 : goto found;
2960 : }
2961 :
2962 7677 : sym->attr.proc = PROC_EXTERNAL;
2963 7677 : goto found;
2964 : }
2965 :
2966 19839 : if (sym->attr.proc == PROC_MODULE
2967 : || sym->attr.proc == PROC_ST_FUNCTION
2968 : || sym->attr.proc == PROC_INTERNAL)
2969 19101 : goto found;
2970 :
2971 738 : if (sym->attr.intrinsic)
2972 : {
2973 731 : m = gfc_intrinsic_func_interface (expr, 1);
2974 731 : if (m == MATCH_YES)
2975 : return MATCH_YES;
2976 0 : if (m == MATCH_NO)
2977 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2978 : "with an intrinsic", sym->name, &expr->where);
2979 :
2980 0 : return MATCH_ERROR;
2981 : }
2982 :
2983 : return MATCH_NO;
2984 :
2985 27054 : found:
2986 27054 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2987 :
2988 27054 : if (sym->result)
2989 27054 : expr->ts = sym->result->ts;
2990 : else
2991 0 : expr->ts = sym->ts;
2992 27054 : expr->value.function.name = sym->name;
2993 27054 : expr->value.function.esym = sym;
2994 : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2995 : error(s). */
2996 27054 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2997 : return MATCH_ERROR;
2998 27053 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2999 : {
3000 322 : expr->rank = CLASS_DATA (sym)->as->rank;
3001 322 : expr->corank = CLASS_DATA (sym)->as->corank;
3002 : }
3003 26731 : else if (sym->as != NULL)
3004 : {
3005 2287 : expr->rank = sym->as->rank;
3006 2287 : expr->corank = sym->as->corank;
3007 : }
3008 :
3009 : return MATCH_YES;
3010 : }
3011 :
3012 :
3013 : static bool
3014 27785 : resolve_specific_f (gfc_expr *expr)
3015 : {
3016 27785 : gfc_symbol *sym;
3017 27785 : match m;
3018 :
3019 27785 : sym = expr->symtree->n.sym;
3020 :
3021 27792 : for (;;)
3022 : {
3023 27792 : m = resolve_specific_f0 (sym, expr);
3024 27792 : if (m == MATCH_YES)
3025 : return true;
3026 8 : if (m == MATCH_ERROR)
3027 : return false;
3028 :
3029 7 : if (sym->ns->parent == NULL)
3030 : break;
3031 :
3032 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3033 :
3034 7 : if (sym == NULL)
3035 : break;
3036 : }
3037 :
3038 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3039 0 : expr->symtree->n.sym->name, &expr->where);
3040 :
3041 0 : return true;
3042 : }
3043 :
3044 : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3045 : candidates in CANDIDATES_LEN. */
3046 :
3047 : static void
3048 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3049 : char **&candidates,
3050 : size_t &candidates_len)
3051 : {
3052 388 : gfc_symtree *p;
3053 :
3054 388 : if (sym == NULL)
3055 : return;
3056 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3057 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3058 51 : vec_push (candidates, candidates_len, sym->name);
3059 :
3060 388 : p = sym->left;
3061 388 : if (p)
3062 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3063 :
3064 388 : p = sym->right;
3065 388 : if (p)
3066 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3067 : }
3068 :
3069 :
3070 : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3071 :
3072 : const char*
3073 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3074 : {
3075 57 : char **candidates = NULL;
3076 57 : size_t candidates_len = 0;
3077 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3078 57 : return gfc_closest_fuzzy_match (fn, candidates);
3079 : }
3080 :
3081 :
3082 : /* Resolve a procedure call not known to be generic nor specific. */
3083 :
3084 : static bool
3085 274477 : resolve_unknown_f (gfc_expr *expr)
3086 : {
3087 274477 : gfc_symbol *sym;
3088 274477 : gfc_typespec *ts;
3089 :
3090 274477 : sym = expr->symtree->n.sym;
3091 :
3092 274477 : if (sym->attr.dummy)
3093 : {
3094 289 : sym->attr.proc = PROC_DUMMY;
3095 289 : expr->value.function.name = sym->name;
3096 289 : goto set_type;
3097 : }
3098 :
3099 : /* See if we have an intrinsic function reference. */
3100 :
3101 274188 : if (gfc_is_intrinsic (sym, 0, expr->where))
3102 : {
3103 271933 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3104 : return true;
3105 : return false;
3106 : }
3107 :
3108 : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3109 : /* Intrinsics were handled above, only non-intrinsics left here. */
3110 2255 : if (sym->attr.flavor == FL_PROCEDURE
3111 2252 : && sym->attr.implicit_type
3112 371 : && sym->ns
3113 371 : && sym->ns->has_implicit_none_export)
3114 : {
3115 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3116 : "for symbol %qs at %L", sym->name, &sym->declared_at);
3117 3 : sym->error = 1;
3118 3 : return false;
3119 : }
3120 :
3121 : /* The reference is to an external name. */
3122 :
3123 2252 : sym->attr.proc = PROC_EXTERNAL;
3124 2252 : expr->value.function.name = sym->name;
3125 2252 : expr->value.function.esym = expr->symtree->n.sym;
3126 :
3127 2252 : if (sym->as != NULL)
3128 : {
3129 1 : expr->rank = sym->as->rank;
3130 1 : expr->corank = sym->as->corank;
3131 : }
3132 :
3133 : /* Type of the expression is either the type of the symbol or the
3134 : default type of the symbol. */
3135 :
3136 2251 : set_type:
3137 2541 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3138 :
3139 2541 : if (sym->ts.type != BT_UNKNOWN)
3140 2490 : expr->ts = sym->ts;
3141 : else
3142 : {
3143 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3144 :
3145 51 : if (ts->type == BT_UNKNOWN)
3146 : {
3147 41 : const char *guessed
3148 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3149 41 : if (guessed)
3150 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3151 : "; did you mean %qs?",
3152 : sym->name, &expr->where, guessed);
3153 : else
3154 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3155 : sym->name, &expr->where);
3156 41 : return false;
3157 : }
3158 : else
3159 10 : expr->ts = *ts;
3160 : }
3161 :
3162 : return true;
3163 : }
3164 :
3165 :
3166 : /* Return true, if the symbol is an external procedure. */
3167 : static bool
3168 845530 : is_external_proc (gfc_symbol *sym)
3169 : {
3170 843839 : if (!sym->attr.dummy && !sym->attr.contained
3171 736921 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3172 160397 : && sym->attr.proc != PROC_ST_FUNCTION
3173 159802 : && !sym->attr.proc_pointer
3174 158694 : && !sym->attr.use_assoc
3175 903983 : && sym->name)
3176 : return true;
3177 :
3178 : return false;
3179 : }
3180 :
3181 :
3182 : /* Figure out if a function reference is pure or not. Also set the name
3183 : of the function for a potential error message. Return nonzero if the
3184 : function is PURE, zero if not. */
3185 : static bool
3186 : pure_stmt_function (gfc_expr *, gfc_symbol *);
3187 :
3188 : bool
3189 254095 : gfc_pure_function (gfc_expr *e, const char **name)
3190 : {
3191 254095 : bool pure;
3192 254095 : gfc_component *comp;
3193 :
3194 254095 : *name = NULL;
3195 :
3196 254095 : if (e->symtree != NULL
3197 253759 : && e->symtree->n.sym != NULL
3198 253759 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3199 305 : return pure_stmt_function (e, e->symtree->n.sym);
3200 :
3201 253790 : comp = gfc_get_proc_ptr_comp (e);
3202 253790 : if (comp)
3203 : {
3204 464 : pure = gfc_pure (comp->ts.interface);
3205 464 : *name = comp->name;
3206 : }
3207 253326 : else if (e->value.function.esym)
3208 : {
3209 52334 : pure = gfc_pure (e->value.function.esym);
3210 52334 : *name = e->value.function.esym->name;
3211 : }
3212 200992 : else if (e->value.function.isym)
3213 : {
3214 399862 : pure = e->value.function.isym->pure
3215 199931 : || e->value.function.isym->elemental;
3216 199931 : *name = e->value.function.isym->name;
3217 : }
3218 1061 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3219 : {
3220 : /* The function has been resolved, but esym is not yet set.
3221 : This can happen with functions as dummy argument. */
3222 287 : pure = e->symtree->n.sym->attr.pure;
3223 287 : *name = e->symtree->n.sym->name;
3224 : }
3225 : else
3226 : {
3227 : /* Implicit functions are not pure. */
3228 774 : pure = 0;
3229 774 : *name = e->value.function.name;
3230 : }
3231 :
3232 : return pure;
3233 : }
3234 :
3235 :
3236 : /* Check if the expression is a reference to an implicitly pure function. */
3237 :
3238 : bool
3239 37759 : gfc_implicit_pure_function (gfc_expr *e)
3240 : {
3241 37759 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3242 37759 : if (comp)
3243 448 : return gfc_implicit_pure (comp->ts.interface);
3244 37311 : else if (e->value.function.esym)
3245 31908 : return gfc_implicit_pure (e->value.function.esym);
3246 : else
3247 : return 0;
3248 : }
3249 :
3250 :
3251 : static bool
3252 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3253 : int *f ATTRIBUTE_UNUSED)
3254 : {
3255 981 : const char *name;
3256 :
3257 : /* Don't bother recursing into other statement functions
3258 : since they will be checked individually for purity. */
3259 981 : if (e->expr_type != EXPR_FUNCTION
3260 343 : || !e->symtree
3261 343 : || e->symtree->n.sym == sym
3262 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3263 : return false;
3264 :
3265 19 : return gfc_pure_function (e, &name) ? false : true;
3266 : }
3267 :
3268 :
3269 : static bool
3270 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3271 : {
3272 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3273 : }
3274 :
3275 :
3276 : /* Check if an impure function is allowed in the current context. */
3277 :
3278 242307 : static bool check_pure_function (gfc_expr *e)
3279 : {
3280 242307 : const char *name = NULL;
3281 242307 : code_stack *stack;
3282 242307 : bool saw_block = false;
3283 :
3284 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3285 : gfc_do_concurrent_flag = 0 when the check for an impure function
3286 : occurs. Check the stack to see if the source code has a nested
3287 : BLOCK construct. */
3288 :
3289 560818 : for (stack = cs_base; stack; stack = stack->prev)
3290 : {
3291 318513 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3292 : {
3293 7157 : saw_block = true;
3294 7157 : continue;
3295 : }
3296 :
3297 5196 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3298 : {
3299 10 : bool is_pure;
3300 318511 : is_pure = (e->value.function.isym
3301 9 : && (e->value.function.isym->pure
3302 1 : || e->value.function.isym->elemental))
3303 11 : || (e->value.function.esym
3304 1 : && (e->value.function.esym->attr.pure
3305 1 : || e->value.function.esym->attr.elemental));
3306 2 : if (!is_pure)
3307 : {
3308 2 : gfc_error ("Reference to impure function at %L inside a "
3309 : "DO CONCURRENT", &e->where);
3310 2 : return false;
3311 : }
3312 : }
3313 : }
3314 :
3315 242305 : if (!gfc_pure_function (e, &name) && name)
3316 : {
3317 36493 : if (forall_flag)
3318 : {
3319 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3320 : "FORALL %s", name, &e->where,
3321 : forall_flag == 2 ? "mask" : "block");
3322 4 : return false;
3323 : }
3324 36489 : else if (gfc_do_concurrent_flag)
3325 : {
3326 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3327 : "DO CONCURRENT %s", name, &e->where,
3328 : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3329 2 : return false;
3330 : }
3331 36487 : else if (gfc_pure (NULL))
3332 : {
3333 5 : gfc_error ("Reference to impure function %qs at %L "
3334 : "within a PURE procedure", name, &e->where);
3335 5 : return false;
3336 : }
3337 36482 : if (!gfc_implicit_pure_function (e))
3338 30106 : gfc_unset_implicit_pure (NULL);
3339 : }
3340 : return true;
3341 : }
3342 :
3343 :
3344 : /* Update current procedure's array_outer_dependency flag, considering
3345 : a call to procedure SYM. */
3346 :
3347 : static void
3348 131378 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3349 : {
3350 : /* Check to see if this is a sibling function that has not yet
3351 : been resolved. */
3352 131378 : gfc_namespace *sibling = gfc_current_ns->sibling;
3353 247837 : for (; sibling; sibling = sibling->sibling)
3354 : {
3355 123262 : if (sibling->proc_name == sym)
3356 : {
3357 6803 : gfc_resolve (sibling);
3358 6803 : break;
3359 : }
3360 : }
3361 :
3362 : /* If SYM has references to outer arrays, so has the procedure calling
3363 : SYM. If SYM is a procedure pointer, we can assume the worst. */
3364 131378 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3365 67715 : && gfc_current_ns->proc_name)
3366 67671 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3367 131378 : }
3368 :
3369 :
3370 : /* Resolve a function call, which means resolving the arguments, then figuring
3371 : out which entity the name refers to. */
3372 :
3373 : static bool
3374 342590 : resolve_function (gfc_expr *expr)
3375 : {
3376 342590 : gfc_actual_arglist *arg;
3377 342590 : gfc_symbol *sym;
3378 342590 : bool t;
3379 342590 : int temp;
3380 342590 : procedure_type p = PROC_INTRINSIC;
3381 342590 : bool no_formal_args;
3382 :
3383 342590 : sym = NULL;
3384 342590 : if (expr->symtree)
3385 342254 : sym = expr->symtree->n.sym;
3386 :
3387 : /* If this is a procedure pointer component, it has already been resolved. */
3388 342590 : if (gfc_is_proc_ptr_comp (expr))
3389 : return true;
3390 :
3391 : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3392 : another caf_get. */
3393 342193 : if (sym && sym->attr.intrinsic
3394 8454 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3395 8454 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3396 : return true;
3397 :
3398 342193 : if (expr->ref)
3399 : {
3400 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3401 : &expr->where);
3402 1 : return false;
3403 : }
3404 :
3405 341856 : if (sym && sym->attr.intrinsic
3406 350646 : && !gfc_resolve_intrinsic (sym, &expr->where))
3407 : return false;
3408 :
3409 342192 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3410 : {
3411 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3412 4 : return false;
3413 : }
3414 :
3415 : /* If this is a deferred TBP with an abstract interface (which may
3416 : of course be referenced), expr->value.function.esym will be set. */
3417 341852 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3418 : {
3419 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3420 : sym->name, &expr->where);
3421 1 : return false;
3422 : }
3423 :
3424 : /* If this is a deferred TBP with an abstract interface, its result
3425 : cannot be an assumed length character (F2003: C418). */
3426 341851 : if (sym && sym->attr.abstract && sym->attr.function
3427 191 : && sym->result->ts.u.cl
3428 157 : && sym->result->ts.u.cl->length == NULL
3429 2 : && !sym->result->ts.deferred)
3430 : {
3431 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3432 : "character length result (F2008: C418)", sym->name,
3433 : &sym->declared_at);
3434 1 : return false;
3435 : }
3436 :
3437 : /* Switch off assumed size checking and do this again for certain kinds
3438 : of procedure, once the procedure itself is resolved. */
3439 342186 : need_full_assumed_size++;
3440 :
3441 342186 : if (expr->symtree && expr->symtree->n.sym)
3442 341850 : p = expr->symtree->n.sym->attr.proc;
3443 :
3444 342186 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3445 1093 : inquiry_argument = true;
3446 341850 : no_formal_args = sym && is_external_proc (sym)
3447 355869 : && gfc_sym_get_dummy_args (sym) == NULL;
3448 :
3449 342186 : if (!resolve_actual_arglist (expr->value.function.actual,
3450 : p, no_formal_args))
3451 : {
3452 67 : inquiry_argument = false;
3453 67 : return false;
3454 : }
3455 :
3456 342119 : inquiry_argument = false;
3457 :
3458 : /* Resume assumed_size checking. */
3459 342119 : need_full_assumed_size--;
3460 :
3461 : /* If the procedure is external, check for usage. */
3462 342119 : if (sym && is_external_proc (sym))
3463 13663 : resolve_global_procedure (sym, &expr->where, 0);
3464 :
3465 342119 : if (sym && sym->ts.type == BT_CHARACTER
3466 3242 : && sym->ts.u.cl
3467 3182 : && sym->ts.u.cl->length == NULL
3468 670 : && !sym->attr.dummy
3469 663 : && !sym->ts.deferred
3470 2 : && expr->value.function.esym == NULL
3471 2 : && !sym->attr.contained)
3472 : {
3473 : /* Internal procedures are taken care of in resolve_contained_fntype. */
3474 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3475 : "be used at %L since it is not a dummy argument",
3476 : sym->name, &expr->where);
3477 1 : return false;
3478 : }
3479 :
3480 : /* Add and check formal interface when -fc-prototypes-external is in
3481 : force, see comment in resolve_call(). */
3482 :
3483 342118 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3484 18 : && sym->attr.external)
3485 : {
3486 18 : if (sym->formal)
3487 : {
3488 6 : bool conflict;
3489 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3490 : sym->formal, 0, 0, 0, NULL);
3491 6 : if (conflict)
3492 : {
3493 6 : sym->ext_dummy_arglist_mismatch = 1;
3494 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3495 : "Different argument lists in external dummy "
3496 : "function %s at %L and %L", sym->name,
3497 : &expr->where, &sym->formal_at);
3498 : }
3499 : }
3500 12 : else if (!sym->formal_resolved)
3501 : {
3502 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3503 6 : sym->formal_at = expr->where;
3504 : }
3505 : }
3506 : /* See if function is already resolved. */
3507 :
3508 342118 : if (expr->value.function.name != NULL
3509 330276 : || expr->value.function.isym != NULL)
3510 : {
3511 12628 : if (expr->ts.type == BT_UNKNOWN)
3512 3 : expr->ts = sym->ts;
3513 : t = true;
3514 : }
3515 : else
3516 : {
3517 : /* Apply the rules of section 14.1.2. */
3518 :
3519 329490 : switch (procedure_kind (sym))
3520 : {
3521 27228 : case PTYPE_GENERIC:
3522 27228 : t = resolve_generic_f (expr);
3523 27228 : break;
3524 :
3525 27785 : case PTYPE_SPECIFIC:
3526 27785 : t = resolve_specific_f (expr);
3527 27785 : break;
3528 :
3529 274477 : case PTYPE_UNKNOWN:
3530 274477 : t = resolve_unknown_f (expr);
3531 274477 : break;
3532 :
3533 : default:
3534 : gfc_internal_error ("resolve_function(): bad function type");
3535 : }
3536 : }
3537 :
3538 : /* If the expression is still a function (it might have simplified),
3539 : then we check to see if we are calling an elemental function. */
3540 :
3541 342118 : if (expr->expr_type != EXPR_FUNCTION)
3542 : return t;
3543 :
3544 : /* Walk the argument list looking for invalid BOZ. */
3545 734355 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3546 492490 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3547 : {
3548 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3549 : "actual argument in a function reference",
3550 : &arg->expr->where);
3551 5 : return false;
3552 : }
3553 :
3554 241865 : temp = need_full_assumed_size;
3555 241865 : need_full_assumed_size = 0;
3556 :
3557 241865 : if (!resolve_elemental_actual (expr, NULL))
3558 : return false;
3559 :
3560 241862 : if (omp_workshare_flag
3561 32 : && expr->value.function.esym
3562 241867 : && ! gfc_elemental (expr->value.function.esym))
3563 : {
3564 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3565 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3566 : &expr->where);
3567 4 : t = false;
3568 : }
3569 :
3570 : #define GENERIC_ID expr->value.function.isym->id
3571 241858 : else if (expr->value.function.actual != NULL
3572 233972 : && expr->value.function.isym != NULL
3573 189273 : && GENERIC_ID != GFC_ISYM_LBOUND
3574 : && GENERIC_ID != GFC_ISYM_LCOBOUND
3575 : && GENERIC_ID != GFC_ISYM_UCOBOUND
3576 : && GENERIC_ID != GFC_ISYM_LEN
3577 : && GENERIC_ID != GFC_ISYM_LOC
3578 : && GENERIC_ID != GFC_ISYM_C_LOC
3579 : && GENERIC_ID != GFC_ISYM_PRESENT)
3580 : {
3581 : /* Array intrinsics must also have the last upper bound of an
3582 : assumed size array argument. UBOUND and SIZE have to be
3583 : excluded from the check if the second argument is anything
3584 : than a constant. */
3585 :
3586 533090 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3587 : {
3588 369517 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3589 45209 : && arg == expr->value.function.actual
3590 16673 : && arg->next != NULL && arg->next->expr)
3591 : {
3592 8236 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3593 : break;
3594 :
3595 8012 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3596 : break;
3597 :
3598 8012 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3599 8012 : < arg->expr->rank)
3600 : break;
3601 : }
3602 :
3603 367114 : if (arg->expr != NULL
3604 244934 : && arg->expr->rank > 0
3605 485050 : && resolve_assumed_size_actual (arg->expr))
3606 : return false;
3607 : }
3608 : }
3609 : #undef GENERIC_ID
3610 :
3611 241859 : need_full_assumed_size = temp;
3612 :
3613 241859 : if (!check_pure_function(expr))
3614 12 : t = false;
3615 :
3616 : /* Functions without the RECURSIVE attribution are not allowed to
3617 : * call themselves. */
3618 241859 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3619 : {
3620 51104 : gfc_symbol *esym;
3621 51104 : esym = expr->value.function.esym;
3622 :
3623 51104 : if (is_illegal_recursion (esym, gfc_current_ns))
3624 : {
3625 5 : if (esym->attr.entry && esym->ns->entries)
3626 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3627 : " function %qs is not RECURSIVE",
3628 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3629 : else
3630 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3631 : " is not RECURSIVE", esym->name, &expr->where);
3632 :
3633 : t = false;
3634 : }
3635 : }
3636 :
3637 : /* Character lengths of use associated functions may contains references to
3638 : symbols not referenced from the current program unit otherwise. Make sure
3639 : those symbols are marked as referenced. */
3640 :
3641 241859 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3642 3380 : && expr->value.function.esym->attr.use_assoc)
3643 : {
3644 1238 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3645 : }
3646 :
3647 : /* Make sure that the expression has a typespec that works. */
3648 241859 : if (expr->ts.type == BT_UNKNOWN)
3649 : {
3650 913 : if (expr->symtree->n.sym->result
3651 904 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3652 559 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3653 559 : expr->ts = expr->symtree->n.sym->result->ts;
3654 : }
3655 :
3656 : /* These derived types with an incomplete namespace, arising from use
3657 : association, cause gfc_get_derived_vtab to segfault. If the function
3658 : namespace does not suffice, something is badly wrong. */
3659 241859 : if (expr->ts.type == BT_DERIVED
3660 9189 : && !expr->ts.u.derived->ns->proc_name)
3661 : {
3662 3 : gfc_symbol *der;
3663 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3664 3 : if (der)
3665 : {
3666 3 : expr->ts.u.derived->refs--;
3667 3 : expr->ts.u.derived = der;
3668 3 : der->refs++;
3669 : }
3670 : else
3671 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3672 : }
3673 :
3674 241859 : if (!expr->ref && !expr->value.function.isym)
3675 : {
3676 52465 : if (expr->value.function.esym)
3677 51404 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3678 : else
3679 1061 : update_current_proc_array_outer_dependency (sym);
3680 : }
3681 189394 : else if (expr->ref)
3682 : /* typebound procedure: Assume the worst. */
3683 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3684 :
3685 241859 : if (expr->value.function.esym
3686 51404 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3687 26 : gfc_warning (OPT_Wdeprecated_declarations,
3688 : "Using function %qs at %L is deprecated",
3689 : sym->name, &expr->where);
3690 :
3691 : /* Check an external function supplied as a dummy argument has an external
3692 : attribute when a program unit uses 'implicit none (external)'. */
3693 241859 : if (expr->expr_type == EXPR_FUNCTION
3694 241859 : && expr->symtree
3695 241523 : && expr->symtree->n.sym->attr.dummy
3696 564 : && expr->symtree->n.sym->ns->has_implicit_none_export
3697 241860 : && !gfc_is_intrinsic(expr->symtree->n.sym, 0, expr->where))
3698 : {
3699 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
3700 : sym->name, &expr->where);
3701 1 : return false;
3702 : }
3703 :
3704 : return t;
3705 : }
3706 :
3707 :
3708 : /************* Subroutine resolution *************/
3709 :
3710 : static bool
3711 76437 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3712 : {
3713 76437 : code_stack *stack;
3714 76437 : bool saw_block = false;
3715 :
3716 76437 : if (gfc_pure (sym))
3717 : return true;
3718 :
3719 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3720 : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3721 : occurs. Walk up the stack to see if the source code has a nested
3722 : construct. */
3723 :
3724 158098 : for (stack = cs_base; stack; stack = stack->prev)
3725 : {
3726 87090 : if (stack->current->op == EXEC_BLOCK)
3727 : {
3728 1896 : saw_block = true;
3729 1896 : continue;
3730 : }
3731 :
3732 85194 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3733 : {
3734 :
3735 2 : bool is_pure = true;
3736 87090 : is_pure = sym->attr.pure || sym->attr.elemental;
3737 :
3738 2 : if (!is_pure)
3739 : {
3740 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3741 : "is not PURE", loc);
3742 2 : return false;
3743 : }
3744 : }
3745 : }
3746 :
3747 71008 : if (forall_flag)
3748 : {
3749 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3750 : name, loc);
3751 0 : return false;
3752 : }
3753 71008 : else if (gfc_do_concurrent_flag)
3754 : {
3755 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3756 : "PURE", name, loc);
3757 6 : return false;
3758 : }
3759 71002 : else if (gfc_pure (NULL))
3760 : {
3761 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3762 4 : return false;
3763 : }
3764 :
3765 70998 : gfc_unset_implicit_pure (NULL);
3766 70998 : return true;
3767 : }
3768 :
3769 :
3770 : static match
3771 2785 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3772 : {
3773 2785 : gfc_symbol *s;
3774 :
3775 2785 : if (sym->attr.generic)
3776 : {
3777 2784 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3778 2784 : if (s != NULL)
3779 : {
3780 2775 : c->resolved_sym = s;
3781 2775 : if (!pure_subroutine (s, s->name, &c->loc))
3782 : return MATCH_ERROR;
3783 2775 : return MATCH_YES;
3784 : }
3785 :
3786 : /* TODO: Need to search for elemental references in generic interface. */
3787 : }
3788 :
3789 10 : if (sym->attr.intrinsic)
3790 1 : return gfc_intrinsic_sub_interface (c, 0);
3791 :
3792 : return MATCH_NO;
3793 : }
3794 :
3795 :
3796 : static bool
3797 2783 : resolve_generic_s (gfc_code *c)
3798 : {
3799 2783 : gfc_symbol *sym;
3800 2783 : match m;
3801 :
3802 2783 : sym = c->symtree->n.sym;
3803 :
3804 2785 : for (;;)
3805 : {
3806 2785 : m = resolve_generic_s0 (c, sym);
3807 2785 : if (m == MATCH_YES)
3808 : return true;
3809 9 : else if (m == MATCH_ERROR)
3810 : return false;
3811 :
3812 9 : generic:
3813 9 : if (sym->ns->parent == NULL)
3814 : break;
3815 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3816 :
3817 3 : if (sym == NULL)
3818 : break;
3819 2 : if (!generic_sym (sym))
3820 0 : goto generic;
3821 : }
3822 :
3823 : /* Last ditch attempt. See if the reference is to an intrinsic
3824 : that possesses a matching interface. 14.1.2.4 */
3825 7 : sym = c->symtree->n.sym;
3826 :
3827 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3828 : {
3829 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3830 : sym->name, &c->loc);
3831 4 : return false;
3832 : }
3833 :
3834 3 : m = gfc_intrinsic_sub_interface (c, 0);
3835 3 : if (m == MATCH_YES)
3836 : return true;
3837 1 : if (m == MATCH_NO)
3838 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3839 : "intrinsic subroutine interface", sym->name, &c->loc);
3840 :
3841 : return false;
3842 : }
3843 :
3844 :
3845 : /* Resolve a subroutine call known to be specific. */
3846 :
3847 : static match
3848 62008 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3849 : {
3850 62008 : match m;
3851 :
3852 62008 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3853 : {
3854 5625 : if (sym->attr.dummy)
3855 : {
3856 257 : sym->attr.proc = PROC_DUMMY;
3857 257 : goto found;
3858 : }
3859 :
3860 5368 : sym->attr.proc = PROC_EXTERNAL;
3861 5368 : goto found;
3862 : }
3863 :
3864 56383 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3865 56383 : goto found;
3866 :
3867 0 : if (sym->attr.intrinsic)
3868 : {
3869 0 : m = gfc_intrinsic_sub_interface (c, 1);
3870 0 : if (m == MATCH_YES)
3871 : return MATCH_YES;
3872 0 : if (m == MATCH_NO)
3873 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3874 : "with an intrinsic", sym->name, &c->loc);
3875 :
3876 0 : return MATCH_ERROR;
3877 : }
3878 :
3879 : return MATCH_NO;
3880 :
3881 62008 : found:
3882 62008 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3883 :
3884 62008 : c->resolved_sym = sym;
3885 62008 : if (!pure_subroutine (sym, sym->name, &c->loc))
3886 : return MATCH_ERROR;
3887 :
3888 : return MATCH_YES;
3889 : }
3890 :
3891 :
3892 : static bool
3893 62008 : resolve_specific_s (gfc_code *c)
3894 : {
3895 62008 : gfc_symbol *sym;
3896 62008 : match m;
3897 :
3898 62008 : sym = c->symtree->n.sym;
3899 :
3900 62008 : for (;;)
3901 : {
3902 62008 : m = resolve_specific_s0 (c, sym);
3903 62008 : if (m == MATCH_YES)
3904 : return true;
3905 7 : if (m == MATCH_ERROR)
3906 : return false;
3907 :
3908 0 : if (sym->ns->parent == NULL)
3909 : break;
3910 :
3911 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3912 :
3913 0 : if (sym == NULL)
3914 : break;
3915 : }
3916 :
3917 0 : sym = c->symtree->n.sym;
3918 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3919 : sym->name, &c->loc);
3920 :
3921 0 : return false;
3922 : }
3923 :
3924 :
3925 : /* Resolve a subroutine call not known to be generic nor specific. */
3926 :
3927 : static bool
3928 15717 : resolve_unknown_s (gfc_code *c)
3929 : {
3930 15717 : gfc_symbol *sym;
3931 :
3932 15717 : sym = c->symtree->n.sym;
3933 :
3934 15717 : if (sym->attr.dummy)
3935 : {
3936 20 : sym->attr.proc = PROC_DUMMY;
3937 20 : goto found;
3938 : }
3939 :
3940 : /* See if we have an intrinsic function reference. */
3941 :
3942 15697 : if (gfc_is_intrinsic (sym, 1, c->loc))
3943 : {
3944 4186 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3945 : return true;
3946 309 : return false;
3947 : }
3948 :
3949 : /* The reference is to an external name. */
3950 :
3951 11511 : found:
3952 11531 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3953 :
3954 11531 : c->resolved_sym = sym;
3955 :
3956 11531 : return pure_subroutine (sym, sym->name, &c->loc);
3957 : }
3958 :
3959 :
3960 :
3961 : static bool
3962 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3963 : gfc_code *c, gfc_namespace *ns)
3964 : {
3965 805 : locus *here;
3966 :
3967 : /* If the type has been imported then its vtype functions are OK. */
3968 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
3969 : return true;
3970 :
3971 : if (e)
3972 791 : here = &e->where;
3973 : else
3974 7 : here = &c->loc;
3975 :
3976 798 : if (s && !s->import_only)
3977 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
3978 :
3979 798 : if (ns->import_state == IMPORT_ONLY
3980 75 : && sym->ns != ns
3981 58 : && (!s || !s->import_only))
3982 : {
3983 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
3984 : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
3985 21 : return false;
3986 : }
3987 777 : else if (ns->import_state == IMPORT_NONE
3988 27 : && sym->ns != ns)
3989 : {
3990 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
3991 : "has IMPORT, NONE", sym->name, here);
3992 12 : return false;
3993 : }
3994 : return true;
3995 : }
3996 :
3997 :
3998 : static bool
3999 6919 : check_import_status (gfc_expr *e)
4000 : {
4001 6919 : gfc_symtree *st;
4002 6919 : gfc_ref *ref;
4003 6919 : gfc_symbol *sym, *der;
4004 6919 : gfc_namespace *ns = gfc_current_ns;
4005 :
4006 6919 : switch (e->expr_type)
4007 : {
4008 727 : case EXPR_VARIABLE:
4009 727 : case EXPR_FUNCTION:
4010 727 : case EXPR_SUBSTRING:
4011 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
4012 :
4013 : /* Check the symbol itself. */
4014 727 : if (sym
4015 727 : && !(ns->proc_name
4016 : && (sym == ns->proc_name))
4017 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4018 : return false;
4019 :
4020 : /* Check the declared derived type. */
4021 717 : if (sym->ts.type == BT_DERIVED)
4022 : {
4023 16 : der = sym->ts.u.derived;
4024 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4025 :
4026 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4027 : return false;
4028 : }
4029 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4030 : {
4031 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4032 : : sym->ts.u.derived;
4033 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4034 :
4035 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4036 : return false;
4037 : }
4038 :
4039 : /* Check the declared derived types of component references. */
4040 724 : for (ref = e->ref; ref; ref = ref->next)
4041 20 : if (ref->type == REF_COMPONENT)
4042 : {
4043 19 : gfc_component *c = ref->u.c.component;
4044 19 : if (c->ts.type == BT_DERIVED)
4045 : {
4046 7 : der = c->ts.u.derived;
4047 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4048 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4049 : return false;
4050 : }
4051 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4052 : {
4053 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4054 : : c->ts.u.derived;
4055 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4056 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4057 : return false;
4058 : }
4059 : }
4060 :
4061 : break;
4062 :
4063 8 : case EXPR_ARRAY:
4064 8 : case EXPR_STRUCTURE:
4065 : /* Check the declared derived type. */
4066 8 : if (e->ts.type == BT_DERIVED)
4067 : {
4068 8 : der = e->ts.u.derived;
4069 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4070 :
4071 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4072 : return false;
4073 : }
4074 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4075 : {
4076 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4077 : : e->ts.u.derived;
4078 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4079 :
4080 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4081 : return false;
4082 : }
4083 :
4084 : break;
4085 :
4086 : /* Either not applicable or resolved away
4087 : case EXPR_OP:
4088 : case EXPR_UNKNOWN:
4089 : case EXPR_CONSTANT:
4090 : case EXPR_NULL:
4091 : case EXPR_COMPCALL:
4092 : case EXPR_PPC: */
4093 :
4094 : default:
4095 : break;
4096 : }
4097 :
4098 : return true;
4099 : }
4100 :
4101 :
4102 : /* Resolve a subroutine call. Although it was tempting to use the same code
4103 : for functions, subroutines and functions are stored differently and this
4104 : makes things awkward. */
4105 :
4106 :
4107 : static bool
4108 80653 : resolve_call (gfc_code *c)
4109 : {
4110 80653 : bool t;
4111 80653 : procedure_type ptype = PROC_INTRINSIC;
4112 80653 : gfc_symbol *csym, *sym;
4113 80653 : bool no_formal_args;
4114 :
4115 80653 : csym = c->symtree ? c->symtree->n.sym : NULL;
4116 :
4117 80653 : if (csym && csym->ts.type != BT_UNKNOWN)
4118 : {
4119 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4120 : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4121 4 : return false;
4122 : }
4123 :
4124 80649 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4125 : {
4126 16789 : gfc_symtree *st;
4127 16789 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4128 16789 : sym = st ? st->n.sym : NULL;
4129 16789 : if (sym && csym != sym
4130 3 : && sym->ns == gfc_current_ns
4131 3 : && sym->attr.flavor == FL_PROCEDURE
4132 3 : && sym->attr.contained)
4133 : {
4134 3 : sym->refs++;
4135 3 : if (csym->attr.generic)
4136 2 : c->symtree->n.sym = sym;
4137 : else
4138 1 : c->symtree = st;
4139 3 : csym = c->symtree->n.sym;
4140 : }
4141 : }
4142 :
4143 : /* If this ia a deferred TBP, c->expr1 will be set. */
4144 80649 : if (!c->expr1 && csym)
4145 : {
4146 78958 : if (csym->attr.abstract)
4147 : {
4148 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4149 : csym->name, &c->loc);
4150 1 : return false;
4151 : }
4152 :
4153 : /* Subroutines without the RECURSIVE attribution are not allowed to
4154 : call themselves. */
4155 78957 : if (is_illegal_recursion (csym, gfc_current_ns))
4156 : {
4157 4 : if (csym->attr.entry && csym->ns->entries)
4158 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4159 : "as subroutine %qs is not RECURSIVE",
4160 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4161 : else
4162 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4163 : "as it is not RECURSIVE", csym->name, &c->loc);
4164 :
4165 80648 : t = false;
4166 : }
4167 : }
4168 :
4169 : /* Switch off assumed size checking and do this again for certain kinds
4170 : of procedure, once the procedure itself is resolved. */
4171 80648 : need_full_assumed_size++;
4172 :
4173 80648 : if (csym)
4174 80648 : ptype = csym->attr.proc;
4175 :
4176 80648 : no_formal_args = csym && is_external_proc (csym)
4177 15554 : && gfc_sym_get_dummy_args (csym) == NULL;
4178 80648 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4179 : return false;
4180 :
4181 : /* Resume assumed_size checking. */
4182 80614 : need_full_assumed_size--;
4183 :
4184 : /* If 'implicit none (external)' and the symbol is a dummy argument,
4185 : check for an 'external' attribute. */
4186 80614 : if (csym->ns->has_implicit_none_export
4187 4422 : && csym->attr.external == 0 && csym->attr.dummy == 1)
4188 : {
4189 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
4190 : csym->name, &c->loc);
4191 1 : return false;
4192 : }
4193 :
4194 : /* If external, check for usage. */
4195 80613 : if (csym && is_external_proc (csym))
4196 15548 : resolve_global_procedure (csym, &c->loc, 1);
4197 :
4198 : /* If we have an external dummy argument, we want to write out its arguments
4199 : with -fc-prototypes-external. Code like
4200 :
4201 : subroutine foo(a,n)
4202 : external a
4203 : if (n == 1) call a(1)
4204 : if (n == 2) call a(2,3)
4205 : end subroutine foo
4206 :
4207 : is actually legal Fortran, but it is not possible to generate a C23-
4208 : compliant prototype for this, so we just record the fact here and
4209 : handle that during -fc-prototypes-external processing. */
4210 :
4211 80613 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4212 14 : && csym->attr.external)
4213 : {
4214 14 : if (csym->formal)
4215 : {
4216 6 : bool conflict;
4217 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4218 : 0, 0, 0, NULL);
4219 6 : if (conflict)
4220 : {
4221 6 : csym->ext_dummy_arglist_mismatch = 1;
4222 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4223 : "Different argument lists in external dummy "
4224 : "subroutine %s at %L and %L", csym->name,
4225 : &c->loc, &csym->formal_at);
4226 : }
4227 : }
4228 8 : else if (!csym->formal_resolved)
4229 : {
4230 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4231 7 : csym->formal_at = c->loc;
4232 : }
4233 : }
4234 :
4235 80613 : t = true;
4236 80613 : if (c->resolved_sym == NULL)
4237 : {
4238 80508 : c->resolved_isym = NULL;
4239 80508 : switch (procedure_kind (csym))
4240 : {
4241 2783 : case PTYPE_GENERIC:
4242 2783 : t = resolve_generic_s (c);
4243 2783 : break;
4244 :
4245 62008 : case PTYPE_SPECIFIC:
4246 62008 : t = resolve_specific_s (c);
4247 62008 : break;
4248 :
4249 15717 : case PTYPE_UNKNOWN:
4250 15717 : t = resolve_unknown_s (c);
4251 15717 : break;
4252 :
4253 : default:
4254 : gfc_internal_error ("resolve_subroutine(): bad function type");
4255 : }
4256 : }
4257 :
4258 : /* Some checks of elemental subroutine actual arguments. */
4259 80612 : if (!resolve_elemental_actual (NULL, c))
4260 : return false;
4261 :
4262 80604 : if (!c->expr1)
4263 78913 : update_current_proc_array_outer_dependency (csym);
4264 : else
4265 : /* Typebound procedure: Assume the worst. */
4266 1691 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4267 :
4268 80604 : if (c->resolved_sym
4269 80291 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4270 34 : gfc_warning (OPT_Wdeprecated_declarations,
4271 : "Using subroutine %qs at %L is deprecated",
4272 : c->resolved_sym->name, &c->loc);
4273 :
4274 80604 : csym = c->resolved_sym ? c->resolved_sym : csym;
4275 80604 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4276 2 : && csym != gfc_current_ns->proc_name)
4277 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4278 :
4279 : return t;
4280 : }
4281 :
4282 :
4283 : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4284 : op1->shape and op2->shape are non-NULL return true if their shapes
4285 : match. If both op1->shape and op2->shape are non-NULL return false
4286 : if their shapes do not match. If either op1->shape or op2->shape is
4287 : NULL, return true. */
4288 :
4289 : static bool
4290 32162 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4291 : {
4292 32162 : bool t;
4293 32162 : int i;
4294 :
4295 32162 : t = true;
4296 :
4297 32162 : if (op1->shape != NULL && op2->shape != NULL)
4298 : {
4299 42814 : for (i = 0; i < op1->rank; i++)
4300 : {
4301 22844 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4302 : {
4303 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4304 : &op1->where, &op2->where);
4305 3 : t = false;
4306 3 : break;
4307 : }
4308 : }
4309 : }
4310 :
4311 32162 : return t;
4312 : }
4313 :
4314 : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4315 : For example A .AND. B becomes IAND(A, B). */
4316 : static gfc_expr *
4317 668 : logical_to_bitwise (gfc_expr *e)
4318 : {
4319 668 : gfc_expr *tmp, *op1, *op2;
4320 668 : gfc_isym_id isym;
4321 668 : gfc_actual_arglist *args = NULL;
4322 :
4323 668 : gcc_assert (e->expr_type == EXPR_OP);
4324 :
4325 668 : isym = GFC_ISYM_NONE;
4326 668 : op1 = e->value.op.op1;
4327 668 : op2 = e->value.op.op2;
4328 :
4329 668 : switch (e->value.op.op)
4330 : {
4331 : case INTRINSIC_NOT:
4332 : isym = GFC_ISYM_NOT;
4333 : break;
4334 126 : case INTRINSIC_AND:
4335 126 : isym = GFC_ISYM_IAND;
4336 126 : break;
4337 127 : case INTRINSIC_OR:
4338 127 : isym = GFC_ISYM_IOR;
4339 127 : break;
4340 270 : case INTRINSIC_NEQV:
4341 270 : isym = GFC_ISYM_IEOR;
4342 270 : break;
4343 126 : case INTRINSIC_EQV:
4344 : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4345 : Change the old expression to NEQV, which will get replaced by IEOR,
4346 : and wrap it in NOT. */
4347 126 : tmp = gfc_copy_expr (e);
4348 126 : tmp->value.op.op = INTRINSIC_NEQV;
4349 126 : tmp = logical_to_bitwise (tmp);
4350 126 : isym = GFC_ISYM_NOT;
4351 126 : op1 = tmp;
4352 126 : op2 = NULL;
4353 126 : break;
4354 0 : default:
4355 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4356 : }
4357 :
4358 : /* Inherit the original operation's operands as arguments. */
4359 668 : args = gfc_get_actual_arglist ();
4360 668 : args->expr = op1;
4361 668 : if (op2)
4362 : {
4363 523 : args->next = gfc_get_actual_arglist ();
4364 523 : args->next->expr = op2;
4365 : }
4366 :
4367 : /* Convert the expression to a function call. */
4368 668 : e->expr_type = EXPR_FUNCTION;
4369 668 : e->value.function.actual = args;
4370 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4371 668 : e->value.function.name = e->value.function.isym->name;
4372 668 : e->value.function.esym = NULL;
4373 :
4374 : /* Make up a pre-resolved function call symtree if we need to. */
4375 668 : if (!e->symtree || !e->symtree->n.sym)
4376 : {
4377 668 : gfc_symbol *sym;
4378 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4379 668 : sym = e->symtree->n.sym;
4380 668 : sym->result = sym;
4381 668 : sym->attr.flavor = FL_PROCEDURE;
4382 668 : sym->attr.function = 1;
4383 668 : sym->attr.elemental = 1;
4384 668 : sym->attr.pure = 1;
4385 668 : sym->attr.referenced = 1;
4386 668 : gfc_intrinsic_symbol (sym);
4387 668 : gfc_commit_symbol (sym);
4388 : }
4389 :
4390 668 : args->name = e->value.function.isym->formal->name;
4391 668 : if (e->value.function.isym->formal->next)
4392 523 : args->next->name = e->value.function.isym->formal->next->name;
4393 :
4394 668 : return e;
4395 : }
4396 :
4397 : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4398 : candidates in CANDIDATES_LEN. */
4399 : static void
4400 57 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4401 : char **&candidates,
4402 : size_t &candidates_len)
4403 : {
4404 59 : gfc_symtree *p;
4405 :
4406 59 : if (uop == NULL)
4407 : return;
4408 :
4409 : /* Not sure how to properly filter here. Use all for a start.
4410 : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4411 : these as i suppose they don't make terribly sense. */
4412 :
4413 59 : if (uop->n.uop->op != NULL)
4414 2 : vec_push (candidates, candidates_len, uop->name);
4415 :
4416 59 : p = uop->left;
4417 59 : if (p)
4418 0 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4419 :
4420 59 : p = uop->right;
4421 59 : if (p)
4422 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4423 : }
4424 :
4425 : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4426 :
4427 : static const char*
4428 57 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4429 : {
4430 57 : char **candidates = NULL;
4431 57 : size_t candidates_len = 0;
4432 57 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4433 57 : return gfc_closest_fuzzy_match (op, candidates);
4434 : }
4435 :
4436 :
4437 : /* Callback finding an impure function as an operand to an .and. or
4438 : .or. expression. Remember the last function warned about to
4439 : avoid double warnings when recursing. */
4440 :
4441 : static int
4442 192721 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4443 : void *data)
4444 : {
4445 192721 : gfc_expr *f = *e;
4446 192721 : const char *name;
4447 192721 : static gfc_expr *last = NULL;
4448 192721 : bool *found = (bool *) data;
4449 :
4450 192721 : if (f->expr_type == EXPR_FUNCTION)
4451 : {
4452 11765 : *found = 1;
4453 11765 : if (f != last && !gfc_pure_function (f, &name)
4454 13040 : && !gfc_implicit_pure_function (f))
4455 : {
4456 1136 : if (name)
4457 1136 : gfc_warning (OPT_Wfunction_elimination,
4458 : "Impure function %qs at %L might not be evaluated",
4459 : name, &f->where);
4460 : else
4461 0 : gfc_warning (OPT_Wfunction_elimination,
4462 : "Impure function at %L might not be evaluated",
4463 : &f->where);
4464 : }
4465 11765 : last = f;
4466 : }
4467 :
4468 192721 : return 0;
4469 : }
4470 :
4471 : /* Return true if TYPE is character based, false otherwise. */
4472 :
4473 : static int
4474 1373 : is_character_based (bt type)
4475 : {
4476 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4477 : }
4478 :
4479 :
4480 : /* If expression is a hollerith, convert it to character and issue a warning
4481 : for the conversion. */
4482 :
4483 : static void
4484 408 : convert_hollerith_to_character (gfc_expr *e)
4485 : {
4486 408 : if (e->ts.type == BT_HOLLERITH)
4487 : {
4488 108 : gfc_typespec t;
4489 108 : gfc_clear_ts (&t);
4490 108 : t.type = BT_CHARACTER;
4491 108 : t.kind = e->ts.kind;
4492 108 : gfc_convert_type_warn (e, &t, 2, 1);
4493 : }
4494 408 : }
4495 :
4496 : /* Convert to numeric and issue a warning for the conversion. */
4497 :
4498 : static void
4499 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4500 : {
4501 240 : gfc_typespec t;
4502 240 : gfc_clear_ts (&t);
4503 240 : t.type = b->ts.type;
4504 240 : t.kind = b->ts.kind;
4505 240 : gfc_convert_type_warn (a, &t, 2, 1);
4506 240 : }
4507 :
4508 : /* Resolve an operator expression node. This can involve replacing the
4509 : operation with a user defined function call. CHECK_INTERFACES is a
4510 : helper macro. */
4511 :
4512 : #define CHECK_INTERFACES \
4513 : { \
4514 : match m = gfc_extend_expr (e); \
4515 : if (m == MATCH_YES) \
4516 : return true; \
4517 : if (m == MATCH_ERROR) \
4518 : return false; \
4519 : }
4520 :
4521 : static bool
4522 530102 : resolve_operator (gfc_expr *e)
4523 : {
4524 530102 : gfc_expr *op1, *op2;
4525 : /* One error uses 3 names; additional space for wording (also via gettext). */
4526 530102 : bool t = true;
4527 :
4528 : /* Reduce stacked parentheses to single pair */
4529 530102 : while (e->expr_type == EXPR_OP
4530 530260 : && e->value.op.op == INTRINSIC_PARENTHESES
4531 23366 : && e->value.op.op1->expr_type == EXPR_OP
4532 547058 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4533 : {
4534 158 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4535 158 : gfc_replace_expr (e, tmp);
4536 : }
4537 :
4538 : /* Resolve all subnodes-- give them types. */
4539 :
4540 530102 : switch (e->value.op.op)
4541 : {
4542 478388 : default:
4543 478388 : if (!gfc_resolve_expr (e->value.op.op2))
4544 530102 : t = false;
4545 :
4546 : /* Fall through. */
4547 :
4548 530102 : case INTRINSIC_NOT:
4549 530102 : case INTRINSIC_UPLUS:
4550 530102 : case INTRINSIC_UMINUS:
4551 530102 : case INTRINSIC_PARENTHESES:
4552 530102 : if (!gfc_resolve_expr (e->value.op.op1))
4553 : return false;
4554 529941 : if (e->value.op.op1
4555 529932 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4556 : {
4557 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4558 0 : "unary operator %qs", &e->value.op.op1->where,
4559 : gfc_op2string (e->value.op.op));
4560 0 : return false;
4561 : }
4562 529941 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4563 6 : && e->value.op.op == INTRINSIC_UMINUS)
4564 : {
4565 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4566 : &e->value.op.op1->where);
4567 2 : return false;
4568 : }
4569 529939 : break;
4570 : }
4571 :
4572 : /* Typecheck the new node. */
4573 :
4574 529939 : op1 = e->value.op.op1;
4575 529939 : op2 = e->value.op.op2;
4576 529939 : if (op1 == NULL && op2 == NULL)
4577 : return false;
4578 : /* Error out if op2 did not resolve. We already diagnosed op1. */
4579 529930 : if (t == false)
4580 : return false;
4581 :
4582 : /* op1 and op2 cannot both be BOZ. */
4583 529864 : if (op1 && op1->ts.type == BT_BOZ
4584 0 : && op2 && op2->ts.type == BT_BOZ)
4585 : {
4586 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4587 0 : "binary operator %qs", &op1->where, &op2->where,
4588 : gfc_op2string (e->value.op.op));
4589 0 : return false;
4590 : }
4591 :
4592 529864 : if ((op1 && op1->expr_type == EXPR_NULL)
4593 529862 : || (op2 && op2->expr_type == EXPR_NULL))
4594 : {
4595 3 : CHECK_INTERFACES
4596 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4597 3 : return false;
4598 : }
4599 :
4600 529861 : switch (e->value.op.op)
4601 : {
4602 8103 : case INTRINSIC_UPLUS:
4603 8103 : case INTRINSIC_UMINUS:
4604 8103 : if (op1->ts.type == BT_INTEGER
4605 : || op1->ts.type == BT_REAL
4606 : || op1->ts.type == BT_COMPLEX
4607 : || op1->ts.type == BT_UNSIGNED)
4608 : {
4609 8034 : e->ts = op1->ts;
4610 8034 : break;
4611 : }
4612 :
4613 69 : CHECK_INTERFACES
4614 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4615 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4616 43 : return false;
4617 :
4618 154846 : case INTRINSIC_POWER:
4619 154846 : case INTRINSIC_PLUS:
4620 154846 : case INTRINSIC_MINUS:
4621 154846 : case INTRINSIC_TIMES:
4622 154846 : case INTRINSIC_DIVIDE:
4623 :
4624 : /* UNSIGNED cannot appear in a mixed expression without explicit
4625 : conversion. */
4626 154846 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4627 : {
4628 3 : CHECK_INTERFACES
4629 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4630 : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4631 : gfc_typename (op1), gfc_typename (op2));
4632 3 : return false;
4633 : }
4634 :
4635 154843 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4636 : {
4637 : /* Do not perform conversions if operands are not conformable as
4638 : required for the binary intrinsic operators (F2018:10.1.5).
4639 : Defer to a possibly overloading user-defined operator. */
4640 154393 : if (!gfc_op_rank_conformable (op1, op2))
4641 : {
4642 36 : CHECK_INTERFACES
4643 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4644 0 : &op1->where, &op2->where);
4645 0 : return false;
4646 : }
4647 :
4648 154357 : gfc_type_convert_binary (e, 1);
4649 154357 : break;
4650 : }
4651 :
4652 450 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4653 : {
4654 221 : CHECK_INTERFACES
4655 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4656 : "numeric operator %qs at %L",
4657 : gfc_op2string (e->value.op.op), &e->where);
4658 2 : return false;
4659 : }
4660 : else
4661 : {
4662 229 : CHECK_INTERFACES
4663 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4664 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4665 : gfc_typename (op2));
4666 3 : return false;
4667 : }
4668 :
4669 2267 : case INTRINSIC_CONCAT:
4670 2267 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4671 2242 : && op1->ts.kind == op2->ts.kind)
4672 : {
4673 2233 : e->ts.type = BT_CHARACTER;
4674 2233 : e->ts.kind = op1->ts.kind;
4675 2233 : break;
4676 : }
4677 :
4678 34 : CHECK_INTERFACES
4679 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4680 : &e->where, gfc_typename (op1), gfc_typename (op2));
4681 10 : return false;
4682 :
4683 69491 : case INTRINSIC_AND:
4684 69491 : case INTRINSIC_OR:
4685 69491 : case INTRINSIC_EQV:
4686 69491 : case INTRINSIC_NEQV:
4687 69491 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4688 : {
4689 68940 : e->ts.type = BT_LOGICAL;
4690 68940 : e->ts.kind = gfc_kind_max (op1, op2);
4691 68940 : if (op1->ts.kind < e->ts.kind)
4692 140 : gfc_convert_type (op1, &e->ts, 2);
4693 68800 : else if (op2->ts.kind < e->ts.kind)
4694 117 : gfc_convert_type (op2, &e->ts, 2);
4695 :
4696 68940 : if (flag_frontend_optimize &&
4697 57916 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4698 : {
4699 : /* Warn about short-circuiting
4700 : with impure function as second operand. */
4701 51915 : bool op2_f = false;
4702 51915 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4703 : }
4704 : break;
4705 : }
4706 :
4707 : /* Logical ops on integers become bitwise ops with -fdec. */
4708 551 : else if (flag_dec
4709 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4710 : {
4711 523 : e->ts.type = BT_INTEGER;
4712 523 : e->ts.kind = gfc_kind_max (op1, op2);
4713 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4714 289 : gfc_convert_type (op1, &e->ts, 1);
4715 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4716 144 : gfc_convert_type (op2, &e->ts, 1);
4717 523 : e = logical_to_bitwise (e);
4718 523 : goto simplify_op;
4719 : }
4720 :
4721 28 : CHECK_INTERFACES
4722 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4723 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4724 : gfc_typename (op2));
4725 16 : return false;
4726 :
4727 20387 : case INTRINSIC_NOT:
4728 : /* Logical ops on integers become bitwise ops with -fdec. */
4729 20387 : if (flag_dec && op1->ts.type == BT_INTEGER)
4730 : {
4731 19 : e->ts.type = BT_INTEGER;
4732 19 : e->ts.kind = op1->ts.kind;
4733 19 : e = logical_to_bitwise (e);
4734 19 : goto simplify_op;
4735 : }
4736 :
4737 20368 : if (op1->ts.type == BT_LOGICAL)
4738 : {
4739 20362 : e->ts.type = BT_LOGICAL;
4740 20362 : e->ts.kind = op1->ts.kind;
4741 20362 : break;
4742 : }
4743 :
4744 6 : CHECK_INTERFACES
4745 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4746 : gfc_typename (op1));
4747 3 : return false;
4748 :
4749 21256 : case INTRINSIC_GT:
4750 21256 : case INTRINSIC_GT_OS:
4751 21256 : case INTRINSIC_GE:
4752 21256 : case INTRINSIC_GE_OS:
4753 21256 : case INTRINSIC_LT:
4754 21256 : case INTRINSIC_LT_OS:
4755 21256 : case INTRINSIC_LE:
4756 21256 : case INTRINSIC_LE_OS:
4757 21256 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4758 : {
4759 18 : CHECK_INTERFACES
4760 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4761 0 : return false;
4762 : }
4763 :
4764 : /* Fall through. */
4765 :
4766 251298 : case INTRINSIC_EQ:
4767 251298 : case INTRINSIC_EQ_OS:
4768 251298 : case INTRINSIC_NE:
4769 251298 : case INTRINSIC_NE_OS:
4770 :
4771 251298 : if (flag_dec
4772 1038 : && is_character_based (op1->ts.type)
4773 251633 : && is_character_based (op2->ts.type))
4774 : {
4775 204 : convert_hollerith_to_character (op1);
4776 204 : convert_hollerith_to_character (op2);
4777 : }
4778 :
4779 251298 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4780 37729 : && op1->ts.kind == op2->ts.kind)
4781 : {
4782 37692 : e->ts.type = BT_LOGICAL;
4783 37692 : e->ts.kind = gfc_default_logical_kind;
4784 37692 : break;
4785 : }
4786 :
4787 : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4788 213606 : if (op1->ts.type == BT_BOZ)
4789 : {
4790 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4791 : "as an operand of a relational operator"),
4792 : &op1->where))
4793 : return false;
4794 :
4795 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4796 : return false;
4797 :
4798 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4799 : return false;
4800 : }
4801 :
4802 : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4803 213606 : if (op2->ts.type == BT_BOZ)
4804 : {
4805 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4806 : " as an operand of a relational operator"),
4807 : &op2->where))
4808 : return false;
4809 :
4810 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4811 : return false;
4812 :
4813 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4814 : return false;
4815 : }
4816 213606 : if (flag_dec
4817 213606 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4818 120 : convert_to_numeric (op1, op2);
4819 :
4820 213606 : if (flag_dec
4821 213606 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4822 120 : convert_to_numeric (op2, op1);
4823 :
4824 213606 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4825 : {
4826 : /* Do not perform conversions if operands are not conformable as
4827 : required for the binary intrinsic operators (F2018:10.1.5).
4828 : Defer to a possibly overloading user-defined operator. */
4829 212477 : if (!gfc_op_rank_conformable (op1, op2))
4830 : {
4831 70 : CHECK_INTERFACES
4832 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4833 0 : &op1->where, &op2->where);
4834 0 : return false;
4835 : }
4836 :
4837 212407 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4838 : {
4839 1 : CHECK_INTERFACES
4840 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4841 1 : "%s and %s", &op1->where, &op2->where,
4842 : gfc_typename (op1), gfc_typename (op2));
4843 1 : return false;
4844 : }
4845 :
4846 212406 : gfc_type_convert_binary (e, 1);
4847 :
4848 212406 : e->ts.type = BT_LOGICAL;
4849 212406 : e->ts.kind = gfc_default_logical_kind;
4850 :
4851 212406 : if (warn_compare_reals)
4852 : {
4853 69 : gfc_intrinsic_op op = e->value.op.op;
4854 :
4855 : /* Type conversion has made sure that the types of op1 and op2
4856 : agree, so it is only necessary to check the first one. */
4857 69 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4858 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4859 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4860 : {
4861 13 : const char *msg;
4862 :
4863 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4864 : msg = G_("Equality comparison for %s at %L");
4865 : else
4866 6 : msg = G_("Inequality comparison for %s at %L");
4867 :
4868 13 : gfc_warning (OPT_Wcompare_reals, msg,
4869 : gfc_typename (op1), &op1->where);
4870 : }
4871 : }
4872 :
4873 : break;
4874 : }
4875 :
4876 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4877 : {
4878 2 : CHECK_INTERFACES
4879 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4880 : &e->where,
4881 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4882 : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4883 2 : }
4884 : else
4885 : {
4886 1127 : CHECK_INTERFACES
4887 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4888 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4889 : gfc_typename (op2));
4890 : }
4891 :
4892 : return false;
4893 :
4894 282 : case INTRINSIC_USER:
4895 282 : if (e->value.op.uop->op == NULL)
4896 : {
4897 57 : const char *name = e->value.op.uop->name;
4898 57 : const char *guessed;
4899 57 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4900 57 : CHECK_INTERFACES
4901 5 : if (guessed)
4902 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4903 : "%qs?", name, &e->where, guessed);
4904 : else
4905 4 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4906 : }
4907 225 : else if (op2 == NULL)
4908 : {
4909 48 : CHECK_INTERFACES
4910 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4911 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4912 : }
4913 : else
4914 : {
4915 177 : e->value.op.uop->op->sym->attr.referenced = 1;
4916 177 : CHECK_INTERFACES
4917 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
4918 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
4919 : gfc_typename (op2));
4920 : }
4921 :
4922 : return false;
4923 :
4924 23169 : case INTRINSIC_PARENTHESES:
4925 23169 : e->ts = op1->ts;
4926 23169 : if (e->ts.type == BT_CHARACTER)
4927 321 : e->ts.u.cl = op1->ts.u.cl;
4928 : break;
4929 :
4930 0 : default:
4931 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
4932 : }
4933 :
4934 : /* Deal with arrayness of an operand through an operator. */
4935 :
4936 527193 : switch (e->value.op.op)
4937 : {
4938 475628 : case INTRINSIC_PLUS:
4939 475628 : case INTRINSIC_MINUS:
4940 475628 : case INTRINSIC_TIMES:
4941 475628 : case INTRINSIC_DIVIDE:
4942 475628 : case INTRINSIC_POWER:
4943 475628 : case INTRINSIC_CONCAT:
4944 475628 : case INTRINSIC_AND:
4945 475628 : case INTRINSIC_OR:
4946 475628 : case INTRINSIC_EQV:
4947 475628 : case INTRINSIC_NEQV:
4948 475628 : case INTRINSIC_EQ:
4949 475628 : case INTRINSIC_EQ_OS:
4950 475628 : case INTRINSIC_NE:
4951 475628 : case INTRINSIC_NE_OS:
4952 475628 : case INTRINSIC_GT:
4953 475628 : case INTRINSIC_GT_OS:
4954 475628 : case INTRINSIC_GE:
4955 475628 : case INTRINSIC_GE_OS:
4956 475628 : case INTRINSIC_LT:
4957 475628 : case INTRINSIC_LT_OS:
4958 475628 : case INTRINSIC_LE:
4959 475628 : case INTRINSIC_LE_OS:
4960 :
4961 475628 : if (op1->rank == 0 && op2->rank == 0)
4962 424133 : e->rank = 0;
4963 :
4964 475628 : if (op1->rank == 0 && op2->rank != 0)
4965 : {
4966 2499 : e->rank = op2->rank;
4967 :
4968 2499 : if (e->shape == NULL)
4969 2469 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
4970 : }
4971 :
4972 475628 : if (op1->rank != 0 && op2->rank == 0)
4973 : {
4974 16773 : e->rank = op1->rank;
4975 :
4976 16773 : if (e->shape == NULL)
4977 16755 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4978 : }
4979 :
4980 475628 : if (op1->rank != 0 && op2->rank != 0)
4981 : {
4982 32223 : if (op1->rank == op2->rank)
4983 : {
4984 32223 : e->rank = op1->rank;
4985 32223 : if (e->shape == NULL)
4986 : {
4987 32162 : t = compare_shapes (op1, op2);
4988 32162 : if (!t)
4989 3 : e->shape = NULL;
4990 : else
4991 32159 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4992 : }
4993 : }
4994 : else
4995 : {
4996 : /* Allow higher level expressions to work. */
4997 0 : e->rank = 0;
4998 :
4999 : /* Try user-defined operators, and otherwise throw an error. */
5000 0 : CHECK_INTERFACES
5001 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
5002 0 : &op1->where, &op2->where);
5003 0 : return false;
5004 : }
5005 : }
5006 : break;
5007 :
5008 51565 : case INTRINSIC_PARENTHESES:
5009 51565 : case INTRINSIC_NOT:
5010 51565 : case INTRINSIC_UPLUS:
5011 51565 : case INTRINSIC_UMINUS:
5012 : /* Simply copy arrayness attribute */
5013 51565 : e->rank = op1->rank;
5014 51565 : e->corank = op1->corank;
5015 :
5016 51565 : if (e->shape == NULL)
5017 51559 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5018 :
5019 : break;
5020 :
5021 : default:
5022 : break;
5023 : }
5024 :
5025 527735 : simplify_op:
5026 :
5027 : /* Attempt to simplify the expression. */
5028 3 : if (t)
5029 : {
5030 527732 : t = gfc_simplify_expr (e, 0);
5031 : /* Some calls do not succeed in simplification and return false
5032 : even though there is no error; e.g. variable references to
5033 : PARAMETER arrays. */
5034 527732 : if (!gfc_is_constant_expr (e))
5035 482074 : t = true;
5036 : }
5037 : return t;
5038 : }
5039 :
5040 : static bool
5041 150 : resolve_conditional (gfc_expr *expr)
5042 : {
5043 150 : gfc_expr *condition, *true_expr, *false_expr;
5044 :
5045 150 : condition = expr->value.conditional.condition;
5046 150 : true_expr = expr->value.conditional.true_expr;
5047 150 : false_expr = expr->value.conditional.false_expr;
5048 :
5049 300 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5050 300 : || !gfc_resolve_expr (false_expr))
5051 0 : return false;
5052 :
5053 150 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5054 : {
5055 2 : gfc_error (
5056 : "Condition in conditional expression must be a scalar logical at %L",
5057 : &condition->where);
5058 2 : return false;
5059 : }
5060 :
5061 148 : if (true_expr->ts.type != false_expr->ts.type)
5062 : {
5063 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5064 : "must have the same declared type",
5065 : &true_expr->where, &false_expr->where);
5066 1 : return false;
5067 : }
5068 :
5069 147 : if (true_expr->ts.kind != false_expr->ts.kind)
5070 : {
5071 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5072 : "must have the same kind parameter",
5073 : &true_expr->where, &false_expr->where);
5074 1 : return false;
5075 : }
5076 :
5077 146 : if (true_expr->rank != false_expr->rank)
5078 : {
5079 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5080 : "must have the same rank",
5081 : &true_expr->where, &false_expr->where);
5082 1 : return false;
5083 : }
5084 :
5085 : /* TODO: support more data types for conditional expressions */
5086 145 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5087 145 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5088 55 : && true_expr->ts.type != BT_CHARACTER)
5089 : {
5090 1 : gfc_error (
5091 : "Sorry, only integer, logical, real, complex and character types are "
5092 : "currently supported for conditional expressions at %L",
5093 : &expr->where);
5094 1 : return false;
5095 : }
5096 :
5097 : /* TODO: support arrays in conditional expressions */
5098 144 : if (true_expr->rank > 0)
5099 : {
5100 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5101 : "expressions at %L",
5102 : &expr->where);
5103 1 : return false;
5104 : }
5105 :
5106 143 : expr->ts = true_expr->ts;
5107 143 : expr->rank = true_expr->rank;
5108 143 : return true;
5109 : }
5110 :
5111 : /************** Array resolution subroutines **************/
5112 :
5113 : enum compare_result
5114 : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5115 :
5116 : /* Compare two integer expressions. */
5117 :
5118 : static compare_result
5119 462519 : compare_bound (gfc_expr *a, gfc_expr *b)
5120 : {
5121 462519 : int i;
5122 :
5123 462519 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5124 303292 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5125 : return CMP_UNKNOWN;
5126 :
5127 : /* If either of the types isn't INTEGER, we must have
5128 : raised an error earlier. */
5129 :
5130 209527 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5131 : return CMP_UNKNOWN;
5132 :
5133 209523 : i = mpz_cmp (a->value.integer, b->value.integer);
5134 :
5135 209523 : if (i < 0)
5136 : return CMP_LT;
5137 98806 : if (i > 0)
5138 39239 : return CMP_GT;
5139 : return CMP_EQ;
5140 : }
5141 :
5142 :
5143 : /* Compare an integer expression with an integer. */
5144 :
5145 : static compare_result
5146 73661 : compare_bound_int (gfc_expr *a, int b)
5147 : {
5148 73661 : int i;
5149 :
5150 73661 : if (a == NULL
5151 31481 : || a->expr_type != EXPR_CONSTANT
5152 28534 : || a->ts.type != BT_INTEGER)
5153 : return CMP_UNKNOWN;
5154 :
5155 28534 : i = mpz_cmp_si (a->value.integer, b);
5156 :
5157 28534 : if (i < 0)
5158 : return CMP_LT;
5159 24492 : if (i > 0)
5160 21413 : return CMP_GT;
5161 : return CMP_EQ;
5162 : }
5163 :
5164 :
5165 : /* Compare an integer expression with a mpz_t. */
5166 :
5167 : static compare_result
5168 68349 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5169 : {
5170 68349 : int i;
5171 :
5172 68349 : if (a == NULL
5173 55719 : || a->expr_type != EXPR_CONSTANT
5174 53598 : || a->ts.type != BT_INTEGER)
5175 : return CMP_UNKNOWN;
5176 :
5177 53595 : i = mpz_cmp (a->value.integer, b);
5178 :
5179 53595 : if (i < 0)
5180 : return CMP_LT;
5181 24407 : if (i > 0)
5182 10366 : return CMP_GT;
5183 : return CMP_EQ;
5184 : }
5185 :
5186 :
5187 : /* Compute the last value of a sequence given by a triplet.
5188 : Return 0 if it wasn't able to compute the last value, or if the
5189 : sequence if empty, and 1 otherwise. */
5190 :
5191 : static int
5192 51462 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5193 : gfc_expr *stride, mpz_t last)
5194 : {
5195 51462 : mpz_t rem;
5196 :
5197 51462 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5198 36413 : || end == NULL || end->expr_type != EXPR_CONSTANT
5199 31818 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5200 : return 0;
5201 :
5202 31499 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5203 31498 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5204 : return 0;
5205 :
5206 6496 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5207 : {
5208 25128 : if (compare_bound (start, end) == CMP_GT)
5209 : return 0;
5210 23739 : mpz_set (last, end->value.integer);
5211 23739 : return 1;
5212 : }
5213 :
5214 6370 : if (compare_bound_int (stride, 0) == CMP_GT)
5215 : {
5216 : /* Stride is positive */
5217 5149 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5218 : return 0;
5219 : }
5220 : else
5221 : {
5222 : /* Stride is negative */
5223 1221 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5224 : return 0;
5225 : }
5226 :
5227 6350 : mpz_init (rem);
5228 6350 : mpz_sub (rem, end->value.integer, start->value.integer);
5229 6350 : mpz_tdiv_r (rem, rem, stride->value.integer);
5230 6350 : mpz_sub (last, end->value.integer, rem);
5231 6350 : mpz_clear (rem);
5232 :
5233 6350 : return 1;
5234 : }
5235 :
5236 :
5237 : /* Compare a single dimension of an array reference to the array
5238 : specification. */
5239 :
5240 : static bool
5241 214567 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5242 : {
5243 214567 : mpz_t last_value;
5244 :
5245 214567 : if (ar->dimen_type[i] == DIMEN_STAR)
5246 : {
5247 495 : gcc_assert (ar->stride[i] == NULL);
5248 : /* This implies [*] as [*:] and [*:3] are not possible. */
5249 495 : if (ar->start[i] == NULL)
5250 : {
5251 403 : gcc_assert (ar->end[i] == NULL);
5252 : return true;
5253 : }
5254 : }
5255 :
5256 : /* Given start, end and stride values, calculate the minimum and
5257 : maximum referenced indexes. */
5258 :
5259 214164 : switch (ar->dimen_type[i])
5260 : {
5261 : case DIMEN_VECTOR:
5262 : case DIMEN_THIS_IMAGE:
5263 : break;
5264 :
5265 154783 : case DIMEN_STAR:
5266 154783 : case DIMEN_ELEMENT:
5267 154783 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5268 : {
5269 2 : if (i < as->rank)
5270 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5271 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5272 2 : mpz_get_si (ar->start[i]->value.integer),
5273 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5274 : else
5275 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5276 : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5277 0 : mpz_get_si (ar->start[i]->value.integer),
5278 0 : mpz_get_si (as->lower[i]->value.integer),
5279 0 : i + 1 - as->rank);
5280 2 : return true;
5281 : }
5282 154781 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5283 : {
5284 39 : if (i < as->rank)
5285 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5286 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5287 39 : mpz_get_si (ar->start[i]->value.integer),
5288 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5289 : else
5290 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5291 : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5292 0 : mpz_get_si (ar->start[i]->value.integer),
5293 0 : mpz_get_si (as->upper[i]->value.integer),
5294 0 : i + 1 - as->rank);
5295 39 : return true;
5296 : }
5297 :
5298 : break;
5299 :
5300 51507 : case DIMEN_RANGE:
5301 51507 : {
5302 : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5303 : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5304 :
5305 51507 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5306 51507 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5307 :
5308 : /* Check for zero stride, which is not allowed. */
5309 51507 : if (comp_stride_zero == CMP_EQ)
5310 : {
5311 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5312 1 : return false;
5313 : }
5314 :
5315 : /* if start == end || (stride > 0 && start < end)
5316 : || (stride < 0 && start > end),
5317 : then the array section contains at least one element. In this
5318 : case, there is an out-of-bounds access if
5319 : (start < lower || start > upper). */
5320 51506 : if (comp_start_end == CMP_EQ
5321 50761 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5322 48116 : && comp_start_end == CMP_LT)
5323 22572 : || (comp_stride_zero == CMP_LT
5324 22572 : && comp_start_end == CMP_GT))
5325 : {
5326 30135 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5327 : {
5328 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5329 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5330 27 : mpz_get_si (AR_START->value.integer),
5331 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5332 27 : return true;
5333 : }
5334 30108 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5335 : {
5336 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5337 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5338 17 : mpz_get_si (AR_START->value.integer),
5339 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5340 17 : return true;
5341 : }
5342 : }
5343 :
5344 : /* If we can compute the highest index of the array section,
5345 : then it also has to be between lower and upper. */
5346 51462 : mpz_init (last_value);
5347 51462 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5348 : last_value))
5349 : {
5350 30089 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5351 : {
5352 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5353 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5354 : mpz_get_si (last_value),
5355 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5356 3 : mpz_clear (last_value);
5357 3 : return true;
5358 : }
5359 30086 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5360 : {
5361 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5362 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5363 : mpz_get_si (last_value),
5364 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5365 7 : mpz_clear (last_value);
5366 7 : return true;
5367 : }
5368 : }
5369 51452 : mpz_clear (last_value);
5370 :
5371 : #undef AR_START
5372 : #undef AR_END
5373 : }
5374 51452 : break;
5375 :
5376 0 : default:
5377 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5378 : }
5379 :
5380 : return true;
5381 : }
5382 :
5383 :
5384 : /* Compare an array reference with an array specification. */
5385 :
5386 : static bool
5387 421716 : compare_spec_to_ref (gfc_array_ref *ar)
5388 : {
5389 421716 : gfc_array_spec *as;
5390 421716 : int i;
5391 :
5392 421716 : as = ar->as;
5393 421716 : i = as->rank - 1;
5394 : /* TODO: Full array sections are only allowed as actual parameters. */
5395 421716 : if (as->type == AS_ASSUMED_SIZE
5396 5768 : && (/*ar->type == AR_FULL
5397 5768 : ||*/ (ar->type == AR_SECTION
5398 514 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5399 : {
5400 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5401 : "not specified at %L", &ar->where);
5402 5 : return false;
5403 : }
5404 :
5405 421711 : if (ar->type == AR_FULL)
5406 : return true;
5407 :
5408 162592 : if (as->rank != ar->dimen)
5409 : {
5410 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5411 : &ar->where, ar->dimen, as->rank);
5412 28 : return false;
5413 : }
5414 :
5415 : /* ar->codimen == 0 is a local array. */
5416 162564 : if (as->corank != ar->codimen && ar->codimen != 0)
5417 : {
5418 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5419 : &ar->where, ar->codimen, as->corank);
5420 0 : return false;
5421 : }
5422 :
5423 367344 : for (i = 0; i < as->rank; i++)
5424 204781 : if (!check_dimension (i, ar, as))
5425 : return false;
5426 :
5427 : /* Local access has no coarray spec. */
5428 162563 : if (ar->codimen != 0)
5429 18814 : for (i = as->rank; i < as->rank + as->corank; i++)
5430 : {
5431 9788 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5432 6816 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5433 : {
5434 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5435 2 : i + 1 - as->rank, &ar->where);
5436 2 : return false;
5437 : }
5438 9786 : if (!check_dimension (i, ar, as))
5439 : return false;
5440 : }
5441 :
5442 : return true;
5443 : }
5444 :
5445 :
5446 : /* Resolve one part of an array index. */
5447 :
5448 : static bool
5449 728276 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5450 : int force_index_integer_kind)
5451 : {
5452 728276 : gfc_typespec ts;
5453 :
5454 728276 : if (index == NULL)
5455 : return true;
5456 :
5457 215511 : if (!gfc_resolve_expr (index))
5458 : return false;
5459 :
5460 215488 : if (check_scalar && index->rank != 0)
5461 : {
5462 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5463 2 : return false;
5464 : }
5465 :
5466 215486 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5467 : {
5468 4 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5469 : &index->where, gfc_basic_typename (index->ts.type));
5470 4 : return false;
5471 : }
5472 :
5473 215482 : if (index->ts.type == BT_REAL)
5474 336 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5475 : &index->where))
5476 : return false;
5477 :
5478 215482 : if ((index->ts.kind != gfc_index_integer_kind
5479 210706 : && force_index_integer_kind)
5480 184721 : || (index->ts.type != BT_INTEGER
5481 : && index->ts.type != BT_UNKNOWN))
5482 : {
5483 31096 : gfc_clear_ts (&ts);
5484 31096 : ts.type = BT_INTEGER;
5485 31096 : ts.kind = gfc_index_integer_kind;
5486 :
5487 31096 : gfc_convert_type_warn (index, &ts, 2, 0);
5488 : }
5489 :
5490 : return true;
5491 : }
5492 :
5493 : /* Resolve one part of an array index. */
5494 :
5495 : bool
5496 485735 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5497 : {
5498 485735 : return gfc_resolve_index_1 (index, check_scalar, 1);
5499 : }
5500 :
5501 : /* Resolve a dim argument to an intrinsic function. */
5502 :
5503 : bool
5504 23817 : gfc_resolve_dim_arg (gfc_expr *dim)
5505 : {
5506 23817 : if (dim == NULL)
5507 : return true;
5508 :
5509 23817 : if (!gfc_resolve_expr (dim))
5510 : return false;
5511 :
5512 23817 : if (dim->rank != 0)
5513 : {
5514 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5515 0 : return false;
5516 :
5517 : }
5518 :
5519 23817 : if (dim->ts.type != BT_INTEGER)
5520 : {
5521 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5522 0 : return false;
5523 : }
5524 :
5525 23817 : if (dim->ts.kind != gfc_index_integer_kind)
5526 : {
5527 15209 : gfc_typespec ts;
5528 :
5529 15209 : gfc_clear_ts (&ts);
5530 15209 : ts.type = BT_INTEGER;
5531 15209 : ts.kind = gfc_index_integer_kind;
5532 :
5533 15209 : gfc_convert_type_warn (dim, &ts, 2, 0);
5534 : }
5535 :
5536 : return true;
5537 : }
5538 :
5539 : /* Given an expression that contains array references, update those array
5540 : references to point to the right array specifications. While this is
5541 : filled in during matching, this information is difficult to save and load
5542 : in a module, so we take care of it here.
5543 :
5544 : The idea here is that the original array reference comes from the
5545 : base symbol. We traverse the list of reference structures, setting
5546 : the stored reference to references. Component references can
5547 : provide an additional array specification. */
5548 : static void
5549 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5550 :
5551 : static bool
5552 897 : find_array_spec (gfc_expr *e)
5553 : {
5554 897 : gfc_array_spec *as;
5555 897 : gfc_component *c;
5556 897 : gfc_ref *ref;
5557 897 : bool class_as = false;
5558 :
5559 897 : if (e->symtree->n.sym->assoc)
5560 : {
5561 217 : if (e->symtree->n.sym->assoc->target)
5562 217 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5563 217 : resolve_assoc_var (e->symtree->n.sym, false);
5564 : }
5565 :
5566 897 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5567 : {
5568 112 : as = CLASS_DATA (e->symtree->n.sym)->as;
5569 112 : class_as = true;
5570 : }
5571 : else
5572 785 : as = e->symtree->n.sym->as;
5573 :
5574 2034 : for (ref = e->ref; ref; ref = ref->next)
5575 1144 : switch (ref->type)
5576 : {
5577 899 : case REF_ARRAY:
5578 899 : if (as == NULL)
5579 : {
5580 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5581 14 : ? ref->u.ar.where : e->where);
5582 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5583 : &loc);
5584 7 : return false;
5585 : }
5586 :
5587 892 : ref->u.ar.as = as;
5588 892 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5589 : as = NULL;
5590 : break;
5591 :
5592 221 : case REF_COMPONENT:
5593 221 : c = ref->u.c.component;
5594 221 : if (c->attr.dimension)
5595 : {
5596 90 : if (as != NULL && !(class_as && as == c->as))
5597 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5598 90 : as = c->as;
5599 : }
5600 :
5601 : break;
5602 :
5603 : case REF_SUBSTRING:
5604 : case REF_INQUIRY:
5605 : break;
5606 : }
5607 :
5608 890 : if (as != NULL)
5609 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5610 :
5611 : return true;
5612 : }
5613 :
5614 :
5615 : /* Resolve an array reference. */
5616 :
5617 : static bool
5618 422442 : resolve_array_ref (gfc_array_ref *ar)
5619 : {
5620 422442 : int i, check_scalar;
5621 422442 : gfc_expr *e;
5622 :
5623 664954 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5624 : {
5625 242541 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5626 :
5627 : /* Do not force gfc_index_integer_kind for the start. We can
5628 : do fine with any integer kind. This avoids temporary arrays
5629 : created for indexing with a vector. */
5630 242541 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5631 : return false;
5632 242514 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5633 : return false;
5634 242512 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5635 : return false;
5636 :
5637 242512 : e = ar->start[i];
5638 :
5639 242512 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5640 144719 : switch (e->rank)
5641 : {
5642 143849 : case 0:
5643 143849 : ar->dimen_type[i] = DIMEN_ELEMENT;
5644 143849 : break;
5645 :
5646 870 : case 1:
5647 870 : ar->dimen_type[i] = DIMEN_VECTOR;
5648 870 : if (e->expr_type == EXPR_VARIABLE
5649 446 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5650 13 : ar->start[i] = gfc_get_parentheses (e);
5651 : break;
5652 :
5653 0 : default:
5654 0 : gfc_error ("Array index at %L is an array of rank %d",
5655 : &ar->c_where[i], e->rank);
5656 0 : return false;
5657 : }
5658 :
5659 : /* Fill in the upper bound, which may be lower than the
5660 : specified one for something like a(2:10:5), which is
5661 : identical to a(2:7:5). Only relevant for strides not equal
5662 : to one. Don't try a division by zero. */
5663 242512 : if (ar->dimen_type[i] == DIMEN_RANGE
5664 71152 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5665 8233 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5666 8086 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5667 : {
5668 8085 : mpz_t size, end;
5669 :
5670 8085 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5671 : {
5672 6380 : if (ar->end[i] == NULL)
5673 : {
5674 7926 : ar->end[i] =
5675 3963 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5676 : &ar->where);
5677 3963 : mpz_set (ar->end[i]->value.integer, end);
5678 : }
5679 2417 : else if (ar->end[i]->ts.type == BT_INTEGER
5680 2417 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5681 : {
5682 2417 : mpz_set (ar->end[i]->value.integer, end);
5683 : }
5684 : else
5685 0 : gcc_unreachable ();
5686 :
5687 6380 : mpz_clear (size);
5688 6380 : mpz_clear (end);
5689 : }
5690 : }
5691 : }
5692 :
5693 422413 : if (ar->type == AR_FULL)
5694 : {
5695 262554 : if (ar->as->rank == 0)
5696 3401 : ar->type = AR_ELEMENT;
5697 :
5698 : /* Make sure array is the same as array(:,:), this way
5699 : we don't need to special case all the time. */
5700 262554 : ar->dimen = ar->as->rank;
5701 627072 : for (i = 0; i < ar->dimen; i++)
5702 : {
5703 364518 : ar->dimen_type[i] = DIMEN_RANGE;
5704 :
5705 364518 : gcc_assert (ar->start[i] == NULL);
5706 364518 : gcc_assert (ar->end[i] == NULL);
5707 364518 : gcc_assert (ar->stride[i] == NULL);
5708 : }
5709 : }
5710 :
5711 : /* If the reference type is unknown, figure out what kind it is. */
5712 :
5713 422413 : if (ar->type == AR_UNKNOWN)
5714 : {
5715 147064 : ar->type = AR_ELEMENT;
5716 285306 : for (i = 0; i < ar->dimen; i++)
5717 175554 : if (ar->dimen_type[i] == DIMEN_RANGE
5718 175554 : || ar->dimen_type[i] == DIMEN_VECTOR)
5719 : {
5720 37312 : ar->type = AR_SECTION;
5721 37312 : break;
5722 : }
5723 : }
5724 :
5725 422413 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5726 : return false;
5727 :
5728 422377 : if (ar->as->corank && ar->codimen == 0)
5729 : {
5730 2074 : int n;
5731 2074 : ar->codimen = ar->as->corank;
5732 5914 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5733 3840 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5734 : }
5735 :
5736 422377 : if (ar->codimen)
5737 : {
5738 13602 : if (ar->team_type == TEAM_NUMBER)
5739 : {
5740 60 : if (!gfc_resolve_expr (ar->team))
5741 : return false;
5742 :
5743 60 : if (ar->team->rank != 0)
5744 : {
5745 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5746 : &ar->team->where);
5747 0 : return false;
5748 : }
5749 :
5750 60 : if (ar->team->ts.type != BT_INTEGER)
5751 : {
5752 6 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5753 : "type, found %s",
5754 6 : &ar->team->where,
5755 : gfc_basic_typename (ar->team->ts.type));
5756 6 : return false;
5757 : }
5758 : }
5759 13542 : else if (ar->team_type == TEAM_TEAM)
5760 : {
5761 42 : if (!gfc_resolve_expr (ar->team))
5762 : return false;
5763 :
5764 42 : if (ar->team->rank != 0)
5765 : {
5766 3 : gfc_error ("TEAM argument at %L must be scalar",
5767 : &ar->team->where);
5768 3 : return false;
5769 : }
5770 :
5771 39 : if (ar->team->ts.type != BT_DERIVED
5772 36 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5773 36 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5774 : {
5775 3 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5776 : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5777 3 : &ar->team->where,
5778 : gfc_basic_typename (ar->team->ts.type));
5779 3 : return false;
5780 : }
5781 : }
5782 13590 : if (ar->stat)
5783 : {
5784 62 : if (!gfc_resolve_expr (ar->stat))
5785 : return false;
5786 :
5787 62 : if (ar->stat->rank != 0)
5788 : {
5789 3 : gfc_error ("STAT argument at %L must be scalar",
5790 : &ar->stat->where);
5791 3 : return false;
5792 : }
5793 :
5794 59 : if (ar->stat->ts.type != BT_INTEGER)
5795 : {
5796 3 : gfc_error ("STAT argument at %L must be of INTEGER "
5797 : "type, found %s",
5798 3 : &ar->stat->where,
5799 : gfc_basic_typename (ar->stat->ts.type));
5800 3 : return false;
5801 : }
5802 :
5803 56 : if (ar->stat->expr_type != EXPR_VARIABLE)
5804 : {
5805 0 : gfc_error ("STAT's expression at %L must be a variable",
5806 : &ar->stat->where);
5807 0 : return false;
5808 : }
5809 : }
5810 : }
5811 : return true;
5812 : }
5813 :
5814 :
5815 : bool
5816 8375 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5817 : {
5818 8375 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5819 :
5820 8375 : if (ref->u.ss.start != NULL)
5821 : {
5822 8375 : if (!gfc_resolve_expr (ref->u.ss.start))
5823 : return false;
5824 :
5825 8375 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5826 : {
5827 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5828 : &ref->u.ss.start->where);
5829 1 : return false;
5830 : }
5831 :
5832 8374 : if (ref->u.ss.start->rank != 0)
5833 : {
5834 0 : gfc_error ("Substring start index at %L must be scalar",
5835 : &ref->u.ss.start->where);
5836 0 : return false;
5837 : }
5838 :
5839 8374 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5840 8374 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5841 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5842 : {
5843 1 : gfc_error ("Substring start index at %L is less than one",
5844 : &ref->u.ss.start->where);
5845 1 : return false;
5846 : }
5847 : }
5848 :
5849 8373 : if (ref->u.ss.end != NULL)
5850 : {
5851 8179 : if (!gfc_resolve_expr (ref->u.ss.end))
5852 : return false;
5853 :
5854 8179 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5855 : {
5856 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5857 : &ref->u.ss.end->where);
5858 1 : return false;
5859 : }
5860 :
5861 8178 : if (ref->u.ss.end->rank != 0)
5862 : {
5863 0 : gfc_error ("Substring end index at %L must be scalar",
5864 : &ref->u.ss.end->where);
5865 0 : return false;
5866 : }
5867 :
5868 8178 : if (ref->u.ss.length != NULL
5869 7844 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5870 8190 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5871 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5872 : {
5873 4 : gfc_error ("Substring end index at %L exceeds the string length",
5874 : &ref->u.ss.start->where);
5875 4 : return false;
5876 : }
5877 :
5878 8174 : if (compare_bound_mpz_t (ref->u.ss.end,
5879 8174 : gfc_integer_kinds[k].huge) == CMP_GT
5880 8174 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5881 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5882 : {
5883 4 : gfc_error ("Substring end index at %L is too large",
5884 : &ref->u.ss.end->where);
5885 4 : return false;
5886 : }
5887 : /* If the substring has the same length as the original
5888 : variable, the reference itself can be deleted. */
5889 :
5890 8170 : if (ref->u.ss.length != NULL
5891 7836 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5892 9084 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5893 228 : *equal_length = true;
5894 : }
5895 :
5896 : return true;
5897 : }
5898 :
5899 :
5900 : /* This function supplies missing substring charlens. */
5901 :
5902 : void
5903 4562 : gfc_resolve_substring_charlen (gfc_expr *e)
5904 : {
5905 4562 : gfc_ref *char_ref;
5906 4562 : gfc_expr *start, *end;
5907 4562 : gfc_typespec *ts = NULL;
5908 4562 : mpz_t diff;
5909 :
5910 8886 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5911 : {
5912 7040 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5913 : break;
5914 4324 : if (char_ref->type == REF_COMPONENT)
5915 328 : ts = &char_ref->u.c.component->ts;
5916 : }
5917 :
5918 4562 : if (!char_ref || char_ref->type == REF_INQUIRY)
5919 1908 : return;
5920 :
5921 2716 : gcc_assert (char_ref->next == NULL);
5922 :
5923 2716 : if (e->ts.u.cl)
5924 : {
5925 120 : if (e->ts.u.cl->length)
5926 108 : gfc_free_expr (e->ts.u.cl->length);
5927 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5928 : return;
5929 : }
5930 :
5931 2704 : if (!e->ts.u.cl)
5932 2596 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5933 :
5934 2704 : if (char_ref->u.ss.start)
5935 2704 : start = gfc_copy_expr (char_ref->u.ss.start);
5936 : else
5937 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5938 :
5939 2704 : if (char_ref->u.ss.end)
5940 2654 : end = gfc_copy_expr (char_ref->u.ss.end);
5941 50 : else if (e->expr_type == EXPR_VARIABLE)
5942 : {
5943 50 : if (!ts)
5944 32 : ts = &e->symtree->n.sym->ts;
5945 50 : end = gfc_copy_expr (ts->u.cl->length);
5946 : }
5947 : else
5948 : end = NULL;
5949 :
5950 2704 : if (!start || !end)
5951 : {
5952 50 : gfc_free_expr (start);
5953 50 : gfc_free_expr (end);
5954 50 : return;
5955 : }
5956 :
5957 : /* Length = (end - start + 1).
5958 : Check first whether it has a constant length. */
5959 2654 : if (gfc_dep_difference (end, start, &diff))
5960 : {
5961 2539 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5962 : &e->where);
5963 :
5964 2539 : mpz_add_ui (len->value.integer, diff, 1);
5965 2539 : mpz_clear (diff);
5966 2539 : e->ts.u.cl->length = len;
5967 : /* The check for length < 0 is handled below */
5968 : }
5969 : else
5970 : {
5971 115 : e->ts.u.cl->length = gfc_subtract (end, start);
5972 115 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5973 : gfc_get_int_expr (gfc_charlen_int_kind,
5974 : NULL, 1));
5975 : }
5976 :
5977 : /* F2008, 6.4.1: Both the starting point and the ending point shall
5978 : be within the range 1, 2, ..., n unless the starting point exceeds
5979 : the ending point, in which case the substring has length zero. */
5980 :
5981 2654 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5982 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5983 :
5984 2654 : e->ts.u.cl->length->ts.type = BT_INTEGER;
5985 2654 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5986 :
5987 : /* Make sure that the length is simplified. */
5988 2654 : gfc_simplify_expr (e->ts.u.cl->length, 1);
5989 2654 : gfc_resolve_expr (e->ts.u.cl->length);
5990 : }
5991 :
5992 :
5993 : /* Convert an array reference to an array element so that PDT KIND and LEN
5994 : or inquiry references are always scalar. */
5995 :
5996 : static void
5997 21 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
5998 : {
5999 21 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6000 21 : int dim;
6001 :
6002 21 : array_ref->u.ar.type = AR_ELEMENT;
6003 21 : expr->rank = 0;
6004 : /* Suppress the runtime bounds check. */
6005 21 : expr->no_bounds_check = 1;
6006 42 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
6007 : {
6008 21 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
6009 21 : if (array_ref->u.ar.start[dim])
6010 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
6011 :
6012 21 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
6013 9 : array_ref->u.ar.start[dim]
6014 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
6015 : else
6016 12 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
6017 :
6018 21 : if (array_ref->u.ar.end[dim])
6019 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
6020 21 : if (array_ref->u.ar.stride[dim])
6021 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
6022 : }
6023 21 : gfc_free_expr (unity);
6024 21 : }
6025 :
6026 :
6027 : /* Resolve subtype references. */
6028 :
6029 : bool
6030 537238 : gfc_resolve_ref (gfc_expr *expr)
6031 : {
6032 537238 : int current_part_dimension, n_components, seen_part_dimension;
6033 537238 : gfc_ref *ref, **prev, *array_ref;
6034 537238 : bool equal_length;
6035 537238 : gfc_symbol *last_pdt = NULL;
6036 :
6037 1054711 : for (ref = expr->ref; ref; ref = ref->next)
6038 518370 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6039 : {
6040 897 : if (!find_array_spec (expr))
6041 : return false;
6042 : break;
6043 : }
6044 :
6045 1573876 : for (prev = &expr->ref; *prev != NULL;
6046 518424 : prev = *prev == NULL ? prev : &(*prev)->next)
6047 518515 : switch ((*prev)->type)
6048 : {
6049 422442 : case REF_ARRAY:
6050 422442 : if (!resolve_array_ref (&(*prev)->u.ar))
6051 : return false;
6052 : break;
6053 :
6054 : case REF_COMPONENT:
6055 : case REF_INQUIRY:
6056 : break;
6057 :
6058 8094 : case REF_SUBSTRING:
6059 8094 : equal_length = false;
6060 8094 : if (!gfc_resolve_substring (*prev, &equal_length))
6061 : return false;
6062 :
6063 8086 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6064 : {
6065 : /* Remove the reference and move the charlen, if any. */
6066 203 : ref = *prev;
6067 203 : *prev = ref->next;
6068 203 : ref->next = NULL;
6069 203 : expr->ts.u.cl = ref->u.ss.length;
6070 203 : ref->u.ss.length = NULL;
6071 203 : gfc_free_ref_list (ref);
6072 : }
6073 : break;
6074 : }
6075 :
6076 : /* Check constraints on part references. */
6077 :
6078 537140 : current_part_dimension = 0;
6079 537140 : seen_part_dimension = 0;
6080 537140 : n_components = 0;
6081 537140 : array_ref = NULL;
6082 :
6083 537140 : if (expr->expr_type == EXPR_VARIABLE && IS_PDT (expr))
6084 388 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6085 :
6086 1055336 : for (ref = expr->ref; ref; ref = ref->next)
6087 : {
6088 518207 : switch (ref->type)
6089 : {
6090 422352 : case REF_ARRAY:
6091 422352 : array_ref = ref;
6092 422352 : switch (ref->u.ar.type)
6093 : {
6094 259151 : case AR_FULL:
6095 : /* Coarray scalar. */
6096 259151 : if (ref->u.ar.as->rank == 0)
6097 : {
6098 : current_part_dimension = 0;
6099 : break;
6100 : }
6101 : /* Fall through. */
6102 299282 : case AR_SECTION:
6103 299282 : current_part_dimension = 1;
6104 299282 : break;
6105 :
6106 123070 : case AR_ELEMENT:
6107 123070 : array_ref = NULL;
6108 123070 : current_part_dimension = 0;
6109 123070 : break;
6110 :
6111 0 : case AR_UNKNOWN:
6112 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6113 : }
6114 :
6115 : break;
6116 :
6117 87175 : case REF_COMPONENT:
6118 87175 : if (current_part_dimension || seen_part_dimension)
6119 : {
6120 : /* F03:C614. */
6121 6282 : if (ref->u.c.component->attr.pointer
6122 6279 : || ref->u.c.component->attr.proc_pointer
6123 6278 : || (ref->u.c.component->ts.type == BT_CLASS
6124 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6125 : {
6126 4 : gfc_error ("Component to the right of a part reference "
6127 : "with nonzero rank must not have the POINTER "
6128 : "attribute at %L", &expr->where);
6129 4 : return false;
6130 : }
6131 6278 : else if (ref->u.c.component->attr.allocatable
6132 6272 : || (ref->u.c.component->ts.type == BT_CLASS
6133 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6134 :
6135 : {
6136 7 : gfc_error ("Component to the right of a part reference "
6137 : "with nonzero rank must not have the ALLOCATABLE "
6138 : "attribute at %L", &expr->where);
6139 7 : return false;
6140 : }
6141 : }
6142 :
6143 : /* Sometimes the component in a component reference is that of the
6144 : pdt_template. Point to the component of pdt_type instead. This
6145 : ensures that the component gets a backend_decl in translation. */
6146 87164 : if (last_pdt)
6147 : {
6148 467 : gfc_component *cmp = last_pdt->components;
6149 1130 : for (; cmp; cmp = cmp->next)
6150 1125 : if (!strcmp (cmp->name, ref->u.c.component->name))
6151 : {
6152 462 : ref->u.c.component = cmp;
6153 462 : break;
6154 : }
6155 467 : ref->u.c.sym = last_pdt;
6156 : }
6157 :
6158 : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6159 87164 : if (ref->u.c.component->ts.type == BT_DERIVED)
6160 : {
6161 20497 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6162 : {
6163 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6164 : &ref->u.c.component->ts.u.derived,
6165 : NULL) != MATCH_YES)
6166 : return false;
6167 0 : last_pdt = ref->u.c.component->ts.u.derived;
6168 : }
6169 20497 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6170 487 : last_pdt = ref->u.c.component->ts.u.derived;
6171 : else
6172 : last_pdt = NULL;
6173 : }
6174 :
6175 : /* The F08 standard requires(See R425, R431, R435, and in particular
6176 : Note 6.7) that a PDT parameter reference be a scalar even if
6177 : the designator is an array." */
6178 87164 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6179 83 : && (ref->u.c.component->attr.pdt_kind
6180 83 : || ref->u.c.component->attr.pdt_len))
6181 7 : reset_array_ref_to_scalar (expr, array_ref);
6182 :
6183 87164 : n_components++;
6184 87164 : break;
6185 :
6186 : case REF_SUBSTRING:
6187 : break;
6188 :
6189 797 : case REF_INQUIRY:
6190 : /* Implement requirement in note 9.7 of F2018 that the result of the
6191 : LEN inquiry be a scalar. */
6192 797 : if (ref->u.i == INQUIRY_LEN && array_ref
6193 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6194 40 : || expr->ts.type == BT_INTEGER))
6195 14 : reset_array_ref_to_scalar (expr, array_ref);
6196 : break;
6197 : }
6198 :
6199 518196 : if (((ref->type == REF_COMPONENT && n_components > 1)
6200 505088 : || ref->next == NULL)
6201 : && current_part_dimension
6202 455405 : && seen_part_dimension)
6203 : {
6204 0 : gfc_error ("Two or more part references with nonzero rank must "
6205 : "not be specified at %L", &expr->where);
6206 0 : return false;
6207 : }
6208 :
6209 518196 : if (ref->type == REF_COMPONENT)
6210 : {
6211 87164 : if (current_part_dimension)
6212 6084 : seen_part_dimension = 1;
6213 :
6214 : /* reset to make sure */
6215 : current_part_dimension = 0;
6216 : }
6217 : }
6218 :
6219 : return true;
6220 : }
6221 :
6222 :
6223 : /* Given an expression, determine its shape. This is easier than it sounds.
6224 : Leaves the shape array NULL if it is not possible to determine the shape. */
6225 :
6226 : static void
6227 2582574 : expression_shape (gfc_expr *e)
6228 : {
6229 2582574 : mpz_t array[GFC_MAX_DIMENSIONS];
6230 2582574 : int i;
6231 :
6232 2582574 : if (e->rank <= 0 || e->shape != NULL)
6233 2408728 : return;
6234 :
6235 697080 : for (i = 0; i < e->rank; i++)
6236 471032 : if (!gfc_array_dimen_size (e, i, &array[i]))
6237 173846 : goto fail;
6238 :
6239 226048 : e->shape = gfc_get_shape (e->rank);
6240 :
6241 226048 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6242 :
6243 226048 : return;
6244 :
6245 173846 : fail:
6246 175517 : for (i--; i >= 0; i--)
6247 1671 : mpz_clear (array[i]);
6248 : }
6249 :
6250 :
6251 : /* Given a variable expression node, compute the rank of the expression by
6252 : examining the base symbol and any reference structures it may have. */
6253 :
6254 : void
6255 2582574 : gfc_expression_rank (gfc_expr *e)
6256 : {
6257 2582574 : gfc_ref *ref, *last_arr_ref = nullptr;
6258 2582574 : int i, rank, corank;
6259 :
6260 : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6261 : could lead to serious confusion... */
6262 2582574 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6263 :
6264 2582574 : if (e->ref == NULL)
6265 : {
6266 1906675 : if (e->expr_type == EXPR_ARRAY)
6267 70650 : goto done;
6268 : /* Constructors can have a rank different from one via RESHAPE(). */
6269 :
6270 1836025 : if (e->symtree != NULL)
6271 : {
6272 : /* After errors the ts.u.derived of a CLASS might not be set. */
6273 1836013 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6274 13779 : && e->symtree->n.sym->ts.u.derived
6275 13774 : && CLASS_DATA (e->symtree->n.sym))
6276 1836013 : ? CLASS_DATA (e->symtree->n.sym)->as
6277 : : e->symtree->n.sym->as;
6278 1836013 : if (as)
6279 : {
6280 589 : e->rank = as->rank;
6281 589 : e->corank = as->corank;
6282 589 : goto done;
6283 : }
6284 : }
6285 1835436 : e->rank = 0;
6286 1835436 : e->corank = 0;
6287 1835436 : goto done;
6288 : }
6289 :
6290 : rank = 0;
6291 : corank = 0;
6292 :
6293 1067086 : for (ref = e->ref; ref; ref = ref->next)
6294 : {
6295 779548 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6296 552 : && ref->u.c.component->attr.function && !ref->next)
6297 : {
6298 357 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6299 357 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6300 : }
6301 :
6302 779548 : if (ref->type != REF_ARRAY)
6303 154219 : continue;
6304 :
6305 625329 : last_arr_ref = ref;
6306 625329 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6307 : {
6308 343610 : rank = ref->u.ar.as->rank;
6309 343610 : break;
6310 : }
6311 :
6312 281719 : if (ref->u.ar.type == AR_SECTION)
6313 : {
6314 : /* Figure out the rank of the section. */
6315 44751 : if (rank != 0)
6316 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6317 :
6318 111976 : for (i = 0; i < ref->u.ar.dimen; i++)
6319 67225 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6320 67225 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6321 58543 : rank++;
6322 :
6323 : break;
6324 : }
6325 : }
6326 675899 : if (last_arr_ref && last_arr_ref->u.ar.as
6327 606360 : && last_arr_ref->u.ar.as->rank != -1)
6328 : {
6329 19260 : for (i = last_arr_ref->u.ar.as->rank;
6330 617524 : i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
6331 : {
6332 : /* For unknown dimen in non-resolved as assume full corank. */
6333 20147 : if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
6334 19583 : || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6335 323 : && !last_arr_ref->u.ar.as->resolved))
6336 : {
6337 : corank = last_arr_ref->u.ar.as->corank;
6338 : break;
6339 : }
6340 19260 : else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6341 19260 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6342 19162 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6343 16672 : corank++;
6344 2588 : else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6345 0 : gfc_internal_error ("Illegal coarray index");
6346 : }
6347 : }
6348 :
6349 675899 : e->rank = rank;
6350 675899 : e->corank = corank;
6351 :
6352 2582574 : done:
6353 2582574 : expression_shape (e);
6354 2582574 : }
6355 :
6356 :
6357 : /* Given two expressions, check that their rank is conformable, i.e. either
6358 : both have the same rank or at least one is a scalar. */
6359 :
6360 : bool
6361 12195678 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6362 : {
6363 12195678 : if (op1->expr_type == EXPR_VARIABLE)
6364 729632 : gfc_expression_rank (op1);
6365 12195678 : if (op2->expr_type == EXPR_VARIABLE)
6366 445910 : gfc_expression_rank (op2);
6367 :
6368 75657 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6369 12271009 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6370 30 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6371 : }
6372 :
6373 : /* Resolve a variable expression. */
6374 :
6375 : static bool
6376 1317846 : resolve_variable (gfc_expr *e)
6377 : {
6378 1317846 : gfc_symbol *sym;
6379 1317846 : bool t;
6380 :
6381 1317846 : t = true;
6382 :
6383 1317846 : if (e->symtree == NULL)
6384 : return false;
6385 1317401 : sym = e->symtree->n.sym;
6386 :
6387 : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6388 : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6389 1317401 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6390 : {
6391 183 : if (!actual_arg || inquiry_argument)
6392 : {
6393 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6394 : "be used as actual argument", sym->name, &e->where);
6395 2 : return false;
6396 : }
6397 : }
6398 : /* TS 29113, 407b. */
6399 1317218 : else if (e->ts.type == BT_ASSUMED)
6400 : {
6401 571 : if (!actual_arg)
6402 : {
6403 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6404 : "as actual argument", sym->name, &e->where);
6405 20 : return false;
6406 : }
6407 551 : else if (inquiry_argument && !first_actual_arg)
6408 : {
6409 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6410 : for all inquiry functions in resolve_function; the reason is
6411 : that the function-name resolution happens too late in that
6412 : function. */
6413 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6414 : "an inquiry function shall be the first argument",
6415 : sym->name, &e->where);
6416 0 : return false;
6417 : }
6418 : }
6419 : /* TS 29113, C535b. */
6420 1316647 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6421 36674 : && sym->ts.u.derived && CLASS_DATA (sym)
6422 36669 : && CLASS_DATA (sym)->as
6423 14180 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6424 1315737 : || (sym->ts.type != BT_CLASS && sym->as
6425 360314 : && sym->as->type == AS_ASSUMED_RANK))
6426 7888 : && !sym->attr.select_rank_temporary
6427 7888 : && !(sym->assoc && sym->assoc->ar))
6428 : {
6429 7888 : if (!actual_arg
6430 1247 : && !(cs_base && cs_base->current
6431 1246 : && (cs_base->current->op == EXEC_SELECT_RANK
6432 188 : || sym->attr.target)))
6433 : {
6434 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6435 : "actual argument", sym->name, &e->where);
6436 144 : return false;
6437 : }
6438 7744 : else if (inquiry_argument && !first_actual_arg)
6439 : {
6440 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6441 : for all inquiry functions in resolve_function; the reason is
6442 : that the function-name resolution happens too late in that
6443 : function. */
6444 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6445 : "to an inquiry function shall be the first argument",
6446 : sym->name, &e->where);
6447 0 : return false;
6448 : }
6449 : }
6450 :
6451 1317235 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6452 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6453 180 : && e->ref->next == NULL))
6454 : {
6455 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6456 : "a subobject reference", sym->name, &e->ref->u.ar.where);
6457 1 : return false;
6458 : }
6459 : /* TS 29113, 407b. */
6460 1317234 : else if (e->ts.type == BT_ASSUMED && e->ref
6461 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6462 680 : && e->ref->next == NULL))
6463 : {
6464 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6465 : "reference", sym->name, &e->ref->u.ar.where);
6466 7 : return false;
6467 : }
6468 :
6469 : /* TS 29113, C535b. */
6470 1317227 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6471 36674 : && sym->ts.u.derived && CLASS_DATA (sym)
6472 36669 : && CLASS_DATA (sym)->as
6473 14180 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6474 1316317 : || (sym->ts.type != BT_CLASS && sym->as
6475 360850 : && sym->as->type == AS_ASSUMED_RANK))
6476 8028 : && !(sym->assoc && sym->assoc->ar)
6477 8028 : && e->ref
6478 8028 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6479 8024 : && e->ref->next == NULL))
6480 : {
6481 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6482 : "reference", sym->name, &e->ref->u.ar.where);
6483 4 : return false;
6484 : }
6485 :
6486 : /* Guessed type variables are associate_names whose selector had not been
6487 : parsed at the time that the construct was parsed. Now the namespace is
6488 : being resolved, the TKR of the selector will be available for fixup of
6489 : the associate_name. */
6490 1317223 : if (IS_INFERRED_TYPE (e) && e->ref)
6491 : {
6492 384 : gfc_fixup_inferred_type_refs (e);
6493 : /* KIND inquiry ref returns the kind of the target. */
6494 384 : if (e->expr_type == EXPR_CONSTANT)
6495 : return true;
6496 : }
6497 1316839 : else if (sym->attr.select_type_temporary
6498 8906 : && sym->ns->assoc_name_inferred)
6499 92 : gfc_fixup_inferred_type_refs (e);
6500 :
6501 : /* For variables that are used in an associate (target => object) where
6502 : the object's basetype is array valued while the target is scalar,
6503 : the ts' type of the component refs is still array valued, which
6504 : can't be translated that way. */
6505 1317211 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6506 585 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6507 585 : && sym->assoc->target->ts.u.derived
6508 585 : && CLASS_DATA (sym->assoc->target)
6509 585 : && CLASS_DATA (sym->assoc->target)->as)
6510 : {
6511 : gfc_ref *ref = e->ref;
6512 661 : while (ref)
6513 : {
6514 503 : switch (ref->type)
6515 : {
6516 218 : case REF_COMPONENT:
6517 218 : ref->u.c.sym = sym->ts.u.derived;
6518 : /* Stop the loop. */
6519 218 : ref = NULL;
6520 218 : break;
6521 285 : default:
6522 285 : ref = ref->next;
6523 285 : break;
6524 : }
6525 : }
6526 : }
6527 :
6528 : /* If this is an associate-name, it may be parsed with an array reference
6529 : in error even though the target is scalar. Fail directly in this case.
6530 : TODO Understand why class scalar expressions must be excluded. */
6531 1317211 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6532 : {
6533 11378 : if (sym->ts.type == BT_CLASS)
6534 242 : gfc_fix_class_refs (e);
6535 11378 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6536 2085 : && e->ref->type == REF_ARRAY)
6537 : {
6538 : /* Unambiguously scalar! */
6539 3 : if (sym->assoc->target
6540 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6541 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6542 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6543 : sym->name, &e->where);
6544 3 : return false;
6545 : }
6546 11375 : else if ((sym->attr.dimension || sym->attr.codimension)
6547 6964 : && (!e->ref || e->ref->type != REF_ARRAY))
6548 : {
6549 : /* This can happen because the parser did not detect that the
6550 : associate name is an array and the expression had no array
6551 : part_ref. */
6552 146 : gfc_ref *ref = gfc_get_ref ();
6553 146 : ref->type = REF_ARRAY;
6554 146 : ref->u.ar.type = AR_FULL;
6555 146 : if (sym->as)
6556 : {
6557 145 : ref->u.ar.as = sym->as;
6558 145 : ref->u.ar.dimen = sym->as->rank;
6559 : }
6560 146 : ref->next = e->ref;
6561 146 : e->ref = ref;
6562 : }
6563 : }
6564 :
6565 1317208 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6566 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6567 :
6568 : /* On the other hand, the parser may not have known this is an array;
6569 : in this case, we have to add a FULL reference. */
6570 1317208 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6571 : {
6572 0 : e->ref = gfc_get_ref ();
6573 0 : e->ref->type = REF_ARRAY;
6574 0 : e->ref->u.ar.type = AR_FULL;
6575 0 : e->ref->u.ar.dimen = 0;
6576 : }
6577 :
6578 : /* Like above, but for class types, where the checking whether an array
6579 : ref is present is more complicated. Furthermore make sure not to add
6580 : the full array ref to _vptr or _len refs. */
6581 1317208 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6582 994 : && CLASS_DATA (sym)
6583 994 : && (CLASS_DATA (sym)->attr.dimension
6584 443 : || CLASS_DATA (sym)->attr.codimension)
6585 557 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6586 : {
6587 533 : gfc_ref *ref, *newref;
6588 :
6589 533 : newref = gfc_get_ref ();
6590 533 : newref->type = REF_ARRAY;
6591 533 : newref->u.ar.type = AR_FULL;
6592 533 : newref->u.ar.dimen = 0;
6593 :
6594 : /* Because this is an associate var and the first ref either is a ref to
6595 : the _data component or not, no traversal of the ref chain is
6596 : needed. The array ref needs to be inserted after the _data ref,
6597 : or when that is not present, which may happened for polymorphic
6598 : types, then at the first position. */
6599 533 : ref = e->ref;
6600 533 : if (!ref)
6601 18 : e->ref = newref;
6602 515 : else if (ref->type == REF_COMPONENT
6603 230 : && strcmp ("_data", ref->u.c.component->name) == 0)
6604 : {
6605 230 : if (!ref->next || ref->next->type != REF_ARRAY)
6606 : {
6607 12 : newref->next = ref->next;
6608 12 : ref->next = newref;
6609 : }
6610 : else
6611 : /* Array ref present already. */
6612 218 : gfc_free_ref_list (newref);
6613 : }
6614 285 : else if (ref->type == REF_ARRAY)
6615 : /* Array ref present already. */
6616 285 : gfc_free_ref_list (newref);
6617 : else
6618 : {
6619 0 : newref->next = ref;
6620 0 : e->ref = newref;
6621 : }
6622 : }
6623 1316675 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6624 : {
6625 485 : gfc_ref *ref;
6626 908 : for (ref = e->ref; ref; ref = ref->next)
6627 453 : if (ref->type == REF_SUBSTRING)
6628 : break;
6629 485 : if (ref == NULL)
6630 455 : e->ts = sym->ts;
6631 : }
6632 :
6633 1317208 : if (e->ref && !gfc_resolve_ref (e))
6634 : return false;
6635 :
6636 1317115 : if (sym->attr.flavor == FL_PROCEDURE
6637 31103 : && (!sym->attr.function
6638 18223 : || (sym->attr.function && sym->result
6639 17775 : && sym->result->attr.proc_pointer
6640 562 : && !sym->result->attr.function)))
6641 : {
6642 12880 : e->ts.type = BT_PROCEDURE;
6643 12880 : goto resolve_procedure;
6644 : }
6645 :
6646 1304235 : if (sym->ts.type != BT_UNKNOWN)
6647 1303592 : gfc_variable_attr (e, &e->ts);
6648 643 : else if (sym->attr.flavor == FL_PROCEDURE
6649 12 : && sym->attr.function && sym->result
6650 12 : && sym->result->ts.type != BT_UNKNOWN
6651 10 : && sym->result->attr.proc_pointer)
6652 10 : e->ts = sym->result->ts;
6653 : else
6654 : {
6655 : /* Must be a simple variable reference. */
6656 633 : if (!gfc_set_default_type (sym, 1, sym->ns))
6657 : return false;
6658 507 : e->ts = sym->ts;
6659 : }
6660 :
6661 1304109 : if (check_assumed_size_reference (sym, e))
6662 : return false;
6663 :
6664 : /* Deal with forward references to entries during gfc_resolve_code, to
6665 : satisfy, at least partially, 12.5.2.5. */
6666 1304090 : if (gfc_current_ns->entries
6667 3060 : && current_entry_id == sym->entry_id
6668 1000 : && cs_base
6669 914 : && cs_base->current
6670 914 : && cs_base->current->op != EXEC_ENTRY)
6671 : {
6672 914 : gfc_entry_list *entry;
6673 914 : gfc_formal_arglist *formal;
6674 914 : int n;
6675 914 : bool seen, saved_specification_expr;
6676 :
6677 : /* If the symbol is a dummy... */
6678 914 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6679 : {
6680 : entry = gfc_current_ns->entries;
6681 : seen = false;
6682 :
6683 : /* ...test if the symbol is a parameter of previous entries. */
6684 1033 : for (; entry && entry->id <= current_entry_id; entry = entry->next)
6685 1006 : for (formal = entry->sym->formal; formal; formal = formal->next)
6686 : {
6687 997 : if (formal->sym && sym->name == formal->sym->name)
6688 : {
6689 : seen = true;
6690 : break;
6691 : }
6692 : }
6693 :
6694 : /* If it has not been seen as a dummy, this is an error. */
6695 453 : if (!seen)
6696 : {
6697 3 : if (specification_expr)
6698 2 : gfc_error ("Variable %qs, used in a specification expression"
6699 : ", is referenced at %L before the ENTRY statement "
6700 : "in which it is a parameter",
6701 : sym->name, &cs_base->current->loc);
6702 : else
6703 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6704 : "statement in which it is a parameter",
6705 : sym->name, &cs_base->current->loc);
6706 : t = false;
6707 : }
6708 : }
6709 :
6710 : /* Now do the same check on the specification expressions. */
6711 914 : saved_specification_expr = specification_expr;
6712 914 : specification_expr = true;
6713 914 : if (sym->ts.type == BT_CHARACTER
6714 914 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6715 : t = false;
6716 :
6717 914 : if (sym->as)
6718 : {
6719 271 : for (n = 0; n < sym->as->rank; n++)
6720 : {
6721 159 : if (!gfc_resolve_expr (sym->as->lower[n]))
6722 0 : t = false;
6723 159 : if (!gfc_resolve_expr (sym->as->upper[n]))
6724 1 : t = false;
6725 : }
6726 : }
6727 914 : specification_expr = saved_specification_expr;
6728 :
6729 914 : if (t)
6730 : /* Update the symbol's entry level. */
6731 909 : sym->entry_id = current_entry_id + 1;
6732 : }
6733 :
6734 : /* If a symbol has been host_associated mark it. This is used latter,
6735 : to identify if aliasing is possible via host association. */
6736 1304090 : if (sym->attr.flavor == FL_VARIABLE
6737 1266352 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6738 6034 : || !sym->ns->code->ext.block.assoc)
6739 1264382 : && gfc_current_ns->parent
6740 601099 : && (gfc_current_ns->parent == sym->ns
6741 563385 : || (gfc_current_ns->parent->parent
6742 11264 : && gfc_current_ns->parent->parent == sym->ns)))
6743 44332 : sym->attr.host_assoc = 1;
6744 :
6745 1304090 : if (gfc_current_ns->proc_name
6746 1300047 : && sym->attr.dimension
6747 354332 : && (sym->ns != gfc_current_ns
6748 330233 : || sym->attr.use_assoc
6749 326253 : || sym->attr.in_common))
6750 32867 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6751 :
6752 1316970 : resolve_procedure:
6753 1316970 : if (t && !resolve_procedure_expression (e))
6754 : t = false;
6755 :
6756 : /* F2008, C617 and C1229. */
6757 1315942 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6758 1413233 : && gfc_is_coindexed (e))
6759 : {
6760 356 : gfc_ref *ref, *ref2 = NULL;
6761 :
6762 439 : for (ref = e->ref; ref; ref = ref->next)
6763 : {
6764 439 : if (ref->type == REF_COMPONENT)
6765 83 : ref2 = ref;
6766 439 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6767 : break;
6768 : }
6769 :
6770 712 : for ( ; ref; ref = ref->next)
6771 368 : if (ref->type == REF_COMPONENT)
6772 : break;
6773 :
6774 : /* Expression itself is not coindexed object. */
6775 356 : if (ref && e->ts.type == BT_CLASS)
6776 : {
6777 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6778 : &e->where);
6779 3 : t = false;
6780 : }
6781 :
6782 : /* Expression itself is coindexed object. */
6783 344 : if (ref == NULL)
6784 : {
6785 344 : gfc_component *c;
6786 344 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6787 464 : for ( ; c; c = c->next)
6788 120 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6789 : {
6790 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6791 : "subcomponent at %L", &e->where);
6792 0 : t = false;
6793 0 : break;
6794 : }
6795 : }
6796 : }
6797 :
6798 1316970 : if (t)
6799 1316962 : gfc_expression_rank (e);
6800 :
6801 1316970 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6802 3 : gfc_warning (OPT_Wdeprecated_declarations,
6803 : "Using variable %qs at %L is deprecated",
6804 : sym->name, &e->where);
6805 : /* Simplify cases where access to a parameter array results in a
6806 : single constant. Suppress errors since those will have been
6807 : issued before, as warnings. */
6808 1316970 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6809 : {
6810 2726 : gfc_push_suppress_errors ();
6811 2726 : gfc_simplify_expr (e, 1);
6812 2726 : gfc_pop_suppress_errors ();
6813 : }
6814 :
6815 : return t;
6816 : }
6817 :
6818 :
6819 : /* 'sym' was initially guessed to be derived type but has been corrected
6820 : in resolve_assoc_var to be a class entity or the derived type correcting.
6821 : If a class entity it will certainly need the _data reference or the
6822 : reference derived type symbol correcting in the first component ref if
6823 : a derived type. */
6824 :
6825 : void
6826 880 : gfc_fixup_inferred_type_refs (gfc_expr *e)
6827 : {
6828 880 : gfc_ref *ref, *new_ref;
6829 880 : gfc_symbol *sym, *derived;
6830 880 : gfc_expr *target;
6831 880 : sym = e->symtree->n.sym;
6832 :
6833 : /* An associate_name whose selector is (i) a component ref of a selector
6834 : that is a inferred type associate_name; or (ii) an intrinsic type that
6835 : has been inferred from an inquiry ref. */
6836 880 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
6837 : {
6838 282 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
6839 282 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
6840 282 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
6841 : {
6842 60 : ref = e->ref;
6843 : /* A substring misidentified as an array section. */
6844 60 : if (sym->ts.type == BT_CHARACTER
6845 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
6846 6 : && !ref->u.ar.stride[0])
6847 : {
6848 6 : new_ref = gfc_get_ref ();
6849 6 : new_ref->type = REF_SUBSTRING;
6850 6 : new_ref->u.ss.start = ref->u.ar.start[0];
6851 6 : new_ref->u.ss.end = ref->u.ar.end[0];
6852 6 : new_ref->u.ss.length = sym->ts.u.cl;
6853 6 : *ref = *new_ref;
6854 6 : free (new_ref);
6855 : }
6856 : else
6857 : {
6858 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
6859 24 : gfc_error ("Invalid array reference at %L", &e->where);
6860 54 : e->ref = ref->next;
6861 54 : free (ref);
6862 : }
6863 : }
6864 :
6865 : /* It is possible for an inquiry reference to be mistaken for a
6866 : component reference. Correct this now. */
6867 282 : ref = e->ref;
6868 282 : if (ref && ref->type == REF_ARRAY)
6869 138 : ref = ref->next;
6870 150 : if (ref && ref->type == REF_COMPONENT
6871 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
6872 : {
6873 12 : e->symtree->n.sym = sym;
6874 12 : *ref = *new_ref;
6875 12 : gfc_free_ref_list (new_ref);
6876 : }
6877 :
6878 : /* The kind of the associate name is best evaluated directly from the
6879 : selector because of the guesses made in primary.cc, when the type
6880 : is still unknown. */
6881 282 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
6882 : {
6883 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6884 12 : sym->assoc->target->ts.kind);
6885 12 : gfc_replace_expr (e, ne);
6886 : }
6887 :
6888 : /* Now that the references are all sorted out, set the expression rank
6889 : and return. */
6890 282 : gfc_expression_rank (e);
6891 282 : return;
6892 : }
6893 :
6894 598 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
6895 : : sym->ts.u.derived;
6896 :
6897 : /* Ensure that class symbols have an array spec and ensure that there
6898 : is a _data field reference following class type references. */
6899 598 : if (sym->ts.type == BT_CLASS
6900 196 : && sym->assoc->target->ts.type == BT_CLASS)
6901 : {
6902 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
6903 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
6904 196 : sym->attr.dimension = 0;
6905 196 : sym->attr.codimension = 0;
6906 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
6907 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
6908 196 : if (e->ref && (e->ref->type != REF_COMPONENT
6909 160 : || e->ref->u.c.component->name[0] != '_'))
6910 : {
6911 82 : ref = gfc_get_ref ();
6912 82 : ref->type = REF_COMPONENT;
6913 82 : ref->next = e->ref;
6914 82 : e->ref = ref;
6915 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
6916 : true, true, NULL);
6917 82 : ref->u.c.sym = sym->ts.u.derived;
6918 : }
6919 : }
6920 :
6921 : /* Proceed as far as the first component reference and ensure that the
6922 : correct derived type is being used. */
6923 861 : for (ref = e->ref; ref; ref = ref->next)
6924 825 : if (ref->type == REF_COMPONENT)
6925 : {
6926 562 : if (ref->u.c.component->name[0] != '_')
6927 366 : ref->u.c.sym = derived;
6928 : else
6929 196 : ref->u.c.sym = sym->ts.u.derived;
6930 : break;
6931 : }
6932 :
6933 : /* Verify that the type inferrence mechanism has not introduced a spurious
6934 : array reference. This can happen with an associate name, whose selector
6935 : is an element of another inferred type. */
6936 598 : target = e->symtree->n.sym->assoc->target;
6937 598 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
6938 186 : && e != target && !target->rank)
6939 : {
6940 : /* First case: array ref after the scalar class or derived
6941 : associate_name. */
6942 186 : if (e->ref && e->ref->type == REF_ARRAY
6943 7 : && e->ref->u.ar.type != AR_ELEMENT)
6944 : {
6945 7 : ref = e->ref;
6946 7 : if (ref->u.ar.type == AR_UNKNOWN)
6947 1 : gfc_error ("Invalid array reference at %L", &e->where);
6948 7 : e->ref = ref->next;
6949 7 : free (ref);
6950 :
6951 : /* If it hasn't a ref to the '_data' field supply one. */
6952 7 : if (sym->ts.type == BT_CLASS
6953 0 : && !(e->ref->type == REF_COMPONENT
6954 0 : && strcmp (e->ref->u.c.component->name, "_data")))
6955 : {
6956 0 : gfc_ref *new_ref;
6957 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
6958 : "_data", true, true, &new_ref);
6959 0 : new_ref->next = e->ref;
6960 0 : e->ref = new_ref;
6961 : }
6962 : }
6963 : /* 2nd case: a ref to the '_data' field followed by an array ref. */
6964 179 : else if (e->ref && e->ref->type == REF_COMPONENT
6965 179 : && strcmp (e->ref->u.c.component->name, "_data") == 0
6966 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
6967 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
6968 : {
6969 0 : ref = e->ref->next;
6970 0 : if (ref->u.ar.type == AR_UNKNOWN)
6971 0 : gfc_error ("Invalid array reference at %L", &e->where);
6972 0 : e->ref->next = e->ref->next->next;
6973 0 : free (ref);
6974 : }
6975 : }
6976 :
6977 : /* Now that all the references are OK, get the expression rank. */
6978 598 : gfc_expression_rank (e);
6979 : }
6980 :
6981 :
6982 : /* Checks to see that the correct symbol has been host associated.
6983 : The only situations where this arises are:
6984 : (i) That in which a twice contained function is parsed after
6985 : the host association is made. On detecting this, change
6986 : the symbol in the expression and convert the array reference
6987 : into an actual arglist if the old symbol is a variable; or
6988 : (ii) That in which an external function is typed but not declared
6989 : explicitly to be external. Here, the old symbol is changed
6990 : from a variable to an external function. */
6991 : static bool
6992 1660436 : check_host_association (gfc_expr *e)
6993 : {
6994 1660436 : gfc_symbol *sym, *old_sym;
6995 1660436 : gfc_symtree *st;
6996 1660436 : int n;
6997 1660436 : gfc_ref *ref;
6998 1660436 : gfc_actual_arglist *arg, *tail = NULL;
6999 1660436 : bool retval = e->expr_type == EXPR_FUNCTION;
7000 :
7001 : /* If the expression is the result of substitution in
7002 : interface.cc(gfc_extend_expr) because there is no way in
7003 : which the host association can be wrong. */
7004 1660436 : if (e->symtree == NULL
7005 1659655 : || e->symtree->n.sym == NULL
7006 1659655 : || e->user_operator)
7007 : return retval;
7008 :
7009 1657902 : old_sym = e->symtree->n.sym;
7010 :
7011 1657902 : if (gfc_current_ns->parent
7012 725531 : && old_sym->ns != gfc_current_ns)
7013 : {
7014 : /* Use the 'USE' name so that renamed module symbols are
7015 : correctly handled. */
7016 90305 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7017 :
7018 90305 : if (sym && old_sym != sym
7019 661 : && sym->attr.flavor == FL_PROCEDURE
7020 105 : && sym->attr.contained)
7021 : {
7022 : /* Clear the shape, since it might not be valid. */
7023 83 : gfc_free_shape (&e->shape, e->rank);
7024 :
7025 : /* Give the expression the right symtree! */
7026 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7027 83 : gcc_assert (st != NULL);
7028 :
7029 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7030 59 : || e->expr_type == EXPR_FUNCTION)
7031 : {
7032 : /* Original was function so point to the new symbol, since
7033 : the actual argument list is already attached to the
7034 : expression. */
7035 30 : e->value.function.esym = NULL;
7036 30 : e->symtree = st;
7037 : }
7038 : else
7039 : {
7040 : /* Original was variable so convert array references into
7041 : an actual arglist. This does not need any checking now
7042 : since resolve_function will take care of it. */
7043 53 : e->value.function.actual = NULL;
7044 53 : e->expr_type = EXPR_FUNCTION;
7045 53 : e->symtree = st;
7046 :
7047 : /* Ambiguity will not arise if the array reference is not
7048 : the last reference. */
7049 55 : for (ref = e->ref; ref; ref = ref->next)
7050 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7051 : break;
7052 :
7053 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7054 17 : && sym->attr.proc == PROC_INTERNAL)
7055 : {
7056 4 : gfc_error ("%qs at %L is host associated at %L into "
7057 : "a contained procedure with an internal "
7058 : "procedure of the same name", sym->name,
7059 : &old_sym->declared_at, &e->where);
7060 4 : return false;
7061 : }
7062 :
7063 13 : if (ref == NULL)
7064 : return false;
7065 :
7066 36 : gcc_assert (ref->type == REF_ARRAY);
7067 :
7068 : /* Grab the start expressions from the array ref and
7069 : copy them into actual arguments. */
7070 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7071 : {
7072 48 : arg = gfc_get_actual_arglist ();
7073 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7074 48 : if (e->value.function.actual == NULL)
7075 36 : tail = e->value.function.actual = arg;
7076 : else
7077 : {
7078 12 : tail->next = arg;
7079 12 : tail = arg;
7080 : }
7081 : }
7082 :
7083 : /* Dump the reference list and set the rank. */
7084 36 : gfc_free_ref_list (e->ref);
7085 36 : e->ref = NULL;
7086 36 : e->rank = sym->as ? sym->as->rank : 0;
7087 36 : e->corank = sym->as ? sym->as->corank : 0;
7088 : }
7089 :
7090 66 : gfc_resolve_expr (e);
7091 66 : sym->refs++;
7092 : }
7093 : /* This case corresponds to a call, from a block or a contained
7094 : procedure, to an external function, which has not been declared
7095 : as being external in the main program but has been typed. */
7096 90222 : else if (sym && old_sym != sym
7097 578 : && !e->ref
7098 310 : && sym->ts.type == BT_UNKNOWN
7099 21 : && old_sym->ts.type != BT_UNKNOWN
7100 19 : && sym->attr.flavor == FL_PROCEDURE
7101 19 : && old_sym->attr.flavor == FL_VARIABLE
7102 7 : && sym->ns->parent == old_sym->ns
7103 7 : && sym->ns->proc_name
7104 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7105 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7106 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7107 : {
7108 6 : old_sym->attr.flavor = FL_PROCEDURE;
7109 6 : old_sym->attr.external = 1;
7110 6 : old_sym->attr.function = 1;
7111 6 : old_sym->result = old_sym;
7112 6 : gfc_resolve_expr (e);
7113 : }
7114 : }
7115 : /* This might have changed! */
7116 1657885 : return e->expr_type == EXPR_FUNCTION;
7117 : }
7118 :
7119 :
7120 : static void
7121 1441 : gfc_resolve_character_operator (gfc_expr *e)
7122 : {
7123 1441 : gfc_expr *op1 = e->value.op.op1;
7124 1441 : gfc_expr *op2 = e->value.op.op2;
7125 1441 : gfc_expr *e1 = NULL;
7126 1441 : gfc_expr *e2 = NULL;
7127 :
7128 1441 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7129 :
7130 1441 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7131 761 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7132 680 : else if (op1->expr_type == EXPR_CONSTANT)
7133 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7134 268 : op1->value.character.length);
7135 :
7136 1441 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7137 749 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7138 692 : else if (op2->expr_type == EXPR_CONSTANT)
7139 461 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7140 461 : op2->value.character.length);
7141 :
7142 1441 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7143 :
7144 1441 : if (!e1 || !e2)
7145 : {
7146 540 : gfc_free_expr (e1);
7147 540 : gfc_free_expr (e2);
7148 :
7149 540 : return;
7150 : }
7151 :
7152 901 : e->ts.u.cl->length = gfc_add (e1, e2);
7153 901 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7154 901 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7155 901 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7156 901 : gfc_resolve_expr (e->ts.u.cl->length);
7157 :
7158 901 : return;
7159 : }
7160 :
7161 :
7162 : /* Ensure that an character expression has a charlen and, if possible, a
7163 : length expression. */
7164 :
7165 : static void
7166 179986 : fixup_charlen (gfc_expr *e)
7167 : {
7168 : /* The cases fall through so that changes in expression type and the need
7169 : for multiple fixes are picked up. In all circumstances, a charlen should
7170 : be available for the middle end to hang a backend_decl on. */
7171 179986 : switch (e->expr_type)
7172 : {
7173 1441 : case EXPR_OP:
7174 1441 : gfc_resolve_character_operator (e);
7175 : /* FALLTHRU */
7176 :
7177 1508 : case EXPR_ARRAY:
7178 1508 : if (e->expr_type == EXPR_ARRAY)
7179 67 : gfc_resolve_character_array_constructor (e);
7180 : /* FALLTHRU */
7181 :
7182 1964 : case EXPR_SUBSTRING:
7183 1964 : if (!e->ts.u.cl && e->ref)
7184 452 : gfc_resolve_substring_charlen (e);
7185 : /* FALLTHRU */
7186 :
7187 179986 : default:
7188 179986 : if (!e->ts.u.cl)
7189 178026 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7190 :
7191 179986 : break;
7192 : }
7193 179986 : }
7194 :
7195 :
7196 : /* Update an actual argument to include the passed-object for type-bound
7197 : procedures at the right position. */
7198 :
7199 : static gfc_actual_arglist*
7200 2945 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7201 : const char *name)
7202 : {
7203 2969 : gcc_assert (argpos > 0);
7204 :
7205 2969 : if (argpos == 1)
7206 : {
7207 2820 : gfc_actual_arglist* result;
7208 :
7209 2820 : result = gfc_get_actual_arglist ();
7210 2820 : result->expr = po;
7211 2820 : result->next = lst;
7212 2820 : if (name)
7213 514 : result->name = name;
7214 :
7215 2820 : return result;
7216 : }
7217 :
7218 149 : if (lst)
7219 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7220 : else
7221 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7222 : return lst;
7223 : }
7224 :
7225 :
7226 : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7227 :
7228 : static gfc_expr*
7229 7156 : extract_compcall_passed_object (gfc_expr* e)
7230 : {
7231 7156 : gfc_expr* po;
7232 :
7233 7156 : if (e->expr_type == EXPR_UNKNOWN)
7234 : {
7235 0 : gfc_error ("Error in typebound call at %L",
7236 : &e->where);
7237 0 : return NULL;
7238 : }
7239 :
7240 7156 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7241 :
7242 7156 : if (e->value.compcall.base_object)
7243 1572 : po = gfc_copy_expr (e->value.compcall.base_object);
7244 : else
7245 : {
7246 5584 : po = gfc_get_expr ();
7247 5584 : po->expr_type = EXPR_VARIABLE;
7248 5584 : po->symtree = e->symtree;
7249 5584 : po->ref = gfc_copy_ref (e->ref);
7250 5584 : po->where = e->where;
7251 : }
7252 :
7253 7156 : if (!gfc_resolve_expr (po))
7254 : return NULL;
7255 :
7256 : return po;
7257 : }
7258 :
7259 :
7260 : /* Update the arglist of an EXPR_COMPCALL expression to include the
7261 : passed-object. */
7262 :
7263 : static bool
7264 3298 : update_compcall_arglist (gfc_expr* e)
7265 : {
7266 3298 : gfc_expr* po;
7267 3298 : gfc_typebound_proc* tbp;
7268 :
7269 3298 : tbp = e->value.compcall.tbp;
7270 :
7271 3298 : if (tbp->error)
7272 : return false;
7273 :
7274 3297 : po = extract_compcall_passed_object (e);
7275 3297 : if (!po)
7276 : return false;
7277 :
7278 3297 : if (tbp->nopass || e->value.compcall.ignore_pass)
7279 : {
7280 1110 : gfc_free_expr (po);
7281 1110 : return true;
7282 : }
7283 :
7284 2187 : if (tbp->pass_arg_num <= 0)
7285 : return false;
7286 :
7287 2186 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7288 : tbp->pass_arg_num,
7289 : tbp->pass_arg);
7290 :
7291 2186 : return true;
7292 : }
7293 :
7294 :
7295 : /* Extract the passed object from a PPC call (a copy of it). */
7296 :
7297 : static gfc_expr*
7298 85 : extract_ppc_passed_object (gfc_expr *e)
7299 : {
7300 85 : gfc_expr *po;
7301 85 : gfc_ref **ref;
7302 :
7303 85 : po = gfc_get_expr ();
7304 85 : po->expr_type = EXPR_VARIABLE;
7305 85 : po->symtree = e->symtree;
7306 85 : po->ref = gfc_copy_ref (e->ref);
7307 85 : po->where = e->where;
7308 :
7309 : /* Remove PPC reference. */
7310 85 : ref = &po->ref;
7311 91 : while ((*ref)->next)
7312 6 : ref = &(*ref)->next;
7313 85 : gfc_free_ref_list (*ref);
7314 85 : *ref = NULL;
7315 :
7316 85 : if (!gfc_resolve_expr (po))
7317 0 : return NULL;
7318 :
7319 : return po;
7320 : }
7321 :
7322 :
7323 : /* Update the actual arglist of a procedure pointer component to include the
7324 : passed-object. */
7325 :
7326 : static bool
7327 574 : update_ppc_arglist (gfc_expr* e)
7328 : {
7329 574 : gfc_expr* po;
7330 574 : gfc_component *ppc;
7331 574 : gfc_typebound_proc* tb;
7332 :
7333 574 : ppc = gfc_get_proc_ptr_comp (e);
7334 574 : if (!ppc)
7335 : return false;
7336 :
7337 574 : tb = ppc->tb;
7338 :
7339 574 : if (tb->error)
7340 : return false;
7341 572 : else if (tb->nopass)
7342 : return true;
7343 :
7344 85 : po = extract_ppc_passed_object (e);
7345 85 : if (!po)
7346 : return false;
7347 :
7348 : /* F08:R739. */
7349 85 : if (po->rank != 0)
7350 : {
7351 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7352 0 : return false;
7353 : }
7354 :
7355 : /* F08:C611. */
7356 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7357 : {
7358 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7359 : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7360 1 : return false;
7361 : }
7362 :
7363 84 : gcc_assert (tb->pass_arg_num > 0);
7364 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7365 : tb->pass_arg_num,
7366 : tb->pass_arg);
7367 :
7368 84 : return true;
7369 : }
7370 :
7371 :
7372 : /* Check that the object a TBP is called on is valid, i.e. it must not be
7373 : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7374 :
7375 : static bool
7376 3309 : check_typebound_baseobject (gfc_expr* e)
7377 : {
7378 3309 : gfc_expr* base;
7379 3309 : bool return_value = false;
7380 :
7381 3309 : base = extract_compcall_passed_object (e);
7382 3309 : if (!base)
7383 : return false;
7384 :
7385 3306 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7386 : {
7387 1 : gfc_error ("Error in typebound call at %L", &e->where);
7388 1 : goto cleanup;
7389 : }
7390 :
7391 3305 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7392 1 : return false;
7393 :
7394 : /* F08:C611. */
7395 3304 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7396 : {
7397 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7398 : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7399 3 : goto cleanup;
7400 : }
7401 :
7402 : /* F08:C1230. If the procedure called is NOPASS,
7403 : the base object must be scalar. */
7404 3301 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7405 : {
7406 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7407 : " be scalar", &e->where);
7408 1 : goto cleanup;
7409 : }
7410 :
7411 : return_value = true;
7412 :
7413 3305 : cleanup:
7414 3305 : gfc_free_expr (base);
7415 3305 : return return_value;
7416 : }
7417 :
7418 :
7419 : /* Resolve a call to a type-bound procedure, either function or subroutine,
7420 : statically from the data in an EXPR_COMPCALL expression. The adapted
7421 : arglist and the target-procedure symtree are returned. */
7422 :
7423 : static bool
7424 3298 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7425 : gfc_actual_arglist** actual)
7426 : {
7427 3298 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7428 3298 : gcc_assert (!e->value.compcall.tbp->is_generic);
7429 :
7430 : /* Update the actual arglist for PASS. */
7431 3298 : if (!update_compcall_arglist (e))
7432 : return false;
7433 :
7434 3296 : *actual = e->value.compcall.actual;
7435 3296 : *target = e->value.compcall.tbp->u.specific;
7436 :
7437 3296 : gfc_free_ref_list (e->ref);
7438 3296 : e->ref = NULL;
7439 3296 : e->value.compcall.actual = NULL;
7440 :
7441 : /* If we find a deferred typebound procedure, check for derived types
7442 : that an overriding typebound procedure has not been missed. */
7443 3296 : if (e->value.compcall.name
7444 3296 : && !e->value.compcall.tbp->non_overridable
7445 3278 : && e->value.compcall.base_object
7446 786 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7447 : {
7448 499 : gfc_symtree *st;
7449 499 : gfc_symbol *derived;
7450 :
7451 : /* Use the derived type of the base_object. */
7452 499 : derived = e->value.compcall.base_object->ts.u.derived;
7453 499 : st = NULL;
7454 :
7455 : /* If necessary, go through the inheritance chain. */
7456 1505 : while (!st && derived)
7457 : {
7458 : /* Look for the typebound procedure 'name'. */
7459 507 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7460 499 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7461 : e->value.compcall.name);
7462 507 : if (!st)
7463 8 : derived = gfc_get_derived_super_type (derived);
7464 : }
7465 :
7466 : /* Now find the specific name in the derived type namespace. */
7467 499 : if (st && st->n.tb && st->n.tb->u.specific)
7468 499 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7469 499 : derived->ns, 1, &st);
7470 499 : if (st)
7471 499 : *target = st;
7472 : }
7473 :
7474 3296 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7475 3296 : && !e->value.compcall.tbp->deferred)
7476 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7477 : " itself recursively. Declare it RECURSIVE or use"
7478 : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7479 :
7480 : return true;
7481 : }
7482 :
7483 :
7484 : /* Get the ultimate declared type from an expression. In addition,
7485 : return the last class/derived type reference and the copy of the
7486 : reference list. If check_types is set true, derived types are
7487 : identified as well as class references. */
7488 : static gfc_symbol*
7489 3240 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7490 : gfc_expr *e, bool check_types)
7491 : {
7492 3240 : gfc_symbol *declared;
7493 3240 : gfc_ref *ref;
7494 :
7495 3240 : declared = NULL;
7496 3240 : if (class_ref)
7497 2832 : *class_ref = NULL;
7498 3240 : if (new_ref)
7499 2545 : *new_ref = gfc_copy_ref (e->ref);
7500 :
7501 4028 : for (ref = e->ref; ref; ref = ref->next)
7502 : {
7503 788 : if (ref->type != REF_COMPONENT)
7504 286 : continue;
7505 :
7506 502 : if ((ref->u.c.component->ts.type == BT_CLASS
7507 256 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7508 427 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7509 : {
7510 353 : declared = ref->u.c.component->ts.u.derived;
7511 353 : if (class_ref)
7512 331 : *class_ref = ref;
7513 : }
7514 : }
7515 :
7516 3240 : if (declared == NULL)
7517 2913 : declared = e->symtree->n.sym->ts.u.derived;
7518 :
7519 3240 : return declared;
7520 : }
7521 :
7522 :
7523 : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7524 : which of the specific bindings (if any) matches the arglist and transform
7525 : the expression into a call of that binding. */
7526 :
7527 : static bool
7528 3300 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7529 : {
7530 3300 : gfc_typebound_proc* genproc;
7531 3300 : const char* genname;
7532 3300 : gfc_symtree *st;
7533 3300 : gfc_symbol *derived;
7534 :
7535 3300 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7536 3300 : genname = e->value.compcall.name;
7537 3300 : genproc = e->value.compcall.tbp;
7538 :
7539 3300 : if (!genproc->is_generic)
7540 : return true;
7541 :
7542 : /* Try the bindings on this type and in the inheritance hierarchy. */
7543 420 : for (; genproc; genproc = genproc->overridden)
7544 : {
7545 418 : gfc_tbp_generic* g;
7546 :
7547 418 : gcc_assert (genproc->is_generic);
7548 646 : for (g = genproc->u.generic; g; g = g->next)
7549 : {
7550 636 : gfc_symbol* target;
7551 636 : gfc_actual_arglist* args;
7552 636 : bool matches;
7553 :
7554 636 : gcc_assert (g->specific);
7555 :
7556 636 : if (g->specific->error)
7557 0 : continue;
7558 :
7559 636 : target = g->specific->u.specific->n.sym;
7560 :
7561 : /* Get the right arglist by handling PASS/NOPASS. */
7562 636 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7563 636 : if (!g->specific->nopass)
7564 : {
7565 550 : gfc_expr* po;
7566 550 : po = extract_compcall_passed_object (e);
7567 550 : if (!po)
7568 : {
7569 0 : gfc_free_actual_arglist (args);
7570 0 : return false;
7571 : }
7572 :
7573 550 : gcc_assert (g->specific->pass_arg_num > 0);
7574 550 : gcc_assert (!g->specific->error);
7575 550 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7576 : g->specific->pass_arg);
7577 : }
7578 636 : resolve_actual_arglist (args, target->attr.proc,
7579 636 : is_external_proc (target)
7580 636 : && gfc_sym_get_dummy_args (target) == NULL);
7581 :
7582 : /* Check if this arglist matches the formal. */
7583 636 : matches = gfc_arglist_matches_symbol (&args, target);
7584 :
7585 : /* Clean up and break out of the loop if we've found it. */
7586 636 : gfc_free_actual_arglist (args);
7587 636 : if (matches)
7588 : {
7589 408 : e->value.compcall.tbp = g->specific;
7590 408 : genname = g->specific_st->name;
7591 : /* Pass along the name for CLASS methods, where the vtab
7592 : procedure pointer component has to be referenced. */
7593 408 : if (name)
7594 161 : *name = genname;
7595 408 : goto success;
7596 : }
7597 : }
7598 : }
7599 :
7600 : /* Nothing matching found! */
7601 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7602 : " %qs at %L", genname, &e->where);
7603 2 : return false;
7604 :
7605 408 : success:
7606 : /* Make sure that we have the right specific instance for the name. */
7607 408 : derived = get_declared_from_expr (NULL, NULL, e, true);
7608 :
7609 408 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7610 408 : if (st)
7611 408 : e->value.compcall.tbp = st->n.tb;
7612 :
7613 : return true;
7614 : }
7615 :
7616 :
7617 : /* Resolve a call to a type-bound subroutine. */
7618 :
7619 : static bool
7620 1706 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7621 : {
7622 1706 : gfc_actual_arglist* newactual;
7623 1706 : gfc_symtree* target;
7624 :
7625 : /* Check that's really a SUBROUTINE. */
7626 1706 : if (!c->expr1->value.compcall.tbp->subroutine)
7627 : {
7628 17 : if (!c->expr1->value.compcall.tbp->is_generic
7629 15 : && c->expr1->value.compcall.tbp->u.specific
7630 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7631 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7632 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7633 : else
7634 : {
7635 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7636 : c->expr1->value.compcall.name, &c->loc);
7637 5 : return false;
7638 : }
7639 : }
7640 :
7641 1701 : if (!check_typebound_baseobject (c->expr1))
7642 : return false;
7643 :
7644 : /* Pass along the name for CLASS methods, where the vtab
7645 : procedure pointer component has to be referenced. */
7646 1694 : if (name)
7647 474 : *name = c->expr1->value.compcall.name;
7648 :
7649 1694 : if (!resolve_typebound_generic_call (c->expr1, name))
7650 : return false;
7651 :
7652 : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7653 1693 : if (overridable)
7654 371 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7655 :
7656 : /* Transform into an ordinary EXEC_CALL for now. */
7657 :
7658 1693 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7659 : return false;
7660 :
7661 1691 : c->ext.actual = newactual;
7662 1691 : c->symtree = target;
7663 1691 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7664 :
7665 1691 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7666 :
7667 1691 : gfc_free_expr (c->expr1);
7668 1691 : c->expr1 = gfc_get_expr ();
7669 1691 : c->expr1->expr_type = EXPR_FUNCTION;
7670 1691 : c->expr1->symtree = target;
7671 1691 : c->expr1->where = c->loc;
7672 :
7673 1691 : return resolve_call (c);
7674 : }
7675 :
7676 :
7677 : /* Resolve a component-call expression. */
7678 : static bool
7679 1627 : resolve_compcall (gfc_expr* e, const char **name)
7680 : {
7681 1627 : gfc_actual_arglist* newactual;
7682 1627 : gfc_symtree* target;
7683 :
7684 : /* Check that's really a FUNCTION. */
7685 1627 : if (!e->value.compcall.tbp->function)
7686 : {
7687 19 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7688 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7689 : &e->where);
7690 19 : return false;
7691 : }
7692 :
7693 :
7694 : /* These must not be assign-calls! */
7695 1608 : gcc_assert (!e->value.compcall.assign);
7696 :
7697 1608 : if (!check_typebound_baseobject (e))
7698 : return false;
7699 :
7700 : /* Pass along the name for CLASS methods, where the vtab
7701 : procedure pointer component has to be referenced. */
7702 1606 : if (name)
7703 862 : *name = e->value.compcall.name;
7704 :
7705 1606 : if (!resolve_typebound_generic_call (e, name))
7706 : return false;
7707 1605 : gcc_assert (!e->value.compcall.tbp->is_generic);
7708 :
7709 : /* Take the rank from the function's symbol. */
7710 1605 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7711 : {
7712 155 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7713 155 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7714 : }
7715 :
7716 : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7717 : arglist to the TBP's binding target. */
7718 :
7719 1605 : if (!resolve_typebound_static (e, &target, &newactual))
7720 : return false;
7721 :
7722 1605 : e->value.function.actual = newactual;
7723 1605 : e->value.function.name = NULL;
7724 1605 : e->value.function.esym = target->n.sym;
7725 1605 : e->value.function.isym = NULL;
7726 1605 : e->symtree = target;
7727 1605 : e->ts = target->n.sym->ts;
7728 1605 : e->expr_type = EXPR_FUNCTION;
7729 :
7730 : /* Resolution is not necessary if this is a class subroutine; this
7731 : function only has to identify the specific proc. Resolution of
7732 : the call will be done next in resolve_typebound_call. */
7733 1605 : return gfc_resolve_expr (e);
7734 : }
7735 :
7736 :
7737 : static bool resolve_fl_derived (gfc_symbol *sym);
7738 :
7739 :
7740 : /* Resolve a typebound function, or 'method'. First separate all
7741 : the non-CLASS references by calling resolve_compcall directly. */
7742 :
7743 : static bool
7744 1627 : resolve_typebound_function (gfc_expr* e)
7745 : {
7746 1627 : gfc_symbol *declared;
7747 1627 : gfc_component *c;
7748 1627 : gfc_ref *new_ref;
7749 1627 : gfc_ref *class_ref;
7750 1627 : gfc_symtree *st;
7751 1627 : const char *name;
7752 1627 : gfc_typespec ts;
7753 1627 : gfc_expr *expr;
7754 1627 : bool overridable;
7755 :
7756 1627 : st = e->symtree;
7757 :
7758 : /* Deal with typebound operators for CLASS objects. */
7759 1627 : expr = e->value.compcall.base_object;
7760 1627 : overridable = !e->value.compcall.tbp->non_overridable;
7761 1627 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7762 : {
7763 : /* Since the typebound operators are generic, we have to ensure
7764 : that any delays in resolution are corrected and that the vtab
7765 : is present. */
7766 184 : ts = expr->ts;
7767 184 : declared = ts.u.derived;
7768 184 : if (!resolve_fl_derived (declared))
7769 : return false;
7770 :
7771 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7772 184 : if (c->ts.u.derived == NULL)
7773 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7774 :
7775 184 : if (!resolve_compcall (e, &name))
7776 : return false;
7777 :
7778 : /* Use the generic name if it is there. */
7779 184 : name = name ? name : e->value.function.esym->name;
7780 184 : e->symtree = expr->symtree;
7781 184 : e->ref = gfc_copy_ref (expr->ref);
7782 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7783 :
7784 : /* Trim away the extraneous references that emerge from nested
7785 : use of interface.cc (extend_expr). */
7786 184 : if (class_ref && class_ref->next)
7787 : {
7788 0 : gfc_free_ref_list (class_ref->next);
7789 0 : class_ref->next = NULL;
7790 : }
7791 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7792 : {
7793 0 : gfc_free_ref_list (e->ref);
7794 0 : e->ref = NULL;
7795 : }
7796 :
7797 184 : gfc_add_vptr_component (e);
7798 184 : gfc_add_component_ref (e, name);
7799 184 : e->value.function.esym = NULL;
7800 184 : if (expr->expr_type != EXPR_VARIABLE)
7801 80 : e->base_expr = expr;
7802 184 : return true;
7803 : }
7804 :
7805 1443 : if (st == NULL)
7806 159 : return resolve_compcall (e, NULL);
7807 :
7808 1284 : if (!gfc_resolve_ref (e))
7809 : return false;
7810 :
7811 : /* It can happen that a generic, typebound procedure is marked as overridable
7812 : with all of the specific procedures being non-overridable. If this is the
7813 : case, it is safe to resolve the compcall. */
7814 1284 : if (!expr && overridable
7815 1276 : && e->value.compcall.tbp->is_generic
7816 186 : && e->value.compcall.tbp->u.generic->specific
7817 185 : && e->value.compcall.tbp->u.generic->specific->non_overridable)
7818 : {
7819 : gfc_tbp_generic *g = e->value.compcall.tbp->u.generic;
7820 6 : for (; g; g = g->next)
7821 4 : if (!g->specific->non_overridable)
7822 : break;
7823 2 : if (g == NULL && resolve_compcall (e, &name))
7824 : return true;
7825 : }
7826 :
7827 : /* Get the CLASS declared type. */
7828 1282 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
7829 :
7830 1282 : if (!resolve_fl_derived (declared))
7831 : return false;
7832 :
7833 : /* Weed out cases of the ultimate component being a derived type. */
7834 1282 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7835 1188 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7836 : {
7837 592 : gfc_free_ref_list (new_ref);
7838 592 : return resolve_compcall (e, NULL);
7839 : }
7840 :
7841 690 : c = gfc_find_component (declared, "_data", true, true, NULL);
7842 :
7843 : /* Treat the call as if it is a typebound procedure, in order to roll
7844 : out the correct name for the specific function. */
7845 690 : if (!resolve_compcall (e, &name))
7846 : {
7847 15 : gfc_free_ref_list (new_ref);
7848 15 : return false;
7849 : }
7850 675 : ts = e->ts;
7851 :
7852 675 : if (overridable)
7853 : {
7854 : /* Convert the expression to a procedure pointer component call. */
7855 673 : e->value.function.esym = NULL;
7856 673 : e->symtree = st;
7857 :
7858 673 : if (new_ref)
7859 124 : e->ref = new_ref;
7860 :
7861 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7862 673 : gfc_add_vptr_component (e);
7863 673 : gfc_add_component_ref (e, name);
7864 :
7865 : /* Recover the typespec for the expression. This is really only
7866 : necessary for generic procedures, where the additional call
7867 : to gfc_add_component_ref seems to throw the collection of the
7868 : correct typespec. */
7869 673 : e->ts = ts;
7870 : }
7871 2 : else if (new_ref)
7872 0 : gfc_free_ref_list (new_ref);
7873 :
7874 : return true;
7875 : }
7876 :
7877 : /* Resolve a typebound subroutine, or 'method'. First separate all
7878 : the non-CLASS references by calling resolve_typebound_call
7879 : directly. */
7880 :
7881 : static bool
7882 1706 : resolve_typebound_subroutine (gfc_code *code)
7883 : {
7884 1706 : gfc_symbol *declared;
7885 1706 : gfc_component *c;
7886 1706 : gfc_ref *new_ref;
7887 1706 : gfc_ref *class_ref;
7888 1706 : gfc_symtree *st;
7889 1706 : const char *name;
7890 1706 : gfc_typespec ts;
7891 1706 : gfc_expr *expr;
7892 1706 : bool overridable;
7893 :
7894 1706 : st = code->expr1->symtree;
7895 :
7896 : /* Deal with typebound operators for CLASS objects. */
7897 1706 : expr = code->expr1->value.compcall.base_object;
7898 1706 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
7899 1706 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7900 : {
7901 : /* If the base_object is not a variable, the corresponding actual
7902 : argument expression must be stored in e->base_expression so
7903 : that the corresponding tree temporary can be used as the base
7904 : object in gfc_conv_procedure_call. */
7905 103 : if (expr->expr_type != EXPR_VARIABLE)
7906 : {
7907 : gfc_actual_arglist *args;
7908 :
7909 : args= code->expr1->value.function.actual;
7910 : for (; args; args = args->next)
7911 : if (expr == args->expr)
7912 : expr = args->expr;
7913 : }
7914 :
7915 : /* Since the typebound operators are generic, we have to ensure
7916 : that any delays in resolution are corrected and that the vtab
7917 : is present. */
7918 103 : declared = expr->ts.u.derived;
7919 103 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7920 103 : if (c->ts.u.derived == NULL)
7921 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7922 :
7923 103 : if (!resolve_typebound_call (code, &name, NULL))
7924 : return false;
7925 :
7926 : /* Use the generic name if it is there. */
7927 103 : name = name ? name : code->expr1->value.function.esym->name;
7928 103 : code->expr1->symtree = expr->symtree;
7929 103 : code->expr1->ref = gfc_copy_ref (expr->ref);
7930 :
7931 : /* Trim away the extraneous references that emerge from nested
7932 : use of interface.cc (extend_expr). */
7933 103 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
7934 103 : if (class_ref && class_ref->next)
7935 : {
7936 0 : gfc_free_ref_list (class_ref->next);
7937 0 : class_ref->next = NULL;
7938 : }
7939 103 : else if (code->expr1->ref && !class_ref)
7940 : {
7941 12 : gfc_free_ref_list (code->expr1->ref);
7942 12 : code->expr1->ref = NULL;
7943 : }
7944 :
7945 : /* Now use the procedure in the vtable. */
7946 103 : gfc_add_vptr_component (code->expr1);
7947 103 : gfc_add_component_ref (code->expr1, name);
7948 103 : code->expr1->value.function.esym = NULL;
7949 103 : if (expr->expr_type != EXPR_VARIABLE)
7950 0 : code->expr1->base_expr = expr;
7951 103 : return true;
7952 : }
7953 :
7954 1603 : if (st == NULL)
7955 340 : return resolve_typebound_call (code, NULL, NULL);
7956 :
7957 1263 : if (!gfc_resolve_ref (code->expr1))
7958 : return false;
7959 :
7960 : /* Get the CLASS declared type. */
7961 1263 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
7962 :
7963 : /* Weed out cases of the ultimate component being a derived type. */
7964 1263 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7965 1198 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7966 : {
7967 887 : gfc_free_ref_list (new_ref);
7968 887 : return resolve_typebound_call (code, NULL, NULL);
7969 : }
7970 :
7971 376 : if (!resolve_typebound_call (code, &name, &overridable))
7972 : {
7973 5 : gfc_free_ref_list (new_ref);
7974 5 : return false;
7975 : }
7976 371 : ts = code->expr1->ts;
7977 :
7978 371 : if (overridable)
7979 : {
7980 : /* Convert the expression to a procedure pointer component call. */
7981 369 : code->expr1->value.function.esym = NULL;
7982 369 : code->expr1->symtree = st;
7983 :
7984 369 : if (new_ref)
7985 93 : code->expr1->ref = new_ref;
7986 :
7987 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7988 369 : gfc_add_vptr_component (code->expr1);
7989 369 : gfc_add_component_ref (code->expr1, name);
7990 :
7991 : /* Recover the typespec for the expression. This is really only
7992 : necessary for generic procedures, where the additional call
7993 : to gfc_add_component_ref seems to throw the collection of the
7994 : correct typespec. */
7995 369 : code->expr1->ts = ts;
7996 : }
7997 2 : else if (new_ref)
7998 0 : gfc_free_ref_list (new_ref);
7999 :
8000 : return true;
8001 : }
8002 :
8003 :
8004 : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8005 :
8006 : static bool
8007 124 : resolve_ppc_call (gfc_code* c)
8008 : {
8009 124 : gfc_component *comp;
8010 :
8011 124 : comp = gfc_get_proc_ptr_comp (c->expr1);
8012 124 : gcc_assert (comp != NULL);
8013 :
8014 124 : c->resolved_sym = c->expr1->symtree->n.sym;
8015 124 : c->expr1->expr_type = EXPR_VARIABLE;
8016 :
8017 124 : if (!comp->attr.subroutine)
8018 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8019 :
8020 124 : if (!gfc_resolve_ref (c->expr1))
8021 : return false;
8022 :
8023 124 : if (!update_ppc_arglist (c->expr1))
8024 : return false;
8025 :
8026 123 : c->ext.actual = c->expr1->value.compcall.actual;
8027 :
8028 123 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8029 123 : !(comp->ts.interface
8030 93 : && comp->ts.interface->formal)))
8031 : return false;
8032 :
8033 123 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8034 : return false;
8035 :
8036 122 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8037 :
8038 122 : return true;
8039 : }
8040 :
8041 :
8042 : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8043 :
8044 : static bool
8045 450 : resolve_expr_ppc (gfc_expr* e)
8046 : {
8047 450 : gfc_component *comp;
8048 :
8049 450 : comp = gfc_get_proc_ptr_comp (e);
8050 450 : gcc_assert (comp != NULL);
8051 :
8052 : /* Convert to EXPR_FUNCTION. */
8053 450 : e->expr_type = EXPR_FUNCTION;
8054 450 : e->value.function.isym = NULL;
8055 450 : e->value.function.actual = e->value.compcall.actual;
8056 450 : e->ts = comp->ts;
8057 450 : if (comp->as != NULL)
8058 : {
8059 28 : e->rank = comp->as->rank;
8060 28 : e->corank = comp->as->corank;
8061 : }
8062 :
8063 450 : if (!comp->attr.function)
8064 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8065 :
8066 450 : if (!gfc_resolve_ref (e))
8067 : return false;
8068 :
8069 450 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8070 450 : !(comp->ts.interface
8071 449 : && comp->ts.interface->formal)))
8072 : return false;
8073 :
8074 450 : if (!update_ppc_arglist (e))
8075 : return false;
8076 :
8077 448 : if (!check_pure_function(e))
8078 : return false;
8079 :
8080 447 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8081 :
8082 447 : return true;
8083 : }
8084 :
8085 :
8086 : static bool
8087 11325 : gfc_is_expandable_expr (gfc_expr *e)
8088 : {
8089 11325 : gfc_constructor *con;
8090 :
8091 11325 : if (e->expr_type == EXPR_ARRAY)
8092 : {
8093 : /* Traverse the constructor looking for variables that are flavor
8094 : parameter. Parameters must be expanded since they are fully used at
8095 : compile time. */
8096 11325 : con = gfc_constructor_first (e->value.constructor);
8097 29999 : for (; con; con = gfc_constructor_next (con))
8098 : {
8099 13230 : if (con->expr->expr_type == EXPR_VARIABLE
8100 5157 : && con->expr->symtree
8101 5157 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8102 5075 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8103 : return true;
8104 8073 : if (con->expr->expr_type == EXPR_ARRAY
8105 8073 : && gfc_is_expandable_expr (con->expr))
8106 : return true;
8107 : }
8108 : }
8109 :
8110 : return false;
8111 : }
8112 :
8113 :
8114 : /* Sometimes variables in specification expressions of the result
8115 : of module procedures in submodules wind up not being the 'real'
8116 : dummy. Find this, if possible, in the namespace of the first
8117 : formal argument. */
8118 :
8119 : static void
8120 3433 : fixup_unique_dummy (gfc_expr *e)
8121 : {
8122 3433 : gfc_symtree *st = NULL;
8123 3433 : gfc_symbol *s = NULL;
8124 :
8125 3433 : if (e->symtree->n.sym->ns->proc_name
8126 3403 : && e->symtree->n.sym->ns->proc_name->formal)
8127 3403 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8128 :
8129 3403 : if (s != NULL)
8130 3403 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8131 :
8132 3433 : if (st != NULL
8133 14 : && st->n.sym != NULL
8134 14 : && st->n.sym->attr.dummy)
8135 14 : e->symtree = st;
8136 3433 : }
8137 :
8138 :
8139 : /* Resolve an expression. That is, make sure that types of operands agree
8140 : with their operators, intrinsic operators are converted to function calls
8141 : for overloaded types and unresolved function references are resolved. */
8142 :
8143 : bool
8144 7092051 : gfc_resolve_expr (gfc_expr *e)
8145 : {
8146 7092051 : bool t;
8147 7092051 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8148 :
8149 7092051 : if (e == NULL || e->do_not_resolve_again)
8150 : return true;
8151 :
8152 : /* inquiry_argument only applies to variables. */
8153 5186547 : inquiry_save = inquiry_argument;
8154 5186547 : actual_arg_save = actual_arg;
8155 5186547 : first_actual_arg_save = first_actual_arg;
8156 :
8157 5186547 : if (e->expr_type != EXPR_VARIABLE)
8158 : {
8159 3868665 : inquiry_argument = false;
8160 3868665 : actual_arg = false;
8161 3868665 : first_actual_arg = false;
8162 : }
8163 1317882 : else if (e->symtree != NULL
8164 1317437 : && *e->symtree->name == '@'
8165 4140 : && e->symtree->n.sym->attr.dummy)
8166 : {
8167 : /* Deal with submodule specification expressions that are not
8168 : found to be referenced in module.cc(read_cleanup). */
8169 3433 : fixup_unique_dummy (e);
8170 : }
8171 :
8172 5186547 : switch (e->expr_type)
8173 : {
8174 530102 : case EXPR_OP:
8175 530102 : t = resolve_operator (e);
8176 530102 : break;
8177 :
8178 150 : case EXPR_CONDITIONAL:
8179 150 : t = resolve_conditional (e);
8180 150 : break;
8181 :
8182 1660436 : case EXPR_FUNCTION:
8183 1660436 : case EXPR_VARIABLE:
8184 :
8185 1660436 : if (check_host_association (e))
8186 342590 : t = resolve_function (e);
8187 : else
8188 1317846 : t = resolve_variable (e);
8189 :
8190 1660436 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8191 6911 : && e->ref->type != REF_SUBSTRING)
8192 2162 : gfc_resolve_substring_charlen (e);
8193 :
8194 : break;
8195 :
8196 1627 : case EXPR_COMPCALL:
8197 1627 : t = resolve_typebound_function (e);
8198 1627 : break;
8199 :
8200 507 : case EXPR_SUBSTRING:
8201 507 : t = gfc_resolve_ref (e);
8202 507 : break;
8203 :
8204 : case EXPR_CONSTANT:
8205 : case EXPR_NULL:
8206 : t = true;
8207 : break;
8208 :
8209 450 : case EXPR_PPC:
8210 450 : t = resolve_expr_ppc (e);
8211 450 : break;
8212 :
8213 70879 : case EXPR_ARRAY:
8214 70879 : t = false;
8215 70879 : if (!gfc_resolve_ref (e))
8216 : break;
8217 :
8218 70879 : t = gfc_resolve_array_constructor (e);
8219 : /* Also try to expand a constructor. */
8220 70879 : if (t)
8221 : {
8222 70777 : gfc_expression_rank (e);
8223 70777 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8224 66452 : gfc_expand_constructor (e, false);
8225 : }
8226 :
8227 : /* This provides the opportunity for the length of constructors with
8228 : character valued function elements to propagate the string length
8229 : to the expression. */
8230 70777 : if (t && e->ts.type == BT_CHARACTER)
8231 : {
8232 : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8233 : here rather then add a duplicate test for it above. */
8234 10725 : gfc_expand_constructor (e, false);
8235 10725 : t = gfc_resolve_character_array_constructor (e);
8236 : }
8237 :
8238 : break;
8239 :
8240 16445 : case EXPR_STRUCTURE:
8241 16445 : t = gfc_resolve_ref (e);
8242 16445 : if (!t)
8243 : break;
8244 :
8245 16445 : t = resolve_structure_cons (e, 0);
8246 16445 : if (!t)
8247 : break;
8248 :
8249 16433 : t = gfc_simplify_expr (e, 0);
8250 16433 : break;
8251 :
8252 0 : default:
8253 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8254 : }
8255 :
8256 5186547 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8257 179986 : fixup_charlen (e);
8258 :
8259 5186547 : inquiry_argument = inquiry_save;
8260 5186547 : actual_arg = actual_arg_save;
8261 5186547 : first_actual_arg = first_actual_arg_save;
8262 :
8263 : /* For some reason, resolving these expressions a second time mangles
8264 : the typespec of the expression itself. */
8265 5186547 : if (t && e->expr_type == EXPR_VARIABLE
8266 1315005 : && e->symtree->n.sym->attr.select_rank_temporary
8267 3422 : && UNLIMITED_POLY (e->symtree->n.sym))
8268 83 : e->do_not_resolve_again = 1;
8269 :
8270 5184021 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8271 6919 : t = check_import_status (e);
8272 :
8273 : return t;
8274 : }
8275 :
8276 :
8277 : /* Resolve an expression from an iterator. They must be scalar and have
8278 : INTEGER or (optionally) REAL type. */
8279 :
8280 : static bool
8281 150953 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8282 : const char *name_msgid)
8283 : {
8284 150953 : if (!gfc_resolve_expr (expr))
8285 : return false;
8286 :
8287 150948 : if (expr->rank != 0)
8288 : {
8289 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8290 0 : return false;
8291 : }
8292 :
8293 150948 : if (expr->ts.type != BT_INTEGER)
8294 : {
8295 274 : if (expr->ts.type == BT_REAL)
8296 : {
8297 274 : if (real_ok)
8298 271 : return gfc_notify_std (GFC_STD_F95_DEL,
8299 : "%s at %L must be integer",
8300 271 : _(name_msgid), &expr->where);
8301 : else
8302 : {
8303 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8304 : &expr->where);
8305 3 : return false;
8306 : }
8307 : }
8308 : else
8309 : {
8310 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8311 0 : return false;
8312 : }
8313 : }
8314 : return true;
8315 : }
8316 :
8317 :
8318 : /* Resolve the expressions in an iterator structure. If REAL_OK is
8319 : false allow only INTEGER type iterators, otherwise allow REAL types.
8320 : Set own_scope to true for ac-implied-do and data-implied-do as those
8321 : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8322 :
8323 : bool
8324 37747 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8325 : {
8326 37747 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8327 : return false;
8328 :
8329 37743 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8330 37743 : _("iterator variable")))
8331 : return false;
8332 :
8333 37737 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8334 : "Start expression in DO loop"))
8335 : return false;
8336 :
8337 37736 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8338 : "End expression in DO loop"))
8339 : return false;
8340 :
8341 37733 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8342 : "Step expression in DO loop"))
8343 : return false;
8344 :
8345 : /* Convert start, end, and step to the same type as var. */
8346 37732 : if (iter->start->ts.kind != iter->var->ts.kind
8347 37452 : || iter->start->ts.type != iter->var->ts.type)
8348 315 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8349 :
8350 37732 : if (iter->end->ts.kind != iter->var->ts.kind
8351 37479 : || iter->end->ts.type != iter->var->ts.type)
8352 278 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8353 :
8354 37732 : if (iter->step->ts.kind != iter->var->ts.kind
8355 37488 : || iter->step->ts.type != iter->var->ts.type)
8356 280 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8357 :
8358 37732 : if (iter->step->expr_type == EXPR_CONSTANT)
8359 : {
8360 36610 : if ((iter->step->ts.type == BT_INTEGER
8361 36527 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8362 73135 : || (iter->step->ts.type == BT_REAL
8363 83 : && mpfr_sgn (iter->step->value.real) == 0))
8364 : {
8365 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8366 3 : &iter->step->where);
8367 3 : return false;
8368 : }
8369 : }
8370 :
8371 37729 : if (iter->start->expr_type == EXPR_CONSTANT
8372 34598 : && iter->end->expr_type == EXPR_CONSTANT
8373 27063 : && iter->step->expr_type == EXPR_CONSTANT)
8374 : {
8375 26796 : int sgn, cmp;
8376 26796 : if (iter->start->ts.type == BT_INTEGER)
8377 : {
8378 26742 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8379 26742 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8380 : }
8381 : else
8382 : {
8383 54 : sgn = mpfr_sgn (iter->step->value.real);
8384 54 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8385 : }
8386 26796 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8387 146 : gfc_warning (OPT_Wzerotrip,
8388 : "DO loop at %L will be executed zero times",
8389 146 : &iter->step->where);
8390 : }
8391 :
8392 37729 : if (iter->end->expr_type == EXPR_CONSTANT
8393 27430 : && iter->end->ts.type == BT_INTEGER
8394 27376 : && iter->step->expr_type == EXPR_CONSTANT
8395 27066 : && iter->step->ts.type == BT_INTEGER
8396 27066 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8397 26695 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8398 : {
8399 25910 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8400 25910 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8401 :
8402 25910 : if (is_step_positive
8403 25539 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8404 7 : gfc_warning (OPT_Wundefined_do_loop,
8405 : "DO loop at %L is undefined as it overflows",
8406 7 : &iter->step->where);
8407 : else if (!is_step_positive
8408 371 : && mpz_cmp (iter->end->value.integer,
8409 371 : gfc_integer_kinds[k].min_int) == 0)
8410 7 : gfc_warning (OPT_Wundefined_do_loop,
8411 : "DO loop at %L is undefined as it underflows",
8412 7 : &iter->step->where);
8413 : }
8414 :
8415 : return true;
8416 : }
8417 :
8418 :
8419 : /* Traversal function for find_forall_index. f == 2 signals that
8420 : that variable itself is not to be checked - only the references. */
8421 :
8422 : static bool
8423 42620 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8424 : {
8425 42620 : if (expr->expr_type != EXPR_VARIABLE)
8426 : return false;
8427 :
8428 : /* A scalar assignment */
8429 18188 : if (!expr->ref || *f == 1)
8430 : {
8431 12128 : if (expr->symtree->n.sym == sym)
8432 : return true;
8433 : else
8434 : return false;
8435 : }
8436 :
8437 6060 : if (*f == 2)
8438 1731 : *f = 1;
8439 : return false;
8440 : }
8441 :
8442 :
8443 : /* Check whether the FORALL index appears in the expression or not.
8444 : Returns true if SYM is found in EXPR. */
8445 :
8446 : bool
8447 27001 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8448 : {
8449 27001 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8450 : return true;
8451 : else
8452 : return false;
8453 : }
8454 :
8455 : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8456 : This constraint specifies rules for variables in locality-specs. */
8457 :
8458 : static int
8459 717 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8460 : {
8461 717 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8462 :
8463 717 : if ((*expr)->expr_type == EXPR_VARIABLE)
8464 : {
8465 22 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8466 22 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8467 24 : list; list = list->next)
8468 : {
8469 5 : if (list->expr->symtree->n.sym == sym)
8470 : {
8471 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8472 : "must not appear in LOCAL locality-spec at %L",
8473 : sym->name, &(*expr)->where, &list->expr->where);
8474 3 : *walk_subtrees = 0;
8475 3 : return 1;
8476 : }
8477 : }
8478 : }
8479 :
8480 714 : *walk_subtrees = 1;
8481 714 : return 0;
8482 : }
8483 :
8484 : static int
8485 3969 : check_default_none_expr (gfc_expr **e, int *, void *data)
8486 : {
8487 3969 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8488 :
8489 3969 : if ((*e)->expr_type == EXPR_VARIABLE)
8490 : {
8491 1798 : gfc_symbol *sym = (*e)->symtree->n.sym;
8492 :
8493 1798 : if (d->sym_hash->contains (sym))
8494 1263 : sym->mark = 1;
8495 :
8496 535 : else if (d->default_none)
8497 : {
8498 6 : gfc_namespace *ns2 = d->ns;
8499 10 : while (ns2)
8500 : {
8501 6 : if (ns2 == sym->ns)
8502 : break;
8503 4 : ns2 = ns2->parent;
8504 : }
8505 :
8506 : /* A DO CONCURRENT iterator cannot appear in a locality spec. */
8507 6 : if (sym->ns->code->ext.concur.forall_iterator)
8508 : {
8509 : gfc_forall_iterator *iter
8510 : = sym->ns->code->ext.concur.forall_iterator;
8511 5 : for (; iter; iter = iter->next)
8512 3 : if (iter->var->symtree
8513 1 : && strcmp(sym->name, iter->var->symtree->name) == 0)
8514 1 : return 0;
8515 : }
8516 :
8517 : /* A named constant is not a variable, so skip test. */
8518 5 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8519 : {
8520 1 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8521 : "of DO CONCURRENT at %L but required due to "
8522 : "DEFAULT (NONE)",
8523 1 : sym->name, &(*e)->where, &d->code->loc);
8524 1 : d->sym_hash->add (sym);
8525 : }
8526 : }
8527 : }
8528 : return 0;
8529 : }
8530 :
8531 : static void
8532 210 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8533 : {
8534 210 : struct check_default_none_data data;
8535 210 : data.code = code;
8536 210 : data.sym_hash = new hash_set<gfc_symbol *>;
8537 210 : data.ns = ns;
8538 210 : data.default_none = code->ext.concur.default_none;
8539 :
8540 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8541 : {
8542 840 : const char *name;
8543 840 : switch (locality)
8544 : {
8545 : case LOCALITY_LOCAL: name = "LOCAL"; break;
8546 210 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8547 210 : case LOCALITY_SHARED: name = "SHARED"; break;
8548 210 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8549 : default: gcc_unreachable ();
8550 : }
8551 :
8552 1227 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8553 387 : list = list->next)
8554 : {
8555 387 : gfc_expr *expr = list->expr;
8556 :
8557 387 : if (locality == LOCALITY_REDUCE
8558 72 : && (expr->expr_type == EXPR_FUNCTION
8559 48 : || expr->expr_type == EXPR_OP))
8560 35 : continue;
8561 :
8562 363 : if (!gfc_resolve_expr (expr))
8563 3 : continue;
8564 :
8565 360 : if (expr->expr_type != EXPR_VARIABLE
8566 360 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8567 360 : || (expr->ref
8568 147 : && (expr->ref->type != REF_ARRAY
8569 147 : || expr->ref->u.ar.type != AR_FULL
8570 143 : || expr->ref->next)))
8571 : {
8572 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8573 : name, &expr->where);
8574 4 : continue;
8575 : }
8576 :
8577 356 : gfc_symbol *sym = expr->symtree->n.sym;
8578 :
8579 356 : if (data.sym_hash->contains (sym))
8580 : {
8581 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8582 : "locality-spec", sym->name, &expr->where);
8583 4 : continue;
8584 : }
8585 :
8586 352 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8587 704 : iter; iter = iter->next)
8588 : {
8589 352 : if (iter->var->symtree->n.sym == sym)
8590 : {
8591 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8592 : "locality-spec", sym->name, &expr->where);
8593 1 : continue;
8594 : }
8595 :
8596 351 : data.sym_hash->add (iter->var->symtree->n.sym);
8597 : }
8598 :
8599 352 : if (locality == LOCALITY_LOCAL
8600 352 : || locality == LOCALITY_LOCAL_INIT
8601 352 : || locality == LOCALITY_REDUCE)
8602 : {
8603 198 : if (sym->attr.optional)
8604 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8605 : "locality-spec at %L",
8606 : sym->name, name, &expr->where);
8607 :
8608 198 : if (sym->attr.dimension
8609 66 : && sym->as
8610 66 : && sym->as->type == AS_ASSUMED_SIZE)
8611 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8612 : "locality-spec at %L",
8613 : sym->name, name, &expr->where);
8614 :
8615 198 : gfc_check_vardef_context (expr, false, false, false, name);
8616 : }
8617 :
8618 198 : if (locality == LOCALITY_LOCAL
8619 : || locality == LOCALITY_LOCAL_INIT)
8620 : {
8621 181 : symbol_attribute attr = gfc_expr_attr (expr);
8622 :
8623 181 : if (attr.allocatable)
8624 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8625 : "locality-spec at %L",
8626 : sym->name, name, &expr->where);
8627 :
8628 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8629 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8630 : " for %qs in %s locality-spec at %L",
8631 : sym->name, name, &expr->where);
8632 :
8633 177 : else if (attr.codimension)
8634 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8635 : "at %L",
8636 : sym->name, name, &expr->where);
8637 :
8638 177 : else if (expr->ts.type == BT_DERIVED
8639 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8640 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8641 : "locality-spec at %L",
8642 : sym->name, name, &expr->where);
8643 :
8644 177 : else if (gfc_has_ultimate_allocatable (expr))
8645 4 : gfc_error ("Type with ultimate allocatable component not "
8646 : "permitted for %qs in %s locality-spec at %L",
8647 : sym->name, name, &expr->where);
8648 : }
8649 :
8650 171 : else if (locality == LOCALITY_REDUCE)
8651 : {
8652 17 : if (sym->attr.asynchronous)
8653 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8654 : "REDUCE locality-spec at %L",
8655 : sym->name, &expr->where);
8656 17 : if (sym->attr.volatile_)
8657 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8658 : "locality-spec at %L", sym->name, &expr->where);
8659 : }
8660 :
8661 352 : data.sym_hash->add (sym);
8662 : }
8663 :
8664 840 : if (locality == LOCALITY_LOCAL)
8665 : {
8666 210 : gcc_assert (locality == 0);
8667 :
8668 210 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8669 437 : iter; iter = iter->next)
8670 : {
8671 227 : gfc_expr_walker (&iter->start,
8672 : do_concur_locality_specs_f2023,
8673 : &data);
8674 :
8675 227 : gfc_expr_walker (&iter->end,
8676 : do_concur_locality_specs_f2023,
8677 : &data);
8678 :
8679 227 : gfc_expr_walker (&iter->stride,
8680 : do_concur_locality_specs_f2023,
8681 : &data);
8682 : }
8683 :
8684 210 : if (code->expr1)
8685 7 : gfc_expr_walker (&code->expr1,
8686 : do_concur_locality_specs_f2023,
8687 : &data);
8688 : }
8689 : }
8690 :
8691 210 : gfc_expr *reduce_op = NULL;
8692 :
8693 210 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8694 258 : list; list = list->next)
8695 : {
8696 48 : gfc_expr *expr = list->expr;
8697 :
8698 48 : if (expr->expr_type != EXPR_VARIABLE)
8699 : {
8700 24 : reduce_op = expr;
8701 24 : continue;
8702 : }
8703 :
8704 24 : if (reduce_op->expr_type == EXPR_OP)
8705 : {
8706 17 : switch (reduce_op->value.op.op)
8707 : {
8708 17 : case INTRINSIC_PLUS:
8709 17 : case INTRINSIC_TIMES:
8710 17 : if (!gfc_numeric_ts (&expr->ts))
8711 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8712 3 : "got %s", expr->symtree->n.sym->name,
8713 : &expr->where, gfc_basic_typename (expr->ts.type));
8714 : break;
8715 0 : case INTRINSIC_AND:
8716 0 : case INTRINSIC_OR:
8717 0 : case INTRINSIC_EQV:
8718 0 : case INTRINSIC_NEQV:
8719 0 : if (expr->ts.type != BT_LOGICAL)
8720 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8721 0 : "got %qs", expr->symtree->n.sym->name,
8722 : &expr->where, gfc_basic_typename (expr->ts.type));
8723 : break;
8724 0 : default:
8725 0 : gcc_unreachable ();
8726 : }
8727 : }
8728 :
8729 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8730 : {
8731 7 : switch (reduce_op->value.function.isym->id)
8732 : {
8733 6 : case GFC_ISYM_MIN:
8734 6 : case GFC_ISYM_MAX:
8735 6 : if (expr->ts.type != BT_INTEGER
8736 : && expr->ts.type != BT_REAL
8737 : && expr->ts.type != BT_CHARACTER)
8738 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8739 : "in REDUCE with MIN/MAX at %L, got %s",
8740 2 : expr->symtree->n.sym->name, &expr->where,
8741 : gfc_basic_typename (expr->ts.type));
8742 : break;
8743 1 : case GFC_ISYM_IAND:
8744 1 : case GFC_ISYM_IOR:
8745 1 : case GFC_ISYM_IEOR:
8746 1 : if (expr->ts.type != BT_INTEGER)
8747 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8748 : "IAND/IOR/IEOR at %L, got %s",
8749 1 : expr->symtree->n.sym->name, &expr->where,
8750 : gfc_basic_typename (expr->ts.type));
8751 : break;
8752 0 : default:
8753 0 : gcc_unreachable ();
8754 : }
8755 : }
8756 :
8757 : else
8758 0 : gcc_unreachable ();
8759 : }
8760 :
8761 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8762 : {
8763 1227 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8764 387 : list = list->next)
8765 : {
8766 387 : if (list->expr->expr_type == EXPR_VARIABLE)
8767 363 : list->expr->symtree->n.sym->mark = 0;
8768 : }
8769 : }
8770 :
8771 210 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8772 : check_default_none_expr, &data);
8773 :
8774 1050 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8775 : {
8776 840 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8777 1227 : while (*plist)
8778 : {
8779 387 : gfc_expr *expr = (*plist)->expr;
8780 387 : if (expr->expr_type == EXPR_VARIABLE)
8781 : {
8782 363 : gfc_symbol *sym = expr->symtree->n.sym;
8783 363 : if (sym->mark == 0)
8784 : {
8785 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8786 : "locality-spec at %L is not used",
8787 : sym->name, &expr->where);
8788 70 : gfc_expr_list *tmp = *plist;
8789 70 : *plist = (*plist)->next;
8790 70 : gfc_free_expr (tmp->expr);
8791 70 : free (tmp);
8792 70 : continue;
8793 70 : }
8794 : }
8795 317 : plist = &((*plist)->next);
8796 : }
8797 : }
8798 :
8799 420 : delete data.sym_hash;
8800 210 : }
8801 :
8802 : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
8803 : to be a scalar INTEGER variable. The subscripts and stride are scalar
8804 : INTEGERs, and if stride is a constant it must be nonzero.
8805 : Furthermore "A subscript or stride in a forall-triplet-spec shall
8806 : not contain a reference to any index-name in the
8807 : forall-triplet-spec-list in which it appears." (7.5.4.1) */
8808 :
8809 : static void
8810 2202 : resolve_forall_iterators (gfc_forall_iterator *it)
8811 : {
8812 2202 : gfc_forall_iterator *iter, *iter2;
8813 :
8814 6320 : for (iter = it; iter; iter = iter->next)
8815 : {
8816 4118 : if (gfc_resolve_expr (iter->var)
8817 4118 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
8818 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
8819 : &iter->var->where);
8820 :
8821 4118 : if (gfc_resolve_expr (iter->start)
8822 4118 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
8823 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
8824 : &iter->start->where);
8825 4118 : if (iter->var->ts.kind != iter->start->ts.kind)
8826 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8827 :
8828 4118 : if (gfc_resolve_expr (iter->end)
8829 4118 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
8830 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
8831 : &iter->end->where);
8832 4118 : if (iter->var->ts.kind != iter->end->ts.kind)
8833 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8834 :
8835 4118 : if (gfc_resolve_expr (iter->stride))
8836 : {
8837 4118 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
8838 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
8839 : &iter->stride->where, "INTEGER");
8840 :
8841 4118 : if (iter->stride->expr_type == EXPR_CONSTANT
8842 4115 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
8843 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
8844 : &iter->stride->where);
8845 : }
8846 4118 : if (iter->var->ts.kind != iter->stride->ts.kind)
8847 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
8848 : }
8849 :
8850 6320 : for (iter = it; iter; iter = iter->next)
8851 11078 : for (iter2 = iter; iter2; iter2 = iter2->next)
8852 : {
8853 6960 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
8854 6958 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
8855 13916 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
8856 6 : gfc_error ("FORALL index %qs may not appear in triplet "
8857 6 : "specification at %L", iter->var->symtree->name,
8858 6 : &iter2->start->where);
8859 : }
8860 2202 : }
8861 :
8862 :
8863 : /* Given a pointer to a symbol that is a derived type, see if it's
8864 : inaccessible, i.e. if it's defined in another module and the components are
8865 : PRIVATE. The search is recursive if necessary. Returns zero if no
8866 : inaccessible components are found, nonzero otherwise. */
8867 :
8868 : static bool
8869 1348 : derived_inaccessible (gfc_symbol *sym)
8870 : {
8871 1348 : gfc_component *c;
8872 :
8873 1348 : if (sym->attr.use_assoc && sym->attr.private_comp)
8874 : return 1;
8875 :
8876 3992 : for (c = sym->components; c; c = c->next)
8877 : {
8878 : /* Prevent an infinite loop through this function. */
8879 2657 : if (c->ts.type == BT_DERIVED
8880 288 : && (c->attr.pointer || c->attr.allocatable)
8881 72 : && sym == c->ts.u.derived)
8882 72 : continue;
8883 :
8884 2585 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
8885 : return 1;
8886 : }
8887 :
8888 : return 0;
8889 : }
8890 :
8891 :
8892 : /* Resolve the argument of a deallocate expression. The expression must be
8893 : a pointer or a full array. */
8894 :
8895 : static bool
8896 8221 : resolve_deallocate_expr (gfc_expr *e)
8897 : {
8898 8221 : symbol_attribute attr;
8899 8221 : int allocatable, pointer;
8900 8221 : gfc_ref *ref;
8901 8221 : gfc_symbol *sym;
8902 8221 : gfc_component *c;
8903 8221 : bool unlimited;
8904 :
8905 8221 : if (!gfc_resolve_expr (e))
8906 : return false;
8907 :
8908 8221 : if (e->expr_type != EXPR_VARIABLE)
8909 0 : goto bad;
8910 :
8911 8221 : sym = e->symtree->n.sym;
8912 8221 : unlimited = UNLIMITED_POLY(sym);
8913 :
8914 8221 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
8915 : {
8916 1556 : allocatable = CLASS_DATA (sym)->attr.allocatable;
8917 1556 : pointer = CLASS_DATA (sym)->attr.class_pointer;
8918 : }
8919 : else
8920 : {
8921 6665 : allocatable = sym->attr.allocatable;
8922 6665 : pointer = sym->attr.pointer;
8923 : }
8924 16471 : for (ref = e->ref; ref; ref = ref->next)
8925 : {
8926 8250 : switch (ref->type)
8927 : {
8928 6148 : case REF_ARRAY:
8929 6148 : if (ref->u.ar.type != AR_FULL
8930 6356 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
8931 208 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
8932 : allocatable = 0;
8933 : break;
8934 :
8935 2102 : case REF_COMPONENT:
8936 2102 : c = ref->u.c.component;
8937 2102 : if (c->ts.type == BT_CLASS)
8938 : {
8939 297 : allocatable = CLASS_DATA (c)->attr.allocatable;
8940 297 : pointer = CLASS_DATA (c)->attr.class_pointer;
8941 : }
8942 : else
8943 : {
8944 1805 : allocatable = c->attr.allocatable;
8945 1805 : pointer = c->attr.pointer;
8946 : }
8947 : break;
8948 :
8949 : case REF_SUBSTRING:
8950 : case REF_INQUIRY:
8951 495 : allocatable = 0;
8952 : break;
8953 : }
8954 : }
8955 :
8956 8221 : attr = gfc_expr_attr (e);
8957 :
8958 8221 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
8959 : {
8960 3 : bad:
8961 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8962 : &e->where);
8963 3 : return false;
8964 : }
8965 :
8966 : /* F2008, C644. */
8967 8218 : if (gfc_is_coindexed (e))
8968 : {
8969 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
8970 1 : return false;
8971 : }
8972 :
8973 8217 : if (pointer
8974 10579 : && !gfc_check_vardef_context (e, true, true, false,
8975 2362 : _("DEALLOCATE object")))
8976 : return false;
8977 8215 : if (!gfc_check_vardef_context (e, false, true, false,
8978 8215 : _("DEALLOCATE object")))
8979 : return false;
8980 :
8981 : return true;
8982 : }
8983 :
8984 :
8985 : /* Returns true if the expression e contains a reference to the symbol sym. */
8986 : static bool
8987 47348 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
8988 : {
8989 47348 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
8990 2081 : return true;
8991 :
8992 : return false;
8993 : }
8994 :
8995 : bool
8996 20077 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
8997 : {
8998 20077 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
8999 : }
9000 :
9001 : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
9002 : of character expressions. */
9003 : static bool
9004 20448 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
9005 : {
9006 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
9007 : }
9008 :
9009 :
9010 : /* Given the expression node e for an allocatable/pointer of derived type to be
9011 : allocated, get the expression node to be initialized afterwards (needed for
9012 : derived types with default initializers, and derived types with allocatable
9013 : components that need nullification.) */
9014 :
9015 : gfc_expr *
9016 5712 : gfc_expr_to_initialize (gfc_expr *e)
9017 : {
9018 5712 : gfc_expr *result;
9019 5712 : gfc_ref *ref;
9020 5712 : int i;
9021 :
9022 5712 : result = gfc_copy_expr (e);
9023 :
9024 : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
9025 11320 : for (ref = result->ref; ref; ref = ref->next)
9026 8922 : if (ref->type == REF_ARRAY && ref->next == NULL)
9027 : {
9028 3314 : if (ref->u.ar.dimen == 0
9029 74 : && ref->u.ar.as && ref->u.ar.as->corank)
9030 : return result;
9031 :
9032 3240 : ref->u.ar.type = AR_FULL;
9033 :
9034 7326 : for (i = 0; i < ref->u.ar.dimen; i++)
9035 4086 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
9036 :
9037 : break;
9038 : }
9039 :
9040 5638 : gfc_free_shape (&result->shape, result->rank);
9041 :
9042 : /* Recalculate rank, shape, etc. */
9043 5638 : gfc_resolve_expr (result);
9044 5638 : return result;
9045 : }
9046 :
9047 :
9048 : /* If the last ref of an expression is an array ref, return a copy of the
9049 : expression with that one removed. Otherwise, a copy of the original
9050 : expression. This is used for allocate-expressions and pointer assignment
9051 : LHS, where there may be an array specification that needs to be stripped
9052 : off when using gfc_check_vardef_context. */
9053 :
9054 : static gfc_expr*
9055 27479 : remove_last_array_ref (gfc_expr* e)
9056 : {
9057 27479 : gfc_expr* e2;
9058 27479 : gfc_ref** r;
9059 :
9060 27479 : e2 = gfc_copy_expr (e);
9061 35428 : for (r = &e2->ref; *r; r = &(*r)->next)
9062 24179 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9063 : {
9064 16230 : gfc_free_ref_list (*r);
9065 16230 : *r = NULL;
9066 16230 : break;
9067 : }
9068 :
9069 27479 : return e2;
9070 : }
9071 :
9072 :
9073 : /* Used in resolve_allocate_expr to check that a allocation-object and
9074 : a source-expr are conformable. This does not catch all possible
9075 : cases; in particular a runtime checking is needed. */
9076 :
9077 : static bool
9078 1901 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9079 : {
9080 1901 : gfc_ref *tail;
9081 1901 : bool scalar;
9082 :
9083 2633 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9084 :
9085 : /* If MOLD= is present and is not scalar, and the allocate-object has an
9086 : explicit-shape-spec, the ranks need not agree. This may be unintended,
9087 : so let's emit a warning if -Wsurprising is given. */
9088 1901 : scalar = !tail || tail->type == REF_COMPONENT;
9089 1901 : if (e1->mold && e1->rank > 0
9090 164 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9091 : {
9092 26 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9093 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9094 : "but MOLD= expression at %L has rank %d",
9095 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9096 : &e1->where, e1->rank);
9097 29 : return true;
9098 : }
9099 :
9100 : /* First compare rank. */
9101 1872 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9102 2 : || (!tail && e1->rank != e2->rank))
9103 : {
9104 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9105 : "same rank as the allocate-object at %L",
9106 : &e1->where, &e2->where);
9107 7 : return false;
9108 : }
9109 :
9110 1865 : if (e1->shape)
9111 : {
9112 1372 : int i;
9113 1372 : mpz_t s;
9114 :
9115 1372 : mpz_init (s);
9116 :
9117 3162 : for (i = 0; i < e1->rank; i++)
9118 : {
9119 1378 : if (tail->u.ar.start[i] == NULL)
9120 : break;
9121 :
9122 418 : if (tail->u.ar.end[i])
9123 : {
9124 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9125 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9126 54 : mpz_add_ui (s, s, 1);
9127 : }
9128 : else
9129 : {
9130 364 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9131 : }
9132 :
9133 418 : if (mpz_cmp (e1->shape[i], s) != 0)
9134 : {
9135 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9136 : "have the same shape", &e1->where, &e2->where);
9137 0 : mpz_clear (s);
9138 0 : return false;
9139 : }
9140 : }
9141 :
9142 1372 : mpz_clear (s);
9143 : }
9144 :
9145 : return true;
9146 : }
9147 :
9148 :
9149 : /* Resolve the expression in an ALLOCATE statement, doing the additional
9150 : checks to see whether the expression is OK or not. The expression must
9151 : have a trailing array reference that gives the size of the array. */
9152 :
9153 : static bool
9154 17151 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9155 : {
9156 17151 : int i, pointer, allocatable, dimension, is_abstract;
9157 17151 : int codimension;
9158 17151 : bool coindexed;
9159 17151 : bool unlimited;
9160 17151 : symbol_attribute attr;
9161 17151 : gfc_ref *ref, *ref2;
9162 17151 : gfc_expr *e2;
9163 17151 : gfc_array_ref *ar;
9164 17151 : gfc_symbol *sym = NULL;
9165 17151 : gfc_alloc *a;
9166 17151 : gfc_component *c;
9167 17151 : bool t;
9168 :
9169 : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9170 : checking of coarrays. */
9171 21788 : for (ref = e->ref; ref; ref = ref->next)
9172 17664 : if (ref->next == NULL)
9173 : break;
9174 :
9175 17151 : if (ref && ref->type == REF_ARRAY)
9176 11850 : ref->u.ar.in_allocate = true;
9177 :
9178 17151 : if (!gfc_resolve_expr (e))
9179 1 : goto failure;
9180 :
9181 : /* Make sure the expression is allocatable or a pointer. If it is
9182 : pointer, the next-to-last reference must be a pointer. */
9183 :
9184 17150 : ref2 = NULL;
9185 17150 : if (e->symtree)
9186 17150 : sym = e->symtree->n.sym;
9187 :
9188 : /* Check whether ultimate component is abstract and CLASS. */
9189 34300 : is_abstract = 0;
9190 :
9191 : /* Is the allocate-object unlimited polymorphic? */
9192 17150 : unlimited = UNLIMITED_POLY(e);
9193 :
9194 17150 : if (e->expr_type != EXPR_VARIABLE)
9195 : {
9196 0 : allocatable = 0;
9197 0 : attr = gfc_expr_attr (e);
9198 0 : pointer = attr.pointer;
9199 0 : dimension = attr.dimension;
9200 0 : codimension = attr.codimension;
9201 : }
9202 : else
9203 : {
9204 17150 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9205 : {
9206 3335 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9207 3335 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9208 3335 : dimension = CLASS_DATA (sym)->attr.dimension;
9209 3335 : codimension = CLASS_DATA (sym)->attr.codimension;
9210 3335 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9211 : }
9212 : else
9213 : {
9214 13815 : allocatable = sym->attr.allocatable;
9215 13815 : pointer = sym->attr.pointer;
9216 13815 : dimension = sym->attr.dimension;
9217 13815 : codimension = sym->attr.codimension;
9218 : }
9219 :
9220 17150 : coindexed = false;
9221 :
9222 34808 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9223 : {
9224 17660 : switch (ref->type)
9225 : {
9226 13257 : case REF_ARRAY:
9227 13257 : if (ref->u.ar.codimen > 0)
9228 : {
9229 754 : int n;
9230 1052 : for (n = ref->u.ar.dimen;
9231 1052 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9232 795 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9233 : {
9234 : coindexed = true;
9235 : break;
9236 : }
9237 : }
9238 :
9239 13257 : if (ref->next != NULL)
9240 1409 : pointer = 0;
9241 : break;
9242 :
9243 4403 : case REF_COMPONENT:
9244 : /* F2008, C644. */
9245 4403 : if (coindexed)
9246 : {
9247 2 : gfc_error ("Coindexed allocatable object at %L",
9248 : &e->where);
9249 2 : goto failure;
9250 : }
9251 :
9252 4401 : c = ref->u.c.component;
9253 4401 : if (c->ts.type == BT_CLASS)
9254 : {
9255 970 : allocatable = CLASS_DATA (c)->attr.allocatable;
9256 970 : pointer = CLASS_DATA (c)->attr.class_pointer;
9257 970 : dimension = CLASS_DATA (c)->attr.dimension;
9258 970 : codimension = CLASS_DATA (c)->attr.codimension;
9259 970 : is_abstract = CLASS_DATA (c)->attr.abstract;
9260 : }
9261 : else
9262 : {
9263 3431 : allocatable = c->attr.allocatable;
9264 3431 : pointer = c->attr.pointer;
9265 3431 : dimension = c->attr.dimension;
9266 3431 : codimension = c->attr.codimension;
9267 3431 : is_abstract = c->attr.abstract;
9268 : }
9269 : break;
9270 :
9271 0 : case REF_SUBSTRING:
9272 0 : case REF_INQUIRY:
9273 0 : allocatable = 0;
9274 0 : pointer = 0;
9275 0 : break;
9276 : }
9277 : }
9278 : }
9279 :
9280 : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9281 : pointer or an allocatable variable. */
9282 17148 : if (allocatable == 0 && pointer == 0)
9283 : {
9284 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9285 : &e->where);
9286 4 : goto failure;
9287 : }
9288 :
9289 : /* Some checks for the SOURCE tag. */
9290 17144 : if (code->expr3)
9291 : {
9292 : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9293 : rank as allocate-object". This would require the MOLD argument to
9294 : NULL() as source-expr for subsequent checking. However, even the
9295 : resulting disassociated pointer or unallocated array has no shape that
9296 : could be used for SOURCE= or MOLD=. */
9297 3802 : if (code->expr3->expr_type == EXPR_NULL)
9298 : {
9299 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9300 : &code->expr3->where);
9301 4 : goto failure;
9302 : }
9303 :
9304 : /* Check F03:C631. */
9305 3798 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9306 : {
9307 10 : gfc_error ("Type of entity at %L is type incompatible with "
9308 10 : "source-expr at %L", &e->where, &code->expr3->where);
9309 10 : goto failure;
9310 : }
9311 :
9312 : /* Check F03:C632 and restriction following Note 6.18. */
9313 3788 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9314 7 : goto failure;
9315 :
9316 : /* Check F03:C633. */
9317 3781 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9318 : {
9319 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9320 : "shall have the same kind type parameter",
9321 : &e->where, &code->expr3->where);
9322 1 : goto failure;
9323 : }
9324 :
9325 : /* Check F2008, C642. */
9326 3780 : if (code->expr3->ts.type == BT_DERIVED
9327 3780 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9328 1166 : || (code->expr3->ts.u.derived->from_intmod
9329 : == INTMOD_ISO_FORTRAN_ENV
9330 0 : && code->expr3->ts.u.derived->intmod_sym_id
9331 : == ISOFORTRAN_LOCK_TYPE)))
9332 : {
9333 0 : gfc_error ("The source-expr at %L shall neither be of type "
9334 : "LOCK_TYPE nor have a LOCK_TYPE component if "
9335 : "allocate-object at %L is a coarray",
9336 0 : &code->expr3->where, &e->where);
9337 0 : goto failure;
9338 : }
9339 :
9340 : /* Check F2008:C639: "Corresponding kind type parameters of
9341 : allocate-object and source-expr shall have the same values." */
9342 3780 : if (e->ts.type == BT_CHARACTER
9343 810 : && !e->ts.deferred
9344 162 : && e->ts.u.cl->length
9345 162 : && code->expr3->ts.type == BT_CHARACTER
9346 3942 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9347 : "SOURCE= or MOLD= specifier"))
9348 17 : goto failure;
9349 :
9350 : /* Check TS18508, C702/C703. */
9351 3763 : if (code->expr3->ts.type == BT_DERIVED
9352 4929 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9353 1166 : || (code->expr3->ts.u.derived->from_intmod
9354 : == INTMOD_ISO_FORTRAN_ENV
9355 0 : && code->expr3->ts.u.derived->intmod_sym_id
9356 : == ISOFORTRAN_EVENT_TYPE)))
9357 : {
9358 0 : gfc_error ("The source-expr at %L shall neither be of type "
9359 : "EVENT_TYPE nor have a EVENT_TYPE component if "
9360 : "allocate-object at %L is a coarray",
9361 0 : &code->expr3->where, &e->where);
9362 0 : goto failure;
9363 : }
9364 : }
9365 :
9366 : /* Check F08:C629. */
9367 17105 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9368 153 : && !code->expr3)
9369 : {
9370 2 : gcc_assert (e->ts.type == BT_CLASS);
9371 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9372 : "type-spec or source-expr", sym->name, &e->where);
9373 2 : goto failure;
9374 : }
9375 :
9376 : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9377 : if and only if each allocate-object is a dummy argument for which the
9378 : corresponding type parameter is assumed. */
9379 17103 : if (code->ext.alloc.ts.type == BT_CHARACTER
9380 508 : && code->ext.alloc.ts.u.cl->length != NULL
9381 493 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9382 23 : && e->ts.u.cl->length == NULL
9383 2 : && e->symtree->n.sym->attr.dummy)
9384 : {
9385 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9386 : "shall be an asterisk as allocate object %qs at %L is a "
9387 : "dummy argument with assumed type parameter",
9388 : sym->name, &e->where);
9389 2 : goto failure;
9390 : }
9391 :
9392 : /* Check F08:C632. */
9393 17101 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9394 60 : && !UNLIMITED_POLY (e))
9395 : {
9396 36 : int cmp;
9397 :
9398 36 : if (!e->ts.u.cl->length)
9399 15 : goto failure;
9400 :
9401 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9402 21 : code->ext.alloc.ts.u.cl->length);
9403 21 : if (cmp == 1 || cmp == -1 || cmp == -3)
9404 : {
9405 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9406 : "character-length parameter as in the declaration",
9407 : sym->name, &e->where);
9408 2 : goto failure;
9409 : }
9410 : }
9411 :
9412 : /* In the variable definition context checks, gfc_expr_attr is used
9413 : on the expression. This is fooled by the array specification
9414 : present in e, thus we have to eliminate that one temporarily. */
9415 17084 : e2 = remove_last_array_ref (e);
9416 17084 : t = true;
9417 17084 : if (t && pointer)
9418 3820 : t = gfc_check_vardef_context (e2, true, true, false,
9419 3820 : _("ALLOCATE object"));
9420 3820 : if (t)
9421 17076 : t = gfc_check_vardef_context (e2, false, true, false,
9422 17076 : _("ALLOCATE object"));
9423 17084 : gfc_free_expr (e2);
9424 17084 : if (!t)
9425 11 : goto failure;
9426 :
9427 17073 : code->ext.alloc.expr3_not_explicit = 0;
9428 17073 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9429 1575 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9430 : {
9431 : /* For class arrays, the initialization with SOURCE is done
9432 : using _copy and trans_call. It is convenient to exploit that
9433 : when the allocated type is different from the declared type but
9434 : no SOURCE exists by setting expr3. */
9435 281 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9436 281 : code->ext.alloc.expr3_not_explicit = 1;
9437 : }
9438 16792 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9439 2553 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9440 6 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9441 : {
9442 : /* We have to zero initialize the integer variable. */
9443 2 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9444 2 : code->ext.alloc.expr3_not_explicit = 1;
9445 : }
9446 :
9447 17073 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9448 : {
9449 : /* Make sure the vtab symbol is present when
9450 : the module variables are generated. */
9451 2929 : gfc_typespec ts = e->ts;
9452 2929 : if (code->expr3)
9453 1306 : ts = code->expr3->ts;
9454 1623 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9455 708 : ts = code->ext.alloc.ts;
9456 :
9457 : /* Finding the vtab also publishes the type's symbol. Therefore this
9458 : statement is necessary. */
9459 2929 : gfc_find_derived_vtab (ts.u.derived);
9460 2929 : }
9461 14144 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9462 : {
9463 : /* Again, make sure the vtab symbol is present when
9464 : the module variables are generated. */
9465 434 : gfc_typespec *ts = NULL;
9466 434 : if (code->expr3)
9467 347 : ts = &code->expr3->ts;
9468 : else
9469 87 : ts = &code->ext.alloc.ts;
9470 :
9471 434 : gcc_assert (ts);
9472 :
9473 : /* Finding the vtab also publishes the type's symbol. Therefore this
9474 : statement is necessary. */
9475 434 : gfc_find_vtab (ts);
9476 : }
9477 :
9478 17073 : if (dimension == 0 && codimension == 0)
9479 5254 : goto success;
9480 :
9481 : /* Make sure the last reference node is an array specification. */
9482 :
9483 11819 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9484 10593 : || (dimension && ref2->u.ar.dimen == 0))
9485 : {
9486 : /* F08:C633. */
9487 1226 : if (code->expr3)
9488 : {
9489 1225 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9490 : "in ALLOCATE statement at %L", &e->where))
9491 0 : goto failure;
9492 1225 : if (code->expr3->rank != 0)
9493 1224 : *array_alloc_wo_spec = true;
9494 : else
9495 : {
9496 1 : gfc_error ("Array specification or array-valued SOURCE= "
9497 : "expression required in ALLOCATE statement at %L",
9498 : &e->where);
9499 1 : goto failure;
9500 : }
9501 : }
9502 : else
9503 : {
9504 1 : gfc_error ("Array specification required in ALLOCATE statement "
9505 : "at %L", &e->where);
9506 1 : goto failure;
9507 : }
9508 : }
9509 :
9510 : /* Make sure that the array section reference makes sense in the
9511 : context of an ALLOCATE specification. */
9512 :
9513 11817 : ar = &ref2->u.ar;
9514 :
9515 11817 : if (codimension)
9516 1173 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9517 : {
9518 689 : switch (ar->dimen_type[i])
9519 : {
9520 2 : case DIMEN_THIS_IMAGE:
9521 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9522 : "at %L", &e->where);
9523 2 : goto failure;
9524 :
9525 98 : case DIMEN_RANGE:
9526 : /* F2018:R937:
9527 : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9528 : */
9529 98 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9530 : {
9531 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9532 : "at %L", &e->where);
9533 8 : goto failure;
9534 : }
9535 90 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9536 : {
9537 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9538 2 : &ar->start[i]->where);
9539 2 : goto failure;
9540 : }
9541 : break;
9542 :
9543 105 : case DIMEN_ELEMENT:
9544 105 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9545 : {
9546 97 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9547 97 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9548 : {
9549 1 : gfc_error ("Upper cobound is less than lower cobound "
9550 : "of 1 at %L", &ar->start[i]->where);
9551 1 : goto failure;
9552 : }
9553 : }
9554 : break;
9555 :
9556 : case DIMEN_STAR:
9557 : break;
9558 :
9559 0 : default:
9560 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9561 : &e->where);
9562 0 : goto failure;
9563 :
9564 : }
9565 : }
9566 28987 : for (i = 0; i < ar->dimen; i++)
9567 : {
9568 17187 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9569 14477 : goto check_symbols;
9570 :
9571 2710 : switch (ar->dimen_type[i])
9572 : {
9573 : case DIMEN_ELEMENT:
9574 : break;
9575 :
9576 2444 : case DIMEN_RANGE:
9577 2444 : if (ar->start[i] != NULL
9578 2444 : && ar->end[i] != NULL
9579 2443 : && ar->stride[i] == NULL)
9580 : break;
9581 :
9582 : /* Fall through. */
9583 :
9584 1 : case DIMEN_UNKNOWN:
9585 1 : case DIMEN_VECTOR:
9586 1 : case DIMEN_STAR:
9587 1 : case DIMEN_THIS_IMAGE:
9588 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9589 : &e->where);
9590 1 : goto failure;
9591 : }
9592 :
9593 2443 : check_symbols:
9594 44782 : for (a = code->ext.alloc.list; a; a = a->next)
9595 : {
9596 27599 : sym = a->expr->symtree->n.sym;
9597 :
9598 : /* TODO - check derived type components. */
9599 27599 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9600 9193 : continue;
9601 :
9602 18406 : if ((ar->start[i] != NULL
9603 17726 : && gfc_find_var_in_expr (sym, ar->start[i]))
9604 36129 : || (ar->end[i] != NULL
9605 2722 : && gfc_find_var_in_expr (sym, ar->end[i])))
9606 : {
9607 3 : gfc_error ("%qs must not appear in the array specification at "
9608 : "%L in the same ALLOCATE statement where it is "
9609 : "itself allocated", sym->name, &ar->where);
9610 3 : goto failure;
9611 : }
9612 : }
9613 : }
9614 :
9615 11991 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9616 : {
9617 865 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9618 674 : || ar->dimen_type[i] == DIMEN_RANGE)
9619 : {
9620 191 : if (i == (ar->dimen + ar->codimen - 1))
9621 : {
9622 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9623 : "statement at %L", &e->where);
9624 0 : goto failure;
9625 : }
9626 191 : continue;
9627 : }
9628 :
9629 483 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9630 483 : && ar->stride[i] == NULL)
9631 : break;
9632 :
9633 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9634 : &e->where);
9635 0 : goto failure;
9636 : }
9637 :
9638 11800 : success:
9639 : return true;
9640 :
9641 : failure:
9642 : return false;
9643 : }
9644 :
9645 :
9646 : static void
9647 20110 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9648 : {
9649 20110 : gfc_expr *stat, *errmsg, *pe, *qe;
9650 20110 : gfc_alloc *a, *p, *q;
9651 :
9652 20110 : stat = code->expr1;
9653 20110 : errmsg = code->expr2;
9654 :
9655 : /* Check the stat variable. */
9656 20110 : if (stat)
9657 : {
9658 661 : if (!gfc_check_vardef_context (stat, false, false, false,
9659 661 : _("STAT variable")))
9660 8 : goto done_stat;
9661 :
9662 653 : if (stat->ts.type != BT_INTEGER
9663 644 : || stat->rank > 0)
9664 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9665 : "variable", &stat->where);
9666 :
9667 653 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9668 0 : goto done_stat;
9669 :
9670 : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9671 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9672 : */
9673 1354 : for (p = code->ext.alloc.list; p; p = p->next)
9674 708 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9675 : {
9676 9 : gfc_ref *ref1, *ref2;
9677 9 : bool found = true;
9678 :
9679 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9680 7 : ref1 = ref1->next, ref2 = ref2->next)
9681 : {
9682 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9683 5 : continue;
9684 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9685 : {
9686 : found = false;
9687 : break;
9688 : }
9689 : }
9690 :
9691 9 : if (found)
9692 : {
9693 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9694 : "the same %s statement", &stat->where, fcn, fcn);
9695 7 : break;
9696 : }
9697 : }
9698 : }
9699 :
9700 19449 : done_stat:
9701 :
9702 : /* Check the errmsg variable. */
9703 20110 : if (errmsg)
9704 : {
9705 150 : if (!stat)
9706 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9707 : &errmsg->where);
9708 :
9709 150 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9710 150 : _("ERRMSG variable")))
9711 6 : goto done_errmsg;
9712 :
9713 : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9714 : F18:R930 errmsg-variable is scalar-default-char-variable
9715 : F18:R906 default-char-variable is variable
9716 : F18:C906 default-char-variable shall be default character. */
9717 144 : if (errmsg->ts.type != BT_CHARACTER
9718 142 : || errmsg->rank > 0
9719 141 : || errmsg->ts.kind != gfc_default_character_kind)
9720 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9721 : "variable", &errmsg->where);
9722 :
9723 144 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9724 0 : goto done_errmsg;
9725 :
9726 : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9727 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9728 : */
9729 286 : for (p = code->ext.alloc.list; p; p = p->next)
9730 147 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9731 : {
9732 9 : gfc_ref *ref1, *ref2;
9733 9 : bool found = true;
9734 :
9735 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9736 7 : ref1 = ref1->next, ref2 = ref2->next)
9737 : {
9738 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9739 4 : continue;
9740 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9741 : {
9742 : found = false;
9743 : break;
9744 : }
9745 : }
9746 :
9747 9 : if (found)
9748 : {
9749 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9750 : "the same %s statement", &errmsg->where, fcn, fcn);
9751 5 : break;
9752 : }
9753 : }
9754 : }
9755 :
9756 19960 : done_errmsg:
9757 :
9758 : /* Check that an allocate-object appears only once in the statement. */
9759 :
9760 45482 : for (p = code->ext.alloc.list; p; p = p->next)
9761 : {
9762 25372 : pe = p->expr;
9763 34610 : for (q = p->next; q; q = q->next)
9764 : {
9765 9238 : qe = q->expr;
9766 9238 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9767 : {
9768 : /* This is a potential collision. */
9769 2093 : gfc_ref *pr = pe->ref;
9770 2093 : gfc_ref *qr = qe->ref;
9771 :
9772 : /* Follow the references until
9773 : a) They start to differ, in which case there is no error;
9774 : you can deallocate a%b and a%c in a single statement
9775 : b) Both of them stop, which is an error
9776 : c) One of them stops, which is also an error. */
9777 4517 : while (1)
9778 : {
9779 3305 : if (pr == NULL && qr == NULL)
9780 : {
9781 7 : gfc_error ("Allocate-object at %L also appears at %L",
9782 : &pe->where, &qe->where);
9783 7 : break;
9784 : }
9785 3298 : else if (pr != NULL && qr == NULL)
9786 : {
9787 2 : gfc_error ("Allocate-object at %L is subobject of"
9788 : " object at %L", &pe->where, &qe->where);
9789 2 : break;
9790 : }
9791 3296 : else if (pr == NULL && qr != NULL)
9792 : {
9793 2 : gfc_error ("Allocate-object at %L is subobject of"
9794 : " object at %L", &qe->where, &pe->where);
9795 2 : break;
9796 : }
9797 : /* Here, pr != NULL && qr != NULL */
9798 3294 : gcc_assert(pr->type == qr->type);
9799 3294 : if (pr->type == REF_ARRAY)
9800 : {
9801 : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
9802 : which are legal. */
9803 1065 : gcc_assert (qr->type == REF_ARRAY);
9804 :
9805 1065 : if (pr->next && qr->next)
9806 : {
9807 : int i;
9808 : gfc_array_ref *par = &(pr->u.ar);
9809 : gfc_array_ref *qar = &(qr->u.ar);
9810 :
9811 1840 : for (i=0; i<par->dimen; i++)
9812 : {
9813 954 : if ((par->start[i] != NULL
9814 0 : || qar->start[i] != NULL)
9815 1908 : && gfc_dep_compare_expr (par->start[i],
9816 954 : qar->start[i]) != 0)
9817 168 : goto break_label;
9818 : }
9819 : }
9820 : }
9821 : else
9822 : {
9823 2229 : if (pr->u.c.component->name != qr->u.c.component->name)
9824 : break;
9825 : }
9826 :
9827 1212 : pr = pr->next;
9828 1212 : qr = qr->next;
9829 1212 : }
9830 9238 : break_label:
9831 : ;
9832 : }
9833 : }
9834 : }
9835 :
9836 20110 : if (strcmp (fcn, "ALLOCATE") == 0)
9837 : {
9838 14139 : bool arr_alloc_wo_spec = false;
9839 :
9840 : /* Resolving the expr3 in the loop over all objects to allocate would
9841 : execute loop invariant code for each loop item. Therefore do it just
9842 : once here. */
9843 14139 : if (code->expr3 && code->expr3->mold
9844 344 : && code->expr3->ts.type == BT_DERIVED
9845 21 : && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
9846 : {
9847 : /* Default initialization via MOLD (non-polymorphic). */
9848 19 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
9849 19 : if (rhs != NULL)
9850 : {
9851 6 : gfc_resolve_expr (rhs);
9852 6 : gfc_free_expr (code->expr3);
9853 6 : code->expr3 = rhs;
9854 : }
9855 : }
9856 31290 : for (a = code->ext.alloc.list; a; a = a->next)
9857 17151 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
9858 :
9859 14139 : if (arr_alloc_wo_spec && code->expr3)
9860 : {
9861 : /* Mark the allocate to have to take the array specification
9862 : from the expr3. */
9863 1218 : code->ext.alloc.arr_spec_from_expr3 = 1;
9864 : }
9865 : }
9866 : else
9867 : {
9868 14192 : for (a = code->ext.alloc.list; a; a = a->next)
9869 8221 : resolve_deallocate_expr (a->expr);
9870 : }
9871 20110 : }
9872 :
9873 :
9874 : /************ SELECT CASE resolution subroutines ************/
9875 :
9876 : /* Callback function for our mergesort variant. Determines interval
9877 : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
9878 : op1 > op2. Assumes we're not dealing with the default case.
9879 : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
9880 : There are nine situations to check. */
9881 :
9882 : static int
9883 1578 : compare_cases (const gfc_case *op1, const gfc_case *op2)
9884 : {
9885 1578 : int retval;
9886 :
9887 1578 : if (op1->low == NULL) /* op1 = (:L) */
9888 : {
9889 : /* op2 = (:N), so overlap. */
9890 52 : retval = 0;
9891 : /* op2 = (M:) or (M:N), L < M */
9892 52 : if (op2->low != NULL
9893 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9894 : retval = -1;
9895 : }
9896 1526 : else if (op1->high == NULL) /* op1 = (K:) */
9897 : {
9898 : /* op2 = (M:), so overlap. */
9899 10 : retval = 0;
9900 : /* op2 = (:N) or (M:N), K > N */
9901 10 : if (op2->high != NULL
9902 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9903 : retval = 1;
9904 : }
9905 : else /* op1 = (K:L) */
9906 : {
9907 1516 : if (op2->low == NULL) /* op2 = (:N), K > N */
9908 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9909 18 : ? 1 : 0;
9910 1498 : else if (op2->high == NULL) /* op2 = (M:), L < M */
9911 14 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9912 10 : ? -1 : 0;
9913 : else /* op2 = (M:N) */
9914 : {
9915 1488 : retval = 0;
9916 : /* L < M */
9917 1488 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9918 : retval = -1;
9919 : /* K > N */
9920 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9921 438 : retval = 1;
9922 : }
9923 : }
9924 :
9925 1578 : return retval;
9926 : }
9927 :
9928 :
9929 : /* Merge-sort a double linked case list, detecting overlap in the
9930 : process. LIST is the head of the double linked case list before it
9931 : is sorted. Returns the head of the sorted list if we don't see any
9932 : overlap, or NULL otherwise. */
9933 :
9934 : static gfc_case *
9935 646 : check_case_overlap (gfc_case *list)
9936 : {
9937 646 : gfc_case *p, *q, *e, *tail;
9938 646 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
9939 :
9940 : /* If the passed list was empty, return immediately. */
9941 646 : if (!list)
9942 : return NULL;
9943 :
9944 : overlap_seen = 0;
9945 : insize = 1;
9946 :
9947 : /* Loop unconditionally. The only exit from this loop is a return
9948 : statement, when we've finished sorting the case list. */
9949 1350 : for (;;)
9950 : {
9951 998 : p = list;
9952 998 : list = NULL;
9953 998 : tail = NULL;
9954 :
9955 : /* Count the number of merges we do in this pass. */
9956 998 : nmerges = 0;
9957 :
9958 : /* Loop while there exists a merge to be done. */
9959 2523 : while (p)
9960 : {
9961 1525 : int i;
9962 :
9963 : /* Count this merge. */
9964 1525 : nmerges++;
9965 :
9966 : /* Cut the list in two pieces by stepping INSIZE places
9967 : forward in the list, starting from P. */
9968 1525 : psize = 0;
9969 1525 : q = p;
9970 3208 : for (i = 0; i < insize; i++)
9971 : {
9972 2243 : psize++;
9973 2243 : q = q->right;
9974 2243 : if (!q)
9975 : break;
9976 : }
9977 : qsize = insize;
9978 :
9979 : /* Now we have two lists. Merge them! */
9980 5013 : while (psize > 0 || (qsize > 0 && q != NULL))
9981 : {
9982 : /* See from which the next case to merge comes from. */
9983 807 : if (psize == 0)
9984 : {
9985 : /* P is empty so the next case must come from Q. */
9986 807 : e = q;
9987 807 : q = q->right;
9988 807 : qsize--;
9989 : }
9990 2681 : else if (qsize == 0 || q == NULL)
9991 : {
9992 : /* Q is empty. */
9993 1103 : e = p;
9994 1103 : p = p->right;
9995 1103 : psize--;
9996 : }
9997 : else
9998 : {
9999 1578 : cmp = compare_cases (p, q);
10000 1578 : if (cmp < 0)
10001 : {
10002 : /* The whole case range for P is less than the
10003 : one for Q. */
10004 1136 : e = p;
10005 1136 : p = p->right;
10006 1136 : psize--;
10007 : }
10008 442 : else if (cmp > 0)
10009 : {
10010 : /* The whole case range for Q is greater than
10011 : the case range for P. */
10012 438 : e = q;
10013 438 : q = q->right;
10014 438 : qsize--;
10015 : }
10016 : else
10017 : {
10018 : /* The cases overlap, or they are the same
10019 : element in the list. Either way, we must
10020 : issue an error and get the next case from P. */
10021 : /* FIXME: Sort P and Q by line number. */
10022 4 : gfc_error ("CASE label at %L overlaps with CASE "
10023 : "label at %L", &p->where, &q->where);
10024 4 : overlap_seen = 1;
10025 4 : e = p;
10026 4 : p = p->right;
10027 4 : psize--;
10028 : }
10029 : }
10030 :
10031 : /* Add the next element to the merged list. */
10032 3488 : if (tail)
10033 2490 : tail->right = e;
10034 : else
10035 : list = e;
10036 3488 : e->left = tail;
10037 3488 : tail = e;
10038 : }
10039 :
10040 : /* P has now stepped INSIZE places along, and so has Q. So
10041 : they're the same. */
10042 : p = q;
10043 : }
10044 998 : tail->right = NULL;
10045 :
10046 : /* If we have done only one merge or none at all, we've
10047 : finished sorting the cases. */
10048 998 : if (nmerges <= 1)
10049 : {
10050 646 : if (!overlap_seen)
10051 : return list;
10052 : else
10053 : return NULL;
10054 : }
10055 :
10056 : /* Otherwise repeat, merging lists twice the size. */
10057 352 : insize *= 2;
10058 352 : }
10059 : }
10060 :
10061 :
10062 : /* Check to see if an expression is suitable for use in a CASE statement.
10063 : Makes sure that all case expressions are scalar constants of the same
10064 : type. Return false if anything is wrong. */
10065 :
10066 : static bool
10067 3307 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10068 : {
10069 3307 : if (e == NULL) return true;
10070 :
10071 3214 : if (e->ts.type != case_expr->ts.type)
10072 : {
10073 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10074 : &e->where, gfc_basic_typename (case_expr->ts.type));
10075 4 : return false;
10076 : }
10077 :
10078 : /* C805 (R808) For a given case-construct, each case-value shall be of
10079 : the same type as case-expr. For character type, length differences
10080 : are allowed, but the kind type parameters shall be the same. */
10081 :
10082 3210 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10083 : {
10084 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10085 : &e->where, case_expr->ts.kind);
10086 4 : return false;
10087 : }
10088 :
10089 : /* Convert the case value kind to that of case expression kind,
10090 : if needed */
10091 :
10092 3206 : if (e->ts.kind != case_expr->ts.kind)
10093 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10094 :
10095 3206 : if (e->rank != 0)
10096 : {
10097 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10098 : &e->where);
10099 0 : return false;
10100 : }
10101 :
10102 : return true;
10103 : }
10104 :
10105 :
10106 : /* Given a completely parsed select statement, we:
10107 :
10108 : - Validate all expressions and code within the SELECT.
10109 : - Make sure that the selection expression is not of the wrong type.
10110 : - Make sure that no case ranges overlap.
10111 : - Eliminate unreachable cases and unreachable code resulting from
10112 : removing case labels.
10113 :
10114 : The standard does allow unreachable cases, e.g. CASE (5:3). But
10115 : they are a hassle for code generation, and to prevent that, we just
10116 : cut them out here. This is not necessary for overlapping cases
10117 : because they are illegal and we never even try to generate code.
10118 :
10119 : We have the additional caveat that a SELECT construct could have
10120 : been a computed GOTO in the source code. Fortunately we can fairly
10121 : easily work around that here: The case_expr for a "real" SELECT CASE
10122 : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10123 : we have to do is make sure that the case_expr is a scalar integer
10124 : expression. */
10125 :
10126 : static void
10127 687 : resolve_select (gfc_code *code, bool select_type)
10128 : {
10129 687 : gfc_code *body;
10130 687 : gfc_expr *case_expr;
10131 687 : gfc_case *cp, *default_case, *tail, *head;
10132 687 : int seen_unreachable;
10133 687 : int seen_logical;
10134 687 : int ncases;
10135 687 : bt type;
10136 687 : bool t;
10137 :
10138 687 : if (code->expr1 == NULL)
10139 : {
10140 : /* This was actually a computed GOTO statement. */
10141 5 : case_expr = code->expr2;
10142 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10143 3 : gfc_error ("Selection expression in computed GOTO statement "
10144 : "at %L must be a scalar integer expression",
10145 : &case_expr->where);
10146 :
10147 : /* Further checking is not necessary because this SELECT was built
10148 : by the compiler, so it should always be OK. Just move the
10149 : case_expr from expr2 to expr so that we can handle computed
10150 : GOTOs as normal SELECTs from here on. */
10151 5 : code->expr1 = code->expr2;
10152 5 : code->expr2 = NULL;
10153 5 : return;
10154 : }
10155 :
10156 682 : case_expr = code->expr1;
10157 682 : type = case_expr->ts.type;
10158 :
10159 : /* F08:C830. */
10160 682 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10161 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10162 :
10163 : {
10164 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10165 : &case_expr->where, gfc_typename (case_expr));
10166 :
10167 : /* Punt. Going on here just produce more garbage error messages. */
10168 0 : return;
10169 : }
10170 :
10171 : /* F08:R842. */
10172 682 : if (!select_type && case_expr->rank != 0)
10173 : {
10174 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10175 : "expression", &case_expr->where);
10176 :
10177 : /* Punt. */
10178 1 : return;
10179 : }
10180 :
10181 : /* Raise a warning if an INTEGER case value exceeds the range of
10182 : the case-expr. Later, all expressions will be promoted to the
10183 : largest kind of all case-labels. */
10184 :
10185 681 : if (type == BT_INTEGER)
10186 1927 : for (body = code->block; body; body = body->block)
10187 2852 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10188 : {
10189 1462 : if (cp->low
10190 1462 : && gfc_check_integer_range (cp->low->value.integer,
10191 : case_expr->ts.kind) != ARITH_OK)
10192 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10193 6 : "not in the range of %s", &cp->low->where,
10194 : gfc_typename (case_expr));
10195 :
10196 1462 : if (cp->high
10197 1178 : && cp->low != cp->high
10198 1570 : && gfc_check_integer_range (cp->high->value.integer,
10199 : case_expr->ts.kind) != ARITH_OK)
10200 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10201 0 : "not in the range of %s", &cp->high->where,
10202 : gfc_typename (case_expr));
10203 : }
10204 :
10205 : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10206 : of the SELECT CASE expression and its CASE values. Walk the lists
10207 : of case values, and if we find a mismatch, promote case_expr to
10208 : the appropriate kind. */
10209 :
10210 681 : if (type == BT_LOGICAL || type == BT_INTEGER)
10211 : {
10212 2113 : for (body = code->block; body; body = body->block)
10213 : {
10214 : /* Walk the case label list. */
10215 3113 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10216 : {
10217 : /* Intercept the DEFAULT case. It does not have a kind. */
10218 1597 : if (cp->low == NULL && cp->high == NULL)
10219 292 : continue;
10220 :
10221 : /* Unreachable case ranges are discarded, so ignore. */
10222 1260 : if (cp->low != NULL && cp->high != NULL
10223 1212 : && cp->low != cp->high
10224 1370 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10225 33 : continue;
10226 :
10227 1272 : if (cp->low != NULL
10228 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10229 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10230 :
10231 1272 : if (cp->high != NULL
10232 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10233 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10234 : }
10235 : }
10236 : }
10237 :
10238 : /* Assume there is no DEFAULT case. */
10239 681 : default_case = NULL;
10240 681 : head = tail = NULL;
10241 681 : ncases = 0;
10242 681 : seen_logical = 0;
10243 :
10244 2502 : for (body = code->block; body; body = body->block)
10245 : {
10246 : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10247 1821 : t = true;
10248 1821 : seen_unreachable = 0;
10249 :
10250 : /* Walk the case label list, making sure that all case labels
10251 : are legal. */
10252 3829 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10253 : {
10254 : /* Count the number of cases in the whole construct. */
10255 2019 : ncases++;
10256 :
10257 : /* Intercept the DEFAULT case. */
10258 2019 : if (cp->low == NULL && cp->high == NULL)
10259 : {
10260 362 : if (default_case != NULL)
10261 : {
10262 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10263 : "by a second DEFAULT CASE at %L",
10264 : &default_case->where, &cp->where);
10265 0 : t = false;
10266 0 : break;
10267 : }
10268 : else
10269 : {
10270 362 : default_case = cp;
10271 362 : continue;
10272 : }
10273 : }
10274 :
10275 : /* Deal with single value cases and case ranges. Errors are
10276 : issued from the validation function. */
10277 1657 : if (!validate_case_label_expr (cp->low, case_expr)
10278 1657 : || !validate_case_label_expr (cp->high, case_expr))
10279 : {
10280 : t = false;
10281 : break;
10282 : }
10283 :
10284 1649 : if (type == BT_LOGICAL
10285 78 : && ((cp->low == NULL || cp->high == NULL)
10286 76 : || cp->low != cp->high))
10287 : {
10288 2 : gfc_error ("Logical range in CASE statement at %L is not "
10289 : "allowed",
10290 1 : cp->low ? &cp->low->where : &cp->high->where);
10291 2 : t = false;
10292 2 : break;
10293 : }
10294 :
10295 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10296 : {
10297 76 : int value;
10298 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10299 76 : if (value & seen_logical)
10300 : {
10301 1 : gfc_error ("Constant logical value in CASE statement "
10302 : "is repeated at %L",
10303 : &cp->low->where);
10304 1 : t = false;
10305 1 : break;
10306 : }
10307 75 : seen_logical |= value;
10308 : }
10309 :
10310 1602 : if (cp->low != NULL && cp->high != NULL
10311 1555 : && cp->low != cp->high
10312 1758 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10313 : {
10314 35 : if (warn_surprising)
10315 1 : gfc_warning (OPT_Wsurprising,
10316 : "Range specification at %L can never be matched",
10317 : &cp->where);
10318 :
10319 35 : cp->unreachable = 1;
10320 35 : seen_unreachable = 1;
10321 : }
10322 : else
10323 : {
10324 : /* If the case range can be matched, it can also overlap with
10325 : other cases. To make sure it does not, we put it in a
10326 : double linked list here. We sort that with a merge sort
10327 : later on to detect any overlapping cases. */
10328 1611 : if (!head)
10329 : {
10330 646 : head = tail = cp;
10331 646 : head->right = head->left = NULL;
10332 : }
10333 : else
10334 : {
10335 965 : tail->right = cp;
10336 965 : tail->right->left = tail;
10337 965 : tail = tail->right;
10338 965 : tail->right = NULL;
10339 : }
10340 : }
10341 : }
10342 :
10343 : /* It there was a failure in the previous case label, give up
10344 : for this case label list. Continue with the next block. */
10345 1821 : if (!t)
10346 11 : continue;
10347 :
10348 : /* See if any case labels that are unreachable have been seen.
10349 : If so, we eliminate them. This is a bit of a kludge because
10350 : the case lists for a single case statement (label) is a
10351 : single forward linked lists. */
10352 1810 : if (seen_unreachable)
10353 : {
10354 : /* Advance until the first case in the list is reachable. */
10355 69 : while (body->ext.block.case_list != NULL
10356 69 : && body->ext.block.case_list->unreachable)
10357 : {
10358 34 : gfc_case *n = body->ext.block.case_list;
10359 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10360 34 : n->next = NULL;
10361 34 : gfc_free_case_list (n);
10362 : }
10363 :
10364 : /* Strip all other unreachable cases. */
10365 35 : if (body->ext.block.case_list)
10366 : {
10367 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10368 : {
10369 1 : if (cp->next->unreachable)
10370 : {
10371 1 : gfc_case *n = cp->next;
10372 1 : cp->next = cp->next->next;
10373 1 : n->next = NULL;
10374 1 : gfc_free_case_list (n);
10375 : }
10376 : }
10377 : }
10378 : }
10379 : }
10380 :
10381 : /* See if there were overlapping cases. If the check returns NULL,
10382 : there was overlap. In that case we don't do anything. If head
10383 : is non-NULL, we prepend the DEFAULT case. The sorted list can
10384 : then used during code generation for SELECT CASE constructs with
10385 : a case expression of a CHARACTER type. */
10386 681 : if (head)
10387 : {
10388 646 : head = check_case_overlap (head);
10389 :
10390 : /* Prepend the default_case if it is there. */
10391 646 : if (head != NULL && default_case)
10392 : {
10393 345 : default_case->left = NULL;
10394 345 : default_case->right = head;
10395 345 : head->left = default_case;
10396 : }
10397 : }
10398 :
10399 : /* Eliminate dead blocks that may be the result if we've seen
10400 : unreachable case labels for a block. */
10401 2468 : for (body = code; body && body->block; body = body->block)
10402 : {
10403 1787 : if (body->block->ext.block.case_list == NULL)
10404 : {
10405 : /* Cut the unreachable block from the code chain. */
10406 34 : gfc_code *c = body->block;
10407 34 : body->block = c->block;
10408 :
10409 : /* Kill the dead block, but not the blocks below it. */
10410 34 : c->block = NULL;
10411 34 : gfc_free_statements (c);
10412 : }
10413 : }
10414 :
10415 : /* More than two cases is legal but insane for logical selects.
10416 : Issue a warning for it. */
10417 681 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10418 0 : gfc_warning (OPT_Wsurprising,
10419 : "Logical SELECT CASE block at %L has more that two cases",
10420 : &code->loc);
10421 : }
10422 :
10423 :
10424 : /* Check if a derived type is extensible. */
10425 :
10426 : bool
10427 23661 : gfc_type_is_extensible (gfc_symbol *sym)
10428 : {
10429 23661 : return !(sym->attr.is_bind_c || sym->attr.sequence
10430 23645 : || (sym->attr.is_class
10431 2201 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10432 : }
10433 :
10434 :
10435 : static void
10436 : resolve_types (gfc_namespace *ns);
10437 :
10438 : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10439 : correct as well as possibly the array-spec. */
10440 :
10441 : static void
10442 12706 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10443 : {
10444 12706 : gfc_expr* target;
10445 12706 : bool parentheses = false;
10446 :
10447 12706 : gcc_assert (sym->assoc);
10448 12706 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10449 :
10450 : /* If this is for SELECT TYPE, the target may not yet be set. In that
10451 : case, return. Resolution will be called later manually again when
10452 : this is done. */
10453 12706 : target = sym->assoc->target;
10454 12706 : if (!target)
10455 : return;
10456 7576 : gcc_assert (!sym->assoc->dangling);
10457 :
10458 7576 : if (target->expr_type == EXPR_OP
10459 260 : && target->value.op.op == INTRINSIC_PARENTHESES
10460 42 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
10461 : {
10462 23 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
10463 23 : gfc_free_expr (target);
10464 23 : target = sym->assoc->target;
10465 23 : parentheses = true;
10466 : }
10467 :
10468 7576 : if (resolve_target && !gfc_resolve_expr (target))
10469 : return;
10470 :
10471 7571 : if (sym->assoc->ar)
10472 : {
10473 : int dim;
10474 : gfc_array_ref *ar = sym->assoc->ar;
10475 68 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10476 : {
10477 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10478 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10479 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10480 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10481 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10482 : "remapping of associate name %s at %L",
10483 : sym->name, &sym->declared_at);
10484 : }
10485 : }
10486 :
10487 : /* For variable targets, we get some attributes from the target. */
10488 7571 : if (target->expr_type == EXPR_VARIABLE)
10489 : {
10490 6588 : gfc_symbol *tsym, *dsym;
10491 :
10492 6588 : gcc_assert (target->symtree);
10493 6588 : tsym = target->symtree->n.sym;
10494 :
10495 6588 : if (gfc_expr_attr (target).proc_pointer)
10496 : {
10497 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10498 : tsym->name, &target->where);
10499 0 : return;
10500 : }
10501 :
10502 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10503 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10504 6589 : && dsym->attr.flavor == FL_DERIVED)
10505 : {
10506 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10507 : tsym->name, &target->where);
10508 1 : return;
10509 : }
10510 :
10511 6587 : if (tsym->attr.flavor == FL_PROCEDURE)
10512 : {
10513 73 : bool is_error = true;
10514 73 : if (tsym->attr.function && tsym->result == tsym)
10515 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10516 137 : if (tsym == ns->proc_name)
10517 : {
10518 : is_error = false;
10519 : break;
10520 : }
10521 64 : if (is_error)
10522 : {
10523 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10524 : tsym->name, &target->where);
10525 13 : return;
10526 : }
10527 : }
10528 :
10529 6574 : sym->attr.asynchronous = tsym->attr.asynchronous;
10530 6574 : sym->attr.volatile_ = tsym->attr.volatile_;
10531 :
10532 13148 : sym->attr.target = tsym->attr.target
10533 6574 : || gfc_expr_attr (target).pointer;
10534 6574 : if (is_subref_array (target))
10535 402 : sym->attr.subref_array_pointer = 1;
10536 : }
10537 983 : else if (target->ts.type == BT_PROCEDURE)
10538 : {
10539 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10540 : &target->where);
10541 0 : return;
10542 : }
10543 :
10544 7557 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10545 : {
10546 : /* By now, the type of the target has been fixed up. */
10547 293 : symbol_attribute attr;
10548 :
10549 293 : if (sym->ts.type == BT_DERIVED
10550 166 : && target->ts.type == BT_CLASS
10551 31 : && !UNLIMITED_POLY (target))
10552 : {
10553 : /* Inferred to be derived type but the target has type class. */
10554 31 : sym->ts = CLASS_DATA (target)->ts;
10555 31 : if (!sym->as)
10556 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10557 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10558 31 : sym->attr.dimension = target->rank ? 1 : 0;
10559 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10560 : target->corank);
10561 31 : sym->as = NULL;
10562 : }
10563 262 : else if (target->ts.type == BT_DERIVED
10564 135 : && target->symtree && target->symtree->n.sym
10565 111 : && target->symtree->n.sym->ts.type == BT_CLASS
10566 0 : && IS_INFERRED_TYPE (target)
10567 0 : && target->ref && target->ref->next
10568 0 : && target->ref->next->type == REF_ARRAY
10569 0 : && !target->ref->next->next)
10570 : {
10571 : /* A inferred type selector whose symbol has been determined to be
10572 : a class array but which only has an array reference. Change the
10573 : associate name and the selector to class type. */
10574 0 : sym->ts = target->ts;
10575 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10576 0 : sym->attr.dimension = target->rank ? 1 : 0;
10577 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10578 : target->corank);
10579 0 : sym->as = NULL;
10580 0 : target->ts = sym->ts;
10581 : }
10582 262 : else if ((target->ts.type == BT_DERIVED)
10583 127 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10584 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10585 : /* Confirmed to be either a derived type or misidentified to be a
10586 : scalar class object, when the selector is a class array. */
10587 141 : sym->ts = target->ts;
10588 : }
10589 :
10590 :
10591 7557 : if (target->expr_type == EXPR_NULL)
10592 : {
10593 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10594 1 : return;
10595 : }
10596 7556 : else if (target->ts.type == BT_UNKNOWN)
10597 : {
10598 2 : gfc_error ("Selector at %L has no type", &target->where);
10599 2 : return;
10600 : }
10601 :
10602 : /* Get type if this was not already set. Note that it can be
10603 : some other type than the target in case this is a SELECT TYPE
10604 : selector! So we must not update when the type is already there. */
10605 7554 : if (sym->ts.type == BT_UNKNOWN)
10606 257 : sym->ts = target->ts;
10607 :
10608 7554 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10609 :
10610 : /* See if this is a valid association-to-variable. */
10611 15108 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10612 6574 : && !parentheses
10613 6553 : && !gfc_has_vector_subscript (target))
10614 7602 : || gfc_is_ptr_fcn (target));
10615 :
10616 : /* Finally resolve if this is an array or not. */
10617 7554 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10618 178 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10619 : {
10620 102 : gfc_expression_rank (target);
10621 102 : if (target->ts.type == BT_DERIVED
10622 55 : && !sym->as
10623 55 : && target->symtree->n.sym->as)
10624 : {
10625 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10626 0 : sym->attr.dimension = 1;
10627 : }
10628 102 : else if (target->ts.type == BT_CLASS
10629 47 : && CLASS_DATA (target)->as)
10630 : {
10631 0 : target->rank = CLASS_DATA (target)->as->rank;
10632 0 : target->corank = CLASS_DATA (target)->as->corank;
10633 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10634 : {
10635 0 : sym->ts = target->ts;
10636 0 : sym->attr.dimension = 0;
10637 : }
10638 : }
10639 : }
10640 :
10641 :
10642 7554 : if (sym->attr.dimension && target->rank == 0)
10643 : {
10644 : /* primary.cc makes the assumption that a reference to an associate
10645 : name followed by a left parenthesis is an array reference. */
10646 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10647 : {
10648 12 : gfc_expression_rank (sym->assoc->target);
10649 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10650 12 : if (!sym->attr.dimension && sym->as)
10651 0 : sym->as = NULL;
10652 : }
10653 :
10654 17 : if (sym->attr.dimension && target->rank == 0)
10655 : {
10656 5 : if (sym->ts.type != BT_CHARACTER)
10657 5 : gfc_error ("Associate-name %qs at %L is used as array",
10658 : sym->name, &sym->declared_at);
10659 5 : sym->attr.dimension = 0;
10660 5 : return;
10661 : }
10662 : }
10663 :
10664 : /* We cannot deal with class selectors that need temporaries. */
10665 7549 : if (target->ts.type == BT_CLASS
10666 7549 : && gfc_ref_needs_temporary_p (target->ref))
10667 : {
10668 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10669 : "yet implemented", &target->where);
10670 1 : return;
10671 : }
10672 :
10673 7548 : if (target->ts.type == BT_CLASS)
10674 2761 : gfc_fix_class_refs (target);
10675 :
10676 7548 : if ((target->rank > 0 || target->corank > 0)
10677 2702 : && !sym->attr.select_rank_temporary)
10678 : {
10679 2702 : gfc_array_spec *as;
10680 : /* The rank may be incorrectly guessed at parsing, therefore make sure
10681 : it is corrected now. */
10682 2702 : if (sym->ts.type != BT_CLASS
10683 2144 : && (!sym->as || sym->as->corank != target->corank))
10684 : {
10685 140 : if (!sym->as)
10686 133 : sym->as = gfc_get_array_spec ();
10687 140 : as = sym->as;
10688 140 : as->rank = target->rank;
10689 140 : as->type = AS_DEFERRED;
10690 140 : as->corank = target->corank;
10691 140 : sym->attr.dimension = 1;
10692 140 : if (as->corank != 0)
10693 7 : sym->attr.codimension = 1;
10694 : }
10695 2562 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10696 557 : && (!CLASS_DATA (sym)->as
10697 557 : || CLASS_DATA (sym)->as->corank != target->corank))
10698 : {
10699 0 : if (!CLASS_DATA (sym)->as)
10700 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10701 0 : as = CLASS_DATA (sym)->as;
10702 0 : as->rank = target->rank;
10703 0 : as->type = AS_DEFERRED;
10704 0 : as->corank = target->corank;
10705 0 : CLASS_DATA (sym)->attr.dimension = 1;
10706 0 : if (as->corank != 0)
10707 0 : CLASS_DATA (sym)->attr.codimension = 1;
10708 : }
10709 : }
10710 4846 : else if (!sym->attr.select_rank_temporary)
10711 : {
10712 : /* target's rank is 0, but the type of the sym is still array valued,
10713 : which has to be corrected. */
10714 3463 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10715 700 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10716 : {
10717 24 : gfc_array_spec *as;
10718 24 : symbol_attribute attr;
10719 : /* The associated variable's type is still the array type
10720 : correct this now. */
10721 24 : gfc_typespec *ts = &target->ts;
10722 24 : gfc_ref *ref;
10723 : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10724 : */
10725 24 : bool internal_ref = true;
10726 :
10727 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10728 : {
10729 48 : switch (ref->type)
10730 : {
10731 24 : case REF_COMPONENT:
10732 24 : ts = &ref->u.c.component->ts;
10733 24 : internal_ref
10734 24 : = target->ref == ref && ref->next
10735 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10736 : break;
10737 24 : case REF_ARRAY:
10738 24 : if (ts->type == BT_CLASS)
10739 0 : ts = &ts->u.derived->components->ts;
10740 24 : if (internal_ref && ref->u.ar.codimen > 0)
10741 0 : for (int i = ref->u.ar.dimen;
10742 : internal_ref
10743 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
10744 : ++i)
10745 0 : internal_ref
10746 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
10747 : break;
10748 : default:
10749 : break;
10750 : }
10751 : }
10752 : /* Only rewrite the type of this symbol, when the refs are not the
10753 : internal ones for class and co-array this-image. */
10754 24 : if (!internal_ref)
10755 : {
10756 : /* Create a scalar instance of the current class type. Because
10757 : the rank of a class array goes into its name, the type has to
10758 : be rebuilt. The alternative of (re-)setting just the
10759 : attributes and as in the current type, destroys the type also
10760 : in other places. */
10761 0 : as = NULL;
10762 0 : sym->ts = *ts;
10763 0 : sym->ts.type = BT_CLASS;
10764 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10765 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
10766 0 : sym->as = NULL;
10767 : }
10768 : }
10769 : }
10770 :
10771 : /* Mark this as an associate variable. */
10772 7548 : sym->attr.associate_var = 1;
10773 :
10774 : /* Fix up the type-spec for CHARACTER types. */
10775 7548 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
10776 : {
10777 502 : gfc_ref *ref;
10778 787 : for (ref = target->ref; ref; ref = ref->next)
10779 311 : if (ref->type == REF_SUBSTRING
10780 74 : && (ref->u.ss.start == NULL
10781 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
10782 74 : || ref->u.ss.end == NULL
10783 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
10784 : break;
10785 :
10786 502 : if (!sym->ts.u.cl)
10787 182 : sym->ts.u.cl = target->ts.u.cl;
10788 :
10789 502 : if (sym->ts.deferred
10790 189 : && sym->ts.u.cl == target->ts.u.cl)
10791 : {
10792 110 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10793 110 : sym->ts.deferred = 1;
10794 : }
10795 :
10796 502 : if (!sym->ts.u.cl->length
10797 326 : && !sym->ts.deferred
10798 137 : && target->expr_type == EXPR_CONSTANT)
10799 : {
10800 30 : sym->ts.u.cl->length =
10801 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
10802 30 : target->value.character.length);
10803 : }
10804 472 : else if (((!sym->ts.u.cl->length
10805 176 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10806 302 : && target->expr_type != EXPR_VARIABLE)
10807 350 : || ref)
10808 : {
10809 148 : if (!sym->ts.deferred)
10810 : {
10811 44 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10812 44 : sym->ts.deferred = 1;
10813 : }
10814 :
10815 : /* This is reset in trans-stmt.cc after the assignment
10816 : of the target expression to the associate name. */
10817 148 : if (ref && sym->as)
10818 26 : sym->attr.pointer = 1;
10819 : else
10820 122 : sym->attr.allocatable = 1;
10821 : }
10822 : }
10823 :
10824 7548 : if (sym->ts.type == BT_CLASS
10825 1403 : && IS_INFERRED_TYPE (target)
10826 13 : && target->ts.type == BT_DERIVED
10827 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
10828 0 : && target->ref && target->ref->next && !target->ref->next->next
10829 0 : && target->ref->next->type == REF_ARRAY)
10830 0 : target->ts = target->symtree->n.sym->ts;
10831 :
10832 : /* If the target is a good class object, so is the associate variable. */
10833 7548 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
10834 713 : sym->attr.class_ok = 1;
10835 :
10836 : /* If the target is a contiguous pointer, so is the associate variable. */
10837 7548 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
10838 3 : sym->attr.contiguous = 1;
10839 : }
10840 :
10841 :
10842 : /* Ensure that SELECT TYPE expressions have the correct rank and a full
10843 : array reference, where necessary. The symbols are artificial and so
10844 : the dimension attribute and arrayspec can also be set. In addition,
10845 : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
10846 : This is corrected here as well.*/
10847 :
10848 : static void
10849 1681 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
10850 : gfc_ref *ref)
10851 : {
10852 1681 : gfc_ref *nref = (*expr1)->ref;
10853 1681 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
10854 1681 : gfc_symbol *sym2;
10855 1681 : gfc_expr *selector = gfc_copy_expr (expr2);
10856 :
10857 1681 : (*expr1)->rank = rank;
10858 1681 : (*expr1)->corank = corank;
10859 1681 : if (selector)
10860 : {
10861 311 : gfc_resolve_expr (selector);
10862 311 : if (selector->expr_type == EXPR_OP
10863 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
10864 2 : sym2 = selector->value.op.op1->symtree->n.sym;
10865 309 : else if (selector->expr_type == EXPR_VARIABLE
10866 7 : || selector->expr_type == EXPR_FUNCTION)
10867 309 : sym2 = selector->symtree->n.sym;
10868 : else
10869 0 : gcc_unreachable ();
10870 : }
10871 : else
10872 : sym2 = NULL;
10873 :
10874 1681 : if (sym1->ts.type == BT_CLASS)
10875 : {
10876 1681 : if ((*expr1)->ts.type != BT_CLASS)
10877 13 : (*expr1)->ts = sym1->ts;
10878 :
10879 1681 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
10880 1681 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
10881 1681 : if (CLASS_DATA (sym1)->as == NULL && sym2)
10882 1 : CLASS_DATA (sym1)->as
10883 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
10884 : }
10885 : else
10886 : {
10887 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
10888 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
10889 0 : if (sym1->as == NULL && sym2)
10890 0 : sym1->as = gfc_copy_array_spec (sym2->as);
10891 : }
10892 :
10893 3045 : for (; nref; nref = nref->next)
10894 2734 : if (nref->next == NULL)
10895 : break;
10896 :
10897 1681 : if (ref && nref && nref->type != REF_ARRAY)
10898 6 : nref->next = gfc_copy_ref (ref);
10899 1675 : else if (ref && !nref)
10900 302 : (*expr1)->ref = gfc_copy_ref (ref);
10901 1373 : else if (ref && nref->u.ar.codimen != corank)
10902 : {
10903 976 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
10904 915 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
10905 61 : nref->u.ar.codimen = corank;
10906 : }
10907 1681 : }
10908 :
10909 :
10910 : static gfc_expr *
10911 6704 : build_loc_call (gfc_expr *sym_expr)
10912 : {
10913 6704 : gfc_expr *loc_call;
10914 6704 : loc_call = gfc_get_expr ();
10915 6704 : loc_call->expr_type = EXPR_FUNCTION;
10916 6704 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
10917 6704 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
10918 6704 : loc_call->symtree->n.sym->attr.intrinsic = 1;
10919 6704 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
10920 6704 : gfc_commit_symbol (loc_call->symtree->n.sym);
10921 6704 : loc_call->ts.type = BT_INTEGER;
10922 6704 : loc_call->ts.kind = gfc_index_integer_kind;
10923 6704 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
10924 6704 : loc_call->value.function.actual = gfc_get_actual_arglist ();
10925 6704 : loc_call->value.function.actual->expr = sym_expr;
10926 6704 : loc_call->where = sym_expr->where;
10927 6704 : return loc_call;
10928 : }
10929 :
10930 : /* Resolve a SELECT TYPE statement. */
10931 :
10932 : static void
10933 3005 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
10934 : {
10935 3005 : gfc_symbol *selector_type;
10936 3005 : gfc_code *body, *new_st, *if_st, *tail;
10937 3005 : gfc_code *class_is = NULL, *default_case = NULL;
10938 3005 : gfc_case *c;
10939 3005 : gfc_symtree *st;
10940 3005 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
10941 3005 : gfc_namespace *ns;
10942 3005 : int error = 0;
10943 3005 : int rank = 0, corank = 0;
10944 3005 : gfc_ref* ref = NULL;
10945 3005 : gfc_expr *selector_expr = NULL;
10946 3005 : gfc_code *old_code = code;
10947 :
10948 3005 : ns = code->ext.block.ns;
10949 3005 : if (code->expr2)
10950 : {
10951 : /* Set this, or coarray checks in resolve will fail. */
10952 639 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
10953 : }
10954 3005 : gfc_resolve (ns);
10955 :
10956 : /* Check for F03:C813. */
10957 3005 : if (code->expr1->ts.type != BT_CLASS
10958 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
10959 : {
10960 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
10961 : "at %L", &code->loc);
10962 42 : return;
10963 : }
10964 :
10965 : /* Prevent segfault, when class type is not initialized due to previous
10966 : error. */
10967 2992 : if (!code->expr1->symtree->n.sym->attr.class_ok
10968 2990 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
10969 : return;
10970 :
10971 2985 : if (code->expr2)
10972 : {
10973 630 : gfc_ref *ref2 = NULL;
10974 1466 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
10975 836 : if (ref->type == REF_COMPONENT
10976 432 : && ref->u.c.component->ts.type == BT_CLASS)
10977 836 : ref2 = ref;
10978 :
10979 630 : if (ref2)
10980 : {
10981 340 : if (code->expr1->symtree->n.sym->attr.untyped)
10982 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
10983 340 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
10984 : }
10985 : else
10986 : {
10987 290 : if (code->expr1->symtree->n.sym->attr.untyped)
10988 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
10989 : /* Sometimes the selector expression is given the typespec of the
10990 : '_data' field, which is logical enough but inappropriate here. */
10991 290 : if (code->expr2->ts.type == BT_DERIVED
10992 80 : && code->expr2->symtree
10993 80 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
10994 80 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
10995 290 : selector_type = CLASS_DATA (code->expr2)
10996 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
10997 : }
10998 :
10999 630 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
11000 : {
11001 297 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
11002 297 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
11003 297 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
11004 : }
11005 :
11006 : /* F2008: C803 The selector expression must not be coindexed. */
11007 630 : if (gfc_is_coindexed (code->expr2))
11008 : {
11009 4 : gfc_error ("Selector at %L must not be coindexed",
11010 4 : &code->expr2->where);
11011 4 : return;
11012 : }
11013 :
11014 : }
11015 : else
11016 : {
11017 2355 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
11018 :
11019 2355 : if (gfc_is_coindexed (code->expr1))
11020 : {
11021 0 : gfc_error ("Selector at %L must not be coindexed",
11022 0 : &code->expr1->where);
11023 0 : return;
11024 : }
11025 : }
11026 :
11027 : /* Loop over TYPE IS / CLASS IS cases. */
11028 8331 : for (body = code->block; body; body = body->block)
11029 : {
11030 5351 : c = body->ext.block.case_list;
11031 :
11032 5351 : if (!error)
11033 : {
11034 : /* Check for repeated cases. */
11035 8316 : for (tail = code->block; tail; tail = tail->block)
11036 : {
11037 8316 : gfc_case *d = tail->ext.block.case_list;
11038 8316 : if (tail == body)
11039 : break;
11040 :
11041 2974 : if (c->ts.type == d->ts.type
11042 516 : && ((c->ts.type == BT_DERIVED
11043 418 : && c->ts.u.derived && d->ts.u.derived
11044 418 : && !strcmp (c->ts.u.derived->name,
11045 : d->ts.u.derived->name))
11046 515 : || c->ts.type == BT_UNKNOWN
11047 515 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11048 55 : && c->ts.kind == d->ts.kind)))
11049 : {
11050 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11051 : &c->where, &d->where);
11052 1 : return;
11053 : }
11054 : }
11055 : }
11056 :
11057 : /* Check F03:C815. */
11058 3386 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11059 2294 : && selector_type
11060 2294 : && !selector_type->attr.unlimited_polymorphic
11061 7323 : && !gfc_type_is_extensible (c->ts.u.derived))
11062 : {
11063 1 : gfc_error ("Derived type %qs at %L must be extensible",
11064 1 : c->ts.u.derived->name, &c->where);
11065 1 : error++;
11066 1 : continue;
11067 : }
11068 :
11069 : /* Check F03:C816. */
11070 5355 : if (c->ts.type != BT_UNKNOWN
11071 3739 : && selector_type && !selector_type->attr.unlimited_polymorphic
11072 7325 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11073 1972 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11074 : {
11075 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11076 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11077 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11078 : else
11079 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11080 : gfc_basic_typename (c->ts.type), &c->where);
11081 6 : error++;
11082 6 : continue;
11083 : }
11084 :
11085 : /* Check F03:C814. */
11086 5343 : if (c->ts.type == BT_CHARACTER
11087 736 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11088 : {
11089 0 : gfc_error ("The type-spec at %L shall specify that each length "
11090 : "type parameter is assumed", &c->where);
11091 0 : error++;
11092 0 : continue;
11093 : }
11094 :
11095 : /* Intercept the DEFAULT case. */
11096 5343 : if (c->ts.type == BT_UNKNOWN)
11097 : {
11098 : /* Check F03:C818. */
11099 1610 : if (default_case)
11100 : {
11101 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11102 : "by a second DEFAULT CASE at %L",
11103 1 : &default_case->ext.block.case_list->where, &c->where);
11104 1 : error++;
11105 1 : continue;
11106 : }
11107 :
11108 : default_case = body;
11109 : }
11110 : }
11111 :
11112 2980 : if (error > 0)
11113 : return;
11114 :
11115 : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11116 : target if present. If there are any EXIT statements referring to the
11117 : SELECT TYPE construct, this is no problem because the gfc_code
11118 : reference stays the same and EXIT is equally possible from the BLOCK
11119 : it is changed to. */
11120 2977 : code->op = EXEC_BLOCK;
11121 2977 : if (code->expr2)
11122 : {
11123 626 : gfc_association_list* assoc;
11124 :
11125 626 : assoc = gfc_get_association_list ();
11126 626 : assoc->st = code->expr1->symtree;
11127 626 : assoc->target = gfc_copy_expr (code->expr2);
11128 626 : assoc->target->where = code->expr2->where;
11129 : /* assoc->variable will be set by resolve_assoc_var. */
11130 :
11131 626 : code->ext.block.assoc = assoc;
11132 626 : code->expr1->symtree->n.sym->assoc = assoc;
11133 :
11134 626 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11135 : }
11136 : else
11137 2351 : code->ext.block.assoc = NULL;
11138 :
11139 : /* Ensure that the selector rank and arrayspec are available to
11140 : correct expressions in which they might be missing. */
11141 2977 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11142 : {
11143 311 : rank = code->expr2->rank;
11144 311 : corank = code->expr2->corank;
11145 585 : for (ref = code->expr2->ref; ref; ref = ref->next)
11146 576 : if (ref->next == NULL)
11147 : break;
11148 311 : if (ref && ref->type == REF_ARRAY)
11149 302 : ref = gfc_copy_ref (ref);
11150 :
11151 : /* Fixup expr1 if necessary. */
11152 311 : if (rank || corank)
11153 311 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11154 : }
11155 2666 : else if (code->expr1->rank || code->expr1->corank)
11156 : {
11157 860 : rank = code->expr1->rank;
11158 860 : corank = code->expr1->corank;
11159 860 : for (ref = code->expr1->ref; ref; ref = ref->next)
11160 860 : if (ref->next == NULL)
11161 : break;
11162 860 : if (ref && ref->type == REF_ARRAY)
11163 860 : ref = gfc_copy_ref (ref);
11164 : }
11165 :
11166 2977 : gfc_expr *orig_expr1 = code->expr1;
11167 :
11168 : /* Add EXEC_SELECT to switch on type. */
11169 2977 : new_st = gfc_get_code (code->op);
11170 2977 : new_st->expr1 = code->expr1;
11171 2977 : new_st->expr2 = code->expr2;
11172 2977 : new_st->block = code->block;
11173 2977 : code->expr1 = code->expr2 = NULL;
11174 2977 : code->block = NULL;
11175 2977 : if (!ns->code)
11176 2977 : ns->code = new_st;
11177 : else
11178 0 : ns->code->next = new_st;
11179 2977 : code = new_st;
11180 2977 : code->op = EXEC_SELECT_TYPE;
11181 :
11182 : /* Use the intrinsic LOC function to generate an integer expression
11183 : for the vtable of the selector. Note that the rank of the selector
11184 : expression has to be set to zero. */
11185 2977 : gfc_add_vptr_component (code->expr1);
11186 2977 : code->expr1->rank = 0;
11187 2977 : code->expr1->corank = 0;
11188 2977 : code->expr1 = build_loc_call (code->expr1);
11189 2977 : selector_expr = code->expr1->value.function.actual->expr;
11190 :
11191 : /* Loop over TYPE IS / CLASS IS cases. */
11192 8312 : for (body = code->block; body; body = body->block)
11193 : {
11194 5335 : gfc_symbol *vtab;
11195 5335 : c = body->ext.block.case_list;
11196 :
11197 : /* Generate an index integer expression for address of the
11198 : TYPE/CLASS vtable and store it in c->low. The hash expression
11199 : is stored in c->high and is used to resolve intrinsic cases. */
11200 5335 : if (c->ts.type != BT_UNKNOWN)
11201 : {
11202 3727 : gfc_expr *e;
11203 3727 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11204 : {
11205 2285 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11206 2285 : gcc_assert (vtab);
11207 2285 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11208 2285 : c->ts.u.derived->hash_value);
11209 : }
11210 : else
11211 : {
11212 1442 : vtab = gfc_find_vtab (&c->ts);
11213 1442 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11214 1442 : e = CLASS_DATA (vtab)->initializer;
11215 1442 : c->high = gfc_copy_expr (e);
11216 1442 : if (c->high->ts.kind != gfc_integer_4_kind)
11217 : {
11218 1 : gfc_typespec ts;
11219 1 : ts.kind = gfc_integer_4_kind;
11220 1 : ts.type = BT_INTEGER;
11221 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11222 : }
11223 : }
11224 :
11225 3727 : e = gfc_lval_expr_from_sym (vtab);
11226 3727 : c->low = build_loc_call (e);
11227 : }
11228 : else
11229 1608 : continue;
11230 :
11231 : /* Associate temporary to selector. This should only be done
11232 : when this case is actually true, so build a new ASSOCIATE
11233 : that does precisely this here (instead of using the
11234 : 'global' one). */
11235 :
11236 : /* First check the derived type import status. */
11237 3727 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11238 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11239 : {
11240 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11241 6 : c->ts.u.derived->name);
11242 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11243 : gfc_current_ns))
11244 6 : error++;
11245 : }
11246 :
11247 3727 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11248 3727 : if (c->ts.type == BT_CLASS)
11249 328 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11250 328 : c->ts.u.derived->name, var_name);
11251 3399 : else if (c->ts.type == BT_DERIVED)
11252 1957 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11253 1957 : c->ts.u.derived->name, var_name);
11254 1442 : else if (c->ts.type == BT_CHARACTER)
11255 : {
11256 736 : HOST_WIDE_INT charlen = 0;
11257 736 : if (c->ts.u.cl && c->ts.u.cl->length
11258 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11259 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11260 736 : snprintf (name, sizeof (name),
11261 : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11262 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11263 : var_name);
11264 : }
11265 : else
11266 706 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11267 : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11268 :
11269 3727 : st = gfc_find_symtree (ns->sym_root, name);
11270 3727 : gcc_assert (st->n.sym->assoc);
11271 3727 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11272 3727 : st->n.sym->assoc->target->where = selector_expr->where;
11273 3727 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11274 : {
11275 3399 : gfc_add_data_component (st->n.sym->assoc->target);
11276 : /* Fixup the target expression if necessary. */
11277 3399 : if (rank || corank)
11278 1370 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11279 : ref);
11280 : }
11281 :
11282 3727 : new_st = gfc_get_code (EXEC_BLOCK);
11283 3727 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11284 3727 : new_st->ext.block.ns->code = body->next;
11285 3727 : body->next = new_st;
11286 :
11287 : /* Chain in the new list only if it is marked as dangling. Otherwise
11288 : there is a CASE label overlap and this is already used. Just ignore,
11289 : the error is diagnosed elsewhere. */
11290 3727 : if (st->n.sym->assoc->dangling)
11291 : {
11292 3726 : new_st->ext.block.assoc = st->n.sym->assoc;
11293 3726 : st->n.sym->assoc->dangling = 0;
11294 : }
11295 :
11296 3727 : resolve_assoc_var (st->n.sym, false);
11297 : }
11298 :
11299 : /* Take out CLASS IS cases for separate treatment. */
11300 : body = code;
11301 8312 : while (body && body->block)
11302 : {
11303 5335 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11304 : {
11305 : /* Add to class_is list. */
11306 328 : if (class_is == NULL)
11307 : {
11308 297 : class_is = body->block;
11309 297 : tail = class_is;
11310 : }
11311 : else
11312 : {
11313 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11314 31 : tail->block = body->block;
11315 31 : tail = tail->block;
11316 : }
11317 : /* Remove from EXEC_SELECT list. */
11318 328 : body->block = body->block->block;
11319 328 : tail->block = NULL;
11320 : }
11321 : else
11322 : body = body->block;
11323 : }
11324 :
11325 2977 : if (class_is)
11326 : {
11327 297 : gfc_symbol *vtab;
11328 :
11329 297 : if (!default_case)
11330 : {
11331 : /* Add a default case to hold the CLASS IS cases. */
11332 295 : for (tail = code; tail->block; tail = tail->block) ;
11333 187 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11334 187 : tail = tail->block;
11335 187 : tail->ext.block.case_list = gfc_get_case ();
11336 187 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11337 187 : tail->next = NULL;
11338 187 : default_case = tail;
11339 : }
11340 :
11341 : /* More than one CLASS IS block? */
11342 297 : if (class_is->block)
11343 : {
11344 37 : gfc_code **c1,*c2;
11345 37 : bool swapped;
11346 : /* Sort CLASS IS blocks by extension level. */
11347 36 : do
11348 : {
11349 37 : swapped = false;
11350 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11351 : {
11352 61 : c2 = (*c1)->block;
11353 : /* F03:C817 (check for doubles). */
11354 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11355 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11356 : {
11357 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11358 : "statement at %L",
11359 : &c2->ext.block.case_list->where);
11360 1 : return;
11361 : }
11362 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11363 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11364 : {
11365 : /* Swap. */
11366 24 : (*c1)->block = c2->block;
11367 24 : c2->block = *c1;
11368 24 : *c1 = c2;
11369 24 : swapped = true;
11370 : }
11371 : }
11372 : }
11373 : while (swapped);
11374 : }
11375 :
11376 : /* Generate IF chain. */
11377 296 : if_st = gfc_get_code (EXEC_IF);
11378 296 : new_st = if_st;
11379 622 : for (body = class_is; body; body = body->block)
11380 : {
11381 326 : new_st->block = gfc_get_code (EXEC_IF);
11382 326 : new_st = new_st->block;
11383 : /* Set up IF condition: Call _gfortran_is_extension_of. */
11384 326 : new_st->expr1 = gfc_get_expr ();
11385 326 : new_st->expr1->expr_type = EXPR_FUNCTION;
11386 326 : new_st->expr1->ts.type = BT_LOGICAL;
11387 326 : new_st->expr1->ts.kind = 4;
11388 326 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11389 326 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11390 326 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11391 : /* Set up arguments. */
11392 326 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11393 326 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11394 326 : new_st->expr1->value.function.actual->expr->where = code->loc;
11395 326 : new_st->expr1->where = code->loc;
11396 326 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11397 326 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11398 326 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11399 326 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11400 326 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11401 326 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11402 : /* Set up types in formal arg list. */
11403 326 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11404 326 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11405 326 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11406 326 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11407 :
11408 326 : new_st->next = body->next;
11409 : }
11410 296 : if (default_case->next)
11411 : {
11412 110 : new_st->block = gfc_get_code (EXEC_IF);
11413 110 : new_st = new_st->block;
11414 110 : new_st->next = default_case->next;
11415 : }
11416 :
11417 : /* Replace CLASS DEFAULT code by the IF chain. */
11418 296 : default_case->next = if_st;
11419 : }
11420 :
11421 : /* Resolve the internal code. This cannot be done earlier because
11422 : it requires that the sym->assoc of selectors is set already. */
11423 2976 : gfc_current_ns = ns;
11424 2976 : gfc_resolve_blocks (code->block, gfc_current_ns);
11425 2976 : gfc_current_ns = old_ns;
11426 :
11427 2976 : free (ref);
11428 : }
11429 :
11430 :
11431 : /* Resolve a SELECT RANK statement. */
11432 :
11433 : static void
11434 1018 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11435 : {
11436 1018 : gfc_namespace *ns;
11437 1018 : gfc_code *body, *new_st, *tail;
11438 1018 : gfc_case *c;
11439 1018 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11440 1018 : char name[2 * GFC_MAX_SYMBOL_LEN];
11441 1018 : gfc_symtree *st;
11442 1018 : gfc_expr *selector_expr = NULL;
11443 1018 : int case_value;
11444 1018 : HOST_WIDE_INT charlen = 0;
11445 :
11446 1018 : ns = code->ext.block.ns;
11447 1018 : gfc_resolve (ns);
11448 :
11449 1018 : code->op = EXEC_BLOCK;
11450 1018 : if (code->expr2)
11451 : {
11452 42 : gfc_association_list* assoc;
11453 :
11454 42 : assoc = gfc_get_association_list ();
11455 42 : assoc->st = code->expr1->symtree;
11456 42 : assoc->target = gfc_copy_expr (code->expr2);
11457 42 : assoc->target->where = code->expr2->where;
11458 : /* assoc->variable will be set by resolve_assoc_var. */
11459 :
11460 42 : code->ext.block.assoc = assoc;
11461 42 : code->expr1->symtree->n.sym->assoc = assoc;
11462 :
11463 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11464 : }
11465 : else
11466 976 : code->ext.block.assoc = NULL;
11467 :
11468 : /* Loop over RANK cases. Note that returning on the errors causes a
11469 : cascade of further errors because the case blocks do not compile
11470 : correctly. */
11471 3320 : for (body = code->block; body; body = body->block)
11472 : {
11473 2302 : c = body->ext.block.case_list;
11474 2302 : if (c->low)
11475 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11476 : else
11477 : case_value = -2;
11478 :
11479 : /* Check for repeated cases. */
11480 5836 : for (tail = code->block; tail; tail = tail->block)
11481 : {
11482 5836 : gfc_case *d = tail->ext.block.case_list;
11483 5836 : int case_value2;
11484 :
11485 5836 : if (tail == body)
11486 : break;
11487 :
11488 : /* Check F2018: C1153. */
11489 3534 : if (!c->low && !d->low)
11490 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11491 : &c->where, &d->where);
11492 :
11493 3534 : if (!c->low || !d->low)
11494 1253 : continue;
11495 :
11496 : /* Check F2018: C1153. */
11497 2281 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11498 2281 : if ((case_value == case_value2) && case_value == -1)
11499 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11500 : &c->where, &d->where);
11501 2280 : else if (case_value == case_value2)
11502 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11503 : case_value, &c->where, &d->where);
11504 : }
11505 :
11506 2302 : if (!c->low)
11507 919 : continue;
11508 :
11509 : /* Check F2018: C1155. */
11510 1383 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11511 1381 : || gfc_expr_attr (code->expr1).pointer))
11512 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11513 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11514 : }
11515 :
11516 : /* Add EXEC_SELECT to switch on rank. */
11517 1018 : new_st = gfc_get_code (code->op);
11518 1018 : new_st->expr1 = code->expr1;
11519 1018 : new_st->expr2 = code->expr2;
11520 1018 : new_st->block = code->block;
11521 1018 : code->expr1 = code->expr2 = NULL;
11522 1018 : code->block = NULL;
11523 1018 : if (!ns->code)
11524 1018 : ns->code = new_st;
11525 : else
11526 0 : ns->code->next = new_st;
11527 1018 : code = new_st;
11528 1018 : code->op = EXEC_SELECT_RANK;
11529 :
11530 1018 : selector_expr = code->expr1;
11531 :
11532 : /* Loop over SELECT RANK cases. */
11533 3320 : for (body = code->block; body; body = body->block)
11534 : {
11535 2302 : c = body->ext.block.case_list;
11536 2302 : int case_value;
11537 :
11538 : /* Pass on the default case. */
11539 2302 : if (c->low == NULL)
11540 919 : continue;
11541 :
11542 : /* Associate temporary to selector. This should only be done
11543 : when this case is actually true, so build a new ASSOCIATE
11544 : that does precisely this here (instead of using the
11545 : 'global' one). */
11546 1383 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11547 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11548 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11549 :
11550 1383 : if (c->ts.type == BT_CLASS)
11551 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11552 1238 : else if (c->ts.type == BT_DERIVED)
11553 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11554 1128 : else if (c->ts.type != BT_CHARACTER)
11555 569 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11556 : else
11557 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11558 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11559 :
11560 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11561 1383 : if (case_value >= 0)
11562 1350 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11563 : else
11564 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11565 :
11566 1383 : st = gfc_find_symtree (ns->sym_root, name);
11567 1383 : gcc_assert (st->n.sym->assoc);
11568 :
11569 1383 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11570 1383 : st->n.sym->assoc->target->where = selector_expr->where;
11571 :
11572 1383 : new_st = gfc_get_code (EXEC_BLOCK);
11573 1383 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11574 1383 : new_st->ext.block.ns->code = body->next;
11575 1383 : body->next = new_st;
11576 :
11577 : /* Chain in the new list only if it is marked as dangling. Otherwise
11578 : there is a CASE label overlap and this is already used. Just ignore,
11579 : the error is diagnosed elsewhere. */
11580 1383 : if (st->n.sym->assoc->dangling)
11581 : {
11582 1381 : new_st->ext.block.assoc = st->n.sym->assoc;
11583 1381 : st->n.sym->assoc->dangling = 0;
11584 : }
11585 :
11586 1383 : resolve_assoc_var (st->n.sym, false);
11587 : }
11588 :
11589 1018 : gfc_current_ns = ns;
11590 1018 : gfc_resolve_blocks (code->block, gfc_current_ns);
11591 1018 : gfc_current_ns = old_ns;
11592 1018 : }
11593 :
11594 :
11595 : /* Resolve a transfer statement. This is making sure that:
11596 : -- a derived type being transferred has only non-pointer components
11597 : -- a derived type being transferred doesn't have private components, unless
11598 : it's being transferred from the module where the type was defined
11599 : -- we're not trying to transfer a whole assumed size array. */
11600 :
11601 : static void
11602 46351 : resolve_transfer (gfc_code *code)
11603 : {
11604 46351 : gfc_symbol *sym, *derived;
11605 46351 : gfc_ref *ref;
11606 46351 : gfc_expr *exp;
11607 46351 : bool write = false;
11608 46351 : bool formatted = false;
11609 46351 : gfc_dt *dt = code->ext.dt;
11610 46351 : gfc_symbol *dtio_sub = NULL;
11611 :
11612 46351 : exp = code->expr1;
11613 :
11614 92708 : while (exp != NULL && exp->expr_type == EXPR_OP
11615 47266 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11616 6 : exp = exp->value.op.op1;
11617 :
11618 46351 : if (exp && exp->expr_type == EXPR_NULL
11619 2 : && code->ext.dt)
11620 : {
11621 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11622 : &exp->where);
11623 2 : return;
11624 : }
11625 :
11626 : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11627 : && exp->expr_type != EXPR_FUNCTION
11628 : && exp->expr_type != EXPR_ARRAY
11629 : && exp->expr_type != EXPR_STRUCTURE))
11630 : return;
11631 :
11632 : /* If we are reading, the variable will be changed. Note that
11633 : code->ext.dt may be NULL if the TRANSFER is related to
11634 : an INQUIRE statement -- but in this case, we are not reading, either. */
11635 25295 : if (dt && dt->dt_io_kind->value.iokind == M_READ
11636 32763 : && !gfc_check_vardef_context (exp, false, false, false,
11637 7320 : _("item in READ")))
11638 : return;
11639 :
11640 25439 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11641 25439 : || exp->expr_type == EXPR_FUNCTION
11642 21065 : || exp->expr_type == EXPR_ARRAY
11643 46504 : ? &exp->ts : &exp->symtree->n.sym->ts;
11644 :
11645 : /* Go to actual component transferred. */
11646 33137 : for (ref = exp->ref; ref; ref = ref->next)
11647 7698 : if (ref->type == REF_COMPONENT)
11648 2181 : ts = &ref->u.c.component->ts;
11649 :
11650 25439 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11651 25291 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11652 : {
11653 717 : derived = ts->u.derived;
11654 :
11655 : /* Determine when to use the formatted DTIO procedure. */
11656 717 : if (dt && (dt->format_expr || dt->format_label))
11657 642 : formatted = true;
11658 :
11659 717 : write = dt->dt_io_kind->value.iokind == M_WRITE
11660 717 : || dt->dt_io_kind->value.iokind == M_PRINT;
11661 717 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11662 :
11663 717 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11664 : {
11665 449 : dt->udtio = exp;
11666 449 : sym = exp->symtree->n.sym->ns->proc_name;
11667 : /* Check to see if this is a nested DTIO call, with the
11668 : dummy as the io-list object. */
11669 449 : if (sym && sym == dtio_sub && sym->formal
11670 30 : && sym->formal->sym == exp->symtree->n.sym
11671 30 : && exp->ref == NULL)
11672 : {
11673 0 : if (!sym->attr.recursive)
11674 : {
11675 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11676 : sym->name, &sym->declared_at);
11677 0 : return;
11678 : }
11679 : }
11680 : }
11681 : }
11682 :
11683 25439 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11684 : {
11685 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11686 : "it is processed by a defined input/output procedure",
11687 : &code->loc);
11688 3 : return;
11689 : }
11690 :
11691 25436 : if (ts->type == BT_DERIVED)
11692 : {
11693 : /* Check that transferred derived type doesn't contain POINTER
11694 : components unless it is processed by a defined input/output
11695 : procedure". */
11696 685 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11697 : {
11698 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11699 : "components unless it is processed by a defined "
11700 : "input/output procedure", &code->loc);
11701 2 : return;
11702 : }
11703 :
11704 : /* F08:C935. */
11705 683 : if (ts->u.derived->attr.proc_pointer_comp)
11706 : {
11707 2 : gfc_error ("Data transfer element at %L cannot have "
11708 : "procedure pointer components", &code->loc);
11709 2 : return;
11710 : }
11711 :
11712 681 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11713 : {
11714 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11715 : "components unless it is processed by a defined "
11716 : "input/output procedure", &code->loc);
11717 6 : return;
11718 : }
11719 :
11720 : /* C_PTR and C_FUNPTR have private components which means they cannot
11721 : be printed. However, if -std=gnu and not -pedantic, allow
11722 : the component to be printed to help debugging. */
11723 675 : if (ts->u.derived->ts.f90_type == BT_VOID)
11724 : {
11725 4 : gfc_error ("Data transfer element at %L "
11726 : "cannot have PRIVATE components", &code->loc);
11727 4 : return;
11728 : }
11729 671 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11730 : {
11731 4 : gfc_error ("Data transfer element at %L cannot have "
11732 : "PRIVATE components unless it is processed by "
11733 : "a defined input/output procedure", &code->loc);
11734 4 : return;
11735 : }
11736 : }
11737 :
11738 25418 : if (exp->expr_type == EXPR_STRUCTURE)
11739 : return;
11740 :
11741 25373 : if (exp->expr_type == EXPR_ARRAY)
11742 : return;
11743 :
11744 24997 : sym = exp->symtree->n.sym;
11745 :
11746 24997 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
11747 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
11748 : {
11749 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
11750 : "an assumed-size array", &code->loc);
11751 1 : return;
11752 : }
11753 : }
11754 :
11755 :
11756 : /*********** Toplevel code resolution subroutines ***********/
11757 :
11758 : /* Find the set of labels that are reachable from this block. We also
11759 : record the last statement in each block. */
11760 :
11761 : static void
11762 673095 : find_reachable_labels (gfc_code *block)
11763 : {
11764 673095 : gfc_code *c;
11765 :
11766 673095 : if (!block)
11767 : return;
11768 :
11769 422053 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
11770 :
11771 : /* Collect labels in this block. We don't keep those corresponding
11772 : to END {IF|SELECT}, these are checked in resolve_branch by going
11773 : up through the code_stack. */
11774 1548705 : for (c = block; c; c = c->next)
11775 : {
11776 1126652 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
11777 3661 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
11778 : }
11779 :
11780 : /* Merge with labels from parent block. */
11781 422053 : if (cs_base->prev)
11782 : {
11783 346746 : gcc_assert (cs_base->prev->reachable_labels);
11784 346746 : bitmap_ior_into (cs_base->reachable_labels,
11785 : cs_base->prev->reachable_labels);
11786 : }
11787 : }
11788 :
11789 : static void
11790 197 : resolve_lock_unlock_event (gfc_code *code)
11791 : {
11792 197 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
11793 197 : && (code->expr1->ts.type != BT_DERIVED
11794 137 : || code->expr1->expr_type != EXPR_VARIABLE
11795 137 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11796 136 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
11797 136 : || code->expr1->rank != 0
11798 181 : || (!gfc_is_coarray (code->expr1) &&
11799 46 : !gfc_is_coindexed (code->expr1))))
11800 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
11801 4 : &code->expr1->where);
11802 193 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
11803 58 : && (code->expr1->ts.type != BT_DERIVED
11804 58 : || code->expr1->expr_type != EXPR_VARIABLE
11805 58 : || code->expr1->ts.u.derived->from_intmod
11806 : != INTMOD_ISO_FORTRAN_ENV
11807 58 : || code->expr1->ts.u.derived->intmod_sym_id
11808 : != ISOFORTRAN_EVENT_TYPE
11809 58 : || code->expr1->rank != 0))
11810 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
11811 : &code->expr1->where);
11812 34 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
11813 209 : && !gfc_is_coindexed (code->expr1))
11814 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
11815 0 : &code->expr1->where);
11816 193 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
11817 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
11818 0 : "coindexed", &code->expr1->where);
11819 :
11820 : /* Check STAT. */
11821 197 : if (code->expr2
11822 54 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
11823 54 : || code->expr2->expr_type != EXPR_VARIABLE))
11824 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11825 : &code->expr2->where);
11826 :
11827 197 : if (code->expr2
11828 251 : && !gfc_check_vardef_context (code->expr2, false, false, false,
11829 54 : _("STAT variable")))
11830 : return;
11831 :
11832 : /* Check ERRMSG. */
11833 197 : if (code->expr3
11834 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
11835 2 : || code->expr3->expr_type != EXPR_VARIABLE))
11836 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
11837 : &code->expr3->where);
11838 :
11839 197 : if (code->expr3
11840 199 : && !gfc_check_vardef_context (code->expr3, false, false, false,
11841 2 : _("ERRMSG variable")))
11842 : return;
11843 :
11844 : /* Check for LOCK the ACQUIRED_LOCK. */
11845 197 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11846 22 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
11847 22 : || code->expr4->expr_type != EXPR_VARIABLE))
11848 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
11849 : "variable", &code->expr4->where);
11850 :
11851 173 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11852 219 : && !gfc_check_vardef_context (code->expr4, false, false, false,
11853 22 : _("ACQUIRED_LOCK variable")))
11854 : return;
11855 :
11856 : /* Check for EVENT WAIT the UNTIL_COUNT. */
11857 197 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
11858 : {
11859 36 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
11860 36 : || code->expr4->rank != 0)
11861 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
11862 0 : "expression", &code->expr4->where);
11863 : }
11864 : }
11865 :
11866 : static void
11867 246 : resolve_team_argument (gfc_expr *team)
11868 : {
11869 246 : gfc_resolve_expr (team);
11870 246 : if (team->rank != 0 || team->ts.type != BT_DERIVED
11871 239 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11872 239 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
11873 : {
11874 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
11875 : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
11876 : &team->where);
11877 : }
11878 246 : }
11879 :
11880 : static void
11881 1358 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
11882 : gfc_expr *e)
11883 : {
11884 1358 : gfc_resolve_expr (e);
11885 1358 : if (e
11886 139 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
11887 124 : || e->expr_type != EXPR_VARIABLE))
11888 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
11889 : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
11890 : exp_kind);
11891 1358 : }
11892 :
11893 : void
11894 679 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
11895 : {
11896 679 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
11897 679 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
11898 : gfc_default_character_kind,
11899 : sync_stat->errmsg);
11900 679 : }
11901 :
11902 : static void
11903 260 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
11904 : gfc_expr *e)
11905 : {
11906 260 : gfc_resolve_expr (e);
11907 260 : if (e
11908 161 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
11909 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
11910 : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
11911 260 : }
11912 :
11913 : static void
11914 130 : resolve_form_team (gfc_code *code)
11915 : {
11916 130 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
11917 : code->expr1);
11918 130 : resolve_team_argument (code->expr2);
11919 130 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
11920 : code->expr3);
11921 130 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11922 130 : }
11923 :
11924 : static void resolve_block_construct (gfc_code *);
11925 :
11926 : static void
11927 73 : resolve_change_team (gfc_code *code)
11928 : {
11929 73 : resolve_team_argument (code->expr1);
11930 73 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
11931 146 : resolve_block_construct (code);
11932 : /* Map the coarray bounds as selected. */
11933 76 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
11934 3 : if (a->ar)
11935 : {
11936 3 : gfc_array_spec *src = a->ar->as, *dst;
11937 3 : if (a->st->n.sym->ts.type == BT_CLASS)
11938 0 : dst = CLASS_DATA (a->st->n.sym)->as;
11939 : else
11940 3 : dst = a->st->n.sym->as;
11941 3 : dst->corank = src->corank;
11942 3 : dst->cotype = src->cotype;
11943 6 : for (int i = 0; i < src->corank; ++i)
11944 : {
11945 3 : dst->lower[dst->rank + i] = src->lower[i];
11946 3 : dst->upper[dst->rank + i] = src->upper[i];
11947 3 : src->lower[i] = src->upper[i] = nullptr;
11948 : }
11949 3 : gfc_free_array_spec (src);
11950 3 : free (a->ar);
11951 3 : a->ar = nullptr;
11952 3 : dst->resolved = false;
11953 3 : gfc_resolve_array_spec (dst, 0);
11954 : }
11955 73 : }
11956 :
11957 : static void
11958 43 : resolve_sync_team (gfc_code *code)
11959 : {
11960 43 : resolve_team_argument (code->expr1);
11961 43 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11962 43 : }
11963 :
11964 : static void
11965 71 : resolve_end_team (gfc_code *code)
11966 : {
11967 71 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11968 71 : }
11969 :
11970 : static void
11971 54 : resolve_critical (gfc_code *code)
11972 : {
11973 54 : gfc_symtree *symtree;
11974 54 : gfc_symbol *lock_type;
11975 54 : char name[GFC_MAX_SYMBOL_LEN];
11976 54 : static int serial = 0;
11977 :
11978 54 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11979 :
11980 54 : if (flag_coarray != GFC_FCOARRAY_LIB)
11981 30 : return;
11982 :
11983 24 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11984 : GFC_PREFIX ("lock_type"));
11985 24 : if (symtree)
11986 12 : lock_type = symtree->n.sym;
11987 : else
11988 : {
11989 12 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
11990 : false) != 0)
11991 0 : gcc_unreachable ();
11992 12 : lock_type = symtree->n.sym;
11993 12 : lock_type->attr.flavor = FL_DERIVED;
11994 12 : lock_type->attr.zero_comp = 1;
11995 12 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
11996 12 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
11997 : }
11998 :
11999 24 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
12000 24 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
12001 0 : gcc_unreachable ();
12002 :
12003 24 : code->resolved_sym = symtree->n.sym;
12004 24 : symtree->n.sym->attr.flavor = FL_VARIABLE;
12005 24 : symtree->n.sym->attr.referenced = 1;
12006 24 : symtree->n.sym->attr.artificial = 1;
12007 24 : symtree->n.sym->attr.codimension = 1;
12008 24 : symtree->n.sym->ts.type = BT_DERIVED;
12009 24 : symtree->n.sym->ts.u.derived = lock_type;
12010 24 : symtree->n.sym->as = gfc_get_array_spec ();
12011 24 : symtree->n.sym->as->corank = 1;
12012 24 : symtree->n.sym->as->type = AS_EXPLICIT;
12013 24 : symtree->n.sym->as->cotype = AS_EXPLICIT;
12014 24 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
12015 : NULL, 1);
12016 24 : gfc_commit_symbols();
12017 : }
12018 :
12019 :
12020 : static void
12021 1307 : resolve_sync (gfc_code *code)
12022 : {
12023 : /* Check imageset. The * case matches expr1 == NULL. */
12024 1307 : if (code->expr1)
12025 : {
12026 71 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
12027 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
12028 : "INTEGER expression", &code->expr1->where);
12029 71 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
12030 27 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
12031 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
12032 : &code->expr1->where);
12033 70 : else if (code->expr1->expr_type == EXPR_ARRAY
12034 70 : && gfc_simplify_expr (code->expr1, 0))
12035 : {
12036 20 : gfc_constructor *cons;
12037 20 : cons = gfc_constructor_first (code->expr1->value.constructor);
12038 60 : for (; cons; cons = gfc_constructor_next (cons))
12039 20 : if (cons->expr->expr_type == EXPR_CONSTANT
12040 20 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
12041 0 : gfc_error ("Imageset argument at %L must between 1 and "
12042 : "num_images()", &cons->expr->where);
12043 : }
12044 : }
12045 :
12046 : /* Check STAT. */
12047 1307 : gfc_resolve_expr (code->expr2);
12048 1307 : if (code->expr2)
12049 : {
12050 108 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12051 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12052 : &code->expr2->where);
12053 : else
12054 107 : gfc_check_vardef_context (code->expr2, false, false, false,
12055 107 : _("STAT variable"));
12056 : }
12057 :
12058 : /* Check ERRMSG. */
12059 1307 : gfc_resolve_expr (code->expr3);
12060 1307 : if (code->expr3)
12061 : {
12062 90 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12063 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12064 : &code->expr3->where);
12065 : else
12066 86 : gfc_check_vardef_context (code->expr3, false, false, false,
12067 86 : _("ERRMSG variable"));
12068 : }
12069 1307 : }
12070 :
12071 :
12072 : /* Given a branch to a label, see if the branch is conforming.
12073 : The code node describes where the branch is located. */
12074 :
12075 : static void
12076 108123 : resolve_branch (gfc_st_label *label, gfc_code *code)
12077 : {
12078 108123 : code_stack *stack;
12079 :
12080 108123 : if (label == NULL)
12081 : return;
12082 :
12083 : /* Step one: is this a valid branching target? */
12084 :
12085 2460 : if (label->defined == ST_LABEL_UNKNOWN)
12086 : {
12087 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12088 : &code->loc);
12089 4 : return;
12090 : }
12091 :
12092 2456 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12093 : {
12094 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12095 : "for the branch statement at %L", &label->where, &code->loc);
12096 4 : return;
12097 : }
12098 :
12099 : /* Step two: make sure this branch is not a branch to itself ;-) */
12100 :
12101 2452 : if (code->here == label)
12102 : {
12103 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12104 : &code->loc);
12105 0 : return;
12106 : }
12107 :
12108 : /* Step three: See if the label is in the same block as the
12109 : branching statement. The hard work has been done by setting up
12110 : the bitmap reachable_labels. */
12111 :
12112 2452 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12113 : {
12114 : /* Check now whether there is a CRITICAL construct; if so, check
12115 : whether the label is still visible outside of the CRITICAL block,
12116 : which is invalid. */
12117 6267 : for (stack = cs_base; stack; stack = stack->prev)
12118 : {
12119 3883 : if (stack->current->op == EXEC_CRITICAL
12120 3883 : && bitmap_bit_p (stack->reachable_labels, label->value))
12121 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12122 : "label at %L", &code->loc, &label->where);
12123 3881 : else if (stack->current->op == EXEC_DO_CONCURRENT
12124 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12125 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12126 : "for label at %L", &code->loc, &label->where);
12127 3881 : else if (stack->current->op == EXEC_CHANGE_TEAM
12128 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12129 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12130 : "for label at %L", &code->loc, &label->where);
12131 : }
12132 :
12133 : return;
12134 : }
12135 :
12136 : /* Step four: If we haven't found the label in the bitmap, it may
12137 : still be the label of the END of the enclosing block, in which
12138 : case we find it by going up the code_stack. */
12139 :
12140 167 : for (stack = cs_base; stack; stack = stack->prev)
12141 : {
12142 131 : if (stack->current->next && stack->current->next->here == label)
12143 : break;
12144 101 : if (stack->current->op == EXEC_CRITICAL)
12145 : {
12146 : /* Note: A label at END CRITICAL does not leave the CRITICAL
12147 : construct as END CRITICAL is still part of it. */
12148 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12149 : " at %L", &code->loc, &label->where);
12150 2 : return;
12151 : }
12152 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12153 : {
12154 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12155 : "label at %L", &code->loc, &label->where);
12156 0 : return;
12157 : }
12158 : }
12159 :
12160 66 : if (stack)
12161 : {
12162 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12163 : return;
12164 : }
12165 :
12166 : /* The label is not in an enclosing block, so illegal. This was
12167 : allowed in Fortran 66, so we allow it as extension. No
12168 : further checks are necessary in this case. */
12169 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12170 : "as the GOTO statement at %L", &label->where,
12171 : &code->loc);
12172 36 : return;
12173 : }
12174 :
12175 :
12176 : /* Check whether EXPR1 has the same shape as EXPR2. */
12177 :
12178 : static bool
12179 1467 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12180 : {
12181 1467 : mpz_t shape[GFC_MAX_DIMENSIONS];
12182 1467 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12183 1467 : bool result = false;
12184 1467 : int i;
12185 :
12186 : /* Compare the rank. */
12187 1467 : if (expr1->rank != expr2->rank)
12188 : return result;
12189 :
12190 : /* Compare the size of each dimension. */
12191 2811 : for (i=0; i<expr1->rank; i++)
12192 : {
12193 1495 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12194 151 : goto ignore;
12195 :
12196 1344 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12197 0 : goto ignore;
12198 :
12199 1344 : if (mpz_cmp (shape[i], shape2[i]))
12200 0 : goto over;
12201 : }
12202 :
12203 : /* When either of the two expression is an assumed size array, we
12204 : ignore the comparison of dimension sizes. */
12205 1316 : ignore:
12206 : result = true;
12207 :
12208 1467 : over:
12209 1467 : gfc_clear_shape (shape, i);
12210 1467 : gfc_clear_shape (shape2, i);
12211 1467 : return result;
12212 : }
12213 :
12214 :
12215 : /* Check whether a WHERE assignment target or a WHERE mask expression
12216 : has the same shape as the outermost WHERE mask expression. */
12217 :
12218 : static void
12219 509 : resolve_where (gfc_code *code, gfc_expr *mask)
12220 : {
12221 509 : gfc_code *cblock;
12222 509 : gfc_code *cnext;
12223 509 : gfc_expr *e = NULL;
12224 :
12225 509 : cblock = code->block;
12226 :
12227 : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12228 : In case of nested WHERE, only the outermost one is stored. */
12229 509 : if (mask == NULL) /* outermost WHERE */
12230 453 : e = cblock->expr1;
12231 : else /* inner WHERE */
12232 509 : e = mask;
12233 :
12234 1387 : while (cblock)
12235 : {
12236 878 : if (cblock->expr1)
12237 : {
12238 : /* Check if the mask-expr has a consistent shape with the
12239 : outermost WHERE mask-expr. */
12240 714 : if (!resolve_where_shape (cblock->expr1, e))
12241 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12242 0 : &cblock->expr1->where);
12243 : }
12244 :
12245 : /* the assignment statement of a WHERE statement, or the first
12246 : statement in where-body-construct of a WHERE construct */
12247 878 : cnext = cblock->next;
12248 1733 : while (cnext)
12249 : {
12250 855 : switch (cnext->op)
12251 : {
12252 : /* WHERE assignment statement */
12253 753 : case EXEC_ASSIGN:
12254 :
12255 : /* Check shape consistent for WHERE assignment target. */
12256 753 : if (e && !resolve_where_shape (cnext->expr1, e))
12257 0 : gfc_error ("WHERE assignment target at %L has "
12258 0 : "inconsistent shape", &cnext->expr1->where);
12259 :
12260 753 : if (cnext->op == EXEC_ASSIGN
12261 753 : && gfc_may_be_finalized (cnext->expr1->ts))
12262 0 : cnext->expr1->must_finalize = 1;
12263 :
12264 : break;
12265 :
12266 :
12267 46 : case EXEC_ASSIGN_CALL:
12268 46 : resolve_call (cnext);
12269 46 : if (!cnext->resolved_sym->attr.elemental)
12270 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12271 2 : &cnext->ext.actual->expr->where);
12272 : break;
12273 :
12274 : /* WHERE or WHERE construct is part of a where-body-construct */
12275 56 : case EXEC_WHERE:
12276 56 : resolve_where (cnext, e);
12277 56 : break;
12278 :
12279 0 : default:
12280 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12281 : &cnext->loc);
12282 : }
12283 : /* the next statement within the same where-body-construct */
12284 855 : cnext = cnext->next;
12285 : }
12286 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12287 878 : cblock = cblock->block;
12288 : }
12289 509 : }
12290 :
12291 :
12292 : /* Resolve assignment in FORALL construct.
12293 : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12294 : FORALL index variables. */
12295 :
12296 : static void
12297 2375 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12298 : {
12299 2375 : int n;
12300 2375 : gfc_symbol *forall_index;
12301 :
12302 6771 : for (n = 0; n < nvar; n++)
12303 : {
12304 4396 : forall_index = var_expr[n]->symtree->n.sym;
12305 :
12306 : /* Check whether the assignment target is one of the FORALL index
12307 : variable. */
12308 4396 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12309 4396 : && (code->expr1->symtree->n.sym == forall_index))
12310 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12311 : &code->expr1->where);
12312 : else
12313 : {
12314 : /* If one of the FORALL index variables doesn't appear in the
12315 : assignment variable, then there could be a many-to-one
12316 : assignment. Emit a warning rather than an error because the
12317 : mask could be resolving this problem.
12318 : DO NOT emit this warning for DO CONCURRENT - reduction-like
12319 : many-to-one assignments are semantically valid (formalized with
12320 : the REDUCE locality-spec in Fortran 2023). */
12321 4396 : if (!find_forall_index (code->expr1, forall_index, 0)
12322 4396 : && !gfc_do_concurrent_flag)
12323 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12324 : "left side of the assignment at %L and so might "
12325 : "cause multiple assignment to this object",
12326 0 : var_expr[n]->symtree->name, &code->expr1->where);
12327 : }
12328 : }
12329 2375 : }
12330 :
12331 :
12332 : /* Resolve WHERE statement in FORALL construct. */
12333 :
12334 : static void
12335 47 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12336 : gfc_expr **var_expr)
12337 : {
12338 47 : gfc_code *cblock;
12339 47 : gfc_code *cnext;
12340 :
12341 47 : cblock = code->block;
12342 113 : while (cblock)
12343 : {
12344 : /* the assignment statement of a WHERE statement, or the first
12345 : statement in where-body-construct of a WHERE construct */
12346 66 : cnext = cblock->next;
12347 132 : while (cnext)
12348 : {
12349 66 : switch (cnext->op)
12350 : {
12351 : /* WHERE assignment statement */
12352 66 : case EXEC_ASSIGN:
12353 66 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12354 :
12355 66 : if (cnext->op == EXEC_ASSIGN
12356 66 : && gfc_may_be_finalized (cnext->expr1->ts))
12357 0 : cnext->expr1->must_finalize = 1;
12358 :
12359 : break;
12360 :
12361 : /* WHERE operator assignment statement */
12362 0 : case EXEC_ASSIGN_CALL:
12363 0 : resolve_call (cnext);
12364 0 : if (!cnext->resolved_sym->attr.elemental)
12365 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12366 0 : &cnext->ext.actual->expr->where);
12367 : break;
12368 :
12369 : /* WHERE or WHERE construct is part of a where-body-construct */
12370 0 : case EXEC_WHERE:
12371 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12372 0 : break;
12373 :
12374 0 : default:
12375 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12376 : &cnext->loc);
12377 : }
12378 : /* the next statement within the same where-body-construct */
12379 66 : cnext = cnext->next;
12380 : }
12381 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12382 66 : cblock = cblock->block;
12383 : }
12384 47 : }
12385 :
12386 :
12387 : /* Traverse the FORALL body to check whether the following errors exist:
12388 : 1. For assignment, check if a many-to-one assignment happens.
12389 : 2. For WHERE statement, check the WHERE body to see if there is any
12390 : many-to-one assignment. */
12391 :
12392 : static void
12393 2202 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12394 : {
12395 2202 : gfc_code *c;
12396 :
12397 2202 : c = code->block->next;
12398 4827 : while (c)
12399 : {
12400 2625 : switch (c->op)
12401 : {
12402 2309 : case EXEC_ASSIGN:
12403 2309 : case EXEC_POINTER_ASSIGN:
12404 2309 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12405 :
12406 2309 : if (c->op == EXEC_ASSIGN
12407 2309 : && gfc_may_be_finalized (c->expr1->ts))
12408 0 : c->expr1->must_finalize = 1;
12409 :
12410 : break;
12411 :
12412 0 : case EXEC_ASSIGN_CALL:
12413 0 : resolve_call (c);
12414 0 : break;
12415 :
12416 : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12417 : there is no need to handle it here. */
12418 : case EXEC_FORALL:
12419 : break;
12420 47 : case EXEC_WHERE:
12421 47 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12422 47 : break;
12423 : default:
12424 : break;
12425 : }
12426 : /* The next statement in the FORALL body. */
12427 2625 : c = c->next;
12428 : }
12429 2202 : }
12430 :
12431 :
12432 : /* Counts the number of iterators needed inside a forall construct, including
12433 : nested forall constructs. This is used to allocate the needed memory
12434 : in gfc_resolve_forall. */
12435 :
12436 : static int gfc_count_forall_iterators (gfc_code *code);
12437 :
12438 : /* Return the deepest nested FORALL/DO CONCURRENT iterator count in CODE's
12439 : next-chain, descending into block arms such as IF/ELSE branches. */
12440 :
12441 : static int
12442 2387 : gfc_max_forall_iterators_in_chain (gfc_code *code)
12443 : {
12444 2387 : int max_iters = 0;
12445 :
12446 5226 : for (gfc_code *c = code; c; c = c->next)
12447 : {
12448 2839 : int sub_iters = 0;
12449 :
12450 2839 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12451 94 : sub_iters = gfc_count_forall_iterators (c);
12452 2745 : else if (c->op == EXEC_BLOCK)
12453 : {
12454 : /* BLOCK/ASSOCIATE bodies live in the block namespace code chain,
12455 : not in the generic c->block arm list used by IF/SELECT. */
12456 21 : if (c->ext.block.ns && c->ext.block.ns->code)
12457 21 : sub_iters = gfc_max_forall_iterators_in_chain (c->ext.block.ns->code);
12458 : }
12459 2724 : else if (c->block)
12460 307 : for (gfc_code *b = c->block; b; b = b->block)
12461 : {
12462 164 : int arm_iters = gfc_max_forall_iterators_in_chain (b->next);
12463 164 : if (arm_iters > sub_iters)
12464 : sub_iters = arm_iters;
12465 : }
12466 :
12467 2839 : if (sub_iters > max_iters)
12468 : max_iters = sub_iters;
12469 : }
12470 :
12471 2387 : return max_iters;
12472 : }
12473 :
12474 :
12475 : static int
12476 2202 : gfc_count_forall_iterators (gfc_code *code)
12477 : {
12478 2202 : int current_iters = 0;
12479 2202 : gfc_forall_iterator *fa;
12480 :
12481 2202 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12482 :
12483 6320 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12484 4118 : current_iters++;
12485 :
12486 2202 : return current_iters + gfc_max_forall_iterators_in_chain (code->block->next);
12487 : }
12488 :
12489 :
12490 : /* Given a FORALL construct.
12491 : 1) Resolve the FORALL iterator.
12492 : 2) Check for shadow index-name(s) and update code block.
12493 : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12494 :
12495 : /* Custom recursive expression walker that replaces symbols.
12496 : This ensures we visit ALL expressions including those in array subscripts. */
12497 :
12498 : static void
12499 114 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st)
12500 : {
12501 144 : if (!expr)
12502 : return;
12503 :
12504 : /* Check if this is a variable reference to replace */
12505 108 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12506 : {
12507 18 : expr->symtree = new_st;
12508 18 : expr->ts = new_st->n.sym->ts;
12509 : }
12510 :
12511 : /* Walk through reference chain (array subscripts, substrings, etc.) */
12512 108 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
12513 : {
12514 0 : if (ref->type == REF_ARRAY)
12515 : {
12516 : gfc_array_ref *ar = &ref->u.ar;
12517 0 : for (int i = 0; i < ar->dimen; i++)
12518 : {
12519 0 : replace_in_expr_recursive (ar->start[i], old_sym, new_st);
12520 0 : replace_in_expr_recursive (ar->end[i], old_sym, new_st);
12521 0 : replace_in_expr_recursive (ar->stride[i], old_sym, new_st);
12522 : }
12523 : }
12524 0 : else if (ref->type == REF_SUBSTRING)
12525 : {
12526 0 : replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st);
12527 0 : replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st);
12528 : }
12529 : }
12530 :
12531 : /* Walk through sub-expressions based on expression type */
12532 108 : switch (expr->expr_type)
12533 : {
12534 30 : case EXPR_OP:
12535 30 : replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st);
12536 30 : replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st);
12537 30 : break;
12538 :
12539 6 : case EXPR_FUNCTION:
12540 18 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
12541 12 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12542 : break;
12543 :
12544 0 : case EXPR_ARRAY:
12545 0 : case EXPR_STRUCTURE:
12546 0 : for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
12547 0 : c; c = gfc_constructor_next (c))
12548 : {
12549 0 : replace_in_expr_recursive (c->expr, old_sym, new_st);
12550 0 : if (c->iterator)
12551 : {
12552 0 : replace_in_expr_recursive (c->iterator->start, old_sym, new_st);
12553 0 : replace_in_expr_recursive (c->iterator->end, old_sym, new_st);
12554 0 : replace_in_expr_recursive (c->iterator->step, old_sym, new_st);
12555 : }
12556 : }
12557 : break;
12558 :
12559 : default:
12560 : break;
12561 : }
12562 : }
12563 :
12564 :
12565 : /* Walk code tree and replace all variable references */
12566 :
12567 : static void
12568 18 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12569 : {
12570 18 : if (!code)
12571 : return;
12572 :
12573 36 : for (gfc_code *c = code; c; c = c->next)
12574 : {
12575 : /* Replace in expressions associated with this code node */
12576 18 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12577 18 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12578 18 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12579 18 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12580 :
12581 : /* Handle special code types with additional expressions */
12582 18 : switch (c->op)
12583 : {
12584 0 : case EXEC_DO:
12585 0 : if (c->ext.iterator)
12586 : {
12587 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12588 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12589 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12590 : }
12591 : break;
12592 :
12593 0 : case EXEC_CALL:
12594 0 : case EXEC_ASSIGN_CALL:
12595 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12596 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12597 : break;
12598 :
12599 0 : case EXEC_SELECT:
12600 0 : for (gfc_code *b = c->block; b; b = b->block)
12601 : {
12602 0 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12603 : {
12604 0 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12605 0 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12606 : }
12607 0 : replace_in_code_recursive (b->next, old_sym, new_st);
12608 : }
12609 : break;
12610 :
12611 0 : case EXEC_FORALL:
12612 0 : case EXEC_DO_CONCURRENT:
12613 0 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12614 : {
12615 0 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12616 0 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12617 0 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12618 : }
12619 : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12620 : they'll be handled separately */
12621 : break;
12622 :
12623 : default:
12624 : break;
12625 : }
12626 :
12627 : /* Recurse into blocks */
12628 18 : if (c->block)
12629 0 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12630 : }
12631 : }
12632 :
12633 :
12634 : /* Replace all references to outer_sym with shadow_st in the given code. */
12635 :
12636 : static void
12637 18 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12638 : gfc_symtree *shadow_st)
12639 : {
12640 : /* Use custom recursive walker to ensure we visit ALL expressions */
12641 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12642 18 : }
12643 :
12644 :
12645 : static void
12646 2202 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12647 : {
12648 2202 : static gfc_expr **var_expr;
12649 2202 : static int total_var = 0;
12650 2202 : static int nvar = 0;
12651 2202 : int i, old_nvar, tmp;
12652 2202 : gfc_forall_iterator *fa;
12653 2202 : bool shadow = false;
12654 :
12655 2202 : old_nvar = nvar;
12656 :
12657 : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12658 2202 : if (code->op == EXEC_FORALL
12659 2202 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12660 : return;
12661 :
12662 : /* Start to resolve a FORALL construct */
12663 : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12664 : forall_save==0 means we're not nested in a FORALL in the current scope,
12665 : but nvar==0 ensures we're not nested in a parent scope either (prevents
12666 : double allocation when FORALL is nested inside DO CONCURRENT). */
12667 2202 : if (forall_save == 0 && nvar == 0)
12668 : {
12669 : /* Count the total number of FORALL indices in the nested FORALL
12670 : construct in order to allocate the VAR_EXPR with proper size. */
12671 2108 : total_var = gfc_count_forall_iterators (code);
12672 :
12673 : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12674 2108 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12675 : }
12676 :
12677 : /* The information about FORALL iterator, including FORALL indices start,
12678 : end and stride. An outer FORALL indice cannot appear in start, end or
12679 : stride. Check for a shadow index-name. */
12680 6320 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12681 : {
12682 : /* Fortran 2008: C738 (R753). */
12683 4118 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12684 : {
12685 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12686 : "of type integer", &fa->var->where);
12687 2 : continue;
12688 : }
12689 :
12690 : /* Check if any outer FORALL index name is the same as the current
12691 : one. Skip this check if the iterator is a shadow variable (from
12692 : DO CONCURRENT type spec) which may not have a symtree yet. */
12693 7125 : for (i = 0; i < nvar; i++)
12694 : {
12695 3009 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12696 3009 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12697 0 : gfc_error ("An outer FORALL construct already has an index "
12698 : "with this name %L", &fa->var->where);
12699 : }
12700 :
12701 4116 : if (fa->shadow)
12702 18 : shadow = true;
12703 :
12704 : /* Record the current FORALL index. */
12705 4116 : var_expr[nvar] = gfc_copy_expr (fa->var);
12706 :
12707 4116 : nvar++;
12708 :
12709 : /* No memory leak. */
12710 4116 : gcc_assert (nvar <= total_var);
12711 : }
12712 :
12713 : /* Need to walk the code and replace references to the index-name with
12714 : references to the shadow index-name. This must be done BEFORE resolving
12715 : the body so that resolution uses the correct shadow variables. */
12716 2202 : if (shadow)
12717 : {
12718 : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
12719 42 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12720 : {
12721 24 : if (fa->shadow)
12722 : {
12723 18 : gfc_symtree *shadow_st;
12724 18 : const char *shadow_name_str;
12725 18 : char *outer_name;
12726 :
12727 : /* fa->var now points to the shadow variable "_name". */
12728 18 : shadow_name_str = fa->var->symtree->name;
12729 18 : shadow_st = fa->var->symtree;
12730 :
12731 18 : if (shadow_name_str[0] != '_')
12732 0 : gfc_internal_error ("Expected shadow variable name to start with _");
12733 :
12734 18 : outer_name = (char *) alloca (strlen (shadow_name_str));
12735 18 : strcpy (outer_name, shadow_name_str + 1);
12736 :
12737 : /* Find the ITERATOR symbol in the current namespace.
12738 : This is the local DO CONCURRENT variable that body expressions reference. */
12739 18 : gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name);
12740 :
12741 18 : if (!iter_st)
12742 : /* No iterator variable found - this shouldn't happen */
12743 0 : continue;
12744 :
12745 18 : gfc_symbol *iter_sym = iter_st->n.sym;
12746 :
12747 : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
12748 18 : if (code->block && code->block->next)
12749 18 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
12750 : }
12751 : }
12752 : }
12753 :
12754 : /* Resolve the FORALL body. */
12755 2202 : gfc_resolve_forall_body (code, nvar, var_expr);
12756 :
12757 : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
12758 2202 : gfc_resolve_blocks (code->block, ns);
12759 :
12760 2202 : tmp = nvar;
12761 2202 : nvar = old_nvar;
12762 : /* Free only the VAR_EXPRs allocated in this frame. */
12763 6318 : for (i = nvar; i < tmp; i++)
12764 4116 : gfc_free_expr (var_expr[i]);
12765 :
12766 2202 : if (nvar == 0)
12767 : {
12768 : /* We are in the outermost FORALL construct. */
12769 2108 : gcc_assert (forall_save == 0);
12770 :
12771 : /* VAR_EXPR is not needed any more. */
12772 2108 : free (var_expr);
12773 2108 : total_var = 0;
12774 : }
12775 : }
12776 :
12777 :
12778 : /* Resolve a BLOCK construct statement. */
12779 :
12780 : static void
12781 7976 : resolve_block_construct (gfc_code* code)
12782 : {
12783 7976 : gfc_namespace *ns = code->ext.block.ns;
12784 :
12785 : /* For an ASSOCIATE block, the associations (and their targets) will be
12786 : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
12787 : namespace. */
12788 7976 : gfc_resolve (ns);
12789 0 : }
12790 :
12791 :
12792 : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
12793 : DO code nodes. */
12794 :
12795 : void
12796 329421 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
12797 : {
12798 329421 : bool t;
12799 :
12800 670271 : for (; b; b = b->block)
12801 : {
12802 340850 : t = gfc_resolve_expr (b->expr1);
12803 340850 : if (!gfc_resolve_expr (b->expr2))
12804 0 : t = false;
12805 :
12806 340850 : switch (b->op)
12807 : {
12808 235542 : case EXEC_IF:
12809 235542 : if (t && b->expr1 != NULL
12810 231263 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
12811 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12812 : &b->expr1->where);
12813 : break;
12814 :
12815 764 : case EXEC_WHERE:
12816 764 : if (t
12817 764 : && b->expr1 != NULL
12818 631 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
12819 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
12820 : &b->expr1->where);
12821 : break;
12822 :
12823 76 : case EXEC_GOTO:
12824 76 : resolve_branch (b->label1, b);
12825 76 : break;
12826 :
12827 0 : case EXEC_BLOCK:
12828 0 : resolve_block_construct (b);
12829 0 : break;
12830 :
12831 : case EXEC_SELECT:
12832 : case EXEC_SELECT_TYPE:
12833 : case EXEC_SELECT_RANK:
12834 : case EXEC_FORALL:
12835 : case EXEC_DO:
12836 : case EXEC_DO_WHILE:
12837 : case EXEC_DO_CONCURRENT:
12838 : case EXEC_CRITICAL:
12839 : case EXEC_READ:
12840 : case EXEC_WRITE:
12841 : case EXEC_IOLENGTH:
12842 : case EXEC_WAIT:
12843 : break;
12844 :
12845 2697 : case EXEC_OMP_ATOMIC:
12846 2697 : case EXEC_OACC_ATOMIC:
12847 2697 : {
12848 : /* Verify this before calling gfc_resolve_code, which might
12849 : change it. */
12850 2697 : gcc_assert (b->op == EXEC_OMP_ATOMIC
12851 : || (b->next && b->next->op == EXEC_ASSIGN));
12852 : }
12853 : break;
12854 :
12855 : case EXEC_OACC_PARALLEL_LOOP:
12856 : case EXEC_OACC_PARALLEL:
12857 : case EXEC_OACC_KERNELS_LOOP:
12858 : case EXEC_OACC_KERNELS:
12859 : case EXEC_OACC_SERIAL_LOOP:
12860 : case EXEC_OACC_SERIAL:
12861 : case EXEC_OACC_DATA:
12862 : case EXEC_OACC_HOST_DATA:
12863 : case EXEC_OACC_LOOP:
12864 : case EXEC_OACC_UPDATE:
12865 : case EXEC_OACC_WAIT:
12866 : case EXEC_OACC_CACHE:
12867 : case EXEC_OACC_ENTER_DATA:
12868 : case EXEC_OACC_EXIT_DATA:
12869 : case EXEC_OACC_ROUTINE:
12870 : case EXEC_OMP_ALLOCATE:
12871 : case EXEC_OMP_ALLOCATORS:
12872 : case EXEC_OMP_ASSUME:
12873 : case EXEC_OMP_CRITICAL:
12874 : case EXEC_OMP_DISPATCH:
12875 : case EXEC_OMP_DISTRIBUTE:
12876 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12877 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12878 : case EXEC_OMP_DISTRIBUTE_SIMD:
12879 : case EXEC_OMP_DO:
12880 : case EXEC_OMP_DO_SIMD:
12881 : case EXEC_OMP_ERROR:
12882 : case EXEC_OMP_LOOP:
12883 : case EXEC_OMP_MASKED:
12884 : case EXEC_OMP_MASKED_TASKLOOP:
12885 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12886 : case EXEC_OMP_MASTER:
12887 : case EXEC_OMP_MASTER_TASKLOOP:
12888 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12889 : case EXEC_OMP_ORDERED:
12890 : case EXEC_OMP_PARALLEL:
12891 : case EXEC_OMP_PARALLEL_DO:
12892 : case EXEC_OMP_PARALLEL_DO_SIMD:
12893 : case EXEC_OMP_PARALLEL_LOOP:
12894 : case EXEC_OMP_PARALLEL_MASKED:
12895 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12896 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12897 : case EXEC_OMP_PARALLEL_MASTER:
12898 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12899 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12900 : case EXEC_OMP_PARALLEL_SECTIONS:
12901 : case EXEC_OMP_PARALLEL_WORKSHARE:
12902 : case EXEC_OMP_SECTIONS:
12903 : case EXEC_OMP_SIMD:
12904 : case EXEC_OMP_SCOPE:
12905 : case EXEC_OMP_SINGLE:
12906 : case EXEC_OMP_TARGET:
12907 : case EXEC_OMP_TARGET_DATA:
12908 : case EXEC_OMP_TARGET_ENTER_DATA:
12909 : case EXEC_OMP_TARGET_EXIT_DATA:
12910 : case EXEC_OMP_TARGET_PARALLEL:
12911 : case EXEC_OMP_TARGET_PARALLEL_DO:
12912 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12913 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12914 : case EXEC_OMP_TARGET_SIMD:
12915 : case EXEC_OMP_TARGET_TEAMS:
12916 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12917 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12918 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12919 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12920 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12921 : case EXEC_OMP_TARGET_UPDATE:
12922 : case EXEC_OMP_TASK:
12923 : case EXEC_OMP_TASKGROUP:
12924 : case EXEC_OMP_TASKLOOP:
12925 : case EXEC_OMP_TASKLOOP_SIMD:
12926 : case EXEC_OMP_TASKWAIT:
12927 : case EXEC_OMP_TASKYIELD:
12928 : case EXEC_OMP_TEAMS:
12929 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12930 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12931 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12932 : case EXEC_OMP_TEAMS_LOOP:
12933 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12934 : case EXEC_OMP_TILE:
12935 : case EXEC_OMP_UNROLL:
12936 : case EXEC_OMP_WORKSHARE:
12937 : break;
12938 :
12939 0 : default:
12940 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
12941 : }
12942 :
12943 340850 : gfc_resolve_code (b->next, ns);
12944 : }
12945 329421 : }
12946 :
12947 : bool
12948 0 : caf_possible_reallocate (gfc_expr *e)
12949 : {
12950 0 : symbol_attribute caf_attr;
12951 0 : gfc_ref *last_arr_ref = nullptr;
12952 :
12953 0 : caf_attr = gfc_caf_attr (e);
12954 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
12955 : return false;
12956 :
12957 : /* Only full array refs can indicate a needed reallocation. */
12958 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
12959 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
12960 0 : last_arr_ref = ref;
12961 :
12962 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
12963 : }
12964 :
12965 : /* Does everything to resolve an ordinary assignment. Returns true
12966 : if this is an interface assignment. */
12967 : static bool
12968 284275 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
12969 : {
12970 284275 : bool rval = false;
12971 284275 : gfc_expr *lhs;
12972 284275 : gfc_expr *rhs;
12973 284275 : int n;
12974 284275 : gfc_ref *ref;
12975 284275 : symbol_attribute attr;
12976 :
12977 284275 : if (gfc_extend_assign (code, ns))
12978 : {
12979 803 : gfc_expr** rhsptr;
12980 :
12981 803 : if (code->op == EXEC_ASSIGN_CALL)
12982 : {
12983 360 : lhs = code->ext.actual->expr;
12984 360 : rhsptr = &code->ext.actual->next->expr;
12985 : }
12986 : else
12987 : {
12988 443 : gfc_actual_arglist* args;
12989 443 : gfc_typebound_proc* tbp;
12990 :
12991 443 : gcc_assert (code->op == EXEC_COMPCALL);
12992 :
12993 443 : args = code->expr1->value.compcall.actual;
12994 443 : lhs = args->expr;
12995 443 : rhsptr = &args->next->expr;
12996 :
12997 443 : tbp = code->expr1->value.compcall.tbp;
12998 443 : gcc_assert (!tbp->is_generic);
12999 : }
13000 :
13001 : /* Make a temporary rhs when there is a default initializer
13002 : and rhs is the same symbol as the lhs. */
13003 803 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
13004 399 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
13005 340 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
13006 995 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
13007 24 : *rhsptr = gfc_get_parentheses (*rhsptr);
13008 :
13009 803 : return true;
13010 : }
13011 :
13012 283472 : lhs = code->expr1;
13013 283472 : rhs = code->expr2;
13014 :
13015 283472 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
13016 263945 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
13017 22025 : && !lhs->symtree->n.sym->attr.proc_pointer
13018 305497 : && gfc_expr_attr (lhs).proc_pointer)
13019 : {
13020 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
13021 : "pointer component",
13022 : &lhs->where);
13023 1 : return false;
13024 : }
13025 :
13026 333890 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
13027 248433 : && rhs->ts.type == BT_CHARACTER
13028 283864 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
13029 : {
13030 : /* Use of -fdec-char-conversions allows assignment of character data
13031 : to non-character variables. This not permitted for nonconstant
13032 : strings. */
13033 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
13034 : gfc_typename (lhs), &rhs->where);
13035 29 : return false;
13036 : }
13037 :
13038 283442 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
13039 : {
13040 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
13041 : gfc_typename (lhs), &rhs->where);
13042 0 : return false;
13043 : }
13044 :
13045 : /* Handle the case of a BOZ literal on the RHS. */
13046 283442 : if (rhs->ts.type == BT_BOZ)
13047 : {
13048 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
13049 : "statement value nor an actual argument of "
13050 : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
13051 : &rhs->where))
13052 : return false;
13053 :
13054 1 : switch (lhs->ts.type)
13055 : {
13056 0 : case BT_INTEGER:
13057 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
13058 : return false;
13059 : break;
13060 1 : case BT_REAL:
13061 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
13062 : return false;
13063 : break;
13064 0 : default:
13065 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13066 0 : return false;
13067 : }
13068 : }
13069 :
13070 283440 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13071 : {
13072 64 : HOST_WIDE_INT llen = 0, rlen = 0;
13073 64 : if (lhs->ts.u.cl != NULL
13074 64 : && lhs->ts.u.cl->length != NULL
13075 53 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13076 53 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13077 :
13078 64 : if (rhs->expr_type == EXPR_CONSTANT)
13079 26 : rlen = rhs->value.character.length;
13080 :
13081 38 : else if (rhs->ts.u.cl != NULL
13082 38 : && rhs->ts.u.cl->length != NULL
13083 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13084 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13085 :
13086 64 : if (rlen && llen && rlen > llen)
13087 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13088 : "CHARACTER expression will be truncated "
13089 : "in assignment (%wd/%wd) at %L",
13090 : llen, rlen, &code->loc);
13091 : }
13092 :
13093 : /* Ensure that a vector index expression for the lvalue is evaluated
13094 : to a temporary if the lvalue symbol is referenced in it. */
13095 283440 : if (lhs->rank)
13096 : {
13097 110491 : for (ref = lhs->ref; ref; ref= ref->next)
13098 58881 : if (ref->type == REF_ARRAY)
13099 : {
13100 130926 : for (n = 0; n < ref->u.ar.dimen; n++)
13101 77562 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13102 77792 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13103 230 : ref->u.ar.start[n]))
13104 14 : ref->u.ar.start[n]
13105 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13106 : }
13107 : }
13108 :
13109 283440 : if (gfc_pure (NULL))
13110 : {
13111 3332 : if (lhs->ts.type == BT_DERIVED
13112 124 : && lhs->expr_type == EXPR_VARIABLE
13113 124 : && lhs->ts.u.derived->attr.pointer_comp
13114 4 : && rhs->expr_type == EXPR_VARIABLE
13115 3335 : && (gfc_impure_variable (rhs->symtree->n.sym)
13116 2 : || gfc_is_coindexed (rhs)))
13117 : {
13118 : /* F2008, C1283. */
13119 2 : if (gfc_is_coindexed (rhs))
13120 1 : gfc_error ("Coindexed expression at %L is assigned to "
13121 : "a derived type variable with a POINTER "
13122 : "component in a PURE procedure",
13123 : &rhs->where);
13124 : else
13125 : /* F2008, C1283 (4). */
13126 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13127 : "shall not be used as the expr at %L of an intrinsic "
13128 : "assignment statement in which the variable is of a "
13129 : "derived type if the derived type has a pointer "
13130 : "component at any level of component selection.",
13131 : &rhs->where);
13132 2 : return rval;
13133 : }
13134 :
13135 : /* Fortran 2008, C1283. */
13136 3330 : if (gfc_is_coindexed (lhs))
13137 : {
13138 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13139 : "procedure", &rhs->where);
13140 1 : return rval;
13141 : }
13142 : }
13143 :
13144 283437 : if (gfc_implicit_pure (NULL))
13145 : {
13146 7188 : if (lhs->expr_type == EXPR_VARIABLE
13147 7188 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13148 5117 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13149 253 : gfc_unset_implicit_pure (NULL);
13150 :
13151 7188 : if (lhs->ts.type == BT_DERIVED
13152 319 : && lhs->expr_type == EXPR_VARIABLE
13153 319 : && lhs->ts.u.derived->attr.pointer_comp
13154 7 : && rhs->expr_type == EXPR_VARIABLE
13155 7195 : && (gfc_impure_variable (rhs->symtree->n.sym)
13156 7 : || gfc_is_coindexed (rhs)))
13157 0 : gfc_unset_implicit_pure (NULL);
13158 :
13159 : /* Fortran 2008, C1283. */
13160 7188 : if (gfc_is_coindexed (lhs))
13161 0 : gfc_unset_implicit_pure (NULL);
13162 : }
13163 :
13164 : /* F2008, 7.2.1.2. */
13165 283437 : attr = gfc_expr_attr (lhs);
13166 283437 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13167 : {
13168 951 : if (attr.codimension)
13169 : {
13170 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13171 : "permitted", &lhs->where);
13172 1 : return false;
13173 : }
13174 950 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13175 : "polymorphic variable at %L", &lhs->where))
13176 : return false;
13177 949 : if (!flag_realloc_lhs)
13178 : {
13179 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13180 : "requires %<-frealloc-lhs%>", &lhs->where);
13181 1 : return false;
13182 : }
13183 : }
13184 282486 : else if (lhs->ts.type == BT_CLASS)
13185 : {
13186 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13187 : "assignment at %L - check that there is a matching specific "
13188 : "subroutine for %<=%> operator", &lhs->where);
13189 9 : return false;
13190 : }
13191 :
13192 283425 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13193 :
13194 : /* F2008, Section 7.2.1.2. */
13195 283425 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13196 : {
13197 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13198 : "component in assignment at %L", &lhs->where);
13199 1 : return false;
13200 : }
13201 :
13202 : /* Assign the 'data' of a class object to a derived type. */
13203 283424 : if (lhs->ts.type == BT_DERIVED
13204 7031 : && rhs->ts.type == BT_CLASS
13205 138 : && rhs->expr_type != EXPR_ARRAY)
13206 132 : gfc_add_data_component (rhs);
13207 :
13208 : /* Make sure there is a vtable and, in particular, a _copy for the
13209 : rhs type. */
13210 283424 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13211 591 : gfc_find_vtab (&rhs->ts);
13212 :
13213 283424 : gfc_check_assign (lhs, rhs, 1);
13214 :
13215 283424 : return false;
13216 : }
13217 :
13218 :
13219 : /* Add a component reference onto an expression. */
13220 :
13221 : static void
13222 665 : add_comp_ref (gfc_expr *e, gfc_component *c)
13223 : {
13224 665 : gfc_ref **ref;
13225 665 : ref = &(e->ref);
13226 889 : while (*ref)
13227 224 : ref = &((*ref)->next);
13228 665 : *ref = gfc_get_ref ();
13229 665 : (*ref)->type = REF_COMPONENT;
13230 665 : (*ref)->u.c.sym = e->ts.u.derived;
13231 665 : (*ref)->u.c.component = c;
13232 665 : e->ts = c->ts;
13233 :
13234 : /* Add a full array ref, as necessary. */
13235 665 : if (c->as)
13236 : {
13237 84 : gfc_add_full_array_ref (e, c->as);
13238 84 : e->rank = c->as->rank;
13239 84 : e->corank = c->as->corank;
13240 : }
13241 665 : }
13242 :
13243 :
13244 : /* Build an assignment. Keep the argument 'op' for future use, so that
13245 : pointer assignments can be made. */
13246 :
13247 : static gfc_code *
13248 952 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13249 : gfc_component *comp1, gfc_component *comp2, locus loc)
13250 : {
13251 952 : gfc_code *this_code;
13252 :
13253 952 : this_code = gfc_get_code (op);
13254 952 : this_code->next = NULL;
13255 952 : this_code->expr1 = gfc_copy_expr (expr1);
13256 952 : this_code->expr2 = gfc_copy_expr (expr2);
13257 952 : this_code->loc = loc;
13258 952 : if (comp1 && comp2)
13259 : {
13260 288 : add_comp_ref (this_code->expr1, comp1);
13261 288 : add_comp_ref (this_code->expr2, comp2);
13262 : }
13263 :
13264 952 : return this_code;
13265 : }
13266 :
13267 :
13268 : /* Makes a temporary variable expression based on the characteristics of
13269 : a given variable expression. */
13270 :
13271 : static gfc_expr*
13272 446 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
13273 : {
13274 446 : static int serial = 0;
13275 446 : char name[GFC_MAX_SYMBOL_LEN];
13276 446 : gfc_symtree *tmp;
13277 446 : gfc_array_spec *as;
13278 446 : gfc_array_ref *aref;
13279 446 : gfc_ref *ref;
13280 :
13281 446 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13282 446 : gfc_get_sym_tree (name, ns, &tmp, false);
13283 446 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13284 :
13285 446 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13286 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13287 : NULL,
13288 0 : e->value.character.length);
13289 :
13290 446 : as = NULL;
13291 446 : ref = NULL;
13292 446 : aref = NULL;
13293 :
13294 : /* Obtain the arrayspec for the temporary. */
13295 446 : if (e->rank && e->expr_type != EXPR_ARRAY
13296 : && e->expr_type != EXPR_FUNCTION
13297 : && e->expr_type != EXPR_OP)
13298 : {
13299 52 : aref = gfc_find_array_ref (e);
13300 52 : if (e->expr_type == EXPR_VARIABLE
13301 52 : && e->symtree->n.sym->as == aref->as)
13302 : as = aref->as;
13303 : else
13304 : {
13305 0 : for (ref = e->ref; ref; ref = ref->next)
13306 0 : if (ref->type == REF_COMPONENT
13307 0 : && ref->u.c.component->as == aref->as)
13308 : {
13309 : as = aref->as;
13310 : break;
13311 : }
13312 : }
13313 : }
13314 :
13315 : /* Add the attributes and the arrayspec to the temporary. */
13316 446 : tmp->n.sym->attr = gfc_expr_attr (e);
13317 446 : tmp->n.sym->attr.function = 0;
13318 446 : tmp->n.sym->attr.proc_pointer = 0;
13319 446 : tmp->n.sym->attr.result = 0;
13320 446 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13321 446 : tmp->n.sym->attr.dummy = 0;
13322 446 : tmp->n.sym->attr.use_assoc = 0;
13323 446 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13324 :
13325 :
13326 446 : if (as)
13327 : {
13328 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13329 52 : if (!ref)
13330 52 : ref = e->ref;
13331 52 : if (as->type == AS_DEFERRED)
13332 46 : tmp->n.sym->attr.allocatable = 1;
13333 : }
13334 394 : else if ((e->rank || e->corank)
13335 94 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13336 0 : || e->expr_type == EXPR_OP))
13337 : {
13338 94 : tmp->n.sym->as = gfc_get_array_spec ();
13339 94 : tmp->n.sym->as->type = AS_DEFERRED;
13340 94 : tmp->n.sym->as->rank = e->rank;
13341 94 : tmp->n.sym->as->corank = e->corank;
13342 94 : tmp->n.sym->attr.allocatable = 1;
13343 94 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13344 188 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13345 : }
13346 : else
13347 300 : tmp->n.sym->attr.dimension = 0;
13348 :
13349 446 : gfc_set_sym_referenced (tmp->n.sym);
13350 446 : gfc_commit_symbol (tmp->n.sym);
13351 446 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13352 :
13353 : /* Should the lhs be a section, use its array ref for the
13354 : temporary expression. */
13355 446 : if (aref && aref->type != AR_FULL)
13356 : {
13357 6 : gfc_free_ref_list (e->ref);
13358 6 : e->ref = gfc_copy_ref (ref);
13359 : }
13360 446 : return e;
13361 : }
13362 :
13363 :
13364 : /* Add one line of code to the code chain, making sure that 'head' and
13365 : 'tail' are appropriately updated. */
13366 :
13367 : static void
13368 656 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13369 : {
13370 656 : gcc_assert (this_code);
13371 656 : if (*head == NULL)
13372 308 : *head = *tail = *this_code;
13373 : else
13374 348 : *tail = gfc_append_code (*tail, *this_code);
13375 656 : *this_code = NULL;
13376 656 : }
13377 :
13378 :
13379 : /* Generate a final call from a variable expression */
13380 :
13381 : static void
13382 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13383 : {
13384 81 : gfc_code *this_code;
13385 81 : gfc_expr *final_expr = NULL;
13386 81 : gfc_expr *size_expr;
13387 81 : gfc_expr *fini_coarray;
13388 :
13389 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13390 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13391 75 : return;
13392 :
13393 : /* Now generate the finalizer call. */
13394 6 : this_code = gfc_get_code (EXEC_CALL);
13395 6 : this_code->symtree = final_expr->symtree;
13396 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13397 :
13398 : //* Expression to be finalized */
13399 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13400 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13401 :
13402 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13403 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13404 6 : size_expr = gfc_get_expr ();
13405 6 : size_expr->where = gfc_current_locus;
13406 6 : size_expr->expr_type = EXPR_OP;
13407 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13408 6 : size_expr->value.op.op1
13409 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13410 : "storage_size", gfc_current_locus, 2,
13411 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13412 : gfc_get_int_expr (gfc_index_integer_kind,
13413 : NULL, 0));
13414 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13415 : gfc_character_storage_size);
13416 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13417 6 : size_expr->ts = size_expr->value.op.op1->ts;
13418 6 : this_code->ext.actual->next->expr = size_expr;
13419 :
13420 : /* fini_coarray */
13421 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13422 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13423 : &tmp_expr->where);
13424 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13425 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13426 :
13427 6 : add_code_to_chain (&this_code, head, tail);
13428 :
13429 : }
13430 :
13431 : /* Counts the potential number of part array references that would
13432 : result from resolution of typebound defined assignments. */
13433 :
13434 :
13435 : static int
13436 243 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13437 : {
13438 243 : gfc_component *c;
13439 243 : int c_depth = 0, t_depth;
13440 :
13441 584 : for (c= derived->components; c; c = c->next)
13442 : {
13443 341 : if ((!gfc_bt_struct (c->ts.type)
13444 261 : || c->attr.pointer
13445 261 : || c->attr.allocatable
13446 260 : || c->attr.proc_pointer_comp
13447 260 : || c->attr.class_pointer
13448 260 : || c->attr.proc_pointer)
13449 81 : && !c->attr.defined_assign_comp)
13450 81 : continue;
13451 :
13452 260 : if (c->as && c_depth == 0)
13453 260 : c_depth = 1;
13454 :
13455 260 : if (c->ts.u.derived->attr.defined_assign_comp)
13456 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13457 : c->as ? 1 : 0);
13458 : else
13459 : t_depth = 0;
13460 :
13461 260 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13462 : }
13463 243 : return depth + c_depth;
13464 : }
13465 :
13466 :
13467 : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13468 : "An intrinsic assignment where the variable is of derived type is performed
13469 : as if each component of the variable were assigned from the corresponding
13470 : component of expr using pointer assignment (10.2.2) for each pointer
13471 : component, defined assignment for each nonpointer nonallocatable component
13472 : of a type that has a type-bound defined assignment consistent with the
13473 : component, intrinsic assignment for each other nonpointer nonallocatable
13474 : component, and intrinsic assignment for each allocated coarray component.
13475 : For unallocated coarray components, the corresponding component of the
13476 : variable shall be unallocated. For a noncoarray allocatable component the
13477 : following sequence of operations is applied.
13478 : (1) If the component of the variable is allocated, it is deallocated.
13479 : (2) If the component of the value of expr is allocated, the
13480 : corresponding component of the variable is allocated with the same
13481 : dynamic type and type parameters as the component of the value of
13482 : expr. If it is an array, it is allocated with the same bounds. The
13483 : value of the component of the value of expr is then assigned to the
13484 : corresponding component of the variable using defined assignment if
13485 : the declared type of the component has a type-bound defined
13486 : assignment consistent with the component, and intrinsic assignment
13487 : for the dynamic type of that component otherwise."
13488 :
13489 : The pointer assignments are taken care of by the intrinsic assignment of the
13490 : structure itself. This function recursively adds defined assignments where
13491 : required. The recursion is accomplished by calling gfc_resolve_code.
13492 :
13493 : When the lhs in a defined assignment has intent INOUT or is intent OUT
13494 : and the component of 'var' is finalizable, we need a temporary for the
13495 : lhs. In pseudo-code for an assignment var = expr:
13496 :
13497 : ! Confine finalization of temporaries, as far as possible.
13498 : Enclose the code for the assignment in a block
13499 : ! Only call function 'expr' once.
13500 : #if ('expr is not a constant or an variable)
13501 : temp_expr = expr
13502 : expr = temp_x
13503 : ! Do the intrinsic assignment
13504 : #if typeof ('var') has a typebound final subroutine
13505 : finalize (var)
13506 : var = expr
13507 : ! Now do the component assignments
13508 : #do over derived type components [%cmp]
13509 : #if (cmp is a pointer of any kind)
13510 : continue
13511 : build the assignment
13512 : resolve the code
13513 : #if the code is a typebound assignment
13514 : #if (arg1 is INOUT or finalizable OUT && !t1)
13515 : t1 = var
13516 : arg1 = t1
13517 : deal with allocatation or not of var and this component
13518 : #elseif the code is an assignment by itself
13519 : #if this component does not need finalization
13520 : delete code and continue
13521 : #else
13522 : remove the leading assignment
13523 : #endif
13524 : commit the code
13525 : #if (t1 and (arg1 is INOUT or finalizable OUT))
13526 : var%cmp = t1%cmp
13527 : #enddo
13528 : put all code chunks involving t1 to the top of the generated code
13529 : insert the generated block in place of the original code
13530 : */
13531 :
13532 : static bool
13533 381 : is_finalizable_type (gfc_typespec ts)
13534 : {
13535 381 : gfc_component *c;
13536 :
13537 381 : if (ts.type != BT_DERIVED)
13538 : return false;
13539 :
13540 : /* (1) Check for FINAL subroutines. */
13541 381 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13542 : return true;
13543 :
13544 : /* (2) Check for components of finalizable type. */
13545 809 : for (c = ts.u.derived->components; c; c = c->next)
13546 470 : if (c->ts.type == BT_DERIVED
13547 243 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13548 242 : && c->ts.u.derived->f2k_derived
13549 242 : && c->ts.u.derived->f2k_derived->finalizers)
13550 : return true;
13551 :
13552 : return false;
13553 : }
13554 :
13555 : /* The temporary assignments have to be put on top of the additional
13556 : code to avoid the result being changed by the intrinsic assignment.
13557 : */
13558 : static int component_assignment_level = 0;
13559 : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13560 : static bool finalizable_comp;
13561 :
13562 : static void
13563 188 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13564 : {
13565 188 : gfc_component *comp1, *comp2;
13566 188 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13567 188 : gfc_code *tmp_code = NULL;
13568 188 : gfc_expr *t1 = NULL;
13569 188 : gfc_expr *tmp_expr = NULL;
13570 188 : int error_count, depth;
13571 188 : bool finalizable_lhs;
13572 :
13573 188 : gfc_get_errors (NULL, &error_count);
13574 :
13575 : /* Filter out continuing processing after an error. */
13576 188 : if (error_count
13577 188 : || (*code)->expr1->ts.type != BT_DERIVED
13578 188 : || (*code)->expr2->ts.type != BT_DERIVED)
13579 140 : return;
13580 :
13581 : /* TODO: Handle more than one part array reference in assignments. */
13582 188 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13583 188 : (*code)->expr1->rank ? 1 : 0);
13584 188 : if (depth > 1)
13585 : {
13586 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13587 : "done because multiple part array references would "
13588 : "occur in intermediate expressions.", &(*code)->loc);
13589 6 : return;
13590 : }
13591 :
13592 182 : if (!component_assignment_level)
13593 134 : finalizable_comp = true;
13594 :
13595 : /* Build a block so that function result temporaries are finalized
13596 : locally on exiting the rather than enclosing scope. */
13597 182 : if (!component_assignment_level)
13598 : {
13599 134 : ns = gfc_build_block_ns (ns);
13600 134 : tmp_code = gfc_get_code (EXEC_NOP);
13601 134 : *tmp_code = **code;
13602 134 : tmp_code->next = NULL;
13603 134 : (*code)->op = EXEC_BLOCK;
13604 134 : (*code)->ext.block.ns = ns;
13605 134 : (*code)->ext.block.assoc = NULL;
13606 134 : (*code)->expr1 = (*code)->expr2 = NULL;
13607 134 : ns->code = tmp_code;
13608 134 : code = &ns->code;
13609 : }
13610 :
13611 182 : component_assignment_level++;
13612 :
13613 182 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13614 :
13615 : /* Create a temporary so that functions get called only once. */
13616 182 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13617 182 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13618 : {
13619 : /* Assign the rhs to the temporary. */
13620 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13621 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13622 : {
13623 : /* Use allocate on assignment for the sake of simplicity. The
13624 : temporary must not take on the optional attribute. Assume
13625 : that the assignment is guarded by a PRESENT condition if the
13626 : lhs is optional. */
13627 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13628 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
13629 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13630 : }
13631 162 : this_code = build_assignment (EXEC_ASSIGN,
13632 : tmp_expr, (*code)->expr2,
13633 81 : NULL, NULL, (*code)->loc);
13634 81 : this_code->expr2->must_finalize = 1;
13635 : /* Add the code and substitute the rhs expression. */
13636 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13637 81 : gfc_free_expr ((*code)->expr2);
13638 81 : (*code)->expr2 = tmp_expr;
13639 : }
13640 :
13641 : /* Do the intrinsic assignment. This is not needed if the lhs is one
13642 : of the temporaries generated here, since the intrinsic assignment
13643 : to the final result already does this. */
13644 182 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
13645 : {
13646 182 : if (finalizable_lhs)
13647 18 : (*code)->expr1->must_finalize = 1;
13648 182 : this_code = build_assignment (EXEC_ASSIGN,
13649 : (*code)->expr1, (*code)->expr2,
13650 : NULL, NULL, (*code)->loc);
13651 182 : add_code_to_chain (&this_code, &head, &tail);
13652 : }
13653 :
13654 182 : comp1 = (*code)->expr1->ts.u.derived->components;
13655 182 : comp2 = (*code)->expr2->ts.u.derived->components;
13656 :
13657 449 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
13658 : {
13659 267 : bool inout = false;
13660 267 : bool finalizable_out = false;
13661 :
13662 : /* The intrinsic assignment does the right thing for pointers
13663 : of all kinds and allocatable components. */
13664 267 : if (!gfc_bt_struct (comp1->ts.type)
13665 200 : || comp1->attr.pointer
13666 200 : || comp1->attr.allocatable
13667 199 : || comp1->attr.proc_pointer_comp
13668 199 : || comp1->attr.class_pointer
13669 199 : || comp1->attr.proc_pointer)
13670 68 : continue;
13671 :
13672 398 : finalizable_comp = is_finalizable_type (comp1->ts)
13673 199 : && !finalizable_lhs;
13674 :
13675 : /* Make an assignment for this component. */
13676 398 : this_code = build_assignment (EXEC_ASSIGN,
13677 : (*code)->expr1, (*code)->expr2,
13678 199 : comp1, comp2, (*code)->loc);
13679 :
13680 : /* Convert the assignment if there is a defined assignment for
13681 : this type. Otherwise, using the call from gfc_resolve_code,
13682 : recurse into its components. */
13683 199 : gfc_resolve_code (this_code, ns);
13684 :
13685 199 : if (this_code->op == EXEC_ASSIGN_CALL)
13686 : {
13687 144 : gfc_formal_arglist *dummy_args;
13688 144 : gfc_symbol *rsym;
13689 : /* Check that there is a typebound defined assignment. If not,
13690 : then this must be a module defined assignment. We cannot
13691 : use the defined_assign_comp attribute here because it must
13692 : be this derived type that has the defined assignment and not
13693 : a parent type. */
13694 144 : if (!(comp1->ts.u.derived->f2k_derived
13695 : && comp1->ts.u.derived->f2k_derived
13696 144 : ->tb_op[INTRINSIC_ASSIGN]))
13697 : {
13698 1 : gfc_free_statements (this_code);
13699 1 : this_code = NULL;
13700 1 : continue;
13701 : }
13702 :
13703 : /* If the first argument of the subroutine has intent INOUT
13704 : a temporary must be generated and used instead. */
13705 143 : rsym = this_code->resolved_sym;
13706 143 : dummy_args = gfc_sym_get_dummy_args (rsym);
13707 268 : finalizable_out = gfc_may_be_finalized (comp1->ts)
13708 18 : && dummy_args
13709 161 : && dummy_args->sym->attr.intent == INTENT_OUT;
13710 286 : inout = dummy_args
13711 268 : && dummy_args->sym->attr.intent == INTENT_INOUT;
13712 72 : if ((inout || finalizable_out)
13713 89 : && !comp1->attr.allocatable)
13714 : {
13715 89 : gfc_code *temp_code;
13716 89 : inout = true;
13717 :
13718 : /* Build the temporary required for the assignment and put
13719 : it at the head of the generated code. */
13720 89 : if (!t1)
13721 : {
13722 89 : gfc_namespace *tmp_ns = ns;
13723 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
13724 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
13725 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
13726 89 : t1->symtree->n.sym->attr.artificial = 1;
13727 178 : temp_code = build_assignment (EXEC_ASSIGN,
13728 : t1, (*code)->expr1,
13729 89 : NULL, NULL, (*code)->loc);
13730 :
13731 : /* For allocatable LHS, check whether it is allocated. Note
13732 : that allocatable components with defined assignment are
13733 : not yet support. See PR 57696. */
13734 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
13735 : {
13736 24 : gfc_code *block;
13737 24 : gfc_expr *e =
13738 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13739 24 : block = gfc_get_code (EXEC_IF);
13740 24 : block->block = gfc_get_code (EXEC_IF);
13741 24 : block->block->expr1
13742 48 : = gfc_build_intrinsic_call (ns,
13743 : GFC_ISYM_ALLOCATED, "allocated",
13744 24 : (*code)->loc, 1, e);
13745 24 : block->block->next = temp_code;
13746 24 : temp_code = block;
13747 : }
13748 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
13749 : }
13750 :
13751 : /* Replace the first actual arg with the component of the
13752 : temporary. */
13753 89 : gfc_free_expr (this_code->ext.actual->expr);
13754 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
13755 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
13756 :
13757 : /* If the LHS variable is allocatable and wasn't allocated and
13758 : the temporary is allocatable, pointer assign the address of
13759 : the freshly allocated LHS to the temporary. */
13760 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
13761 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
13762 : {
13763 18 : gfc_code *block;
13764 18 : gfc_expr *cond;
13765 :
13766 18 : cond = gfc_get_expr ();
13767 18 : cond->ts.type = BT_LOGICAL;
13768 18 : cond->ts.kind = gfc_default_logical_kind;
13769 18 : cond->expr_type = EXPR_OP;
13770 18 : cond->where = (*code)->loc;
13771 18 : cond->value.op.op = INTRINSIC_NOT;
13772 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
13773 : GFC_ISYM_ALLOCATED, "allocated",
13774 18 : (*code)->loc, 1, gfc_copy_expr (t1));
13775 18 : block = gfc_get_code (EXEC_IF);
13776 18 : block->block = gfc_get_code (EXEC_IF);
13777 18 : block->block->expr1 = cond;
13778 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13779 : t1, (*code)->expr1,
13780 18 : NULL, NULL, (*code)->loc);
13781 18 : add_code_to_chain (&block, &head, &tail);
13782 : }
13783 : }
13784 : }
13785 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
13786 : {
13787 : /* Don't add intrinsic assignments since they are already
13788 : effected by the intrinsic assignment of the structure, unless
13789 : finalization is required. */
13790 7 : if (finalizable_comp)
13791 0 : this_code->expr1->must_finalize = 1;
13792 : else
13793 : {
13794 7 : gfc_free_statements (this_code);
13795 7 : this_code = NULL;
13796 7 : continue;
13797 : }
13798 : }
13799 : else
13800 : {
13801 : /* Resolution has expanded an assignment of a derived type with
13802 : defined assigned components. Remove the redundant, leading
13803 : assignment. */
13804 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
13805 48 : gfc_code *tmp = this_code;
13806 48 : this_code = this_code->next;
13807 48 : tmp->next = NULL;
13808 48 : gfc_free_statements (tmp);
13809 : }
13810 :
13811 191 : add_code_to_chain (&this_code, &head, &tail);
13812 :
13813 191 : if (t1 && (inout || finalizable_out))
13814 : {
13815 : /* Transfer the value to the final result. */
13816 178 : this_code = build_assignment (EXEC_ASSIGN,
13817 : (*code)->expr1, t1,
13818 89 : comp1, comp2, (*code)->loc);
13819 89 : this_code->expr1->must_finalize = 0;
13820 89 : add_code_to_chain (&this_code, &head, &tail);
13821 : }
13822 : }
13823 :
13824 : /* Put the temporary assignments at the top of the generated code. */
13825 182 : if (tmp_head && component_assignment_level == 1)
13826 : {
13827 126 : gfc_append_code (tmp_head, head);
13828 126 : head = tmp_head;
13829 126 : tmp_head = tmp_tail = NULL;
13830 : }
13831 :
13832 : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
13833 : not accidentally deallocated. Hence, nullify t1. */
13834 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
13835 271 : && gfc_expr_attr ((*code)->expr1).allocatable)
13836 : {
13837 18 : gfc_code *block;
13838 18 : gfc_expr *cond;
13839 18 : gfc_expr *e;
13840 :
13841 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13842 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
13843 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
13844 18 : block = gfc_get_code (EXEC_IF);
13845 18 : block->block = gfc_get_code (EXEC_IF);
13846 18 : block->block->expr1 = cond;
13847 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13848 : t1, gfc_get_null_expr (&(*code)->loc),
13849 18 : NULL, NULL, (*code)->loc);
13850 18 : gfc_append_code (tail, block);
13851 18 : tail = block;
13852 : }
13853 :
13854 182 : component_assignment_level--;
13855 :
13856 : /* Make an explicit final call for the function result. */
13857 182 : if (tmp_expr)
13858 81 : generate_final_call (tmp_expr, &head, &tail);
13859 :
13860 182 : if (tmp_code)
13861 : {
13862 134 : ns->code = head;
13863 134 : return;
13864 : }
13865 :
13866 : /* Now attach the remaining code chain to the input code. Step on
13867 : to the end of the new code since resolution is complete. */
13868 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
13869 48 : tail->next = (*code)->next;
13870 : /* Overwrite 'code' because this would place the intrinsic assignment
13871 : before the temporary for the lhs is created. */
13872 48 : gfc_free_expr ((*code)->expr1);
13873 48 : gfc_free_expr ((*code)->expr2);
13874 48 : **code = *head;
13875 48 : if (head != tail)
13876 48 : free (head);
13877 48 : *code = tail;
13878 : }
13879 :
13880 :
13881 : /* F2008: Pointer function assignments are of the form:
13882 : ptr_fcn (args) = expr
13883 : This function breaks these assignments into two statements:
13884 : temporary_pointer => ptr_fcn(args)
13885 : temporary_pointer = expr */
13886 :
13887 : static bool
13888 284519 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
13889 : {
13890 284519 : gfc_expr *tmp_ptr_expr;
13891 284519 : gfc_code *this_code;
13892 284519 : gfc_component *comp;
13893 284519 : gfc_symbol *s;
13894 :
13895 284519 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
13896 : return false;
13897 :
13898 : /* Even if standard does not support this feature, continue to build
13899 : the two statements to avoid upsetting frontend_passes.c. */
13900 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
13901 : "%L", &(*code)->loc);
13902 :
13903 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
13904 :
13905 205 : if (comp)
13906 6 : s = comp->ts.interface;
13907 : else
13908 199 : s = (*code)->expr1->symtree->n.sym;
13909 :
13910 205 : if (s == NULL || !s->result->attr.pointer)
13911 : {
13912 5 : gfc_error ("The function result on the lhs of the assignment at "
13913 : "%L must have the pointer attribute.",
13914 5 : &(*code)->expr1->where);
13915 5 : (*code)->op = EXEC_NOP;
13916 5 : return false;
13917 : }
13918 :
13919 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
13920 :
13921 : /* get_temp_from_expression is set up for ordinary assignments. To that
13922 : end, where array bounds are not known, arrays are made allocatable.
13923 : Change the temporary to a pointer here. */
13924 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
13925 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
13926 200 : tmp_ptr_expr->where = (*code)->loc;
13927 :
13928 : /* A new charlen is required to ensure that the variable string length
13929 : is different to that of the original lhs for deferred results. */
13930 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
13931 : {
13932 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
13933 60 : tmp_ptr_expr->ts.deferred = 1;
13934 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
13935 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
13936 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
13937 : }
13938 :
13939 400 : this_code = build_assignment (EXEC_ASSIGN,
13940 : tmp_ptr_expr, (*code)->expr2,
13941 200 : NULL, NULL, (*code)->loc);
13942 200 : this_code->next = (*code)->next;
13943 200 : (*code)->next = this_code;
13944 200 : (*code)->op = EXEC_POINTER_ASSIGN;
13945 200 : (*code)->expr2 = (*code)->expr1;
13946 200 : (*code)->expr1 = tmp_ptr_expr;
13947 :
13948 200 : return true;
13949 : }
13950 :
13951 :
13952 : /* Deferred character length assignments from an operator expression
13953 : require a temporary because the character length of the lhs can
13954 : change in the course of the assignment. */
13955 :
13956 : static bool
13957 283472 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
13958 : {
13959 283472 : gfc_expr *tmp_expr;
13960 283472 : gfc_code *this_code;
13961 :
13962 283472 : if (!((*code)->expr1->ts.type == BT_CHARACTER
13963 27045 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
13964 836 : && (*code)->expr2->ts.type == BT_CHARACTER
13965 835 : && (*code)->expr2->expr_type == EXPR_OP))
13966 : return false;
13967 :
13968 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
13969 : return false;
13970 :
13971 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
13972 : return false;
13973 :
13974 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13975 22 : tmp_expr->where = (*code)->loc;
13976 :
13977 : /* A new charlen is required to ensure that the variable string
13978 : length is different to that of the original lhs. */
13979 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
13980 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
13981 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
13982 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
13983 :
13984 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
13985 :
13986 22 : this_code = build_assignment (EXEC_ASSIGN,
13987 22 : (*code)->expr1,
13988 : gfc_copy_expr (tmp_expr),
13989 : NULL, NULL, (*code)->loc);
13990 :
13991 22 : (*code)->expr1 = tmp_expr;
13992 :
13993 22 : this_code->next = (*code)->next;
13994 22 : (*code)->next = this_code;
13995 :
13996 22 : return true;
13997 : }
13998 :
13999 :
14000 : /* Given a block of code, recursively resolve everything pointed to by this
14001 : code block. */
14002 :
14003 : void
14004 673095 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
14005 : {
14006 673095 : int omp_workshare_save;
14007 673095 : int forall_save, do_concurrent_save;
14008 673095 : code_stack frame;
14009 673095 : bool t;
14010 :
14011 673095 : frame.prev = cs_base;
14012 673095 : frame.head = code;
14013 673095 : cs_base = &frame;
14014 :
14015 673095 : find_reachable_labels (code);
14016 :
14017 1800021 : for (; code; code = code->next)
14018 : {
14019 1126927 : frame.current = code;
14020 1126927 : forall_save = forall_flag;
14021 1126927 : do_concurrent_save = gfc_do_concurrent_flag;
14022 :
14023 1126927 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
14024 : {
14025 2202 : if (code->op == EXEC_FORALL)
14026 1992 : forall_flag = 1;
14027 210 : else if (code->op == EXEC_DO_CONCURRENT)
14028 210 : gfc_do_concurrent_flag = 1;
14029 2202 : gfc_resolve_forall (code, ns, forall_save);
14030 2202 : if (code->op == EXEC_FORALL)
14031 1992 : forall_flag = 2;
14032 210 : else if (code->op == EXEC_DO_CONCURRENT)
14033 210 : gfc_do_concurrent_flag = 2;
14034 : }
14035 1124725 : else if (code->op == EXEC_OMP_METADIRECTIVE)
14036 138 : for (gfc_omp_variant *variant
14037 : = code->ext.omp_variants;
14038 448 : variant; variant = variant->next)
14039 310 : gfc_resolve_code (variant->code, ns);
14040 1124587 : else if (code->block)
14041 : {
14042 327222 : omp_workshare_save = -1;
14043 327222 : switch (code->op)
14044 : {
14045 10115 : case EXEC_OACC_PARALLEL_LOOP:
14046 10115 : case EXEC_OACC_PARALLEL:
14047 10115 : case EXEC_OACC_KERNELS_LOOP:
14048 10115 : case EXEC_OACC_KERNELS:
14049 10115 : case EXEC_OACC_SERIAL_LOOP:
14050 10115 : case EXEC_OACC_SERIAL:
14051 10115 : case EXEC_OACC_DATA:
14052 10115 : case EXEC_OACC_HOST_DATA:
14053 10115 : case EXEC_OACC_LOOP:
14054 10115 : gfc_resolve_oacc_blocks (code, ns);
14055 10115 : break;
14056 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
14057 54 : omp_workshare_save = omp_workshare_flag;
14058 54 : omp_workshare_flag = 1;
14059 54 : gfc_resolve_omp_parallel_blocks (code, ns);
14060 54 : break;
14061 5960 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14062 5960 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14063 5960 : case EXEC_OMP_MASKED_TASKLOOP:
14064 5960 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14065 5960 : case EXEC_OMP_MASTER_TASKLOOP:
14066 5960 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14067 5960 : case EXEC_OMP_PARALLEL:
14068 5960 : case EXEC_OMP_PARALLEL_DO:
14069 5960 : case EXEC_OMP_PARALLEL_DO_SIMD:
14070 5960 : case EXEC_OMP_PARALLEL_LOOP:
14071 5960 : case EXEC_OMP_PARALLEL_MASKED:
14072 5960 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14073 5960 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14074 5960 : case EXEC_OMP_PARALLEL_MASTER:
14075 5960 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14076 5960 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14077 5960 : case EXEC_OMP_PARALLEL_SECTIONS:
14078 5960 : case EXEC_OMP_TARGET_PARALLEL:
14079 5960 : case EXEC_OMP_TARGET_PARALLEL_DO:
14080 5960 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14081 5960 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14082 5960 : case EXEC_OMP_TARGET_TEAMS:
14083 5960 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14084 5960 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14085 5960 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14086 5960 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14087 5960 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14088 5960 : case EXEC_OMP_TASK:
14089 5960 : case EXEC_OMP_TASKLOOP:
14090 5960 : case EXEC_OMP_TASKLOOP_SIMD:
14091 5960 : case EXEC_OMP_TEAMS:
14092 5960 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14093 5960 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14094 5960 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14095 5960 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14096 5960 : case EXEC_OMP_TEAMS_LOOP:
14097 5960 : omp_workshare_save = omp_workshare_flag;
14098 5960 : omp_workshare_flag = 0;
14099 5960 : gfc_resolve_omp_parallel_blocks (code, ns);
14100 5960 : break;
14101 3063 : case EXEC_OMP_DISTRIBUTE:
14102 3063 : case EXEC_OMP_DISTRIBUTE_SIMD:
14103 3063 : case EXEC_OMP_DO:
14104 3063 : case EXEC_OMP_DO_SIMD:
14105 3063 : case EXEC_OMP_LOOP:
14106 3063 : case EXEC_OMP_SIMD:
14107 3063 : case EXEC_OMP_TARGET_SIMD:
14108 3063 : case EXEC_OMP_TILE:
14109 3063 : case EXEC_OMP_UNROLL:
14110 3063 : gfc_resolve_omp_do_blocks (code, ns);
14111 3063 : break;
14112 : case EXEC_SELECT_TYPE:
14113 : case EXEC_SELECT_RANK:
14114 : /* Blocks are handled in resolve_select_type/rank because we
14115 : have to transform the SELECT TYPE into ASSOCIATE first. */
14116 : break;
14117 : case EXEC_DO_CONCURRENT:
14118 : gfc_do_concurrent_flag = 1;
14119 : gfc_resolve_blocks (code->block, ns);
14120 : gfc_do_concurrent_flag = 2;
14121 : break;
14122 39 : case EXEC_OMP_WORKSHARE:
14123 39 : omp_workshare_save = omp_workshare_flag;
14124 39 : omp_workshare_flag = 1;
14125 : /* FALL THROUGH */
14126 304033 : default:
14127 304033 : gfc_resolve_blocks (code->block, ns);
14128 304033 : break;
14129 : }
14130 :
14131 323225 : if (omp_workshare_save != -1)
14132 6053 : omp_workshare_flag = omp_workshare_save;
14133 : }
14134 797365 : start:
14135 1127132 : t = true;
14136 1127132 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14137 1125745 : t = gfc_resolve_expr (code->expr1);
14138 :
14139 1127132 : forall_flag = forall_save;
14140 1127132 : gfc_do_concurrent_flag = do_concurrent_save;
14141 :
14142 1127132 : if (!gfc_resolve_expr (code->expr2))
14143 637 : t = false;
14144 :
14145 1127132 : if (code->op == EXEC_ALLOCATE
14146 1127132 : && !gfc_resolve_expr (code->expr3))
14147 : t = false;
14148 :
14149 1127132 : switch (code->op)
14150 : {
14151 : case EXEC_NOP:
14152 : case EXEC_END_BLOCK:
14153 : case EXEC_END_NESTED_BLOCK:
14154 : case EXEC_CYCLE:
14155 : case EXEC_PAUSE:
14156 : break;
14157 :
14158 216054 : case EXEC_STOP:
14159 216054 : case EXEC_ERROR_STOP:
14160 216054 : if (code->expr2 != NULL
14161 37 : && (code->expr2->ts.type != BT_LOGICAL
14162 37 : || code->expr2->rank != 0))
14163 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14164 : &code->expr2->where);
14165 : break;
14166 :
14167 : case EXEC_EXIT:
14168 : case EXEC_CONTINUE:
14169 : case EXEC_DT_END:
14170 : case EXEC_ASSIGN_CALL:
14171 : break;
14172 :
14173 54 : case EXEC_CRITICAL:
14174 54 : resolve_critical (code);
14175 54 : break;
14176 :
14177 1307 : case EXEC_SYNC_ALL:
14178 1307 : case EXEC_SYNC_IMAGES:
14179 1307 : case EXEC_SYNC_MEMORY:
14180 1307 : resolve_sync (code);
14181 1307 : break;
14182 :
14183 197 : case EXEC_LOCK:
14184 197 : case EXEC_UNLOCK:
14185 197 : case EXEC_EVENT_POST:
14186 197 : case EXEC_EVENT_WAIT:
14187 197 : resolve_lock_unlock_event (code);
14188 197 : break;
14189 :
14190 : case EXEC_FAIL_IMAGE:
14191 : break;
14192 :
14193 130 : case EXEC_FORM_TEAM:
14194 130 : resolve_form_team (code);
14195 130 : break;
14196 :
14197 73 : case EXEC_CHANGE_TEAM:
14198 73 : resolve_change_team (code);
14199 73 : break;
14200 :
14201 71 : case EXEC_END_TEAM:
14202 71 : resolve_end_team (code);
14203 71 : break;
14204 :
14205 43 : case EXEC_SYNC_TEAM:
14206 43 : resolve_sync_team (code);
14207 43 : break;
14208 :
14209 1420 : case EXEC_ENTRY:
14210 : /* Keep track of which entry we are up to. */
14211 1420 : current_entry_id = code->ext.entry->id;
14212 1420 : break;
14213 :
14214 453 : case EXEC_WHERE:
14215 453 : resolve_where (code, NULL);
14216 453 : break;
14217 :
14218 1250 : case EXEC_GOTO:
14219 1250 : if (code->expr1 != NULL)
14220 : {
14221 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14222 76 : || code->expr1->ts.type != BT_INTEGER
14223 76 : || (code->expr1->ref
14224 1 : && code->expr1->ref->type == REF_ARRAY)
14225 75 : || code->expr1->symtree == NULL
14226 75 : || (code->expr1->symtree->n.sym
14227 75 : && (code->expr1->symtree->n.sym->attr.flavor
14228 75 : == FL_PARAMETER)))
14229 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14230 : "scalar INTEGER variable", &code->expr1->where);
14231 74 : else if (code->expr1->symtree->n.sym
14232 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14233 1 : gfc_error ("Variable %qs has not been assigned a target "
14234 : "label at %L", code->expr1->symtree->n.sym->name,
14235 : &code->expr1->where);
14236 : }
14237 : else
14238 1172 : resolve_branch (code->label1, code);
14239 : break;
14240 :
14241 3187 : case EXEC_RETURN:
14242 3187 : if (code->expr1 != NULL
14243 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14244 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14245 : "INTEGER return specifier", &code->expr1->where);
14246 : break;
14247 :
14248 : case EXEC_INIT_ASSIGN:
14249 : case EXEC_END_PROCEDURE:
14250 : break;
14251 :
14252 285694 : case EXEC_ASSIGN:
14253 285694 : if (!t)
14254 : break;
14255 :
14256 285019 : if (flag_coarray == GFC_FCOARRAY_LIB
14257 285019 : && gfc_is_coindexed (code->expr1))
14258 : {
14259 : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14260 : coindexed variable. */
14261 500 : code->op = EXEC_CALL;
14262 500 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14263 : true);
14264 500 : code->resolved_sym = code->symtree->n.sym;
14265 500 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14266 500 : code->resolved_sym->attr.intrinsic = 1;
14267 500 : code->resolved_sym->attr.subroutine = 1;
14268 500 : code->resolved_isym
14269 500 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14270 500 : gfc_commit_symbol (code->resolved_sym);
14271 500 : code->ext.actual = gfc_get_actual_arglist ();
14272 500 : code->ext.actual->expr = code->expr1;
14273 500 : code->ext.actual->next = gfc_get_actual_arglist ();
14274 500 : if (code->expr2->expr_type != EXPR_VARIABLE
14275 500 : && code->expr2->expr_type != EXPR_CONSTANT)
14276 : {
14277 : /* Convert assignments of expr1[...] = expr2 into
14278 : tvar = expr2
14279 : expr1[...] = tvar
14280 : when expr2 is not trivial. */
14281 54 : gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
14282 54 : gfc_code next_code = *code;
14283 54 : gfc_code *rhs_code
14284 108 : = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
14285 54 : NULL, code->expr2->where);
14286 54 : *code = *rhs_code;
14287 54 : code->next = rhs_code;
14288 54 : *rhs_code = next_code;
14289 :
14290 54 : rhs_code->ext.actual->next->expr = tvar;
14291 54 : rhs_code->expr1 = NULL;
14292 54 : rhs_code->expr2 = NULL;
14293 : }
14294 : else
14295 : {
14296 446 : code->ext.actual->next->expr = code->expr2;
14297 :
14298 446 : code->expr1 = NULL;
14299 446 : code->expr2 = NULL;
14300 : }
14301 : break;
14302 : }
14303 :
14304 284519 : if (code->expr1->ts.type == BT_CLASS)
14305 1066 : gfc_find_vtab (&code->expr2->ts);
14306 :
14307 : /* If this is a pointer function in an lvalue variable context,
14308 : the new code will have to be resolved afresh. This is also the
14309 : case with an error, where the code is transformed into NOP to
14310 : prevent ICEs downstream. */
14311 284519 : if (resolve_ptr_fcn_assign (&code, ns)
14312 284519 : || code->op == EXEC_NOP)
14313 205 : goto start;
14314 :
14315 284314 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14316 284314 : _("assignment")))
14317 : break;
14318 :
14319 284275 : if (resolve_ordinary_assign (code, ns))
14320 : {
14321 803 : if (omp_workshare_flag)
14322 : {
14323 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14324 1 : "at %L", &code->loc);
14325 1 : break;
14326 : }
14327 802 : if (code->op == EXEC_COMPCALL)
14328 443 : goto compcall;
14329 : else
14330 359 : goto call;
14331 : }
14332 :
14333 : /* Check for dependencies in deferred character length array
14334 : assignments and generate a temporary, if necessary. */
14335 283472 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14336 : break;
14337 :
14338 : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14339 283450 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14340 7034 : && code->expr1->ts.u.derived
14341 7034 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14342 188 : generate_component_assignments (&code, ns);
14343 283262 : else if (code->op == EXEC_ASSIGN)
14344 : {
14345 283262 : if (gfc_may_be_finalized (code->expr1->ts))
14346 1211 : code->expr1->must_finalize = 1;
14347 283262 : if (code->expr2->expr_type == EXPR_ARRAY
14348 283262 : && gfc_may_be_finalized (code->expr2->ts))
14349 43 : code->expr2->must_finalize = 1;
14350 : }
14351 :
14352 : break;
14353 :
14354 126 : case EXEC_LABEL_ASSIGN:
14355 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14356 0 : gfc_error ("Label %d referenced at %L is never defined",
14357 : code->label1->value, &code->label1->where);
14358 126 : if (t
14359 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14360 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14361 126 : || code->expr1->symtree->n.sym->ts.kind
14362 126 : != gfc_default_integer_kind
14363 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14364 125 : || code->expr1->symtree->n.sym->as != NULL))
14365 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14366 : "default INTEGER variable", &code->expr1->where);
14367 : break;
14368 :
14369 10400 : case EXEC_POINTER_ASSIGN:
14370 10400 : {
14371 10400 : gfc_expr* e;
14372 :
14373 10400 : if (!t)
14374 : break;
14375 :
14376 : /* This is both a variable definition and pointer assignment
14377 : context, so check both of them. For rank remapping, a final
14378 : array ref may be present on the LHS and fool gfc_expr_attr
14379 : used in gfc_check_vardef_context. Remove it. */
14380 10395 : e = remove_last_array_ref (code->expr1);
14381 20790 : t = gfc_check_vardef_context (e, true, false, false,
14382 10395 : _("pointer assignment"));
14383 10395 : if (t)
14384 10366 : t = gfc_check_vardef_context (e, false, false, false,
14385 10366 : _("pointer assignment"));
14386 10395 : gfc_free_expr (e);
14387 :
14388 1137179 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14389 :
14390 10253 : if (!t)
14391 : break;
14392 :
14393 : /* Assigning a class object always is a regular assign. */
14394 10253 : if (code->expr2->ts.type == BT_CLASS
14395 567 : && code->expr1->ts.type == BT_CLASS
14396 476 : && CLASS_DATA (code->expr2)
14397 475 : && !CLASS_DATA (code->expr2)->attr.dimension
14398 10874 : && !(gfc_expr_attr (code->expr1).proc_pointer
14399 54 : && code->expr2->expr_type == EXPR_VARIABLE
14400 42 : && code->expr2->symtree->n.sym->attr.flavor
14401 42 : == FL_PROCEDURE))
14402 326 : code->op = EXEC_ASSIGN;
14403 : break;
14404 : }
14405 :
14406 72 : case EXEC_ARITHMETIC_IF:
14407 72 : {
14408 72 : gfc_expr *e = code->expr1;
14409 :
14410 72 : gfc_resolve_expr (e);
14411 72 : if (e->expr_type == EXPR_NULL)
14412 1 : gfc_error ("Invalid NULL at %L", &e->where);
14413 :
14414 72 : if (t && (e->rank > 0
14415 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14416 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14417 : "REAL or INTEGER expression", &e->where);
14418 :
14419 72 : resolve_branch (code->label1, code);
14420 72 : resolve_branch (code->label2, code);
14421 72 : resolve_branch (code->label3, code);
14422 : }
14423 72 : break;
14424 :
14425 229390 : case EXEC_IF:
14426 229390 : if (t && code->expr1 != NULL
14427 0 : && (code->expr1->ts.type != BT_LOGICAL
14428 0 : || code->expr1->rank != 0))
14429 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14430 : &code->expr1->where);
14431 : break;
14432 :
14433 78916 : case EXEC_CALL:
14434 78916 : call:
14435 78916 : resolve_call (code);
14436 78916 : break;
14437 :
14438 1706 : case EXEC_COMPCALL:
14439 1706 : compcall:
14440 1706 : resolve_typebound_subroutine (code);
14441 1706 : break;
14442 :
14443 124 : case EXEC_CALL_PPC:
14444 124 : resolve_ppc_call (code);
14445 124 : break;
14446 :
14447 687 : case EXEC_SELECT:
14448 : /* Select is complicated. Also, a SELECT construct could be
14449 : a transformed computed GOTO. */
14450 687 : resolve_select (code, false);
14451 687 : break;
14452 :
14453 3005 : case EXEC_SELECT_TYPE:
14454 3005 : resolve_select_type (code, ns);
14455 3005 : break;
14456 :
14457 1018 : case EXEC_SELECT_RANK:
14458 1018 : resolve_select_rank (code, ns);
14459 1018 : break;
14460 :
14461 7903 : case EXEC_BLOCK:
14462 7903 : resolve_block_construct (code);
14463 7903 : break;
14464 :
14465 32732 : case EXEC_DO:
14466 32732 : if (code->ext.iterator != NULL)
14467 : {
14468 32732 : gfc_iterator *iter = code->ext.iterator;
14469 32732 : if (gfc_resolve_iterator (iter, true, false))
14470 32718 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14471 : true);
14472 : }
14473 : break;
14474 :
14475 531 : case EXEC_DO_WHILE:
14476 531 : if (code->expr1 == NULL)
14477 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14478 : "DO WHILE");
14479 531 : if (t
14480 531 : && (code->expr1->rank != 0
14481 531 : || code->expr1->ts.type != BT_LOGICAL))
14482 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14483 : "a scalar LOGICAL expression", &code->expr1->where);
14484 : break;
14485 :
14486 14141 : case EXEC_ALLOCATE:
14487 14141 : if (t)
14488 14139 : resolve_allocate_deallocate (code, "ALLOCATE");
14489 :
14490 : break;
14491 :
14492 5971 : case EXEC_DEALLOCATE:
14493 5971 : if (t)
14494 5971 : resolve_allocate_deallocate (code, "DEALLOCATE");
14495 :
14496 : break;
14497 :
14498 3897 : case EXEC_OPEN:
14499 3897 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14500 : break;
14501 :
14502 3670 : resolve_branch (code->ext.open->err, code);
14503 3670 : break;
14504 :
14505 3085 : case EXEC_CLOSE:
14506 3085 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14507 : break;
14508 :
14509 3051 : resolve_branch (code->ext.close->err, code);
14510 3051 : break;
14511 :
14512 2797 : case EXEC_BACKSPACE:
14513 2797 : case EXEC_ENDFILE:
14514 2797 : case EXEC_REWIND:
14515 2797 : case EXEC_FLUSH:
14516 2797 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14517 : break;
14518 :
14519 2731 : resolve_branch (code->ext.filepos->err, code);
14520 2731 : break;
14521 :
14522 817 : case EXEC_INQUIRE:
14523 817 : if (!gfc_resolve_inquire (code->ext.inquire))
14524 : break;
14525 :
14526 769 : resolve_branch (code->ext.inquire->err, code);
14527 769 : break;
14528 :
14529 92 : case EXEC_IOLENGTH:
14530 92 : gcc_assert (code->ext.inquire != NULL);
14531 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14532 : break;
14533 :
14534 90 : resolve_branch (code->ext.inquire->err, code);
14535 90 : break;
14536 :
14537 89 : case EXEC_WAIT:
14538 89 : if (!gfc_resolve_wait (code->ext.wait))
14539 : break;
14540 :
14541 74 : resolve_branch (code->ext.wait->err, code);
14542 74 : resolve_branch (code->ext.wait->end, code);
14543 74 : resolve_branch (code->ext.wait->eor, code);
14544 74 : break;
14545 :
14546 32350 : case EXEC_READ:
14547 32350 : case EXEC_WRITE:
14548 32350 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14549 : break;
14550 :
14551 32042 : resolve_branch (code->ext.dt->err, code);
14552 32042 : resolve_branch (code->ext.dt->end, code);
14553 32042 : resolve_branch (code->ext.dt->eor, code);
14554 32042 : break;
14555 :
14556 46351 : case EXEC_TRANSFER:
14557 46351 : resolve_transfer (code);
14558 46351 : break;
14559 :
14560 2202 : case EXEC_DO_CONCURRENT:
14561 2202 : case EXEC_FORALL:
14562 2202 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14563 :
14564 2202 : if (code->expr1 != NULL
14565 732 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14566 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14567 : "expression", &code->expr1->where);
14568 :
14569 2202 : if (code->op == EXEC_DO_CONCURRENT)
14570 210 : resolve_locality_spec (code, ns);
14571 : break;
14572 :
14573 13160 : case EXEC_OACC_PARALLEL_LOOP:
14574 13160 : case EXEC_OACC_PARALLEL:
14575 13160 : case EXEC_OACC_KERNELS_LOOP:
14576 13160 : case EXEC_OACC_KERNELS:
14577 13160 : case EXEC_OACC_SERIAL_LOOP:
14578 13160 : case EXEC_OACC_SERIAL:
14579 13160 : case EXEC_OACC_DATA:
14580 13160 : case EXEC_OACC_HOST_DATA:
14581 13160 : case EXEC_OACC_LOOP:
14582 13160 : case EXEC_OACC_UPDATE:
14583 13160 : case EXEC_OACC_WAIT:
14584 13160 : case EXEC_OACC_CACHE:
14585 13160 : case EXEC_OACC_ENTER_DATA:
14586 13160 : case EXEC_OACC_EXIT_DATA:
14587 13160 : case EXEC_OACC_ATOMIC:
14588 13160 : case EXEC_OACC_DECLARE:
14589 13160 : gfc_resolve_oacc_directive (code, ns);
14590 13160 : break;
14591 :
14592 16888 : case EXEC_OMP_ALLOCATE:
14593 16888 : case EXEC_OMP_ALLOCATORS:
14594 16888 : case EXEC_OMP_ASSUME:
14595 16888 : case EXEC_OMP_ATOMIC:
14596 16888 : case EXEC_OMP_BARRIER:
14597 16888 : case EXEC_OMP_CANCEL:
14598 16888 : case EXEC_OMP_CANCELLATION_POINT:
14599 16888 : case EXEC_OMP_CRITICAL:
14600 16888 : case EXEC_OMP_FLUSH:
14601 16888 : case EXEC_OMP_DEPOBJ:
14602 16888 : case EXEC_OMP_DISPATCH:
14603 16888 : case EXEC_OMP_DISTRIBUTE:
14604 16888 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14605 16888 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14606 16888 : case EXEC_OMP_DISTRIBUTE_SIMD:
14607 16888 : case EXEC_OMP_DO:
14608 16888 : case EXEC_OMP_DO_SIMD:
14609 16888 : case EXEC_OMP_ERROR:
14610 16888 : case EXEC_OMP_INTEROP:
14611 16888 : case EXEC_OMP_LOOP:
14612 16888 : case EXEC_OMP_MASTER:
14613 16888 : case EXEC_OMP_MASTER_TASKLOOP:
14614 16888 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14615 16888 : case EXEC_OMP_MASKED:
14616 16888 : case EXEC_OMP_MASKED_TASKLOOP:
14617 16888 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14618 16888 : case EXEC_OMP_METADIRECTIVE:
14619 16888 : case EXEC_OMP_ORDERED:
14620 16888 : case EXEC_OMP_SCAN:
14621 16888 : case EXEC_OMP_SCOPE:
14622 16888 : case EXEC_OMP_SECTIONS:
14623 16888 : case EXEC_OMP_SIMD:
14624 16888 : case EXEC_OMP_SINGLE:
14625 16888 : case EXEC_OMP_TARGET:
14626 16888 : case EXEC_OMP_TARGET_DATA:
14627 16888 : case EXEC_OMP_TARGET_ENTER_DATA:
14628 16888 : case EXEC_OMP_TARGET_EXIT_DATA:
14629 16888 : case EXEC_OMP_TARGET_PARALLEL:
14630 16888 : case EXEC_OMP_TARGET_PARALLEL_DO:
14631 16888 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14632 16888 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14633 16888 : case EXEC_OMP_TARGET_SIMD:
14634 16888 : case EXEC_OMP_TARGET_TEAMS:
14635 16888 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14636 16888 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14637 16888 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14638 16888 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14639 16888 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14640 16888 : case EXEC_OMP_TARGET_UPDATE:
14641 16888 : case EXEC_OMP_TASK:
14642 16888 : case EXEC_OMP_TASKGROUP:
14643 16888 : case EXEC_OMP_TASKLOOP:
14644 16888 : case EXEC_OMP_TASKLOOP_SIMD:
14645 16888 : case EXEC_OMP_TASKWAIT:
14646 16888 : case EXEC_OMP_TASKYIELD:
14647 16888 : case EXEC_OMP_TEAMS:
14648 16888 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14649 16888 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14650 16888 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14651 16888 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14652 16888 : case EXEC_OMP_TEAMS_LOOP:
14653 16888 : case EXEC_OMP_TILE:
14654 16888 : case EXEC_OMP_UNROLL:
14655 16888 : case EXEC_OMP_WORKSHARE:
14656 16888 : gfc_resolve_omp_directive (code, ns);
14657 16888 : break;
14658 :
14659 3874 : case EXEC_OMP_PARALLEL:
14660 3874 : case EXEC_OMP_PARALLEL_DO:
14661 3874 : case EXEC_OMP_PARALLEL_DO_SIMD:
14662 3874 : case EXEC_OMP_PARALLEL_LOOP:
14663 3874 : case EXEC_OMP_PARALLEL_MASKED:
14664 3874 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14665 3874 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14666 3874 : case EXEC_OMP_PARALLEL_MASTER:
14667 3874 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14668 3874 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14669 3874 : case EXEC_OMP_PARALLEL_SECTIONS:
14670 3874 : case EXEC_OMP_PARALLEL_WORKSHARE:
14671 3874 : omp_workshare_save = omp_workshare_flag;
14672 3874 : omp_workshare_flag = 0;
14673 3874 : gfc_resolve_omp_directive (code, ns);
14674 3874 : omp_workshare_flag = omp_workshare_save;
14675 3874 : break;
14676 :
14677 0 : default:
14678 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
14679 : }
14680 : }
14681 :
14682 673094 : cs_base = frame.prev;
14683 673094 : }
14684 :
14685 :
14686 : /* Resolve initial values and make sure they are compatible with
14687 : the variable. */
14688 :
14689 : static void
14690 1838537 : resolve_values (gfc_symbol *sym)
14691 : {
14692 1838537 : bool t;
14693 :
14694 1838537 : if (sym->value == NULL)
14695 : return;
14696 :
14697 414363 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
14698 14 : gfc_warning (OPT_Wdeprecated_declarations,
14699 : "Using parameter %qs declared at %L is deprecated",
14700 : sym->name, &sym->declared_at);
14701 :
14702 414363 : if (sym->value->expr_type == EXPR_STRUCTURE)
14703 39366 : t= resolve_structure_cons (sym->value, 1);
14704 : else
14705 374997 : t = gfc_resolve_expr (sym->value);
14706 :
14707 414363 : if (!t)
14708 : return;
14709 :
14710 414361 : gfc_check_assign_symbol (sym, NULL, sym->value);
14711 : }
14712 :
14713 :
14714 : /* Verify any BIND(C) derived types in the namespace so we can report errors
14715 : for them once, rather than for each variable declared of that type. */
14716 :
14717 : static void
14718 1809714 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
14719 : {
14720 1809714 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
14721 82429 : && derived_sym->attr.is_bind_c == 1)
14722 26984 : verify_bind_c_derived_type (derived_sym);
14723 :
14724 1809714 : return;
14725 : }
14726 :
14727 :
14728 : /* Check the interfaces of DTIO procedures associated with derived
14729 : type 'sym'. These procedures can either have typebound bindings or
14730 : can appear in DTIO generic interfaces. */
14731 :
14732 : static void
14733 1839507 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
14734 : {
14735 1839507 : if (!sym || sym->attr.flavor != FL_DERIVED)
14736 : return;
14737 :
14738 91593 : gfc_check_dtio_interfaces (sym);
14739 :
14740 91593 : return;
14741 : }
14742 :
14743 : /* Verify that any binding labels used in a given namespace do not collide
14744 : with the names or binding labels of any global symbols. Multiple INTERFACE
14745 : for the same procedure are permitted. Abstract interfaces and dummy
14746 : arguments are not checked. */
14747 :
14748 : static void
14749 1839507 : gfc_verify_binding_labels (gfc_symbol *sym)
14750 : {
14751 1839507 : gfc_gsymbol *gsym;
14752 1839507 : const char *module;
14753 :
14754 1839507 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
14755 61668 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
14756 33768 : || sym->attr.abstract || sym->attr.dummy)
14757 : return;
14758 :
14759 33668 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
14760 :
14761 33668 : if (sym->module)
14762 : module = sym->module;
14763 11958 : else if (sym->ns && sym->ns->proc_name
14764 11958 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
14765 4504 : module = sym->ns->proc_name->name;
14766 7454 : else if (sym->ns && sym->ns->parent
14767 358 : && sym->ns && sym->ns->parent->proc_name
14768 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
14769 272 : module = sym->ns->parent->proc_name->name;
14770 : else
14771 : module = NULL;
14772 :
14773 33668 : if (!gsym
14774 11347 : || (!gsym->defined
14775 8509 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
14776 : {
14777 22321 : if (!gsym)
14778 22321 : gsym = gfc_get_gsymbol (sym->binding_label, true);
14779 30830 : gsym->where = sym->declared_at;
14780 30830 : gsym->sym_name = sym->name;
14781 30830 : gsym->binding_label = sym->binding_label;
14782 30830 : gsym->ns = sym->ns;
14783 30830 : gsym->mod_name = module;
14784 30830 : if (sym->attr.function)
14785 19942 : gsym->type = GSYM_FUNCTION;
14786 10888 : else if (sym->attr.subroutine)
14787 10749 : gsym->type = GSYM_SUBROUTINE;
14788 : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
14789 30830 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
14790 30830 : return;
14791 : }
14792 :
14793 2838 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
14794 : {
14795 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
14796 : "identifier as entity at %L", sym->name,
14797 : sym->binding_label, &sym->declared_at, &gsym->where);
14798 : /* Clear the binding label to prevent checking multiple times. */
14799 1 : sym->binding_label = NULL;
14800 1 : return;
14801 : }
14802 :
14803 2837 : if (sym->attr.flavor == FL_VARIABLE && module
14804 37 : && (strcmp (module, gsym->mod_name) != 0
14805 35 : || strcmp (sym->name, gsym->sym_name) != 0))
14806 : {
14807 : /* This can only happen if the variable is defined in a module - if it
14808 : isn't the same module, reject it. */
14809 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
14810 : "uses the same global identifier as entity at %L from module %qs",
14811 : sym->name, module, sym->binding_label,
14812 : &sym->declared_at, &gsym->where, gsym->mod_name);
14813 3 : sym->binding_label = NULL;
14814 3 : return;
14815 : }
14816 :
14817 2834 : if ((sym->attr.function || sym->attr.subroutine)
14818 2798 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
14819 2796 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
14820 2483 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
14821 2089 : && (module != gsym->mod_name
14822 2085 : || strcmp (gsym->sym_name, sym->name) != 0
14823 2085 : || (module && strcmp (module, gsym->mod_name) != 0)))
14824 : {
14825 : /* Print an error if the procedure is defined multiple times; we have to
14826 : exclude references to the same procedure via module association or
14827 : multiple checks for the same procedure. */
14828 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
14829 : "global identifier as entity at %L", sym->name,
14830 : sym->binding_label, &sym->declared_at, &gsym->where);
14831 4 : sym->binding_label = NULL;
14832 : }
14833 : }
14834 :
14835 :
14836 : /* Resolve an index expression. */
14837 :
14838 : static bool
14839 264411 : resolve_index_expr (gfc_expr *e)
14840 : {
14841 264411 : if (!gfc_resolve_expr (e))
14842 : return false;
14843 :
14844 264401 : if (!gfc_simplify_expr (e, 0))
14845 : return false;
14846 :
14847 264399 : if (!gfc_specification_expr (e))
14848 : return false;
14849 :
14850 : return true;
14851 : }
14852 :
14853 :
14854 : /* Resolve a charlen structure. */
14855 :
14856 : static bool
14857 102954 : resolve_charlen (gfc_charlen *cl)
14858 : {
14859 102954 : int k;
14860 102954 : bool saved_specification_expr;
14861 :
14862 102954 : if (cl->resolved)
14863 : return true;
14864 :
14865 94629 : cl->resolved = 1;
14866 94629 : saved_specification_expr = specification_expr;
14867 94629 : specification_expr = true;
14868 :
14869 94629 : if (cl->length_from_typespec)
14870 : {
14871 2111 : if (!gfc_resolve_expr (cl->length))
14872 : {
14873 1 : specification_expr = saved_specification_expr;
14874 1 : return false;
14875 : }
14876 :
14877 2110 : if (!gfc_simplify_expr (cl->length, 0))
14878 : {
14879 0 : specification_expr = saved_specification_expr;
14880 0 : return false;
14881 : }
14882 :
14883 : /* cl->length has been resolved. It should have an integer type. */
14884 2110 : if (cl->length
14885 2109 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
14886 : {
14887 4 : gfc_error ("Scalar INTEGER expression expected at %L",
14888 : &cl->length->where);
14889 4 : return false;
14890 : }
14891 : }
14892 : else
14893 : {
14894 92518 : if (!resolve_index_expr (cl->length))
14895 : {
14896 19 : specification_expr = saved_specification_expr;
14897 19 : return false;
14898 : }
14899 : }
14900 :
14901 : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
14902 : a negative value, the length of character entities declared is zero. */
14903 94605 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14904 56247 : && mpz_sgn (cl->length->value.integer) < 0)
14905 0 : gfc_replace_expr (cl->length,
14906 : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
14907 :
14908 : /* Check that the character length is not too large. */
14909 94605 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
14910 94605 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14911 56247 : && cl->length->ts.type == BT_INTEGER
14912 56247 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
14913 : {
14914 4 : gfc_error ("String length at %L is too large", &cl->length->where);
14915 4 : specification_expr = saved_specification_expr;
14916 4 : return false;
14917 : }
14918 :
14919 94601 : specification_expr = saved_specification_expr;
14920 94601 : return true;
14921 : }
14922 :
14923 :
14924 : /* Test for non-constant shape arrays. */
14925 :
14926 : static bool
14927 117083 : is_non_constant_shape_array (gfc_symbol *sym)
14928 : {
14929 117083 : gfc_expr *e;
14930 117083 : int i;
14931 117083 : bool not_constant;
14932 :
14933 117083 : not_constant = false;
14934 117083 : if (sym->as != NULL)
14935 : {
14936 : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
14937 : has not been simplified; parameter array references. Do the
14938 : simplification now. */
14939 154647 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
14940 : {
14941 89330 : if (i == GFC_MAX_DIMENSIONS)
14942 : break;
14943 :
14944 89328 : e = sym->as->lower[i];
14945 89328 : if (e && (!resolve_index_expr(e)
14946 86528 : || !gfc_is_constant_expr (e)))
14947 : not_constant = true;
14948 89328 : e = sym->as->upper[i];
14949 89328 : if (e && (!resolve_index_expr(e)
14950 85337 : || !gfc_is_constant_expr (e)))
14951 : not_constant = true;
14952 : }
14953 : }
14954 117083 : return not_constant;
14955 : }
14956 :
14957 : /* Given a symbol and an initialization expression, add code to initialize
14958 : the symbol to the function entry. */
14959 : static void
14960 2099 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
14961 : {
14962 2099 : gfc_expr *lval;
14963 2099 : gfc_code *init_st;
14964 2099 : gfc_namespace *ns = sym->ns;
14965 :
14966 2099 : if (sym->attr.function && sym->result == sym && IS_PDT (sym))
14967 : {
14968 41 : gfc_free_expr (init);
14969 41 : return;
14970 : }
14971 :
14972 : /* Search for the function namespace if this is a contained
14973 : function without an explicit result. */
14974 2058 : if (sym->attr.function && sym == sym->result
14975 303 : && sym->name != sym->ns->proc_name->name)
14976 : {
14977 302 : ns = ns->contained;
14978 1365 : for (;ns; ns = ns->sibling)
14979 1299 : if (strcmp (ns->proc_name->name, sym->name) == 0)
14980 : break;
14981 : }
14982 :
14983 2058 : if (ns == NULL)
14984 : {
14985 66 : gfc_free_expr (init);
14986 66 : return;
14987 : }
14988 :
14989 : /* Build an l-value expression for the result. */
14990 1992 : lval = gfc_lval_expr_from_sym (sym);
14991 :
14992 : /* Add the code at scope entry. */
14993 1992 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
14994 1992 : init_st->next = ns->code;
14995 1992 : ns->code = init_st;
14996 :
14997 : /* Assign the default initializer to the l-value. */
14998 1992 : init_st->loc = sym->declared_at;
14999 1992 : init_st->expr1 = lval;
15000 1992 : init_st->expr2 = init;
15001 : }
15002 :
15003 :
15004 : /* Whether or not we can generate a default initializer for a symbol. */
15005 :
15006 : static bool
15007 29785 : can_generate_init (gfc_symbol *sym)
15008 : {
15009 29785 : symbol_attribute *a;
15010 29785 : if (!sym)
15011 : return false;
15012 29785 : a = &sym->attr;
15013 :
15014 : /* These symbols should never have a default initialization. */
15015 48918 : return !(
15016 29785 : a->allocatable
15017 29785 : || a->external
15018 28633 : || a->pointer
15019 28633 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
15020 5636 : && (CLASS_DATA (sym)->attr.class_pointer
15021 3688 : || CLASS_DATA (sym)->attr.proc_pointer))
15022 26685 : || a->in_equivalence
15023 26564 : || a->in_common
15024 26517 : || a->data
15025 26339 : || sym->module
15026 22511 : || a->cray_pointee
15027 22449 : || a->cray_pointer
15028 22449 : || sym->assoc
15029 19802 : || (!a->referenced && !a->result)
15030 19133 : || (a->dummy && (a->intent != INTENT_OUT
15031 1081 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
15032 19133 : || (a->function && sym != sym->result)
15033 : );
15034 : }
15035 :
15036 :
15037 : /* Assign the default initializer to a derived type variable or result. */
15038 :
15039 : static void
15040 11430 : apply_default_init (gfc_symbol *sym)
15041 : {
15042 11430 : gfc_expr *init = NULL;
15043 :
15044 11430 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15045 : return;
15046 :
15047 11187 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
15048 10334 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15049 :
15050 11187 : if (init == NULL && sym->ts.type != BT_CLASS)
15051 : return;
15052 :
15053 1717 : build_init_assign (sym, init);
15054 1717 : sym->attr.referenced = 1;
15055 : }
15056 :
15057 :
15058 : /* Build an initializer for a local. Returns null if the symbol should not have
15059 : a default initialization. */
15060 :
15061 : static gfc_expr *
15062 203318 : build_default_init_expr (gfc_symbol *sym)
15063 : {
15064 : /* These symbols should never have a default initialization. */
15065 203318 : if (sym->attr.allocatable
15066 189710 : || sym->attr.external
15067 189710 : || sym->attr.dummy
15068 124679 : || sym->attr.pointer
15069 116583 : || sym->attr.in_equivalence
15070 114207 : || sym->attr.in_common
15071 111106 : || sym->attr.data
15072 108808 : || sym->module
15073 106328 : || sym->attr.cray_pointee
15074 106027 : || sym->attr.cray_pointer
15075 105725 : || sym->assoc)
15076 : return NULL;
15077 :
15078 : /* Get the appropriate init expression. */
15079 101035 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
15080 : }
15081 :
15082 : /* Add an initialization expression to a local variable. */
15083 : static void
15084 203318 : apply_default_init_local (gfc_symbol *sym)
15085 : {
15086 203318 : gfc_expr *init = NULL;
15087 :
15088 : /* The symbol should be a variable or a function return value. */
15089 203318 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15090 203318 : || (sym->attr.function && sym->result != sym))
15091 : return;
15092 :
15093 : /* Try to build the initializer expression. If we can't initialize
15094 : this symbol, then init will be NULL. */
15095 203318 : init = build_default_init_expr (sym);
15096 203318 : if (init == NULL)
15097 : return;
15098 :
15099 : /* For saved variables, we don't want to add an initializer at function
15100 : entry, so we just add a static initializer. Note that automatic variables
15101 : are stack allocated even with -fno-automatic; we have also to exclude
15102 : result variable, which are also nonstatic. */
15103 419 : if (!sym->attr.automatic
15104 419 : && (sym->attr.save || sym->ns->save_all
15105 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15106 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15107 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15108 : {
15109 : /* Don't clobber an existing initializer! */
15110 37 : gcc_assert (sym->value == NULL);
15111 37 : sym->value = init;
15112 37 : return;
15113 : }
15114 :
15115 382 : build_init_assign (sym, init);
15116 : }
15117 :
15118 :
15119 : /* Resolution of common features of flavors variable and procedure. */
15120 :
15121 : static bool
15122 962448 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15123 : {
15124 962448 : gfc_array_spec *as;
15125 :
15126 962448 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15127 19080 : && sym->ts.u.derived && CLASS_DATA (sym))
15128 19074 : as = CLASS_DATA (sym)->as;
15129 : else
15130 943374 : as = sym->as;
15131 :
15132 : /* Constraints on deferred shape variable. */
15133 962448 : if (as == NULL || as->type != AS_DEFERRED)
15134 : {
15135 938316 : bool pointer, allocatable, dimension;
15136 :
15137 938316 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15138 15927 : && sym->ts.u.derived && CLASS_DATA (sym))
15139 : {
15140 15921 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15141 15921 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15142 15921 : dimension = CLASS_DATA (sym)->attr.dimension;
15143 : }
15144 : else
15145 : {
15146 922395 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15147 922395 : allocatable = sym->attr.allocatable;
15148 922395 : dimension = sym->attr.dimension;
15149 : }
15150 :
15151 938316 : if (allocatable)
15152 : {
15153 7999 : if (dimension
15154 7999 : && as
15155 524 : && as->type != AS_ASSUMED_RANK
15156 5 : && !sym->attr.select_rank_temporary)
15157 : {
15158 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15159 : "shape or assumed rank", sym->name, &sym->declared_at);
15160 3 : return false;
15161 : }
15162 7996 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15163 : "%qs at %L may not be ALLOCATABLE",
15164 : sym->name, &sym->declared_at))
15165 : return false;
15166 : }
15167 :
15168 938312 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15169 : {
15170 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15171 : "assumed rank", sym->name, &sym->declared_at);
15172 4 : sym->error = 1;
15173 4 : return false;
15174 : }
15175 : }
15176 : else
15177 : {
15178 24132 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15179 4601 : && sym->ts.type != BT_CLASS && !sym->assoc)
15180 : {
15181 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15182 : sym->name, &sym->declared_at);
15183 3 : return false;
15184 : }
15185 : }
15186 :
15187 : /* Constraints on polymorphic variables. */
15188 962437 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15189 : {
15190 : /* F03:C502. */
15191 18414 : if (sym->attr.class_ok
15192 18358 : && sym->ts.u.derived
15193 18353 : && !sym->attr.select_type_temporary
15194 17270 : && !UNLIMITED_POLY (sym)
15195 14763 : && CLASS_DATA (sym)
15196 14762 : && CLASS_DATA (sym)->ts.u.derived
15197 33175 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15198 : {
15199 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15200 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15201 : &sym->declared_at);
15202 5 : return false;
15203 : }
15204 :
15205 : /* F03:C509. */
15206 : /* Assume that use associated symbols were checked in the module ns.
15207 : Class-variables that are associate-names are also something special
15208 : and excepted from the test. */
15209 18409 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15210 54 : && !sym->attr.select_type_temporary
15211 54 : && !sym->attr.select_rank_temporary)
15212 : {
15213 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15214 : "or pointer", sym->name, &sym->declared_at);
15215 54 : return false;
15216 : }
15217 : }
15218 :
15219 : return true;
15220 : }
15221 :
15222 :
15223 : /* Additional checks for symbols with flavor variable and derived
15224 : type. To be called from resolve_fl_variable. */
15225 :
15226 : static bool
15227 81425 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15228 : {
15229 81425 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15230 :
15231 : /* Check to see if a derived type is blocked from being host
15232 : associated by the presence of another class I symbol in the same
15233 : namespace. 14.6.1.3 of the standard and the discussion on
15234 : comp.lang.fortran. */
15235 81425 : if (sym->ts.u.derived
15236 81420 : && sym->ns != sym->ts.u.derived->ns
15237 46643 : && !sym->ts.u.derived->attr.use_assoc
15238 17201 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15239 : {
15240 16248 : gfc_symbol *s;
15241 16248 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15242 16248 : if (s && s->attr.generic)
15243 2 : s = gfc_find_dt_in_generic (s);
15244 16248 : if (s && !gfc_fl_struct (s->attr.flavor))
15245 : {
15246 2 : gfc_error ("The type %qs cannot be host associated at %L "
15247 : "because it is blocked by an incompatible object "
15248 : "of the same name declared at %L",
15249 2 : sym->ts.u.derived->name, &sym->declared_at,
15250 : &s->declared_at);
15251 2 : return false;
15252 : }
15253 : }
15254 :
15255 : /* 4th constraint in section 11.3: "If an object of a type for which
15256 : component-initialization is specified (R429) appears in the
15257 : specification-part of a module and does not have the ALLOCATABLE
15258 : or POINTER attribute, the object shall have the SAVE attribute."
15259 :
15260 : The check for initializers is performed with
15261 : gfc_has_default_initializer because gfc_default_initializer generates
15262 : a hidden default for allocatable components. */
15263 80766 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15264 18189 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15265 407 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15266 21 : && !sym->attr.pointer && !sym->attr.allocatable
15267 21 : && gfc_has_default_initializer (sym->ts.u.derived)
15268 81432 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15269 : "%qs at %L, needed due to the default "
15270 : "initialization", sym->name, &sym->declared_at))
15271 : return false;
15272 :
15273 : /* Assign default initializer. */
15274 81421 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15275 75283 : && (!no_init_flag
15276 58883 : || (sym->attr.intent == INTENT_OUT
15277 3225 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15278 19451 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15279 :
15280 : return true;
15281 : }
15282 :
15283 :
15284 : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15285 : except in the declaration of an entity or component that has the POINTER
15286 : or ALLOCATABLE attribute. */
15287 :
15288 : static bool
15289 1498932 : deferred_requirements (gfc_symbol *sym)
15290 : {
15291 1498932 : if (sym->ts.deferred
15292 7897 : && !(sym->attr.pointer
15293 2369 : || sym->attr.allocatable
15294 92 : || sym->attr.associate_var
15295 7 : || sym->attr.omp_udr_artificial_var))
15296 : {
15297 : /* If a function has a result variable, only check the variable. */
15298 7 : if (sym->result && sym->name != sym->result->name)
15299 : return true;
15300 :
15301 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15302 : "requires either the POINTER or ALLOCATABLE attribute",
15303 : sym->name, &sym->declared_at);
15304 6 : return false;
15305 : }
15306 : return true;
15307 : }
15308 :
15309 :
15310 : /* Resolve symbols with flavor variable. */
15311 :
15312 : static bool
15313 645836 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15314 : {
15315 645836 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15316 : "SAVE attribute");
15317 :
15318 645836 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15319 : return false;
15320 :
15321 : /* Set this flag to check that variables are parameters of all entries.
15322 : This check is effected by the call to gfc_resolve_expr through
15323 : is_non_constant_shape_array. */
15324 645776 : bool saved_specification_expr = specification_expr;
15325 645776 : specification_expr = true;
15326 :
15327 645776 : if (sym->ns->proc_name
15328 645681 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15329 640710 : || sym->ns->proc_name->attr.is_main_program)
15330 82076 : && !sym->attr.use_assoc
15331 78958 : && !sym->attr.allocatable
15332 73290 : && !sym->attr.pointer
15333 715435 : && is_non_constant_shape_array (sym))
15334 : {
15335 : /* F08:C541. The shape of an array defined in a main program or module
15336 : * needs to be constant. */
15337 3 : gfc_error ("The module or main program array %qs at %L must "
15338 : "have constant shape", sym->name, &sym->declared_at);
15339 3 : specification_expr = saved_specification_expr;
15340 3 : return false;
15341 : }
15342 :
15343 : /* Constraints on deferred type parameter. */
15344 645773 : if (!deferred_requirements (sym))
15345 : return false;
15346 :
15347 645769 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15348 : {
15349 : /* Make sure that character string variables with assumed length are
15350 : dummy arguments. */
15351 35838 : gfc_expr *e = NULL;
15352 :
15353 35838 : if (sym->ts.u.cl)
15354 35838 : e = sym->ts.u.cl->length;
15355 : else
15356 : return false;
15357 :
15358 35838 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15359 2578 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15360 2 : && !sym->attr.omp_udr_artificial_var)
15361 : {
15362 2 : gfc_error ("Entity with assumed character length at %L must be a "
15363 : "dummy argument or a PARAMETER", &sym->declared_at);
15364 2 : specification_expr = saved_specification_expr;
15365 2 : return false;
15366 : }
15367 :
15368 20733 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15369 : {
15370 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15371 1 : specification_expr = saved_specification_expr;
15372 1 : return false;
15373 : }
15374 :
15375 35835 : if (!gfc_is_constant_expr (e)
15376 35835 : && !(e->expr_type == EXPR_VARIABLE
15377 1388 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
15378 : {
15379 2184 : if (!sym->attr.use_assoc && sym->ns->proc_name
15380 1680 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15381 1679 : || sym->ns->proc_name->attr.is_main_program))
15382 : {
15383 3 : gfc_error ("%qs at %L must have constant character length "
15384 : "in this context", sym->name, &sym->declared_at);
15385 3 : specification_expr = saved_specification_expr;
15386 3 : return false;
15387 : }
15388 2181 : if (sym->attr.in_common)
15389 : {
15390 1 : gfc_error ("COMMON variable %qs at %L must have constant "
15391 : "character length", sym->name, &sym->declared_at);
15392 1 : specification_expr = saved_specification_expr;
15393 1 : return false;
15394 : }
15395 : }
15396 : }
15397 :
15398 645762 : if (sym->value == NULL && sym->attr.referenced
15399 205197 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
15400 203318 : apply_default_init_local (sym); /* Try to apply a default initialization. */
15401 :
15402 : /* Determine if the symbol may not have an initializer. */
15403 645762 : int no_init_flag = 0, automatic_flag = 0;
15404 645762 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
15405 169812 : || sym->attr.intrinsic || sym->attr.result)
15406 : no_init_flag = 1;
15407 137604 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
15408 172044 : && is_non_constant_shape_array (sym))
15409 : {
15410 1345 : no_init_flag = automatic_flag = 1;
15411 :
15412 : /* Also, they must not have the SAVE attribute.
15413 : SAVE_IMPLICIT is checked below. */
15414 1345 : if (sym->as && sym->attr.codimension)
15415 : {
15416 7 : int corank = sym->as->corank;
15417 7 : sym->as->corank = 0;
15418 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
15419 7 : sym->as->corank = corank;
15420 : }
15421 1345 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
15422 : {
15423 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15424 2 : specification_expr = saved_specification_expr;
15425 2 : return false;
15426 : }
15427 : }
15428 :
15429 : /* Ensure that any initializer is simplified. */
15430 645760 : if (sym->value)
15431 7959 : gfc_simplify_expr (sym->value, 1);
15432 :
15433 : /* Reject illegal initializers. */
15434 645760 : if (!sym->mark && sym->value)
15435 : {
15436 7959 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
15437 67 : && CLASS_DATA (sym)->attr.allocatable))
15438 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
15439 : sym->name, &sym->declared_at);
15440 7958 : else if (sym->attr.external)
15441 0 : gfc_error ("External %qs at %L cannot have an initializer",
15442 : sym->name, &sym->declared_at);
15443 7958 : else if (sym->attr.dummy)
15444 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
15445 : sym->name, &sym->declared_at);
15446 7955 : else if (sym->attr.intrinsic)
15447 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
15448 : sym->name, &sym->declared_at);
15449 7955 : else if (sym->attr.result)
15450 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
15451 : sym->name, &sym->declared_at);
15452 7954 : else if (automatic_flag)
15453 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
15454 : sym->name, &sym->declared_at);
15455 : else
15456 7949 : goto no_init_error;
15457 10 : specification_expr = saved_specification_expr;
15458 10 : return false;
15459 : }
15460 :
15461 637801 : no_init_error:
15462 645750 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
15463 : {
15464 81425 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
15465 81425 : specification_expr = saved_specification_expr;
15466 81425 : return res;
15467 : }
15468 :
15469 564325 : specification_expr = saved_specification_expr;
15470 564325 : return true;
15471 : }
15472 :
15473 :
15474 : /* Compare the dummy characteristics of a module procedure interface
15475 : declaration with the corresponding declaration in a submodule. */
15476 : static gfc_formal_arglist *new_formal;
15477 : static char errmsg[200];
15478 :
15479 : static void
15480 1298 : compare_fsyms (gfc_symbol *sym)
15481 : {
15482 1298 : gfc_symbol *fsym;
15483 :
15484 1298 : if (sym == NULL || new_formal == NULL)
15485 : return;
15486 :
15487 1298 : fsym = new_formal->sym;
15488 :
15489 1298 : if (sym == fsym)
15490 : return;
15491 :
15492 1274 : if (strcmp (sym->name, fsym->name) == 0)
15493 : {
15494 486 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
15495 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
15496 : }
15497 : }
15498 :
15499 :
15500 : /* Resolve a procedure. */
15501 :
15502 : static bool
15503 472499 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
15504 : {
15505 472499 : gfc_formal_arglist *arg;
15506 472499 : bool allocatable_or_pointer = false;
15507 :
15508 472499 : if (sym->attr.function
15509 472499 : && !resolve_fl_var_and_proc (sym, mp_flag))
15510 : return false;
15511 :
15512 : /* Constraints on deferred type parameter. */
15513 472489 : if (!deferred_requirements (sym))
15514 : return false;
15515 :
15516 472488 : if (sym->ts.type == BT_CHARACTER)
15517 : {
15518 11564 : gfc_charlen *cl = sym->ts.u.cl;
15519 :
15520 7470 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
15521 12734 : && !resolve_charlen (cl))
15522 : return false;
15523 :
15524 11563 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
15525 10394 : && sym->attr.proc == PROC_ST_FUNCTION)
15526 : {
15527 0 : gfc_error ("Character-valued statement function %qs at %L must "
15528 : "have constant length", sym->name, &sym->declared_at);
15529 0 : return false;
15530 : }
15531 : }
15532 :
15533 : /* Ensure that derived type for are not of a private type. Internal
15534 : module procedures are excluded by 2.2.3.3 - i.e., they are not
15535 : externally accessible and can access all the objects accessible in
15536 : the host. */
15537 108834 : if (!(sym->ns->parent && sym->ns->parent->proc_name
15538 108834 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15539 557221 : && gfc_check_symbol_access (sym))
15540 : {
15541 441457 : gfc_interface *iface;
15542 :
15543 931625 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
15544 : {
15545 490169 : if (arg->sym
15546 490028 : && arg->sym->ts.type == BT_DERIVED
15547 42812 : && arg->sym->ts.u.derived
15548 42812 : && !arg->sym->ts.u.derived->attr.use_assoc
15549 4382 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15550 490178 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
15551 : "and cannot be a dummy argument"
15552 : " of %qs, which is PUBLIC at %L",
15553 9 : arg->sym->name, sym->name,
15554 : &sym->declared_at))
15555 : {
15556 : /* Stop this message from recurring. */
15557 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15558 1 : return false;
15559 : }
15560 : }
15561 :
15562 : /* PUBLIC interfaces may expose PRIVATE procedures that take types
15563 : PRIVATE to the containing module. */
15564 628441 : for (iface = sym->generic; iface; iface = iface->next)
15565 : {
15566 436713 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
15567 : {
15568 249728 : if (arg->sym
15569 249696 : && arg->sym->ts.type == BT_DERIVED
15570 8010 : && !arg->sym->ts.u.derived->attr.use_assoc
15571 244 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15572 249732 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
15573 : "PUBLIC interface %qs at %L "
15574 : "takes dummy arguments of %qs which "
15575 : "is PRIVATE", iface->sym->name,
15576 4 : sym->name, &iface->sym->declared_at,
15577 4 : gfc_typename(&arg->sym->ts)))
15578 : {
15579 : /* Stop this message from recurring. */
15580 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15581 1 : return false;
15582 : }
15583 : }
15584 : }
15585 : }
15586 :
15587 472485 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
15588 67 : && !sym->attr.proc_pointer)
15589 : {
15590 2 : gfc_error ("Function %qs at %L cannot have an initializer",
15591 : sym->name, &sym->declared_at);
15592 :
15593 : /* Make sure no second error is issued for this. */
15594 2 : sym->value->error = 1;
15595 2 : return false;
15596 : }
15597 :
15598 : /* An external symbol may not have an initializer because it is taken to be
15599 : a procedure. Exception: Procedure Pointers. */
15600 472483 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
15601 : {
15602 0 : gfc_error ("External object %qs at %L may not have an initializer",
15603 : sym->name, &sym->declared_at);
15604 0 : return false;
15605 : }
15606 :
15607 : /* An elemental function is required to return a scalar 12.7.1 */
15608 472483 : if (sym->attr.elemental && sym->attr.function
15609 86257 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15610 2 : && CLASS_DATA (sym)->as)))
15611 : {
15612 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
15613 : "result", sym->name, &sym->declared_at);
15614 : /* Reset so that the error only occurs once. */
15615 3 : sym->attr.elemental = 0;
15616 3 : return false;
15617 : }
15618 :
15619 472480 : if (sym->attr.proc == PROC_ST_FUNCTION
15620 221 : && (sym->attr.allocatable || sym->attr.pointer))
15621 : {
15622 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
15623 : "allocatable attribute", sym->name, &sym->declared_at);
15624 2 : return false;
15625 : }
15626 :
15627 : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
15628 : char-len-param shall not be array-valued, pointer-valued, recursive
15629 : or pure. ....snip... A character value of * may only be used in the
15630 : following ways: (i) Dummy arg of procedure - dummy associates with
15631 : actual length; (ii) To declare a named constant; or (iii) External
15632 : function - but length must be declared in calling scoping unit. */
15633 472478 : if (sym->attr.function
15634 316593 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
15635 6556 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
15636 : {
15637 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
15638 178 : || (sym->attr.recursive) || (sym->attr.pure))
15639 : {
15640 4 : if (sym->as && sym->as->rank)
15641 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15642 : "array-valued", sym->name, &sym->declared_at);
15643 :
15644 4 : if (sym->attr.pointer)
15645 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15646 : "pointer-valued", sym->name, &sym->declared_at);
15647 :
15648 4 : if (sym->attr.pure)
15649 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15650 : "pure", sym->name, &sym->declared_at);
15651 :
15652 4 : if (sym->attr.recursive)
15653 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15654 : "recursive", sym->name, &sym->declared_at);
15655 :
15656 4 : return false;
15657 : }
15658 :
15659 : /* Appendix B.2 of the standard. Contained functions give an
15660 : error anyway. Deferred character length is an F2003 feature.
15661 : Don't warn on intrinsic conversion functions, which start
15662 : with two underscores. */
15663 176 : if (!sym->attr.contained && !sym->ts.deferred
15664 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
15665 172 : gfc_notify_std (GFC_STD_F95_OBS,
15666 : "CHARACTER(*) function %qs at %L",
15667 : sym->name, &sym->declared_at);
15668 : }
15669 :
15670 : /* F2008, C1218. */
15671 472474 : if (sym->attr.elemental)
15672 : {
15673 89475 : if (sym->attr.proc_pointer)
15674 : {
15675 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
15676 : : sym->name);
15677 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
15678 : name, &sym->declared_at);
15679 7 : return false;
15680 : }
15681 89468 : if (sym->attr.dummy)
15682 : {
15683 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
15684 : sym->name, &sym->declared_at);
15685 3 : return false;
15686 : }
15687 : }
15688 :
15689 : /* F2018, C15100: "The result of an elemental function shall be scalar,
15690 : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
15691 : pointer is tested and caught elsewhere. */
15692 472464 : if (sym->result)
15693 265916 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
15694 265916 : && CLASS_DATA (sym->result) ?
15695 1661 : (CLASS_DATA (sym->result)->attr.allocatable
15696 1661 : || CLASS_DATA (sym->result)->attr.pointer) :
15697 264255 : (sym->result->attr.allocatable
15698 264255 : || sym->result->attr.pointer);
15699 :
15700 472464 : if (sym->attr.elemental && sym->result
15701 85882 : && allocatable_or_pointer)
15702 : {
15703 4 : gfc_error ("Function result variable %qs at %L of elemental "
15704 : "function %qs shall not have an ALLOCATABLE or POINTER "
15705 : "attribute", sym->result->name,
15706 : &sym->result->declared_at, sym->name);
15707 4 : return false;
15708 : }
15709 :
15710 : /* F2018:C1585: "The function result of a pure function shall not be both
15711 : polymorphic and allocatable, or have a polymorphic allocatable ultimate
15712 : component." */
15713 472460 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
15714 : {
15715 2441 : if (sym->ts.type == BT_CLASS
15716 5 : && sym->attr.class_ok
15717 4 : && CLASS_DATA (sym->result)
15718 4 : && CLASS_DATA (sym->result)->attr.allocatable)
15719 : {
15720 4 : gfc_error ("Result variable %qs of pure function at %L is "
15721 : "polymorphic allocatable",
15722 : sym->result->name, &sym->result->declared_at);
15723 4 : return false;
15724 : }
15725 :
15726 2437 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
15727 : {
15728 : gfc_component *c = sym->ts.u.derived->components;
15729 4419 : for (; c; c = c->next)
15730 2291 : if (c->ts.type == BT_CLASS
15731 2 : && CLASS_DATA (c)
15732 2 : && CLASS_DATA (c)->attr.allocatable)
15733 : {
15734 2 : gfc_error ("Result variable %qs of pure function at %L has "
15735 : "polymorphic allocatable component %qs",
15736 : sym->result->name, &sym->result->declared_at,
15737 : c->name);
15738 2 : return false;
15739 : }
15740 : }
15741 : }
15742 :
15743 472454 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
15744 : {
15745 6584 : gfc_formal_arglist *curr_arg;
15746 6584 : int has_non_interop_arg = 0;
15747 :
15748 6584 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15749 6584 : sym->common_block))
15750 : {
15751 : /* Clear these to prevent looking at them again if there was an
15752 : error. */
15753 2 : sym->attr.is_bind_c = 0;
15754 2 : sym->attr.is_c_interop = 0;
15755 2 : sym->ts.is_c_interop = 0;
15756 : }
15757 : else
15758 : {
15759 : /* So far, no errors have been found. */
15760 6582 : sym->attr.is_c_interop = 1;
15761 6582 : sym->ts.is_c_interop = 1;
15762 : }
15763 :
15764 6584 : curr_arg = gfc_sym_get_dummy_args (sym);
15765 29585 : while (curr_arg != NULL)
15766 : {
15767 : /* Skip implicitly typed dummy args here. */
15768 16417 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
15769 16361 : if (!gfc_verify_c_interop_param (curr_arg->sym))
15770 : /* If something is found to fail, record the fact so we
15771 : can mark the symbol for the procedure as not being
15772 : BIND(C) to try and prevent multiple errors being
15773 : reported. */
15774 16417 : has_non_interop_arg = 1;
15775 :
15776 16417 : curr_arg = curr_arg->next;
15777 : }
15778 :
15779 : /* See if any of the arguments were not interoperable and if so, clear
15780 : the procedure symbol to prevent duplicate error messages. */
15781 6584 : if (has_non_interop_arg != 0)
15782 : {
15783 128 : sym->attr.is_c_interop = 0;
15784 128 : sym->ts.is_c_interop = 0;
15785 128 : sym->attr.is_bind_c = 0;
15786 : }
15787 : }
15788 :
15789 472454 : if (!sym->attr.proc_pointer)
15790 : {
15791 471408 : if (sym->attr.save == SAVE_EXPLICIT)
15792 : {
15793 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
15794 : "in %qs at %L", sym->name, &sym->declared_at);
15795 5 : return false;
15796 : }
15797 471403 : if (sym->attr.intent)
15798 : {
15799 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
15800 : "in %qs at %L", sym->name, &sym->declared_at);
15801 1 : return false;
15802 : }
15803 471402 : if (sym->attr.subroutine && sym->attr.result)
15804 : {
15805 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
15806 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
15807 2 : return false;
15808 : }
15809 471400 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
15810 134606 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
15811 134603 : || sym->attr.contained))
15812 : {
15813 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
15814 : "in %qs at %L", sym->name, &sym->declared_at);
15815 3 : return false;
15816 : }
15817 471397 : if (strcmp ("ppr@", sym->name) == 0)
15818 : {
15819 0 : gfc_error ("Procedure pointer result %qs at %L "
15820 : "is missing the pointer attribute",
15821 0 : sym->ns->proc_name->name, &sym->declared_at);
15822 0 : return false;
15823 : }
15824 : }
15825 :
15826 : /* Assume that a procedure whose body is not known has references
15827 : to external arrays. */
15828 472443 : if (sym->attr.if_source != IFSRC_DECL)
15829 325183 : sym->attr.array_outer_dependency = 1;
15830 :
15831 : /* Compare the characteristics of a module procedure with the
15832 : interface declaration. Ideally this would be done with
15833 : gfc_compare_interfaces but, at present, the formal interface
15834 : cannot be copied to the ts.interface. */
15835 472443 : if (sym->attr.module_procedure
15836 1493 : && sym->attr.if_source == IFSRC_DECL)
15837 : {
15838 622 : gfc_symbol *iface;
15839 622 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
15840 622 : char *module_name;
15841 622 : char *submodule_name;
15842 622 : strcpy (name, sym->ns->proc_name->name);
15843 622 : module_name = strtok (name, ".");
15844 622 : submodule_name = strtok (NULL, ".");
15845 :
15846 622 : iface = sym->tlink;
15847 622 : sym->tlink = NULL;
15848 :
15849 : /* Make sure that the result uses the correct charlen for deferred
15850 : length results. */
15851 622 : if (iface && sym->result
15852 182 : && iface->ts.type == BT_CHARACTER
15853 19 : && iface->ts.deferred)
15854 6 : sym->result->ts.u.cl = iface->ts.u.cl;
15855 :
15856 6 : if (iface == NULL)
15857 195 : goto check_formal;
15858 :
15859 : /* Check the procedure characteristics. */
15860 427 : if (sym->attr.elemental != iface->attr.elemental)
15861 : {
15862 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
15863 : "PROCEDURE at %L and its interface in %s",
15864 : &sym->declared_at, module_name);
15865 10 : return false;
15866 : }
15867 :
15868 426 : if (sym->attr.pure != iface->attr.pure)
15869 : {
15870 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
15871 : "PROCEDURE at %L and its interface in %s",
15872 : &sym->declared_at, module_name);
15873 2 : return false;
15874 : }
15875 :
15876 424 : if (sym->attr.recursive != iface->attr.recursive)
15877 : {
15878 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
15879 : "PROCEDURE at %L and its interface in %s",
15880 : &sym->declared_at, module_name);
15881 2 : return false;
15882 : }
15883 :
15884 : /* Check the result characteristics. */
15885 422 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
15886 : {
15887 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
15888 : "in MODULE %qs and the declaration at %L in "
15889 : "(SUB)MODULE %qs",
15890 : errmsg, module_name, &sym->declared_at,
15891 : submodule_name ? submodule_name : module_name);
15892 5 : return false;
15893 : }
15894 :
15895 417 : check_formal:
15896 : /* Check the characteristics of the formal arguments. */
15897 612 : if (sym->formal && sym->formal_ns)
15898 : {
15899 1192 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
15900 : {
15901 684 : new_formal = arg;
15902 684 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
15903 : }
15904 : }
15905 : }
15906 :
15907 : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
15908 : BIND(C) attribute. */
15909 472433 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
15910 : {
15911 1 : gfc_error ("Interface of %qs at %L must be explicit",
15912 : sym->name, &sym->declared_at);
15913 1 : return false;
15914 : }
15915 :
15916 : return true;
15917 : }
15918 :
15919 :
15920 : /* Resolve a list of finalizer procedures. That is, after they have hopefully
15921 : been defined and we now know their defined arguments, check that they fulfill
15922 : the requirements of the standard for procedures used as finalizers. */
15923 :
15924 : static bool
15925 110745 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
15926 : {
15927 110745 : gfc_finalizer *list, *pdt_finalizers = NULL;
15928 110745 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
15929 110745 : bool result = true;
15930 110745 : bool seen_scalar = false;
15931 110745 : gfc_symbol *vtab;
15932 110745 : gfc_component *c;
15933 110745 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
15934 :
15935 110745 : if (parent)
15936 15349 : gfc_resolve_finalizers (parent, finalizable);
15937 :
15938 : /* Ensure that derived-type components have a their finalizers resolved. */
15939 110745 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
15940 348636 : for (c = derived->components; c; c = c->next)
15941 237891 : if (c->ts.type == BT_DERIVED
15942 66674 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
15943 : {
15944 8173 : bool has_final2 = false;
15945 8173 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
15946 0 : return false; /* Error. */
15947 8173 : has_final = has_final || has_final2;
15948 : }
15949 : /* Return early if not finalizable. */
15950 110745 : if (!has_final)
15951 : {
15952 108240 : if (finalizable)
15953 8085 : *finalizable = false;
15954 108240 : return true;
15955 : }
15956 :
15957 : /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of
15958 : the template. If the finalizers field has the same value, it needs to be
15959 : supplied with finalizers of the same pdt_type. */
15960 2505 : if (derived->attr.pdt_type
15961 30 : && derived->template_sym
15962 12 : && derived->template_sym->f2k_derived
15963 12 : && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers)
15964 2517 : && derived->f2k_derived->finalizers == pdt_finalizers)
15965 : {
15966 12 : gfc_finalizer *tmp = NULL;
15967 12 : derived->f2k_derived->finalizers = NULL;
15968 12 : prev_link = &derived->f2k_derived->finalizers;
15969 48 : for (list = pdt_finalizers; list; list = list->next)
15970 : {
15971 36 : gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym);
15972 36 : if (args->sym
15973 36 : && args->sym->ts.type == BT_DERIVED
15974 36 : && args->sym->ts.u.derived
15975 36 : && !strcmp (args->sym->ts.u.derived->name, derived->name))
15976 : {
15977 18 : tmp = gfc_get_finalizer ();
15978 18 : *tmp = *list;
15979 18 : tmp->next = NULL;
15980 18 : if (*prev_link)
15981 : {
15982 6 : (*prev_link)->next = tmp;
15983 6 : prev_link = &tmp;
15984 : }
15985 : else
15986 12 : *prev_link = tmp;
15987 18 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
15988 : }
15989 : }
15990 : }
15991 :
15992 : /* Walk over the list of finalizer-procedures, check them, and if any one
15993 : does not fit in with the standard's definition, print an error and remove
15994 : it from the list. */
15995 2505 : prev_link = &derived->f2k_derived->finalizers;
15996 5170 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
15997 : {
15998 2665 : gfc_formal_arglist *dummy_args;
15999 2665 : gfc_symbol* arg;
16000 2665 : gfc_finalizer* i;
16001 2665 : int my_rank;
16002 :
16003 : /* Skip this finalizer if we already resolved it. */
16004 2665 : if (list->proc_tree)
16005 : {
16006 2138 : if (list->proc_tree->n.sym->formal->sym->as == NULL
16007 584 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
16008 1554 : seen_scalar = true;
16009 2138 : prev_link = &(list->next);
16010 2138 : continue;
16011 : }
16012 :
16013 : /* Check this exists and is a SUBROUTINE. */
16014 527 : if (!list->proc_sym->attr.subroutine)
16015 : {
16016 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
16017 : list->proc_sym->name, &list->where);
16018 3 : goto error;
16019 : }
16020 :
16021 : /* We should have exactly one argument. */
16022 524 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
16023 524 : if (!dummy_args || dummy_args->next)
16024 : {
16025 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
16026 : &list->where);
16027 2 : goto error;
16028 : }
16029 522 : arg = dummy_args->sym;
16030 :
16031 522 : if (!arg)
16032 : {
16033 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16034 1 : &list->proc_sym->declared_at, derived->name);
16035 1 : goto error;
16036 : }
16037 :
16038 521 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
16039 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
16040 : {
16041 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
16042 : "be the only finalizer with the same kind/type "
16043 : "(F2018: C790)", &list->where);
16044 0 : goto error;
16045 : }
16046 :
16047 : /* This argument must be of our type. */
16048 521 : if (!derived->attr.pdt_template
16049 521 : && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived))
16050 : {
16051 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16052 : &arg->declared_at, derived->name);
16053 2 : goto error;
16054 : }
16055 :
16056 : /* It must neither be a pointer nor allocatable nor optional. */
16057 519 : if (arg->attr.pointer)
16058 : {
16059 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
16060 : &arg->declared_at);
16061 1 : goto error;
16062 : }
16063 518 : if (arg->attr.allocatable)
16064 : {
16065 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16066 : " ALLOCATABLE", &arg->declared_at);
16067 1 : goto error;
16068 : }
16069 517 : if (arg->attr.optional)
16070 : {
16071 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
16072 : &arg->declared_at);
16073 1 : goto error;
16074 : }
16075 :
16076 : /* It must not be INTENT(OUT). */
16077 516 : if (arg->attr.intent == INTENT_OUT)
16078 : {
16079 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16080 : " INTENT(OUT)", &arg->declared_at);
16081 1 : goto error;
16082 : }
16083 :
16084 : /* Warn if the procedure is non-scalar and not assumed shape. */
16085 515 : if (warn_surprising && arg->as && arg->as->rank != 0
16086 3 : && arg->as->type != AS_ASSUMED_SHAPE)
16087 2 : gfc_warning (OPT_Wsurprising,
16088 : "Non-scalar FINAL procedure at %L should have assumed"
16089 : " shape argument", &arg->declared_at);
16090 :
16091 : /* Check that it does not match in kind and rank with a FINAL procedure
16092 : defined earlier. To really loop over the *earlier* declarations,
16093 : we need to walk the tail of the list as new ones were pushed at the
16094 : front. */
16095 : /* TODO: Handle kind parameters once they are implemented. */
16096 515 : my_rank = (arg->as ? arg->as->rank : 0);
16097 610 : for (i = list->next; i; i = i->next)
16098 : {
16099 97 : gfc_formal_arglist *dummy_args;
16100 :
16101 : /* Argument list might be empty; that is an error signalled earlier,
16102 : but we nevertheless continued resolving. */
16103 97 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
16104 97 : if (dummy_args && !derived->attr.pdt_template)
16105 : {
16106 95 : gfc_symbol* i_arg = dummy_args->sym;
16107 95 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
16108 95 : if (i_rank == my_rank)
16109 : {
16110 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
16111 : " rank (%d) as %qs",
16112 2 : list->proc_sym->name, &list->where, my_rank,
16113 2 : i->proc_sym->name);
16114 2 : goto error;
16115 : }
16116 : }
16117 : }
16118 :
16119 : /* Is this the/a scalar finalizer procedure? */
16120 513 : if (my_rank == 0)
16121 387 : seen_scalar = true;
16122 :
16123 : /* Find the symtree for this procedure. */
16124 513 : gcc_assert (!list->proc_tree);
16125 513 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16126 :
16127 513 : prev_link = &list->next;
16128 513 : continue;
16129 :
16130 : /* Remove wrong nodes immediately from the list so we don't risk any
16131 : troubles in the future when they might fail later expectations. */
16132 14 : error:
16133 14 : i = list;
16134 14 : *prev_link = list->next;
16135 14 : gfc_free_finalizer (i);
16136 14 : result = false;
16137 513 : }
16138 :
16139 2505 : if (result == false)
16140 : return false;
16141 :
16142 : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16143 : were nodes in the list, must have been for arrays. It is surely a good
16144 : idea to have a scalar version there if there's something to finalize. */
16145 2501 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16146 1 : gfc_warning (OPT_Wsurprising,
16147 : "Only array FINAL procedures declared for derived type %qs"
16148 : " defined at %L, suggest also scalar one unless an assumed"
16149 : " rank finalizer has been declared",
16150 : derived->name, &derived->declared_at);
16151 :
16152 2501 : if (!derived->attr.pdt_template)
16153 : {
16154 2477 : vtab = gfc_find_derived_vtab (derived);
16155 2477 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16156 2477 : if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym)
16157 2477 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16158 : }
16159 :
16160 2501 : if (finalizable)
16161 640 : *finalizable = true;
16162 :
16163 : return true;
16164 : }
16165 :
16166 :
16167 : static gfc_symbol * containing_dt;
16168 :
16169 : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16170 : arguments whose declared types are PDT instances only transmit the PASS arg
16171 : if they match the enclosing derived type. */
16172 :
16173 : static bool
16174 1460 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16175 : {
16176 1460 : gfc_formal_arglist *dummy_args;
16177 1460 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16178 : {
16179 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16180 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16181 126 : dummy_args = dummy_args->next;
16182 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16183 532 : if (dummy_args->sym->ts.type == BT_CLASS
16184 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16185 : containing_dt->name))
16186 : return true;
16187 : }
16188 : return false;
16189 : }
16190 :
16191 :
16192 : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16193 :
16194 : static bool
16195 732 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16196 : const char* generic_name, locus where)
16197 : {
16198 732 : gfc_symbol *sym1, *sym2;
16199 732 : const char *pass1, *pass2;
16200 732 : gfc_formal_arglist *dummy_args;
16201 :
16202 732 : gcc_assert (t1->specific && t2->specific);
16203 732 : gcc_assert (!t1->specific->is_generic);
16204 732 : gcc_assert (!t2->specific->is_generic);
16205 732 : gcc_assert (t1->is_operator == t2->is_operator);
16206 :
16207 732 : sym1 = t1->specific->u.specific->n.sym;
16208 732 : sym2 = t2->specific->u.specific->n.sym;
16209 :
16210 732 : if (sym1 == sym2)
16211 : return true;
16212 :
16213 : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16214 732 : if (sym1->attr.subroutine != sym2->attr.subroutine
16215 730 : || sym1->attr.function != sym2->attr.function)
16216 : {
16217 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16218 : " GENERIC %qs at %L",
16219 : sym1->name, sym2->name, generic_name, &where);
16220 2 : return false;
16221 : }
16222 :
16223 : /* Determine PASS arguments. */
16224 730 : if (t1->specific->nopass)
16225 : pass1 = NULL;
16226 679 : else if (t1->specific->pass_arg)
16227 : pass1 = t1->specific->pass_arg;
16228 : else
16229 : {
16230 420 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16231 420 : if (dummy_args)
16232 419 : pass1 = dummy_args->sym->name;
16233 : else
16234 : pass1 = NULL;
16235 : }
16236 730 : if (t2->specific->nopass)
16237 : pass2 = NULL;
16238 678 : else if (t2->specific->pass_arg)
16239 : pass2 = t2->specific->pass_arg;
16240 : else
16241 : {
16242 541 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16243 541 : if (dummy_args)
16244 540 : pass2 = dummy_args->sym->name;
16245 : else
16246 : pass2 = NULL;
16247 : }
16248 :
16249 : /* Care must be taken with pdt types and templates because the declared type
16250 : of the argument that is not 'no_pass' need not be the same as the
16251 : containing derived type. If this is the case, subject the argument to
16252 : the full interface check, even though it cannot be used in the type
16253 : bound context. */
16254 730 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16255 730 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16256 :
16257 730 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16258 730 : pass1 = pass2 = NULL;
16259 :
16260 : /* Compare the interfaces. */
16261 730 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16262 : NULL, 0, pass1, pass2))
16263 : {
16264 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16265 : sym1->name, sym2->name, generic_name, &where);
16266 8 : return false;
16267 : }
16268 :
16269 : return true;
16270 : }
16271 :
16272 :
16273 : /* Worker function for resolving a generic procedure binding; this is used to
16274 : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16275 :
16276 : The difference between those cases is finding possible inherited bindings
16277 : that are overridden, as one has to look for them in tb_sym_root,
16278 : tb_uop_root or tb_op, respectively. Thus the caller must already find
16279 : the super-type and set p->overridden correctly. */
16280 :
16281 : static bool
16282 2296 : resolve_tb_generic_targets (gfc_symbol* super_type,
16283 : gfc_typebound_proc* p, const char* name)
16284 : {
16285 2296 : gfc_tbp_generic* target;
16286 2296 : gfc_symtree* first_target;
16287 2296 : gfc_symtree* inherited;
16288 :
16289 2296 : gcc_assert (p && p->is_generic);
16290 :
16291 : /* Try to find the specific bindings for the symtrees in our target-list. */
16292 2296 : gcc_assert (p->u.generic);
16293 5172 : for (target = p->u.generic; target; target = target->next)
16294 2893 : if (!target->specific)
16295 : {
16296 2514 : gfc_typebound_proc* overridden_tbp;
16297 2514 : gfc_tbp_generic* g;
16298 2514 : const char* target_name;
16299 :
16300 2514 : target_name = target->specific_st->name;
16301 :
16302 : /* Defined for this type directly. */
16303 2514 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16304 : {
16305 2505 : target->specific = target->specific_st->n.tb;
16306 2505 : goto specific_found;
16307 : }
16308 :
16309 : /* Look for an inherited specific binding. */
16310 9 : if (super_type)
16311 : {
16312 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16313 : true, NULL);
16314 :
16315 5 : if (inherited)
16316 : {
16317 5 : gcc_assert (inherited->n.tb);
16318 5 : target->specific = inherited->n.tb;
16319 5 : goto specific_found;
16320 : }
16321 : }
16322 :
16323 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16324 : " at %L", target_name, name, &p->where);
16325 4 : return false;
16326 :
16327 : /* Once we've found the specific binding, check it is not ambiguous with
16328 : other specifics already found or inherited for the same GENERIC. */
16329 2510 : specific_found:
16330 2510 : gcc_assert (target->specific);
16331 :
16332 : /* This must really be a specific binding! */
16333 2510 : if (target->specific->is_generic)
16334 : {
16335 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16336 : " %qs is GENERIC, too", name, &p->where, target_name);
16337 3 : return false;
16338 : }
16339 :
16340 : /* Check those already resolved on this type directly. */
16341 6428 : for (g = p->u.generic; g; g = g->next)
16342 1428 : if (g != target && g->specific
16343 4642 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16344 : return false;
16345 :
16346 : /* Check for ambiguity with inherited specific targets. */
16347 2516 : for (overridden_tbp = p->overridden; overridden_tbp;
16348 16 : overridden_tbp = overridden_tbp->overridden)
16349 19 : if (overridden_tbp->is_generic)
16350 : {
16351 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16352 : {
16353 18 : gcc_assert (g->specific);
16354 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16355 : return false;
16356 : }
16357 : }
16358 : }
16359 :
16360 : /* If we attempt to "overwrite" a specific binding, this is an error. */
16361 2279 : if (p->overridden && !p->overridden->is_generic)
16362 : {
16363 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16364 : " the same name", name, &p->where);
16365 1 : return false;
16366 : }
16367 :
16368 : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16369 : all must have the same attributes here. */
16370 2278 : first_target = p->u.generic->specific->u.specific;
16371 2278 : gcc_assert (first_target);
16372 2278 : p->subroutine = first_target->n.sym->attr.subroutine;
16373 2278 : p->function = first_target->n.sym->attr.function;
16374 :
16375 2278 : return true;
16376 : }
16377 :
16378 :
16379 : /* Resolve a GENERIC procedure binding for a derived type. */
16380 :
16381 : static bool
16382 1202 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
16383 : {
16384 1202 : gfc_symbol* super_type;
16385 :
16386 : /* Find the overridden binding if any. */
16387 1202 : st->n.tb->overridden = NULL;
16388 1202 : super_type = gfc_get_derived_super_type (derived);
16389 1202 : if (super_type)
16390 : {
16391 40 : gfc_symtree* overridden;
16392 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
16393 : true, NULL);
16394 :
16395 40 : if (overridden && overridden->n.tb)
16396 21 : st->n.tb->overridden = overridden->n.tb;
16397 : }
16398 :
16399 : /* Resolve using worker function. */
16400 1202 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
16401 : }
16402 :
16403 :
16404 : /* Retrieve the target-procedure of an operator binding and do some checks in
16405 : common for intrinsic and user-defined type-bound operators. */
16406 :
16407 : static gfc_symbol*
16408 1166 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
16409 : {
16410 1166 : gfc_symbol* target_proc;
16411 :
16412 1166 : gcc_assert (target->specific && !target->specific->is_generic);
16413 1166 : target_proc = target->specific->u.specific->n.sym;
16414 1166 : gcc_assert (target_proc);
16415 :
16416 : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
16417 1166 : if (target->specific->nopass)
16418 : {
16419 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
16420 2 : return NULL;
16421 : }
16422 :
16423 : return target_proc;
16424 : }
16425 :
16426 :
16427 : /* Resolve a type-bound intrinsic operator. */
16428 :
16429 : static bool
16430 1035 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
16431 : gfc_typebound_proc* p)
16432 : {
16433 1035 : gfc_symbol* super_type;
16434 1035 : gfc_tbp_generic* target;
16435 :
16436 : /* If there's already an error here, do nothing (but don't fail again). */
16437 1035 : if (p->error)
16438 : return true;
16439 :
16440 : /* Operators should always be GENERIC bindings. */
16441 1035 : gcc_assert (p->is_generic);
16442 :
16443 : /* Look for an overridden binding. */
16444 1035 : super_type = gfc_get_derived_super_type (derived);
16445 1035 : if (super_type && super_type->f2k_derived)
16446 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
16447 : op, true, NULL);
16448 : else
16449 1034 : p->overridden = NULL;
16450 :
16451 : /* Resolve general GENERIC properties using worker function. */
16452 1035 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
16453 1 : goto error;
16454 :
16455 : /* Check the targets to be procedures of correct interface. */
16456 2115 : for (target = p->u.generic; target; target = target->next)
16457 : {
16458 1106 : gfc_symbol* target_proc;
16459 :
16460 1106 : target_proc = get_checked_tb_operator_target (target, p->where);
16461 1106 : if (!target_proc)
16462 1 : goto error;
16463 :
16464 1105 : if (!gfc_check_operator_interface (target_proc, op, p->where))
16465 3 : goto error;
16466 :
16467 : /* Add target to non-typebound operator list. */
16468 1102 : if (!target->specific->deferred && !derived->attr.use_assoc
16469 385 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
16470 : {
16471 383 : gfc_interface *head, *intr;
16472 :
16473 : /* Preempt 'gfc_check_new_interface' for submodules, where the
16474 : mechanism for handling module procedures winds up resolving
16475 : operator interfaces twice and would otherwise cause an error.
16476 : Likewise, new instances of PDTs can cause the operator inter-
16477 : faces to be resolved multiple times. */
16478 455 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
16479 91 : if (intr->sym == target_proc
16480 21 : && (target_proc->attr.used_in_submodule
16481 4 : || derived->attr.pdt_type
16482 2 : || derived->attr.pdt_template))
16483 : return true;
16484 :
16485 364 : if (!gfc_check_new_interface (derived->ns->op[op],
16486 : target_proc, p->where))
16487 : return false;
16488 362 : head = derived->ns->op[op];
16489 362 : intr = gfc_get_interface ();
16490 362 : intr->sym = target_proc;
16491 362 : intr->where = p->where;
16492 362 : intr->next = head;
16493 362 : derived->ns->op[op] = intr;
16494 : }
16495 : }
16496 :
16497 : return true;
16498 :
16499 5 : error:
16500 5 : p->error = 1;
16501 5 : return false;
16502 : }
16503 :
16504 :
16505 : /* Resolve a type-bound user operator (tree-walker callback). */
16506 :
16507 : static gfc_symbol* resolve_bindings_derived;
16508 : static bool resolve_bindings_result;
16509 :
16510 : static bool check_uop_procedure (gfc_symbol* sym, locus where);
16511 :
16512 : static void
16513 59 : resolve_typebound_user_op (gfc_symtree* stree)
16514 : {
16515 59 : gfc_symbol* super_type;
16516 59 : gfc_tbp_generic* target;
16517 :
16518 59 : gcc_assert (stree && stree->n.tb);
16519 :
16520 59 : if (stree->n.tb->error)
16521 : return;
16522 :
16523 : /* Operators should always be GENERIC bindings. */
16524 59 : gcc_assert (stree->n.tb->is_generic);
16525 :
16526 : /* Find overridden procedure, if any. */
16527 59 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16528 59 : if (super_type && super_type->f2k_derived)
16529 : {
16530 0 : gfc_symtree* overridden;
16531 0 : overridden = gfc_find_typebound_user_op (super_type, NULL,
16532 : stree->name, true, NULL);
16533 :
16534 0 : if (overridden && overridden->n.tb)
16535 0 : stree->n.tb->overridden = overridden->n.tb;
16536 : }
16537 : else
16538 59 : stree->n.tb->overridden = NULL;
16539 :
16540 : /* Resolve basically using worker function. */
16541 59 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
16542 0 : goto error;
16543 :
16544 : /* Check the targets to be functions of correct interface. */
16545 116 : for (target = stree->n.tb->u.generic; target; target = target->next)
16546 : {
16547 60 : gfc_symbol* target_proc;
16548 :
16549 60 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
16550 60 : if (!target_proc)
16551 1 : goto error;
16552 :
16553 59 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
16554 2 : goto error;
16555 : }
16556 :
16557 : return;
16558 :
16559 3 : error:
16560 3 : resolve_bindings_result = false;
16561 3 : stree->n.tb->error = 1;
16562 : }
16563 :
16564 :
16565 : /* Resolve the type-bound procedures for a derived type. */
16566 :
16567 : static void
16568 9879 : resolve_typebound_procedure (gfc_symtree* stree)
16569 : {
16570 9879 : gfc_symbol* proc;
16571 9879 : locus where;
16572 9879 : gfc_symbol* me_arg;
16573 9879 : gfc_symbol* super_type;
16574 9879 : gfc_component* comp;
16575 :
16576 9879 : gcc_assert (stree);
16577 :
16578 : /* Undefined specific symbol from GENERIC target definition. */
16579 9879 : if (!stree->n.tb)
16580 9797 : return;
16581 :
16582 9873 : if (stree->n.tb->error)
16583 : return;
16584 :
16585 : /* If this is a GENERIC binding, use that routine. */
16586 9857 : if (stree->n.tb->is_generic)
16587 : {
16588 1202 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
16589 17 : goto error;
16590 : return;
16591 : }
16592 :
16593 : /* Get the target-procedure to check it. */
16594 8655 : gcc_assert (!stree->n.tb->is_generic);
16595 8655 : gcc_assert (stree->n.tb->u.specific);
16596 8655 : proc = stree->n.tb->u.specific->n.sym;
16597 8655 : where = stree->n.tb->where;
16598 :
16599 : /* Default access should already be resolved from the parser. */
16600 8655 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
16601 :
16602 8655 : if (stree->n.tb->deferred)
16603 : {
16604 672 : if (!check_proc_interface (proc, &where))
16605 5 : goto error;
16606 : }
16607 : else
16608 : {
16609 : /* If proc has not been resolved at this point, proc->name may
16610 : actually be a USE associated entity. See PR fortran/89647. */
16611 7983 : if (!proc->resolve_symbol_called
16612 5314 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
16613 : {
16614 11 : gfc_symbol *tmp;
16615 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
16616 11 : if (tmp && tmp->attr.use_assoc)
16617 : {
16618 1 : proc->module = tmp->module;
16619 1 : proc->attr.proc = tmp->attr.proc;
16620 1 : proc->attr.function = tmp->attr.function;
16621 1 : proc->attr.subroutine = tmp->attr.subroutine;
16622 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
16623 1 : proc->ts = tmp->ts;
16624 1 : proc->result = tmp->result;
16625 : }
16626 : }
16627 :
16628 : /* Check for F08:C465. */
16629 7983 : if ((!proc->attr.subroutine && !proc->attr.function)
16630 7973 : || (proc->attr.proc != PROC_MODULE
16631 70 : && proc->attr.if_source != IFSRC_IFBODY
16632 7 : && !proc->attr.module_procedure)
16633 7972 : || proc->attr.abstract)
16634 : {
16635 12 : gfc_error ("%qs must be a module procedure or an external "
16636 : "procedure with an explicit interface at %L",
16637 : proc->name, &where);
16638 12 : goto error;
16639 : }
16640 : }
16641 :
16642 8638 : stree->n.tb->subroutine = proc->attr.subroutine;
16643 8638 : stree->n.tb->function = proc->attr.function;
16644 :
16645 : /* Find the super-type of the current derived type. We could do this once and
16646 : store in a global if speed is needed, but as long as not I believe this is
16647 : more readable and clearer. */
16648 8638 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16649 :
16650 : /* If PASS, resolve and check arguments if not already resolved / loaded
16651 : from a .mod file. */
16652 8638 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
16653 : {
16654 2741 : gfc_formal_arglist *dummy_args;
16655 :
16656 2741 : dummy_args = gfc_sym_get_dummy_args (proc);
16657 2741 : if (stree->n.tb->pass_arg)
16658 : {
16659 459 : gfc_formal_arglist *i;
16660 :
16661 : /* If an explicit passing argument name is given, walk the arg-list
16662 : and look for it. */
16663 :
16664 459 : me_arg = NULL;
16665 459 : stree->n.tb->pass_arg_num = 1;
16666 585 : for (i = dummy_args; i; i = i->next)
16667 : {
16668 583 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
16669 : {
16670 : me_arg = i->sym;
16671 : break;
16672 : }
16673 126 : ++stree->n.tb->pass_arg_num;
16674 : }
16675 :
16676 459 : if (!me_arg)
16677 : {
16678 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
16679 : " argument %qs",
16680 : proc->name, stree->n.tb->pass_arg, &where,
16681 : stree->n.tb->pass_arg);
16682 2 : goto error;
16683 : }
16684 : }
16685 : else
16686 : {
16687 : /* Otherwise, take the first one; there should in fact be at least
16688 : one. */
16689 2282 : stree->n.tb->pass_arg_num = 1;
16690 2282 : if (!dummy_args)
16691 : {
16692 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
16693 : " least one argument", proc->name, &where);
16694 2 : goto error;
16695 : }
16696 2280 : me_arg = dummy_args->sym;
16697 : }
16698 :
16699 : /* Now check that the argument-type matches and the passed-object
16700 : dummy argument is generally fine. */
16701 :
16702 2280 : gcc_assert (me_arg);
16703 :
16704 2737 : if (me_arg->ts.type != BT_CLASS)
16705 : {
16706 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
16707 : " at %L", proc->name, &where);
16708 5 : goto error;
16709 : }
16710 :
16711 : /* The derived type is not a PDT template or type. Resolve as usual. */
16712 2732 : if (!resolve_bindings_derived->attr.pdt_template
16713 2723 : && !(containing_dt && containing_dt->attr.pdt_type
16714 60 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
16715 2703 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
16716 : {
16717 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16718 : "the derived-type %qs", me_arg->name, proc->name,
16719 : me_arg->name, &where, resolve_bindings_derived->name);
16720 0 : goto error;
16721 : }
16722 :
16723 2732 : if (resolve_bindings_derived->attr.pdt_template
16724 2741 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
16725 9 : CLASS_DATA (me_arg)->ts.u.derived))
16726 : {
16727 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16728 : "the parametric derived-type %qs", me_arg->name,
16729 : proc->name, me_arg->name, &where,
16730 : resolve_bindings_derived->name);
16731 0 : goto error;
16732 : }
16733 :
16734 2732 : if (((resolve_bindings_derived->attr.pdt_template
16735 9 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
16736 9 : CLASS_DATA (me_arg)->ts.u.derived))
16737 2723 : || resolve_bindings_derived->attr.pdt_type)
16738 69 : && (me_arg->param_list != NULL)
16739 2801 : && (gfc_spec_list_type (me_arg->param_list,
16740 69 : CLASS_DATA(me_arg)->ts.u.derived)
16741 : != SPEC_ASSUMED))
16742 : {
16743 :
16744 : /* Add a check to verify if there are any LEN parameters in the
16745 : first place. If there are LEN parameters, throw this error.
16746 : If there are only KIND parameters, then don't trigger
16747 : this error. */
16748 6 : gfc_component *c;
16749 6 : bool seen_len_param = false;
16750 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
16751 :
16752 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
16753 : {
16754 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
16755 : me_arg_param->name, true, true, NULL);
16756 :
16757 6 : gcc_assert (c != NULL);
16758 :
16759 6 : if (c->attr.pdt_kind)
16760 0 : continue;
16761 :
16762 : /* Getting here implies that there is a pdt_len parameter
16763 : in the list. */
16764 : seen_len_param = true;
16765 : break;
16766 : }
16767 :
16768 6 : if (seen_len_param)
16769 : {
16770 6 : gfc_error ("All LEN type parameters of the passed dummy "
16771 : "argument %qs of %qs at %L must be ASSUMED.",
16772 : me_arg->name, proc->name, &where);
16773 6 : goto error;
16774 : }
16775 : }
16776 :
16777 2726 : gcc_assert (me_arg->ts.type == BT_CLASS);
16778 2726 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
16779 : {
16780 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
16781 : " scalar", proc->name, &where);
16782 1 : goto error;
16783 : }
16784 2725 : if (CLASS_DATA (me_arg)->attr.allocatable)
16785 : {
16786 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16787 : " be ALLOCATABLE", proc->name, &where);
16788 2 : goto error;
16789 : }
16790 2723 : if (CLASS_DATA (me_arg)->attr.class_pointer)
16791 : {
16792 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16793 : " be POINTER", proc->name, &where);
16794 2 : goto error;
16795 : }
16796 : }
16797 :
16798 : /* If we are extending some type, check that we don't override a procedure
16799 : flagged NON_OVERRIDABLE. */
16800 8618 : stree->n.tb->overridden = NULL;
16801 8618 : if (super_type)
16802 : {
16803 1480 : gfc_symtree* overridden;
16804 1480 : overridden = gfc_find_typebound_proc (super_type, NULL,
16805 : stree->name, true, NULL);
16806 :
16807 1480 : if (overridden)
16808 : {
16809 1210 : if (overridden->n.tb)
16810 1210 : stree->n.tb->overridden = overridden->n.tb;
16811 :
16812 1210 : if (!gfc_check_typebound_override (stree, overridden))
16813 26 : goto error;
16814 : }
16815 : }
16816 :
16817 : /* See if there's a name collision with a component directly in this type. */
16818 20728 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
16819 12137 : if (!strcmp (comp->name, stree->name))
16820 : {
16821 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
16822 : " %qs",
16823 : stree->name, &where, resolve_bindings_derived->name);
16824 1 : goto error;
16825 : }
16826 :
16827 : /* Try to find a name collision with an inherited component. */
16828 8591 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
16829 : NULL))
16830 : {
16831 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
16832 : " component of %qs",
16833 : stree->name, &where, resolve_bindings_derived->name);
16834 1 : goto error;
16835 : }
16836 :
16837 8590 : stree->n.tb->error = 0;
16838 8590 : return;
16839 :
16840 82 : error:
16841 82 : resolve_bindings_result = false;
16842 82 : stree->n.tb->error = 1;
16843 : }
16844 :
16845 :
16846 : static bool
16847 85138 : resolve_typebound_procedures (gfc_symbol* derived)
16848 : {
16849 85138 : int op;
16850 85138 : gfc_symbol* super_type;
16851 :
16852 85138 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
16853 : return true;
16854 :
16855 4701 : super_type = gfc_get_derived_super_type (derived);
16856 4701 : if (super_type)
16857 847 : resolve_symbol (super_type);
16858 :
16859 4701 : resolve_bindings_derived = derived;
16860 4701 : resolve_bindings_result = true;
16861 :
16862 4701 : containing_dt = derived; /* Needed for checks of PDTs. */
16863 4701 : if (derived->f2k_derived->tb_sym_root)
16864 4701 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
16865 : &resolve_typebound_procedure);
16866 :
16867 4701 : if (derived->f2k_derived->tb_uop_root)
16868 55 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
16869 : &resolve_typebound_user_op);
16870 4701 : containing_dt = NULL;
16871 :
16872 136329 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
16873 : {
16874 131628 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
16875 131628 : if (p && !resolve_typebound_intrinsic_op (derived,
16876 : (gfc_intrinsic_op)op, p))
16877 7 : resolve_bindings_result = false;
16878 : }
16879 :
16880 4701 : return resolve_bindings_result;
16881 : }
16882 :
16883 :
16884 : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
16885 : to give all identical derived types the same backend_decl. */
16886 : static void
16887 174695 : add_dt_to_dt_list (gfc_symbol *derived)
16888 : {
16889 174695 : if (!derived->dt_next)
16890 : {
16891 81259 : if (gfc_derived_types)
16892 : {
16893 66663 : derived->dt_next = gfc_derived_types->dt_next;
16894 66663 : gfc_derived_types->dt_next = derived;
16895 : }
16896 : else
16897 : {
16898 14596 : derived->dt_next = derived;
16899 : }
16900 81259 : gfc_derived_types = derived;
16901 : }
16902 174695 : }
16903 :
16904 :
16905 : /* Ensure that a derived-type is really not abstract, meaning that every
16906 : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
16907 :
16908 : static bool
16909 7068 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
16910 : {
16911 7068 : if (!st)
16912 : return true;
16913 :
16914 2766 : if (!ensure_not_abstract_walker (sub, st->left))
16915 : return false;
16916 2766 : if (!ensure_not_abstract_walker (sub, st->right))
16917 : return false;
16918 :
16919 2765 : if (st->n.tb && st->n.tb->deferred)
16920 : {
16921 2013 : gfc_symtree* overriding;
16922 2013 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
16923 2013 : if (!overriding)
16924 : return false;
16925 2012 : gcc_assert (overriding->n.tb);
16926 2012 : if (overriding->n.tb->deferred)
16927 : {
16928 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
16929 : " %qs is DEFERRED and not overridden",
16930 : sub->name, &sub->declared_at, st->name);
16931 5 : return false;
16932 : }
16933 : }
16934 :
16935 : return true;
16936 : }
16937 :
16938 : static bool
16939 1388 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
16940 : {
16941 : /* The algorithm used here is to recursively travel up the ancestry of sub
16942 : and for each ancestor-type, check all bindings. If any of them is
16943 : DEFERRED, look it up starting from sub and see if the found (overriding)
16944 : binding is not DEFERRED.
16945 : This is not the most efficient way to do this, but it should be ok and is
16946 : clearer than something sophisticated. */
16947 :
16948 1537 : gcc_assert (ancestor && !sub->attr.abstract);
16949 :
16950 1537 : if (!ancestor->attr.abstract)
16951 : return true;
16952 :
16953 : /* Walk bindings of this ancestor. */
16954 1536 : if (ancestor->f2k_derived)
16955 : {
16956 1536 : bool t;
16957 1536 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
16958 1536 : if (!t)
16959 : return false;
16960 : }
16961 :
16962 : /* Find next ancestor type and recurse on it. */
16963 1530 : ancestor = gfc_get_derived_super_type (ancestor);
16964 1530 : if (ancestor)
16965 : return ensure_not_abstract (sub, ancestor);
16966 :
16967 : return true;
16968 : }
16969 :
16970 :
16971 : /* This check for typebound defined assignments is done recursively
16972 : since the order in which derived types are resolved is not always in
16973 : order of the declarations. */
16974 :
16975 : static void
16976 179080 : check_defined_assignments (gfc_symbol *derived)
16977 : {
16978 179080 : gfc_component *c;
16979 :
16980 599658 : for (c = derived->components; c; c = c->next)
16981 : {
16982 422355 : if (!gfc_bt_struct (c->ts.type)
16983 101747 : || c->attr.pointer
16984 20152 : || c->attr.proc_pointer_comp
16985 20152 : || c->attr.class_pointer
16986 20146 : || c->attr.proc_pointer)
16987 402640 : continue;
16988 :
16989 19715 : if (c->ts.u.derived->attr.defined_assign_comp
16990 19480 : || (c->ts.u.derived->f2k_derived
16991 18910 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
16992 : {
16993 1753 : derived->attr.defined_assign_comp = 1;
16994 1753 : return;
16995 : }
16996 :
16997 17962 : if (c->attr.allocatable)
16998 6505 : continue;
16999 :
17000 11457 : check_defined_assignments (c->ts.u.derived);
17001 11457 : if (c->ts.u.derived->attr.defined_assign_comp)
17002 : {
17003 24 : derived->attr.defined_assign_comp = 1;
17004 24 : return;
17005 : }
17006 : }
17007 : }
17008 :
17009 :
17010 : /* Resolve a single component of a derived type or structure. */
17011 :
17012 : static bool
17013 402966 : resolve_component (gfc_component *c, gfc_symbol *sym)
17014 : {
17015 402966 : gfc_symbol *super_type;
17016 402966 : symbol_attribute *attr;
17017 :
17018 402966 : if (c->attr.artificial)
17019 : return true;
17020 :
17021 : /* Do not allow vtype components to be resolved in nameless namespaces
17022 : such as block data because the procedure pointers will cause ICEs
17023 : and vtables are not needed in these contexts. */
17024 275342 : if (sym->attr.vtype && sym->attr.use_assoc
17025 48067 : && sym->ns->proc_name == NULL)
17026 : return true;
17027 :
17028 : /* F2008, C442. */
17029 275333 : if ((!sym->attr.is_class || c != sym->components)
17030 275333 : && c->attr.codimension
17031 208 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
17032 : {
17033 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
17034 : "deferred shape", c->name, &c->loc);
17035 4 : return false;
17036 : }
17037 :
17038 : /* F2008, C443. */
17039 275329 : if (c->attr.codimension && c->ts.type == BT_DERIVED
17040 85 : && c->ts.u.derived->ts.is_iso_c)
17041 : {
17042 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17043 : "shall not be a coarray", c->name, &c->loc);
17044 1 : return false;
17045 : }
17046 :
17047 : /* F2008, C444. */
17048 275328 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
17049 28 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
17050 26 : || c->attr.allocatable))
17051 : {
17052 3 : gfc_error ("Component %qs at %L with coarray component "
17053 : "shall be a nonpointer, nonallocatable scalar",
17054 : c->name, &c->loc);
17055 3 : return false;
17056 : }
17057 :
17058 : /* F2008, C448. */
17059 275325 : if (c->ts.type == BT_CLASS)
17060 : {
17061 6862 : if (c->attr.class_ok && CLASS_DATA (c))
17062 : {
17063 6854 : attr = &(CLASS_DATA (c)->attr);
17064 :
17065 : /* Fix up contiguous attribute. */
17066 6854 : if (c->attr.contiguous)
17067 11 : attr->contiguous = 1;
17068 : }
17069 : else
17070 : attr = NULL;
17071 : }
17072 : else
17073 268463 : attr = &c->attr;
17074 :
17075 275328 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
17076 : {
17077 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
17078 : "is not an array pointer", c->name, &c->loc);
17079 5 : return false;
17080 : }
17081 :
17082 : /* F2003, 15.2.1 - length has to be one. */
17083 40488 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
17084 275339 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
17085 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
17086 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
17087 : {
17088 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
17089 : c->name, &c->loc);
17090 1 : return false;
17091 : }
17092 :
17093 50972 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
17094 269 : && !sym->attr.pdt_type && !sym->attr.pdt_template
17095 275327 : && !(gfc_get_derived_super_type (sym)
17096 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
17097 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
17098 : {
17099 8 : gfc_actual_arglist *type_spec_list;
17100 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
17101 : &type_spec_list)
17102 : != MATCH_YES)
17103 0 : return false;
17104 8 : gfc_free_actual_arglist (c->param_list);
17105 8 : c->param_list = type_spec_list;
17106 8 : if (!sym->attr.pdt_type)
17107 8 : sym->attr.pdt_comp = 1;
17108 : }
17109 275311 : else if (IS_PDT (c) && !sym->attr.pdt_type)
17110 54 : sym->attr.pdt_comp = 1;
17111 :
17112 275319 : if (c->attr.proc_pointer && c->ts.interface)
17113 : {
17114 14485 : gfc_symbol *ifc = c->ts.interface;
17115 :
17116 14485 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
17117 : {
17118 6 : c->tb->error = 1;
17119 6 : return false;
17120 : }
17121 :
17122 14479 : if (ifc->attr.if_source || ifc->attr.intrinsic)
17123 : {
17124 : /* Resolve interface and copy attributes. */
17125 14430 : if (ifc->formal && !ifc->formal_ns)
17126 2531 : resolve_symbol (ifc);
17127 14430 : if (ifc->attr.intrinsic)
17128 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17129 :
17130 14430 : if (ifc->result)
17131 : {
17132 7565 : c->ts = ifc->result->ts;
17133 7565 : c->attr.allocatable = ifc->result->attr.allocatable;
17134 7565 : c->attr.pointer = ifc->result->attr.pointer;
17135 7565 : c->attr.dimension = ifc->result->attr.dimension;
17136 7565 : c->as = gfc_copy_array_spec (ifc->result->as);
17137 7565 : c->attr.class_ok = ifc->result->attr.class_ok;
17138 : }
17139 : else
17140 : {
17141 6865 : c->ts = ifc->ts;
17142 6865 : c->attr.allocatable = ifc->attr.allocatable;
17143 6865 : c->attr.pointer = ifc->attr.pointer;
17144 6865 : c->attr.dimension = ifc->attr.dimension;
17145 6865 : c->as = gfc_copy_array_spec (ifc->as);
17146 6865 : c->attr.class_ok = ifc->attr.class_ok;
17147 : }
17148 14430 : c->ts.interface = ifc;
17149 14430 : c->attr.function = ifc->attr.function;
17150 14430 : c->attr.subroutine = ifc->attr.subroutine;
17151 :
17152 14430 : c->attr.pure = ifc->attr.pure;
17153 14430 : c->attr.elemental = ifc->attr.elemental;
17154 14430 : c->attr.recursive = ifc->attr.recursive;
17155 14430 : c->attr.always_explicit = ifc->attr.always_explicit;
17156 14430 : c->attr.ext_attr |= ifc->attr.ext_attr;
17157 : /* Copy char length. */
17158 14430 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17159 : {
17160 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17161 454 : if (cl->length && !cl->resolved
17162 601 : && !gfc_resolve_expr (cl->length))
17163 : {
17164 0 : c->tb->error = 1;
17165 0 : return false;
17166 : }
17167 491 : c->ts.u.cl = cl;
17168 : }
17169 : }
17170 : }
17171 260834 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17172 : {
17173 : /* Since PPCs are not implicitly typed, a PPC without an explicit
17174 : interface must be a subroutine. */
17175 116 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17176 : }
17177 :
17178 : /* Procedure pointer components: Check PASS arg. */
17179 275313 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17180 804 : && !sym->attr.vtype)
17181 : {
17182 94 : gfc_symbol* me_arg;
17183 :
17184 94 : if (c->tb->pass_arg)
17185 : {
17186 19 : gfc_formal_arglist* i;
17187 :
17188 : /* If an explicit passing argument name is given, walk the arg-list
17189 : and look for it. */
17190 :
17191 19 : me_arg = NULL;
17192 19 : c->tb->pass_arg_num = 1;
17193 33 : for (i = c->ts.interface->formal; i; i = i->next)
17194 : {
17195 32 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17196 : {
17197 : me_arg = i->sym;
17198 : break;
17199 : }
17200 14 : c->tb->pass_arg_num++;
17201 : }
17202 :
17203 19 : if (!me_arg)
17204 : {
17205 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17206 : "at %L has no argument %qs", c->name,
17207 : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17208 1 : c->tb->error = 1;
17209 1 : return false;
17210 : }
17211 : }
17212 : else
17213 : {
17214 : /* Otherwise, take the first one; there should in fact be at least
17215 : one. */
17216 75 : c->tb->pass_arg_num = 1;
17217 75 : if (!c->ts.interface->formal)
17218 : {
17219 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17220 : "must have at least one argument",
17221 : c->name, &c->loc);
17222 3 : c->tb->error = 1;
17223 3 : return false;
17224 : }
17225 72 : me_arg = c->ts.interface->formal->sym;
17226 : }
17227 :
17228 : /* Now check that the argument-type matches. */
17229 72 : gcc_assert (me_arg);
17230 90 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17231 89 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17232 89 : || (me_arg->ts.type == BT_CLASS
17233 81 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17234 : {
17235 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17236 : " the derived type %qs", me_arg->name, c->name,
17237 : me_arg->name, &c->loc, sym->name);
17238 1 : c->tb->error = 1;
17239 1 : return false;
17240 : }
17241 :
17242 : /* Check for F03:C453. */
17243 89 : if (CLASS_DATA (me_arg)->attr.dimension)
17244 : {
17245 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17246 : "must be scalar", me_arg->name, c->name, me_arg->name,
17247 : &c->loc);
17248 1 : c->tb->error = 1;
17249 1 : return false;
17250 : }
17251 :
17252 88 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17253 : {
17254 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17255 : "may not have the POINTER attribute", me_arg->name,
17256 : c->name, me_arg->name, &c->loc);
17257 1 : c->tb->error = 1;
17258 1 : return false;
17259 : }
17260 :
17261 87 : if (CLASS_DATA (me_arg)->attr.allocatable)
17262 : {
17263 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17264 : "may not be ALLOCATABLE", me_arg->name, c->name,
17265 : me_arg->name, &c->loc);
17266 1 : c->tb->error = 1;
17267 1 : return false;
17268 : }
17269 :
17270 86 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17271 : {
17272 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17273 : " at %L", c->name, &c->loc);
17274 2 : return false;
17275 : }
17276 :
17277 : }
17278 :
17279 : /* Check type-spec if this is not the parent-type component. */
17280 275303 : if (((sym->attr.is_class
17281 12195 : && (!sym->components->ts.u.derived->attr.extension
17282 2362 : || c != CLASS_DATA (sym->components)))
17283 264428 : || (!sym->attr.is_class
17284 263108 : && (!sym->attr.extension || c != sym->components)))
17285 267274 : && !sym->attr.vtype
17286 436007 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17287 : return false;
17288 :
17289 275302 : super_type = gfc_get_derived_super_type (sym);
17290 :
17291 : /* If this type is an extension, set the accessibility of the parent
17292 : component. */
17293 275302 : if (super_type
17294 25272 : && ((sym->attr.is_class
17295 12195 : && c == CLASS_DATA (sym->components))
17296 16838 : || (!sym->attr.is_class && c == sym->components))
17297 15143 : && strcmp (super_type->name, c->name) == 0)
17298 6547 : c->attr.access = super_type->attr.access;
17299 :
17300 : /* If this type is an extension, see if this component has the same name
17301 : as an inherited type-bound procedure. */
17302 25272 : if (super_type && !sym->attr.is_class
17303 13077 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17304 : {
17305 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17306 : " inherited type-bound procedure",
17307 : c->name, sym->name, &c->loc);
17308 1 : return false;
17309 : }
17310 :
17311 275301 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17312 9371 : && !c->ts.deferred)
17313 : {
17314 7148 : if (sym->attr.pdt_template || c->attr.pdt_string)
17315 250 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17316 :
17317 7148 : if (c->ts.u.cl->length == NULL
17318 7142 : || !resolve_charlen(c->ts.u.cl)
17319 14289 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17320 : {
17321 9 : gfc_error ("Character length of component %qs needs to "
17322 : "be a constant specification expression at %L",
17323 : c->name,
17324 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17325 9 : return false;
17326 : }
17327 :
17328 7139 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17329 : {
17330 2 : if (!c->ts.u.cl->length->error)
17331 : {
17332 1 : gfc_error ("Character length expression of component %qs at %L "
17333 : "must be of INTEGER type, found %s",
17334 1 : c->name, &c->ts.u.cl->length->where,
17335 : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17336 1 : c->ts.u.cl->length->error = 1;
17337 : }
17338 2 : return false;
17339 : }
17340 : }
17341 :
17342 275290 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17343 2259 : && !c->attr.pointer && !c->attr.allocatable)
17344 : {
17345 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17346 : "length must be a POINTER or ALLOCATABLE",
17347 : c->name, sym->name, &c->loc);
17348 1 : return false;
17349 : }
17350 :
17351 : /* Add the hidden deferred length field. */
17352 275289 : if (c->ts.type == BT_CHARACTER
17353 9871 : && (c->ts.deferred || c->attr.pdt_string)
17354 2428 : && !c->attr.function
17355 2392 : && !sym->attr.is_class)
17356 : {
17357 2245 : char name[GFC_MAX_SYMBOL_LEN+9];
17358 2245 : gfc_component *strlen;
17359 2245 : sprintf (name, "_%s_length", c->name);
17360 2245 : strlen = gfc_find_component (sym, name, true, true, NULL);
17361 2245 : if (strlen == NULL)
17362 : {
17363 475 : if (!gfc_add_component (sym, name, &strlen))
17364 0 : return false;
17365 475 : strlen->ts.type = BT_INTEGER;
17366 475 : strlen->ts.kind = gfc_charlen_int_kind;
17367 475 : strlen->attr.access = ACCESS_PRIVATE;
17368 475 : strlen->attr.artificial = 1;
17369 : }
17370 : }
17371 :
17372 275289 : if (c->ts.type == BT_DERIVED
17373 51149 : && sym->component_access != ACCESS_PRIVATE
17374 50129 : && gfc_check_symbol_access (sym)
17375 98222 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
17376 49059 : && !c->ts.u.derived->attr.use_assoc
17377 26261 : && !gfc_check_symbol_access (c->ts.u.derived)
17378 275485 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
17379 : "PRIVATE type and cannot be a component of "
17380 : "%qs, which is PUBLIC at %L", c->name,
17381 : sym->name, &sym->declared_at))
17382 : return false;
17383 :
17384 275288 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
17385 : {
17386 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
17387 : "type %s", c->name, &c->loc, sym->name);
17388 2 : return false;
17389 : }
17390 :
17391 275286 : if (sym->attr.sequence)
17392 : {
17393 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
17394 : {
17395 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
17396 : "not have the SEQUENCE attribute",
17397 : c->ts.u.derived->name, &sym->declared_at);
17398 0 : return false;
17399 : }
17400 : }
17401 :
17402 275286 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
17403 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
17404 275286 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
17405 7194 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
17406 0 : CLASS_DATA (c)->ts.u.derived
17407 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
17408 :
17409 : /* If an allocatable component derived type is of the same type as
17410 : the enclosing derived type, we need a vtable generating so that
17411 : the __deallocate procedure is created. */
17412 275286 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
17413 58353 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
17414 399 : gfc_find_vtab (&c->ts);
17415 :
17416 : /* Ensure that all the derived type components are put on the
17417 : derived type list; even in formal namespaces, where derived type
17418 : pointer components might not have been declared. */
17419 275286 : if (c->ts.type == BT_DERIVED
17420 51148 : && c->ts.u.derived
17421 51148 : && c->ts.u.derived->components
17422 47932 : && c->attr.pointer
17423 32924 : && sym != c->ts.u.derived)
17424 4213 : add_dt_to_dt_list (c->ts.u.derived);
17425 :
17426 275286 : if (c->as && c->as->type != AS_DEFERRED
17427 6203 : && (c->attr.pointer || c->attr.allocatable))
17428 : return false;
17429 :
17430 275272 : if (!gfc_resolve_array_spec (c->as,
17431 275272 : !(c->attr.pointer || c->attr.proc_pointer
17432 224090 : || c->attr.allocatable)))
17433 : return false;
17434 :
17435 103466 : if (c->initializer && !sym->attr.vtype
17436 31601 : && !c->attr.pdt_kind && !c->attr.pdt_len
17437 303931 : && !gfc_check_assign_symbol (sym, c, c->initializer))
17438 : return false;
17439 :
17440 : return true;
17441 : }
17442 :
17443 :
17444 : /* Be nice about the locus for a structure expression - show the locus of the
17445 : first non-null sub-expression if we can. */
17446 :
17447 : static locus *
17448 4 : cons_where (gfc_expr *struct_expr)
17449 : {
17450 4 : gfc_constructor *cons;
17451 :
17452 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
17453 :
17454 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
17455 12 : for (; cons; cons = gfc_constructor_next (cons))
17456 : {
17457 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
17458 4 : return &cons->expr->where;
17459 : }
17460 :
17461 0 : return &struct_expr->where;
17462 : }
17463 :
17464 : /* Resolve the components of a structure type. Much less work than derived
17465 : types. */
17466 :
17467 : static bool
17468 913 : resolve_fl_struct (gfc_symbol *sym)
17469 : {
17470 913 : gfc_component *c;
17471 913 : gfc_expr *init = NULL;
17472 913 : bool success;
17473 :
17474 : /* Make sure UNIONs do not have overlapping initializers. */
17475 913 : if (sym->attr.flavor == FL_UNION)
17476 : {
17477 498 : for (c = sym->components; c; c = c->next)
17478 : {
17479 331 : if (init && c->initializer)
17480 : {
17481 2 : gfc_error ("Conflicting initializers in union at %L and %L",
17482 : cons_where (init), cons_where (c->initializer));
17483 2 : gfc_free_expr (c->initializer);
17484 2 : c->initializer = NULL;
17485 : }
17486 291 : if (init == NULL)
17487 291 : init = c->initializer;
17488 : }
17489 : }
17490 :
17491 913 : success = true;
17492 2830 : for (c = sym->components; c; c = c->next)
17493 1917 : if (!resolve_component (c, sym))
17494 0 : success = false;
17495 :
17496 913 : if (!success)
17497 : return false;
17498 :
17499 913 : if (sym->components)
17500 862 : add_dt_to_dt_list (sym);
17501 :
17502 : return true;
17503 : }
17504 :
17505 : /* Figure if the derived type is using itself directly in one of its components
17506 : or through referencing other derived types. The information is required to
17507 : generate the __deallocate and __final type bound procedures to ensure
17508 : freeing larger hierarchies of derived types with allocatable objects. */
17509 :
17510 : static void
17511 136167 : resolve_cyclic_derived_type (gfc_symbol *derived)
17512 : {
17513 136167 : hash_set<gfc_symbol *> seen, to_examin;
17514 136167 : gfc_component *c;
17515 136167 : seen.add (derived);
17516 136167 : to_examin.add (derived);
17517 456224 : while (!to_examin.is_empty ())
17518 : {
17519 186076 : gfc_symbol *cand = *to_examin.begin ();
17520 186076 : to_examin.remove (cand);
17521 501206 : for (c = cand->components; c; c = c->next)
17522 317316 : if (c->ts.type == BT_DERIVED)
17523 : {
17524 69674 : if (c->ts.u.derived == derived)
17525 : {
17526 1168 : derived->attr.recursive = 1;
17527 2186 : return;
17528 : }
17529 68506 : else if (!seen.contains (c->ts.u.derived))
17530 : {
17531 45433 : seen.add (c->ts.u.derived);
17532 45433 : to_examin.add (c->ts.u.derived);
17533 : }
17534 : }
17535 247642 : else if (c->ts.type == BT_CLASS)
17536 : {
17537 9494 : if (!c->attr.class_ok)
17538 7 : continue;
17539 9487 : if (CLASS_DATA (c)->ts.u.derived == derived)
17540 : {
17541 1018 : derived->attr.recursive = 1;
17542 1018 : return;
17543 : }
17544 8469 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
17545 : {
17546 4717 : seen.add (CLASS_DATA (c)->ts.u.derived);
17547 4717 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
17548 : }
17549 : }
17550 : }
17551 136167 : }
17552 :
17553 : /* Resolve the components of a derived type. This does not have to wait until
17554 : resolution stage, but can be done as soon as the dt declaration has been
17555 : parsed. */
17556 :
17557 : static bool
17558 167708 : resolve_fl_derived0 (gfc_symbol *sym)
17559 : {
17560 167708 : gfc_symbol* super_type;
17561 167708 : gfc_component *c;
17562 167708 : gfc_formal_arglist *f;
17563 167708 : bool success;
17564 :
17565 167708 : if (sym->attr.unlimited_polymorphic)
17566 : return true;
17567 :
17568 167708 : super_type = gfc_get_derived_super_type (sym);
17569 :
17570 : /* F2008, C432. */
17571 167708 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
17572 : {
17573 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
17574 : "parent type %qs shall also have one", sym->name,
17575 : &sym->declared_at, super_type->name);
17576 2 : return false;
17577 : }
17578 :
17579 : /* Ensure the extended type gets resolved before we do. */
17580 17157 : if (super_type && !resolve_fl_derived0 (super_type))
17581 : return false;
17582 :
17583 : /* An ABSTRACT type must be extensible. */
17584 167700 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
17585 : {
17586 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
17587 : sym->name, &sym->declared_at);
17588 2 : return false;
17589 : }
17590 :
17591 : /* Resolving components below, may create vtabs for which the cyclic type
17592 : information needs to be present. */
17593 167698 : if (!sym->attr.vtype)
17594 136167 : resolve_cyclic_derived_type (sym);
17595 :
17596 167698 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
17597 : : sym->components;
17598 :
17599 : success = true;
17600 568747 : for ( ; c != NULL; c = c->next)
17601 401049 : if (!resolve_component (c, sym))
17602 85 : success = false;
17603 :
17604 167698 : if (!success)
17605 : return false;
17606 :
17607 : /* Now add the caf token field, where needed. */
17608 167623 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
17609 989 : && !sym->attr.vtype)
17610 : {
17611 2220 : for (c = sym->components; c; c = c->next)
17612 1430 : if (!c->attr.dimension && !c->attr.codimension
17613 794 : && (c->attr.allocatable || c->attr.pointer))
17614 : {
17615 146 : char name[GFC_MAX_SYMBOL_LEN+9];
17616 146 : gfc_component *token;
17617 146 : sprintf (name, "_caf_%s", c->name);
17618 146 : token = gfc_find_component (sym, name, true, true, NULL);
17619 146 : if (token == NULL)
17620 : {
17621 82 : if (!gfc_add_component (sym, name, &token))
17622 0 : return false;
17623 82 : token->ts.type = BT_VOID;
17624 82 : token->ts.kind = gfc_default_integer_kind;
17625 82 : token->attr.access = ACCESS_PRIVATE;
17626 82 : token->attr.artificial = 1;
17627 82 : token->attr.caf_token = 1;
17628 : }
17629 146 : c->caf_token = token;
17630 : }
17631 : }
17632 :
17633 167623 : check_defined_assignments (sym);
17634 :
17635 167623 : if (!sym->attr.defined_assign_comp && super_type)
17636 16150 : sym->attr.defined_assign_comp
17637 16150 : = super_type->attr.defined_assign_comp;
17638 :
17639 : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
17640 : all DEFERRED bindings are overridden. */
17641 17150 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
17642 1391 : && !sym->attr.is_class
17643 3141 : && !ensure_not_abstract (sym, super_type))
17644 : return false;
17645 :
17646 : /* Check that there is a component for every PDT parameter. */
17647 167617 : if (sym->attr.pdt_template)
17648 : {
17649 2238 : for (f = sym->formal; f; f = f->next)
17650 : {
17651 1310 : if (!f->sym)
17652 1 : continue;
17653 1309 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
17654 1309 : if (c == NULL)
17655 : {
17656 9 : gfc_error ("Parameterized type %qs does not have a component "
17657 : "corresponding to parameter %qs at %L", sym->name,
17658 9 : f->sym->name, &sym->declared_at);
17659 9 : break;
17660 : }
17661 : }
17662 : }
17663 :
17664 : /* Add derived type to the derived type list. */
17665 167617 : add_dt_to_dt_list (sym);
17666 :
17667 167617 : return true;
17668 : }
17669 :
17670 : /* The following procedure does the full resolution of a derived type,
17671 : including resolution of all type-bound procedures (if present). In contrast
17672 : to 'resolve_fl_derived0' this can only be done after the module has been
17673 : parsed completely. */
17674 :
17675 : static bool
17676 87240 : resolve_fl_derived (gfc_symbol *sym)
17677 : {
17678 87240 : gfc_symbol *gen_dt = NULL;
17679 :
17680 87240 : if (sym->attr.unlimited_polymorphic)
17681 : return true;
17682 :
17683 87240 : if (!sym->attr.is_class)
17684 74790 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
17685 55816 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
17686 2287 : && (!gen_dt->generic->sym->attr.use_assoc
17687 2145 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
17688 87415 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
17689 : "%qs at %L being the same name as derived "
17690 : "type at %L", sym->name,
17691 : gen_dt->generic->sym == sym
17692 11 : ? gen_dt->generic->next->sym->name
17693 : : gen_dt->generic->sym->name,
17694 : gen_dt->generic->sym == sym
17695 11 : ? &gen_dt->generic->next->sym->declared_at
17696 : : &gen_dt->generic->sym->declared_at,
17697 : &sym->declared_at))
17698 : return false;
17699 :
17700 87236 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
17701 : {
17702 13 : gfc_error ("Derived type %qs at %L has not been declared",
17703 : sym->name, &sym->declared_at);
17704 13 : return false;
17705 : }
17706 :
17707 : /* Resolve the finalizer procedures. */
17708 87223 : if (!gfc_resolve_finalizers (sym, NULL))
17709 : return false;
17710 :
17711 87220 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
17712 : {
17713 : /* Fix up incomplete CLASS symbols. */
17714 12450 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
17715 12450 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
17716 :
17717 12450 : if (data->ts.u.derived->attr.pdt_template)
17718 : {
17719 6 : match m;
17720 6 : m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
17721 : &data->param_list);
17722 6 : if (m != MATCH_YES
17723 6 : || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
17724 : {
17725 0 : gfc_error ("Failed to build PDT class component at %L",
17726 : &sym->declared_at);
17727 0 : return false;
17728 : }
17729 6 : data = gfc_find_component (sym, "_data", true, true, NULL);
17730 6 : vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
17731 : }
17732 :
17733 : /* Nothing more to do for unlimited polymorphic entities. */
17734 12450 : if (data->ts.u.derived->attr.unlimited_polymorphic)
17735 : {
17736 2003 : add_dt_to_dt_list (sym);
17737 2003 : return true;
17738 : }
17739 10447 : else if (vptr->ts.u.derived == NULL)
17740 : {
17741 6156 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
17742 6156 : gcc_assert (vtab);
17743 6156 : vptr->ts.u.derived = vtab->ts.u.derived;
17744 6156 : if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
17745 : return false;
17746 : }
17747 : }
17748 :
17749 85217 : if (!resolve_fl_derived0 (sym))
17750 : return false;
17751 :
17752 : /* Resolve the type-bound procedures. */
17753 85138 : if (!resolve_typebound_procedures (sym))
17754 : return false;
17755 :
17756 : /* Generate module vtables subject to their accessibility and their not
17757 : being vtables or pdt templates. If this is not done class declarations
17758 : in external procedures wind up with their own version and so SELECT TYPE
17759 : fails because the vptrs do not have the same address. */
17760 85097 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
17761 85036 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
17762 63883 : || (sym->attr.recursive && sym->attr.alloc_comp))
17763 21307 : && sym->attr.access != ACCESS_PRIVATE
17764 21274 : && !(sym->attr.vtype || sym->attr.pdt_template))
17765 : {
17766 19163 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
17767 19163 : gfc_set_sym_referenced (vtab);
17768 : }
17769 :
17770 : return true;
17771 : }
17772 :
17773 :
17774 : static bool
17775 835 : resolve_fl_namelist (gfc_symbol *sym)
17776 : {
17777 835 : gfc_namelist *nl;
17778 835 : gfc_symbol *nlsym;
17779 :
17780 2984 : for (nl = sym->namelist; nl; nl = nl->next)
17781 : {
17782 : /* Check again, the check in match only works if NAMELIST comes
17783 : after the decl. */
17784 2154 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
17785 : {
17786 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
17787 : "allowed", nl->sym->name, sym->name, &sym->declared_at);
17788 1 : return false;
17789 : }
17790 :
17791 652 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
17792 2161 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17793 : "with assumed shape in namelist %qs at %L",
17794 : nl->sym->name, sym->name, &sym->declared_at))
17795 : return false;
17796 :
17797 2152 : if (is_non_constant_shape_array (nl->sym)
17798 2202 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17799 : "with nonconstant shape in namelist %qs at %L",
17800 50 : nl->sym->name, sym->name, &sym->declared_at))
17801 : return false;
17802 :
17803 2151 : if (nl->sym->ts.type == BT_CHARACTER
17804 589 : && (nl->sym->ts.u.cl->length == NULL
17805 550 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
17806 2233 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
17807 : "nonconstant character length in "
17808 82 : "namelist %qs at %L", nl->sym->name,
17809 : sym->name, &sym->declared_at))
17810 : return false;
17811 :
17812 : }
17813 :
17814 : /* Reject PRIVATE objects in a PUBLIC namelist. */
17815 830 : if (gfc_check_symbol_access (sym))
17816 : {
17817 2965 : for (nl = sym->namelist; nl; nl = nl->next)
17818 : {
17819 2148 : if (!nl->sym->attr.use_assoc
17820 4000 : && !is_sym_host_assoc (nl->sym, sym->ns)
17821 4126 : && !gfc_check_symbol_access (nl->sym))
17822 : {
17823 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
17824 : "cannot be member of PUBLIC namelist %qs at %L",
17825 2 : nl->sym->name, sym->name, &sym->declared_at);
17826 2 : return false;
17827 : }
17828 :
17829 2146 : if (nl->sym->ts.type == BT_DERIVED
17830 466 : && (nl->sym->ts.u.derived->attr.alloc_comp
17831 464 : || nl->sym->ts.u.derived->attr.pointer_comp))
17832 : {
17833 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
17834 : "namelist %qs at %L with ALLOCATABLE "
17835 : "or POINTER components", nl->sym->name,
17836 : sym->name, &sym->declared_at))
17837 : return false;
17838 : return true;
17839 : }
17840 :
17841 : /* Types with private components that came here by USE-association. */
17842 2141 : if (nl->sym->ts.type == BT_DERIVED
17843 2141 : && derived_inaccessible (nl->sym->ts.u.derived))
17844 : {
17845 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
17846 : "components and cannot be member of namelist %qs at %L",
17847 : nl->sym->name, sym->name, &sym->declared_at);
17848 6 : return false;
17849 : }
17850 :
17851 : /* Types with private components that are defined in the same module. */
17852 2135 : if (nl->sym->ts.type == BT_DERIVED
17853 910 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
17854 2413 : && nl->sym->ts.u.derived->attr.private_comp)
17855 : {
17856 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
17857 : "cannot be a member of PUBLIC namelist %qs at %L",
17858 : nl->sym->name, sym->name, &sym->declared_at);
17859 0 : return false;
17860 : }
17861 : }
17862 : }
17863 :
17864 :
17865 : /* 14.1.2 A module or internal procedure represent local entities
17866 : of the same type as a namelist member and so are not allowed. */
17867 2949 : for (nl = sym->namelist; nl; nl = nl->next)
17868 : {
17869 2135 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
17870 1576 : continue;
17871 :
17872 559 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
17873 7 : if ((nl->sym == sym->ns->proc_name)
17874 1 : ||
17875 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
17876 6 : continue;
17877 :
17878 553 : nlsym = NULL;
17879 553 : if (nl->sym->name)
17880 553 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
17881 553 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
17882 : {
17883 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
17884 : "attribute in %qs at %L", nlsym->name,
17885 : &sym->declared_at);
17886 3 : return false;
17887 : }
17888 : }
17889 :
17890 : return true;
17891 : }
17892 :
17893 :
17894 : static bool
17895 380687 : resolve_fl_parameter (gfc_symbol *sym)
17896 : {
17897 : /* A parameter array's shape needs to be constant. */
17898 380687 : if (sym->as != NULL
17899 380687 : && (sym->as->type == AS_DEFERRED
17900 6251 : || is_non_constant_shape_array (sym)))
17901 : {
17902 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
17903 : "or of deferred shape", sym->name, &sym->declared_at);
17904 17 : return false;
17905 : }
17906 :
17907 : /* Constraints on deferred type parameter. */
17908 380670 : if (!deferred_requirements (sym))
17909 : return false;
17910 :
17911 : /* Make sure a parameter that has been implicitly typed still
17912 : matches the implicit type, since PARAMETER statements can precede
17913 : IMPLICIT statements. */
17914 380669 : if (sym->attr.implicit_type
17915 381382 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
17916 713 : sym->ns)))
17917 : {
17918 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
17919 : "later IMPLICIT type", sym->name, &sym->declared_at);
17920 0 : return false;
17921 : }
17922 :
17923 : /* Make sure the types of derived parameters are consistent. This
17924 : type checking is deferred until resolution because the type may
17925 : refer to a derived type from the host. */
17926 380669 : if (sym->ts.type == BT_DERIVED
17927 380669 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
17928 : {
17929 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
17930 0 : &sym->value->where);
17931 0 : return false;
17932 : }
17933 :
17934 : /* F03:C509,C514. */
17935 380669 : if (sym->ts.type == BT_CLASS)
17936 : {
17937 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
17938 : sym->name, &sym->declared_at);
17939 0 : return false;
17940 : }
17941 :
17942 : /* Some programmers can have a typo when using an implied-do loop to
17943 : initialize an array constant. For example,
17944 : INTEGER I,J
17945 : INTEGER, PARAMETER :: A(3) = [(I, I = 1, 3)] ! OK
17946 : INTEGER, PARAMETER :: B(3) = [(A(J), I = 1, 3)] ! Not OK, J undefined
17947 : This check catches the typo. */
17948 380669 : if (sym->attr.dimension
17949 6244 : && sym->value && sym->value->expr_type == EXPR_ARRAY
17950 386909 : && !gfc_is_constant_expr (sym->value))
17951 : {
17952 : /* PR fortran/117070 argues a nonconstant proc pointer can appear in
17953 : the array constructor of a paramater. This seems inconsistant with
17954 : the concept of a parameter. TODO: Needs an interpretation. */
17955 20 : if (sym->value->ts.type == BT_DERIVED
17956 18 : && sym->value->ts.u.derived
17957 18 : && sym->value->ts.u.derived->attr.proc_pointer_comp)
17958 : return true;
17959 2 : gfc_error ("Expecting constant expression near %L", &sym->value->where);
17960 2 : return false;
17961 : }
17962 :
17963 : return true;
17964 : }
17965 :
17966 :
17967 : /* Called by resolve_symbol to check PDTs. */
17968 :
17969 : static void
17970 1291 : resolve_pdt (gfc_symbol* sym)
17971 : {
17972 1291 : gfc_symbol *derived = NULL;
17973 1291 : gfc_actual_arglist *param;
17974 1291 : gfc_component *c;
17975 1291 : bool const_len_exprs = true;
17976 1291 : bool assumed_len_exprs = false;
17977 1291 : symbol_attribute *attr;
17978 :
17979 1291 : if (sym->ts.type == BT_DERIVED)
17980 : {
17981 1064 : derived = sym->ts.u.derived;
17982 1064 : attr = &(sym->attr);
17983 : }
17984 227 : else if (sym->ts.type == BT_CLASS)
17985 : {
17986 227 : derived = CLASS_DATA (sym)->ts.u.derived;
17987 227 : attr = &(CLASS_DATA (sym)->attr);
17988 : }
17989 : else
17990 0 : gcc_unreachable ();
17991 :
17992 1291 : gcc_assert (derived->attr.pdt_type);
17993 :
17994 3075 : for (param = sym->param_list; param; param = param->next)
17995 : {
17996 1784 : c = gfc_find_component (derived, param->name, false, true, NULL);
17997 1784 : gcc_assert (c);
17998 1784 : if (c->attr.pdt_kind)
17999 950 : continue;
18000 :
18001 589 : if (param->expr && !gfc_is_constant_expr (param->expr)
18002 909 : && c->attr.pdt_len)
18003 : const_len_exprs = false;
18004 759 : else if (param->spec_type == SPEC_ASSUMED)
18005 274 : assumed_len_exprs = true;
18006 :
18007 834 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
18008 10 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
18009 8 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
18010 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
18011 : "parameter %qs and requires either the POINTER "
18012 : "or ALLOCATABLE attribute",
18013 : sym->name, &sym->declared_at,
18014 : param->name);
18015 :
18016 : }
18017 :
18018 1291 : if (!const_len_exprs
18019 75 : && (sym->ns->proc_name->attr.is_main_program
18020 74 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18021 73 : || sym->attr.save != SAVE_NONE))
18022 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
18023 : "SAVE attribute or be a variable declared in the "
18024 : "main program, a module or a submodule(F08/C513)",
18025 : sym->name, &sym->declared_at);
18026 :
18027 1291 : if (assumed_len_exprs && !(sym->attr.dummy
18028 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
18029 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
18030 : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
18031 : sym->name, &sym->declared_at);
18032 1291 : }
18033 :
18034 :
18035 : /* Resolve the symbol's array spec. */
18036 :
18037 : static bool
18038 1685102 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
18039 : {
18040 1685102 : gfc_namespace *orig_current_ns = gfc_current_ns;
18041 1685102 : gfc_current_ns = gfc_get_spec_ns (sym);
18042 :
18043 1685102 : bool saved_specification_expr = specification_expr;
18044 1685102 : specification_expr = true;
18045 :
18046 1685102 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
18047 :
18048 1685102 : specification_expr = saved_specification_expr;
18049 1685102 : gfc_current_ns = orig_current_ns;
18050 :
18051 1685102 : return result;
18052 : }
18053 :
18054 :
18055 : /* Do anything necessary to resolve a symbol. Right now, we just
18056 : assume that an otherwise unknown symbol is a variable. This sort
18057 : of thing commonly happens for symbols in module. */
18058 :
18059 : static void
18060 1824239 : resolve_symbol (gfc_symbol *sym)
18061 : {
18062 1824239 : int check_constant, mp_flag;
18063 1824239 : gfc_symtree *symtree;
18064 1824239 : gfc_symtree *this_symtree;
18065 1824239 : gfc_namespace *ns;
18066 1824239 : gfc_component *c;
18067 1824239 : symbol_attribute class_attr;
18068 1824239 : gfc_array_spec *as;
18069 :
18070 1824239 : if (sym->resolve_symbol_called >= 1)
18071 170428 : return;
18072 1750728 : sym->resolve_symbol_called = 1;
18073 :
18074 : /* No symbol will ever have union type; only components can be unions.
18075 : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
18076 : (just like derived type declaration symbols have flavor FL_DERIVED). */
18077 1750728 : gcc_assert (sym->ts.type != BT_UNION);
18078 :
18079 : /* Coarrayed polymorphic objects with allocatable or pointer components are
18080 : yet unsupported for -fcoarray=lib. */
18081 1750728 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
18082 112 : && sym->ts.u.derived && CLASS_DATA (sym)
18083 112 : && CLASS_DATA (sym)->attr.codimension
18084 94 : && CLASS_DATA (sym)->ts.u.derived
18085 93 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
18086 90 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
18087 : {
18088 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
18089 : "type coarrays at %L are unsupported", &sym->declared_at);
18090 6 : return;
18091 : }
18092 :
18093 1750722 : if (sym->attr.artificial)
18094 : return;
18095 :
18096 1656470 : if (sym->attr.unlimited_polymorphic)
18097 : return;
18098 :
18099 1655016 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
18100 : {
18101 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
18102 : "the OpenMP DEPEND clause", &sym->declared_at);
18103 4 : return;
18104 : }
18105 :
18106 1655012 : if (sym->attr.flavor == FL_UNKNOWN
18107 1633907 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
18108 440800 : && !sym->attr.generic && !sym->attr.external
18109 178901 : && sym->attr.if_source == IFSRC_UNKNOWN
18110 80454 : && sym->ts.type == BT_UNKNOWN))
18111 : {
18112 : /* A symbol in a common block might not have been resolved yet properly.
18113 : Do not try to find an interface with the same name. */
18114 93176 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
18115 21101 : && !sym->attr.generic && !sym->attr.external
18116 21050 : && sym->attr.in_common)
18117 2594 : goto skip_interfaces;
18118 :
18119 : /* If we find that a flavorless symbol is an interface in one of the
18120 : parent namespaces, find its symtree in this namespace, free the
18121 : symbol and set the symtree to point to the interface symbol. */
18122 129371 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
18123 : {
18124 39467 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
18125 39467 : if (symtree && (symtree->n.sym->generic ||
18126 724 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
18127 634 : && sym->ns->construct_entities)))
18128 : {
18129 686 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
18130 : sym->name);
18131 686 : if (this_symtree->n.sym == sym)
18132 : {
18133 678 : symtree->n.sym->refs++;
18134 678 : gfc_release_symbol (sym);
18135 678 : this_symtree->n.sym = symtree->n.sym;
18136 678 : return;
18137 : }
18138 : }
18139 : }
18140 :
18141 89904 : skip_interfaces:
18142 : /* Otherwise give it a flavor according to such attributes as
18143 : it has. */
18144 92498 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
18145 20920 : && sym->attr.intrinsic == 0)
18146 20916 : sym->attr.flavor = FL_VARIABLE;
18147 71582 : else if (sym->attr.flavor == FL_UNKNOWN)
18148 : {
18149 55 : sym->attr.flavor = FL_PROCEDURE;
18150 55 : if (sym->attr.dimension)
18151 0 : sym->attr.function = 1;
18152 : }
18153 : }
18154 :
18155 1654334 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
18156 2304 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
18157 :
18158 1448 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
18159 1655782 : && !resolve_procedure_interface (sym))
18160 : return;
18161 :
18162 1654323 : if (sym->attr.is_protected && !sym->attr.proc_pointer
18163 130 : && (sym->attr.procedure || sym->attr.external))
18164 : {
18165 0 : if (sym->attr.external)
18166 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18167 : "at %L", &sym->declared_at);
18168 : else
18169 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18170 : "at %L", &sym->declared_at);
18171 :
18172 0 : return;
18173 : }
18174 :
18175 : /* Ensure that variables of derived or class type having a finalizer are
18176 : marked used even when the variable is not used anything else in the scope.
18177 : This fixes PR118730. */
18178 645953 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18179 442013 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18180 1703506 : && gfc_may_be_finalized (sym->ts))
18181 8360 : gfc_set_sym_referenced (sym);
18182 :
18183 1654323 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18184 : return;
18185 :
18186 1653552 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18187 1654315 : && !resolve_fl_struct (sym))
18188 : return;
18189 :
18190 : /* Symbols that are module procedures with results (functions) have
18191 : the types and array specification copied for type checking in
18192 : procedures that call them, as well as for saving to a module
18193 : file. These symbols can't stand the scrutiny that their results
18194 : can. */
18195 1654183 : mp_flag = (sym->result != NULL && sym->result != sym);
18196 :
18197 : /* Make sure that the intrinsic is consistent with its internal
18198 : representation. This needs to be done before assigning a default
18199 : type to avoid spurious warnings. */
18200 1620378 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18201 1686437 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18202 : return;
18203 :
18204 : /* Resolve associate names. */
18205 1654147 : if (sym->assoc)
18206 6711 : resolve_assoc_var (sym, true);
18207 :
18208 : /* Assign default type to symbols that need one and don't have one. */
18209 1654147 : if (sym->ts.type == BT_UNKNOWN)
18210 : {
18211 398035 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18212 : {
18213 11758 : gfc_set_default_type (sym, 1, NULL);
18214 : }
18215 :
18216 257264 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18217 60983 : && !sym->attr.function && !sym->attr.subroutine
18218 399650 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18219 564 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18220 :
18221 398035 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18222 : {
18223 : /* The specific case of an external procedure should emit an error
18224 : in the case that there is no implicit type. */
18225 101379 : if (!mp_flag)
18226 : {
18227 95431 : if (!sym->attr.mixed_entry_master)
18228 95325 : gfc_set_default_type (sym, sym->attr.external, NULL);
18229 : }
18230 : else
18231 : {
18232 : /* Result may be in another namespace. */
18233 5948 : resolve_symbol (sym->result);
18234 :
18235 5948 : if (!sym->result->attr.proc_pointer)
18236 : {
18237 5769 : sym->ts = sym->result->ts;
18238 5769 : sym->as = gfc_copy_array_spec (sym->result->as);
18239 5769 : sym->attr.dimension = sym->result->attr.dimension;
18240 5769 : sym->attr.codimension = sym->result->attr.codimension;
18241 5769 : sym->attr.pointer = sym->result->attr.pointer;
18242 5769 : sym->attr.allocatable = sym->result->attr.allocatable;
18243 5769 : sym->attr.contiguous = sym->result->attr.contiguous;
18244 : }
18245 : }
18246 : }
18247 : }
18248 1256112 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18249 31288 : resolve_symbol_array_spec (sym->result, false);
18250 :
18251 : /* For a CLASS-valued function with a result variable, affirm that it has
18252 : been resolved also when looking at the symbol 'sym'. */
18253 429323 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18254 719 : sym->attr.class_ok = sym->result->attr.class_ok;
18255 :
18256 1654147 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18257 19083 : && CLASS_DATA (sym))
18258 : {
18259 19082 : as = CLASS_DATA (sym)->as;
18260 19082 : class_attr = CLASS_DATA (sym)->attr;
18261 19082 : class_attr.pointer = class_attr.class_pointer;
18262 : }
18263 : else
18264 : {
18265 1635065 : class_attr = sym->attr;
18266 1635065 : as = sym->as;
18267 : }
18268 :
18269 : /* F2008, C530. */
18270 1654147 : if (sym->attr.contiguous
18271 7687 : && !sym->attr.associate_var
18272 7686 : && (!class_attr.dimension
18273 7683 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18274 128 : && !class_attr.pointer)))
18275 : {
18276 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18277 : "array pointer or an assumed-shape or assumed-rank array",
18278 : sym->name, &sym->declared_at);
18279 7 : return;
18280 : }
18281 :
18282 : /* Assumed size arrays and assumed shape arrays must be dummy
18283 : arguments. Array-spec's of implied-shape should have been resolved to
18284 : AS_EXPLICIT already. */
18285 :
18286 1646585 : if (as)
18287 : {
18288 : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18289 : specification expression. */
18290 144982 : if (as->type == AS_IMPLIED_SHAPE)
18291 : {
18292 : int i;
18293 1 : for (i=0; i<as->rank; i++)
18294 : {
18295 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18296 : {
18297 1 : gfc_error ("Bad specification for assumed size array at %L",
18298 : &as->lower[i]->where);
18299 1 : return;
18300 : }
18301 : }
18302 0 : gcc_unreachable();
18303 : }
18304 :
18305 144981 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18306 112080 : || as->type == AS_ASSUMED_SHAPE)
18307 44430 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18308 8 : && !sym->attr.associate_var)
18309 : {
18310 7 : if (as->type == AS_ASSUMED_SIZE)
18311 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18312 : &sym->declared_at);
18313 : else
18314 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18315 : &sym->declared_at);
18316 7 : return;
18317 : }
18318 : /* TS 29113, C535a. */
18319 144974 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18320 60 : && !sym->attr.select_type_temporary
18321 60 : && !(cs_base && cs_base->current
18322 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18323 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18324 0 : && cs_base->current->op == EXEC_BLOCK))))
18325 : {
18326 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18327 : &sym->declared_at);
18328 18 : return;
18329 : }
18330 144956 : if (as->type == AS_ASSUMED_RANK
18331 26194 : && (sym->attr.codimension || sym->attr.value))
18332 : {
18333 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18334 : "CODIMENSION attribute", &sym->declared_at);
18335 2 : return;
18336 : }
18337 : }
18338 :
18339 : /* Make sure symbols with known intent or optional are really dummy
18340 : variable. Because of ENTRY statement, this has to be deferred
18341 : until resolution time. */
18342 :
18343 1654112 : if (!sym->attr.dummy
18344 1189048 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
18345 : {
18346 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
18347 2 : return;
18348 : }
18349 :
18350 1654110 : if (sym->attr.value && !sym->attr.dummy)
18351 : {
18352 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
18353 : "it is not a dummy argument", sym->name, &sym->declared_at);
18354 2 : return;
18355 : }
18356 :
18357 1654108 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
18358 : {
18359 616 : gfc_charlen *cl = sym->ts.u.cl;
18360 616 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
18361 : {
18362 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
18363 : "attribute must have constant length",
18364 : sym->name, &sym->declared_at);
18365 2 : return;
18366 : }
18367 :
18368 614 : if (sym->ts.is_c_interop
18369 381 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
18370 : {
18371 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
18372 : "with VALUE attribute must have length one",
18373 : sym->name, &sym->declared_at);
18374 1 : return;
18375 : }
18376 : }
18377 :
18378 1654105 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18379 122404 : && sym->ts.u.derived->attr.generic)
18380 : {
18381 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
18382 20 : if (!sym->ts.u.derived)
18383 : {
18384 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
18385 : "which has not been defined", sym->name,
18386 : &sym->declared_at, sym->ts.u.derived->name);
18387 0 : sym->ts.type = BT_UNKNOWN;
18388 0 : return;
18389 : }
18390 : }
18391 :
18392 : /* Use the same constraints as TYPE(*), except for the type check
18393 : and that only scalars and assumed-size arrays are permitted. */
18394 1654105 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
18395 : {
18396 12960 : if (!sym->attr.dummy)
18397 : {
18398 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18399 : "a dummy argument", sym->name, &sym->declared_at);
18400 1 : return;
18401 : }
18402 :
18403 12959 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
18404 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
18405 0 : && sym->ts.type != BT_COMPLEX)
18406 : {
18407 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18408 : "of type TYPE(*) or of an numeric intrinsic type",
18409 : sym->name, &sym->declared_at);
18410 0 : return;
18411 : }
18412 :
18413 12959 : if (sym->attr.allocatable || sym->attr.codimension
18414 12957 : || sym->attr.pointer || sym->attr.value)
18415 : {
18416 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18417 : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
18418 : "attribute", sym->name, &sym->declared_at);
18419 4 : return;
18420 : }
18421 :
18422 12955 : if (sym->attr.intent == INTENT_OUT)
18423 : {
18424 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18425 : "have the INTENT(OUT) attribute",
18426 : sym->name, &sym->declared_at);
18427 0 : return;
18428 : }
18429 12955 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
18430 : {
18431 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
18432 : "either be a scalar or an assumed-size array",
18433 : sym->name, &sym->declared_at);
18434 1 : return;
18435 : }
18436 :
18437 : /* Set the type to TYPE(*) and add a dimension(*) to ensure
18438 : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
18439 : packing. */
18440 12954 : sym->ts.type = BT_ASSUMED;
18441 12954 : sym->as = gfc_get_array_spec ();
18442 12954 : sym->as->type = AS_ASSUMED_SIZE;
18443 12954 : sym->as->rank = 1;
18444 12954 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
18445 : }
18446 1641145 : else if (sym->ts.type == BT_ASSUMED)
18447 : {
18448 : /* TS 29113, C407a. */
18449 11006 : if (!sym->attr.dummy)
18450 : {
18451 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
18452 : "for dummy variables", sym->name, &sym->declared_at);
18453 7 : return;
18454 : }
18455 10999 : if (sym->attr.allocatable || sym->attr.codimension
18456 10995 : || sym->attr.pointer || sym->attr.value)
18457 : {
18458 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
18459 : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
18460 : sym->name, &sym->declared_at);
18461 8 : return;
18462 : }
18463 10991 : if (sym->attr.intent == INTENT_OUT)
18464 : {
18465 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
18466 : "INTENT(OUT) attribute",
18467 : sym->name, &sym->declared_at);
18468 2 : return;
18469 : }
18470 10989 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
18471 : {
18472 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
18473 : "explicit-shape array", sym->name, &sym->declared_at);
18474 3 : return;
18475 : }
18476 : }
18477 :
18478 : /* If the symbol is marked as bind(c), that it is declared at module level
18479 : scope and verify its type and kind. Do not do the latter for symbols
18480 : that are implicitly typed because that is handled in
18481 : gfc_set_default_type. Handle dummy arguments and procedure definitions
18482 : separately. Also, anything that is use associated is not handled here
18483 : but instead is handled in the module it is declared in. Finally, derived
18484 : type definitions are allowed to be BIND(C) since that only implies that
18485 : they're interoperable, and they are checked fully for interoperability
18486 : when a variable is declared of that type. */
18487 1654079 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
18488 7159 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
18489 567 : && sym->attr.flavor != FL_DERIVED)
18490 : {
18491 167 : bool t = true;
18492 :
18493 : /* First, make sure the variable is declared at the
18494 : module-level scope (J3/04-007, Section 15.3). */
18495 167 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
18496 7 : && !sym->attr.in_common)
18497 : {
18498 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
18499 : "is neither a COMMON block nor declared at the "
18500 : "module level scope", sym->name, &(sym->declared_at));
18501 6 : t = false;
18502 : }
18503 161 : else if (sym->ts.type == BT_CHARACTER
18504 161 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
18505 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
18506 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
18507 : {
18508 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
18509 1 : sym->name, &sym->declared_at);
18510 1 : t = false;
18511 : }
18512 160 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
18513 : {
18514 1 : t = verify_com_block_vars_c_interop (sym->common_head);
18515 : }
18516 159 : else if (sym->attr.implicit_type == 0)
18517 : {
18518 : /* If type() declaration, we need to verify that the components
18519 : of the given type are all C interoperable, etc. */
18520 157 : if (sym->ts.type == BT_DERIVED &&
18521 24 : sym->ts.u.derived->attr.is_c_interop != 1)
18522 : {
18523 : /* Make sure the user marked the derived type as BIND(C). If
18524 : not, call the verify routine. This could print an error
18525 : for the derived type more than once if multiple variables
18526 : of that type are declared. */
18527 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
18528 1 : verify_bind_c_derived_type (sym->ts.u.derived);
18529 157 : t = false;
18530 : }
18531 :
18532 : /* Verify the variable itself as C interoperable if it
18533 : is BIND(C). It is not possible for this to succeed if
18534 : the verify_bind_c_derived_type failed, so don't have to handle
18535 : any error returned by verify_bind_c_derived_type. */
18536 157 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
18537 157 : sym->common_block);
18538 : }
18539 :
18540 165 : if (!t)
18541 : {
18542 : /* clear the is_bind_c flag to prevent reporting errors more than
18543 : once if something failed. */
18544 10 : sym->attr.is_bind_c = 0;
18545 10 : return;
18546 : }
18547 : }
18548 :
18549 : /* If a derived type symbol has reached this point, without its
18550 : type being declared, we have an error. Notice that most
18551 : conditions that produce undefined derived types have already
18552 : been dealt with. However, the likes of:
18553 : implicit type(t) (t) ..... call foo (t) will get us here if
18554 : the type is not declared in the scope of the implicit
18555 : statement. Change the type to BT_UNKNOWN, both because it is so
18556 : and to prevent an ICE. */
18557 1654069 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18558 122402 : && sym->ts.u.derived->components == NULL
18559 1138 : && !sym->ts.u.derived->attr.zero_comp)
18560 : {
18561 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
18562 : "which has not been defined", sym->name,
18563 : &sym->declared_at, sym->ts.u.derived->name);
18564 3 : sym->ts.type = BT_UNKNOWN;
18565 3 : return;
18566 : }
18567 :
18568 : /* Make sure that the derived type has been resolved and that the
18569 : derived type is visible in the symbol's namespace, if it is a
18570 : module function and is not PRIVATE. */
18571 1654066 : if (sym->ts.type == BT_DERIVED
18572 129303 : && sym->ts.u.derived->attr.use_assoc
18573 112148 : && sym->ns->proc_name
18574 112140 : && sym->ns->proc_name->attr.flavor == FL_MODULE
18575 1659919 : && !resolve_fl_derived (sym->ts.u.derived))
18576 : return;
18577 :
18578 : /* Unless the derived-type declaration is use associated, Fortran 95
18579 : does not allow public entries of private derived types.
18580 : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
18581 : 161 in 95-006r3. */
18582 1654066 : if (sym->ts.type == BT_DERIVED
18583 129303 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
18584 7881 : && !sym->ts.u.derived->attr.use_assoc
18585 2028 : && gfc_check_symbol_access (sym)
18586 1823 : && !gfc_check_symbol_access (sym->ts.u.derived)
18587 1654080 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
18588 : "derived type %qs",
18589 14 : (sym->attr.flavor == FL_PARAMETER)
18590 : ? "parameter" : "variable",
18591 : sym->name, &sym->declared_at,
18592 14 : sym->ts.u.derived->name))
18593 : return;
18594 :
18595 : /* F2008, C1302. */
18596 1654059 : if (sym->ts.type == BT_DERIVED
18597 129296 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18598 154 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
18599 129265 : || sym->ts.u.derived->attr.lock_comp)
18600 44 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18601 : {
18602 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
18603 : "type LOCK_TYPE must be a coarray", sym->name,
18604 : &sym->declared_at);
18605 4 : return;
18606 : }
18607 :
18608 : /* TS18508, C702/C703. */
18609 1654055 : if (sym->ts.type == BT_DERIVED
18610 129292 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18611 153 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
18612 129275 : || sym->ts.u.derived->attr.event_comp)
18613 17 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18614 : {
18615 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
18616 : "type EVENT_TYPE must be a coarray", sym->name,
18617 : &sym->declared_at);
18618 1 : return;
18619 : }
18620 :
18621 : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
18622 : default initialization is defined (5.1.2.4.4). */
18623 1654054 : if (sym->ts.type == BT_DERIVED
18624 129291 : && sym->attr.dummy
18625 44647 : && sym->attr.intent == INTENT_OUT
18626 2356 : && sym->as
18627 381 : && sym->as->type == AS_ASSUMED_SIZE)
18628 : {
18629 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
18630 : {
18631 1 : if (c->initializer)
18632 : {
18633 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
18634 : "ASSUMED SIZE and so cannot have a default initializer",
18635 : sym->name, &sym->declared_at);
18636 1 : return;
18637 : }
18638 : }
18639 : }
18640 :
18641 : /* F2008, C542. */
18642 1654053 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18643 44646 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
18644 : {
18645 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
18646 : "INTENT(OUT)", sym->name, &sym->declared_at);
18647 0 : return;
18648 : }
18649 :
18650 : /* TS18508. */
18651 1654053 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18652 44646 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
18653 : {
18654 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
18655 : "INTENT(OUT)", sym->name, &sym->declared_at);
18656 0 : return;
18657 : }
18658 :
18659 : /* F2008, C525. */
18660 1654053 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18661 1653953 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18662 19086 : && sym->ts.u.derived && CLASS_DATA (sym)
18663 19080 : && CLASS_DATA (sym)->attr.coarray_comp))
18664 1653953 : || class_attr.codimension)
18665 1772 : && (sym->attr.result || sym->result == sym))
18666 : {
18667 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
18668 : "a coarray component", sym->name, &sym->declared_at);
18669 8 : return;
18670 : }
18671 :
18672 : /* F2008, C524. */
18673 1654045 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
18674 411 : && sym->ts.u.derived->ts.is_iso_c)
18675 : {
18676 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
18677 : "shall not be a coarray", sym->name, &sym->declared_at);
18678 3 : return;
18679 : }
18680 :
18681 : /* F2008, C525. */
18682 1654042 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18683 1653945 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18684 19085 : && sym->ts.u.derived && CLASS_DATA (sym)
18685 19079 : && CLASS_DATA (sym)->attr.coarray_comp))
18686 97 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
18687 93 : || class_attr.allocatable))
18688 : {
18689 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
18690 : "nonpointer, nonallocatable scalar, which is not a coarray",
18691 : sym->name, &sym->declared_at);
18692 4 : return;
18693 : }
18694 :
18695 : /* F2008, C526. The function-result case was handled above. */
18696 1654038 : if (class_attr.codimension
18697 1664 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
18698 348 : || sym->attr.select_type_temporary
18699 272 : || sym->attr.associate_var
18700 254 : || (sym->ns->save_all && !sym->attr.automatic)
18701 254 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18702 254 : || sym->ns->proc_name->attr.is_main_program
18703 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
18704 : {
18705 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
18706 : "nor a dummy argument", sym->name, &sym->declared_at);
18707 4 : return;
18708 : }
18709 : /* F2008, C528. */
18710 1654034 : else if (class_attr.codimension && !sym->attr.select_type_temporary
18711 1584 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
18712 : {
18713 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
18714 : "deferred shape without allocatable", sym->name,
18715 : &sym->declared_at);
18716 6 : return;
18717 : }
18718 1654028 : else if (class_attr.codimension && class_attr.allocatable && as
18719 610 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
18720 : {
18721 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
18722 : "deferred shape", sym->name, &sym->declared_at);
18723 9 : return;
18724 : }
18725 :
18726 : /* F2008, C541. */
18727 1654019 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18728 1653926 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18729 19080 : && sym->ts.u.derived && CLASS_DATA (sym)
18730 19074 : && CLASS_DATA (sym)->attr.coarray_comp))
18731 1653926 : || (class_attr.codimension && class_attr.allocatable))
18732 694 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
18733 : {
18734 3 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
18735 : "allocatable coarray or have coarray components",
18736 : sym->name, &sym->declared_at);
18737 3 : return;
18738 : }
18739 :
18740 1654016 : if (class_attr.codimension && sym->attr.dummy
18741 469 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
18742 : {
18743 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
18744 : "procedure %qs", sym->name, &sym->declared_at,
18745 : sym->ns->proc_name->name);
18746 2 : return;
18747 : }
18748 :
18749 1654014 : if (sym->ts.type == BT_LOGICAL
18750 111987 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
18751 111984 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
18752 30954 : && sym->ns->proc_name->attr.is_bind_c)))
18753 : {
18754 : int i;
18755 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
18756 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
18757 : break;
18758 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
18759 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
18760 : "%L with non-C_Bool kind in BIND(C) procedure "
18761 : "%qs", sym->name, &sym->declared_at,
18762 13 : sym->ns->proc_name->name))
18763 : return;
18764 167 : else if (!gfc_logical_kinds[i].c_bool
18765 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
18766 : "%qs at %L with non-C_Bool kind in "
18767 : "BIND(C) procedure %qs", sym->name,
18768 : &sym->declared_at,
18769 15 : sym->attr.function ? sym->name
18770 13 : : sym->ns->proc_name->name))
18771 : return;
18772 : }
18773 :
18774 1654011 : switch (sym->attr.flavor)
18775 : {
18776 645836 : case FL_VARIABLE:
18777 645836 : if (!resolve_fl_variable (sym, mp_flag))
18778 : return;
18779 : break;
18780 :
18781 472500 : case FL_PROCEDURE:
18782 472500 : if (sym->formal && !sym->formal_ns)
18783 : {
18784 : /* Check that none of the arguments are a namelist. */
18785 : gfc_formal_arglist *formal = sym->formal;
18786 :
18787 104696 : for (; formal; formal = formal->next)
18788 71122 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
18789 : {
18790 1 : gfc_error ("Namelist %qs cannot be an argument to "
18791 : "subroutine or function at %L",
18792 : formal->sym->name, &sym->declared_at);
18793 1 : return;
18794 : }
18795 : }
18796 :
18797 472499 : if (!resolve_fl_procedure (sym, mp_flag))
18798 : return;
18799 : break;
18800 :
18801 835 : case FL_NAMELIST:
18802 835 : if (!resolve_fl_namelist (sym))
18803 : return;
18804 : break;
18805 :
18806 380687 : case FL_PARAMETER:
18807 380687 : if (!resolve_fl_parameter (sym))
18808 : return;
18809 : break;
18810 :
18811 : default:
18812 : break;
18813 : }
18814 :
18815 : /* Resolve array specifier. Check as well some constraints
18816 : on COMMON blocks. */
18817 :
18818 1653814 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
18819 :
18820 1653814 : resolve_symbol_array_spec (sym, check_constant);
18821 :
18822 : /* Resolve formal namespaces. */
18823 1653814 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
18824 258799 : && !sym->attr.contained && !sym->attr.intrinsic)
18825 233825 : gfc_resolve (sym->formal_ns);
18826 :
18827 : /* Make sure the formal namespace is present. */
18828 1653814 : if (sym->formal && !sym->formal_ns)
18829 : {
18830 : gfc_formal_arglist *formal = sym->formal;
18831 34000 : while (formal && !formal->sym)
18832 11 : formal = formal->next;
18833 :
18834 33989 : if (formal)
18835 : {
18836 33978 : sym->formal_ns = formal->sym->ns;
18837 33978 : if (sym->formal_ns && sym->ns != formal->sym->ns)
18838 25710 : sym->formal_ns->refs++;
18839 : }
18840 : }
18841 :
18842 : /* Check threadprivate restrictions. */
18843 1653814 : if ((sym->attr.threadprivate || sym->attr.omp_groupprivate)
18844 384 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
18845 33 : && !(sym->ns->save_all && !sym->attr.automatic)
18846 32 : && sym->module == NULL
18847 17 : && (sym->ns->proc_name == NULL
18848 17 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18849 4 : && !sym->ns->proc_name->attr.is_main_program)))
18850 : {
18851 2 : if (sym->attr.threadprivate)
18852 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
18853 : else
18854 1 : gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE "
18855 : "attribute", sym->name, &sym->declared_at);
18856 : }
18857 :
18858 1653814 : if (sym->attr.omp_groupprivate && sym->value)
18859 2 : gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an "
18860 : "initializer", sym->name, &sym->declared_at);
18861 :
18862 : /* Check omp declare target restrictions. */
18863 1653814 : if ((sym->attr.omp_declare_target
18864 1652402 : || sym->attr.omp_declare_target_link
18865 1652354 : || sym->attr.omp_declare_target_local)
18866 1500 : && !sym->attr.omp_groupprivate /* already warned. */
18867 1453 : && sym->attr.flavor == FL_VARIABLE
18868 612 : && !sym->attr.save
18869 199 : && !(sym->ns->save_all && !sym->attr.automatic)
18870 199 : && (!sym->attr.in_common
18871 186 : && sym->module == NULL
18872 96 : && (sym->ns->proc_name == NULL
18873 96 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18874 6 : && !sym->ns->proc_name->attr.is_main_program))))
18875 4 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
18876 : sym->name, &sym->declared_at);
18877 :
18878 : /* If we have come this far we can apply default-initializers, as
18879 : described in 14.7.5, to those variables that have not already
18880 : been assigned one. */
18881 1653814 : if (sym->ts.type == BT_DERIVED
18882 129261 : && !sym->value
18883 104511 : && !sym->attr.allocatable
18884 101602 : && !sym->attr.alloc_comp)
18885 : {
18886 101544 : symbol_attribute *a = &sym->attr;
18887 :
18888 101544 : if ((!a->save && !a->dummy && !a->pointer
18889 55638 : && !a->in_common && !a->use_assoc
18890 10190 : && a->referenced
18891 7986 : && !((a->function || a->result)
18892 1556 : && (!a->dimension
18893 130 : || sym->ts.u.derived->attr.alloc_comp
18894 89 : || sym->ts.u.derived->attr.pointer_comp))
18895 6505 : && !(a->function && sym != sym->result))
18896 95059 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
18897 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
18898 7914 : apply_default_init (sym);
18899 93630 : else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
18900 2667 : && sym->result)
18901 : /* Default initialization for function results. */
18902 2663 : apply_default_init (sym->result);
18903 90967 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
18904 11537 : && (sym->ts.u.derived->attr.alloc_comp
18905 11095 : || sym->ts.u.derived->attr.pointer_comp))
18906 : /* Mark the result symbol to be referenced, when it has allocatable
18907 : components. */
18908 501 : sym->result->attr.referenced = 1;
18909 : }
18910 :
18911 1653814 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
18912 18582 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
18913 1226 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
18914 1151 : && !CLASS_DATA (sym)->attr.class_pointer
18915 1125 : && !CLASS_DATA (sym)->attr.allocatable)
18916 853 : apply_default_init (sym);
18917 :
18918 : /* If this symbol has a type-spec, check it. */
18919 1653814 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
18920 627401 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
18921 1342967 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
18922 : return;
18923 :
18924 1653811 : if (sym->param_list)
18925 1291 : resolve_pdt (sym);
18926 : }
18927 :
18928 :
18929 3918 : void gfc_resolve_symbol (gfc_symbol *sym)
18930 : {
18931 3918 : resolve_symbol (sym);
18932 3918 : return;
18933 : }
18934 :
18935 :
18936 : /************* Resolve DATA statements *************/
18937 :
18938 : static struct
18939 : {
18940 : gfc_data_value *vnode;
18941 : mpz_t left;
18942 : }
18943 : values;
18944 :
18945 :
18946 : /* Advance the values structure to point to the next value in the data list. */
18947 :
18948 : static bool
18949 10892 : next_data_value (void)
18950 : {
18951 16660 : while (mpz_cmp_ui (values.left, 0) == 0)
18952 : {
18953 :
18954 8198 : if (values.vnode->next == NULL)
18955 : return false;
18956 :
18957 5768 : values.vnode = values.vnode->next;
18958 5768 : mpz_set (values.left, values.vnode->repeat);
18959 : }
18960 :
18961 : return true;
18962 : }
18963 :
18964 :
18965 : static bool
18966 3557 : check_data_variable (gfc_data_variable *var, locus *where)
18967 : {
18968 3557 : gfc_expr *e;
18969 3557 : mpz_t size;
18970 3557 : mpz_t offset;
18971 3557 : bool t;
18972 3557 : ar_type mark = AR_UNKNOWN;
18973 3557 : int i;
18974 3557 : mpz_t section_index[GFC_MAX_DIMENSIONS];
18975 3557 : int vector_offset[GFC_MAX_DIMENSIONS];
18976 3557 : gfc_ref *ref;
18977 3557 : gfc_array_ref *ar;
18978 3557 : gfc_symbol *sym;
18979 3557 : int has_pointer;
18980 :
18981 3557 : if (!gfc_resolve_expr (var->expr))
18982 : return false;
18983 :
18984 3557 : ar = NULL;
18985 3557 : e = var->expr;
18986 :
18987 3557 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
18988 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
18989 0 : e = e->value.function.actual->expr;
18990 :
18991 3557 : if (e->expr_type != EXPR_VARIABLE)
18992 : {
18993 0 : gfc_error ("Expecting definable entity near %L", where);
18994 0 : return false;
18995 : }
18996 :
18997 3557 : sym = e->symtree->n.sym;
18998 :
18999 3557 : if (sym->ns->is_block_data && !sym->attr.in_common)
19000 : {
19001 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
19002 : sym->name, &sym->declared_at);
19003 2 : return false;
19004 : }
19005 :
19006 3555 : if (e->ref == NULL && sym->as)
19007 : {
19008 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
19009 : " declaration", sym->name, where);
19010 1 : return false;
19011 : }
19012 :
19013 3554 : if (gfc_is_coindexed (e))
19014 : {
19015 7 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
19016 : where);
19017 7 : return false;
19018 : }
19019 :
19020 3547 : has_pointer = sym->attr.pointer;
19021 :
19022 5988 : for (ref = e->ref; ref; ref = ref->next)
19023 : {
19024 2445 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
19025 : has_pointer = 1;
19026 :
19027 2419 : if (has_pointer)
19028 : {
19029 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
19030 : {
19031 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
19032 : "be a full array", sym->name, where);
19033 1 : return false;
19034 : }
19035 :
19036 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
19037 : {
19038 1 : gfc_error ("DATA object near %L has the pointer attribute "
19039 : "and the corresponding DATA value is not a valid "
19040 : "initial-data-target", where);
19041 1 : return false;
19042 : }
19043 : }
19044 :
19045 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
19046 : {
19047 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
19048 : "attribute", ref->u.c.component->name, &e->where);
19049 1 : return false;
19050 : }
19051 :
19052 : /* Reject substrings of strings of non-constant length. */
19053 2442 : if (ref->type == REF_SUBSTRING
19054 73 : && ref->u.ss.length
19055 73 : && ref->u.ss.length->length
19056 2515 : && !gfc_is_constant_expr (ref->u.ss.length->length))
19057 1 : goto bad_charlen;
19058 : }
19059 :
19060 : /* Reject strings with deferred length or non-constant length. */
19061 3543 : if (e->ts.type == BT_CHARACTER
19062 3543 : && (e->ts.deferred
19063 374 : || (e->ts.u.cl->length
19064 323 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
19065 5 : goto bad_charlen;
19066 :
19067 3538 : mpz_init_set_si (offset, 0);
19068 :
19069 3538 : if (e->rank == 0 || has_pointer)
19070 : {
19071 2691 : mpz_init_set_ui (size, 1);
19072 2691 : ref = NULL;
19073 : }
19074 : else
19075 : {
19076 847 : ref = e->ref;
19077 :
19078 : /* Find the array section reference. */
19079 1030 : for (ref = e->ref; ref; ref = ref->next)
19080 : {
19081 1030 : if (ref->type != REF_ARRAY)
19082 92 : continue;
19083 938 : if (ref->u.ar.type == AR_ELEMENT)
19084 91 : continue;
19085 : break;
19086 : }
19087 847 : gcc_assert (ref);
19088 :
19089 : /* Set marks according to the reference pattern. */
19090 847 : switch (ref->u.ar.type)
19091 : {
19092 : case AR_FULL:
19093 : mark = AR_FULL;
19094 : break;
19095 :
19096 151 : case AR_SECTION:
19097 151 : ar = &ref->u.ar;
19098 : /* Get the start position of array section. */
19099 151 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
19100 151 : mark = AR_SECTION;
19101 151 : break;
19102 :
19103 0 : default:
19104 0 : gcc_unreachable ();
19105 : }
19106 :
19107 847 : if (!gfc_array_size (e, &size))
19108 : {
19109 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
19110 : where);
19111 1 : mpz_clear (offset);
19112 1 : return false;
19113 : }
19114 : }
19115 :
19116 3537 : t = true;
19117 :
19118 11937 : while (mpz_cmp_ui (size, 0) > 0)
19119 : {
19120 8463 : if (!next_data_value ())
19121 : {
19122 1 : gfc_error ("DATA statement at %L has more variables than values",
19123 : where);
19124 1 : t = false;
19125 1 : break;
19126 : }
19127 :
19128 8462 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
19129 8462 : if (!t)
19130 : break;
19131 :
19132 : /* If we have more than one element left in the repeat count,
19133 : and we have more than one element left in the target variable,
19134 : then create a range assignment. */
19135 : /* FIXME: Only done for full arrays for now, since array sections
19136 : seem tricky. */
19137 8443 : if (mark == AR_FULL && ref && ref->next == NULL
19138 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
19139 : {
19140 137 : mpz_t range;
19141 :
19142 137 : if (mpz_cmp (size, values.left) >= 0)
19143 : {
19144 126 : mpz_init_set (range, values.left);
19145 126 : mpz_sub (size, size, values.left);
19146 126 : mpz_set_ui (values.left, 0);
19147 : }
19148 : else
19149 : {
19150 11 : mpz_init_set (range, size);
19151 11 : mpz_sub (values.left, values.left, size);
19152 11 : mpz_set_ui (size, 0);
19153 : }
19154 :
19155 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19156 : offset, &range);
19157 :
19158 137 : mpz_add (offset, offset, range);
19159 137 : mpz_clear (range);
19160 :
19161 137 : if (!t)
19162 : break;
19163 129 : }
19164 :
19165 : /* Assign initial value to symbol. */
19166 : else
19167 : {
19168 8306 : mpz_sub_ui (values.left, values.left, 1);
19169 8306 : mpz_sub_ui (size, size, 1);
19170 :
19171 8306 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19172 : offset, NULL);
19173 8306 : if (!t)
19174 : break;
19175 :
19176 8271 : if (mark == AR_FULL)
19177 5259 : mpz_add_ui (offset, offset, 1);
19178 :
19179 : /* Modify the array section indexes and recalculate the offset
19180 : for next element. */
19181 3012 : else if (mark == AR_SECTION)
19182 366 : gfc_advance_section (section_index, ar, &offset, vector_offset);
19183 : }
19184 : }
19185 :
19186 3537 : if (mark == AR_SECTION)
19187 : {
19188 344 : for (i = 0; i < ar->dimen; i++)
19189 194 : mpz_clear (section_index[i]);
19190 : }
19191 :
19192 3537 : mpz_clear (size);
19193 3537 : mpz_clear (offset);
19194 :
19195 3537 : return t;
19196 :
19197 6 : bad_charlen:
19198 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19199 : &e->where);
19200 6 : return false;
19201 : }
19202 :
19203 :
19204 : static bool traverse_data_var (gfc_data_variable *, locus *);
19205 :
19206 : /* Iterate over a list of elements in a DATA statement. */
19207 :
19208 : static bool
19209 237 : traverse_data_list (gfc_data_variable *var, locus *where)
19210 : {
19211 237 : mpz_t trip;
19212 237 : iterator_stack frame;
19213 237 : gfc_expr *e, *start, *end, *step;
19214 237 : bool retval = true;
19215 :
19216 237 : mpz_init (frame.value);
19217 237 : mpz_init (trip);
19218 :
19219 237 : start = gfc_copy_expr (var->iter.start);
19220 237 : end = gfc_copy_expr (var->iter.end);
19221 237 : step = gfc_copy_expr (var->iter.step);
19222 :
19223 237 : if (!gfc_simplify_expr (start, 1)
19224 237 : || start->expr_type != EXPR_CONSTANT)
19225 : {
19226 0 : gfc_error ("start of implied-do loop at %L could not be "
19227 : "simplified to a constant value", &start->where);
19228 0 : retval = false;
19229 0 : goto cleanup;
19230 : }
19231 237 : if (!gfc_simplify_expr (end, 1)
19232 237 : || end->expr_type != EXPR_CONSTANT)
19233 : {
19234 0 : gfc_error ("end of implied-do loop at %L could not be "
19235 : "simplified to a constant value", &end->where);
19236 0 : retval = false;
19237 0 : goto cleanup;
19238 : }
19239 237 : if (!gfc_simplify_expr (step, 1)
19240 237 : || step->expr_type != EXPR_CONSTANT)
19241 : {
19242 0 : gfc_error ("step of implied-do loop at %L could not be "
19243 : "simplified to a constant value", &step->where);
19244 0 : retval = false;
19245 0 : goto cleanup;
19246 : }
19247 237 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19248 : {
19249 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19250 : &step->where);
19251 1 : retval = false;
19252 1 : goto cleanup;
19253 : }
19254 :
19255 236 : mpz_set (trip, end->value.integer);
19256 236 : mpz_sub (trip, trip, start->value.integer);
19257 236 : mpz_add (trip, trip, step->value.integer);
19258 :
19259 236 : mpz_div (trip, trip, step->value.integer);
19260 :
19261 236 : mpz_set (frame.value, start->value.integer);
19262 :
19263 236 : frame.prev = iter_stack;
19264 236 : frame.variable = var->iter.var->symtree;
19265 236 : iter_stack = &frame;
19266 :
19267 1127 : while (mpz_cmp_ui (trip, 0) > 0)
19268 : {
19269 905 : if (!traverse_data_var (var->list, where))
19270 : {
19271 14 : retval = false;
19272 14 : goto cleanup;
19273 : }
19274 :
19275 891 : e = gfc_copy_expr (var->expr);
19276 891 : if (!gfc_simplify_expr (e, 1))
19277 : {
19278 0 : gfc_free_expr (e);
19279 0 : retval = false;
19280 0 : goto cleanup;
19281 : }
19282 :
19283 891 : mpz_add (frame.value, frame.value, step->value.integer);
19284 :
19285 891 : mpz_sub_ui (trip, trip, 1);
19286 : }
19287 :
19288 222 : cleanup:
19289 237 : mpz_clear (frame.value);
19290 237 : mpz_clear (trip);
19291 :
19292 237 : gfc_free_expr (start);
19293 237 : gfc_free_expr (end);
19294 237 : gfc_free_expr (step);
19295 :
19296 237 : iter_stack = frame.prev;
19297 237 : return retval;
19298 : }
19299 :
19300 :
19301 : /* Type resolve variables in the variable list of a DATA statement. */
19302 :
19303 : static bool
19304 3418 : traverse_data_var (gfc_data_variable *var, locus *where)
19305 : {
19306 3418 : bool t;
19307 :
19308 7114 : for (; var; var = var->next)
19309 : {
19310 3794 : if (var->expr == NULL)
19311 237 : t = traverse_data_list (var, where);
19312 : else
19313 3557 : t = check_data_variable (var, where);
19314 :
19315 3794 : if (!t)
19316 : return false;
19317 : }
19318 :
19319 : return true;
19320 : }
19321 :
19322 :
19323 : /* Resolve the expressions and iterators associated with a data statement.
19324 : This is separate from the assignment checking because data lists should
19325 : only be resolved once. */
19326 :
19327 : static bool
19328 2668 : resolve_data_variables (gfc_data_variable *d)
19329 : {
19330 5707 : for (; d; d = d->next)
19331 : {
19332 3044 : if (d->list == NULL)
19333 : {
19334 2891 : if (!gfc_resolve_expr (d->expr))
19335 : return false;
19336 : }
19337 : else
19338 : {
19339 153 : if (!gfc_resolve_iterator (&d->iter, false, true))
19340 : return false;
19341 :
19342 150 : if (!resolve_data_variables (d->list))
19343 : return false;
19344 : }
19345 : }
19346 :
19347 : return true;
19348 : }
19349 :
19350 :
19351 : /* Resolve a single DATA statement. We implement this by storing a pointer to
19352 : the value list into static variables, and then recursively traversing the
19353 : variables list, expanding iterators and such. */
19354 :
19355 : static void
19356 2518 : resolve_data (gfc_data *d)
19357 : {
19358 :
19359 2518 : if (!resolve_data_variables (d->var))
19360 : return;
19361 :
19362 2513 : values.vnode = d->value;
19363 2513 : if (d->value == NULL)
19364 0 : mpz_set_ui (values.left, 0);
19365 : else
19366 2513 : mpz_set (values.left, d->value->repeat);
19367 :
19368 2513 : if (!traverse_data_var (d->var, &d->where))
19369 : return;
19370 :
19371 : /* At this point, we better not have any values left. */
19372 :
19373 2429 : if (next_data_value ())
19374 0 : gfc_error ("DATA statement at %L has more values than variables",
19375 : &d->where);
19376 : }
19377 :
19378 :
19379 : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
19380 : accessed by host or use association, is a dummy argument to a pure function,
19381 : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
19382 : is storage associated with any such variable, shall not be used in the
19383 : following contexts: (clients of this function). */
19384 :
19385 : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
19386 : procedure. Returns zero if assignment is OK, nonzero if there is a
19387 : problem. */
19388 : bool
19389 54799 : gfc_impure_variable (gfc_symbol *sym)
19390 : {
19391 54799 : gfc_symbol *proc;
19392 54799 : gfc_namespace *ns;
19393 :
19394 54799 : if (sym->attr.use_assoc || sym->attr.in_common)
19395 : return 1;
19396 :
19397 : /* The namespace of a module procedure interface holds the arguments and
19398 : symbols, and so the symbol namespace can be different to that of the
19399 : procedure. */
19400 54187 : if (sym->ns != gfc_current_ns
19401 5813 : && gfc_current_ns->proc_name->abr_modproc_decl
19402 36 : && sym->ns->proc_name->attr.function
19403 12 : && sym->attr.result
19404 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
19405 : return 0;
19406 :
19407 : /* Check if the symbol's ns is inside the pure procedure. */
19408 58807 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19409 : {
19410 58519 : if (ns == sym->ns)
19411 : break;
19412 6119 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
19413 5060 : && !(sym->attr.function || sym->attr.result))
19414 : return 1;
19415 : }
19416 :
19417 52688 : proc = sym->ns->proc_name;
19418 52688 : if (sym->attr.dummy
19419 5830 : && !sym->attr.value
19420 5708 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
19421 5505 : || proc->attr.function))
19422 691 : return 1;
19423 :
19424 : /* TODO: Sort out what can be storage associated, if anything, and include
19425 : it here. In principle equivalences should be scanned but it does not
19426 : seem to be possible to storage associate an impure variable this way. */
19427 : return 0;
19428 : }
19429 :
19430 :
19431 : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
19432 : current namespace is inside a pure procedure. */
19433 :
19434 : bool
19435 2298256 : gfc_pure (gfc_symbol *sym)
19436 : {
19437 2298256 : symbol_attribute attr;
19438 2298256 : gfc_namespace *ns;
19439 :
19440 2298256 : if (sym == NULL)
19441 : {
19442 : /* Check if the current namespace or one of its parents
19443 : belongs to a pure procedure. */
19444 3152229 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19445 : {
19446 1861461 : sym = ns->proc_name;
19447 1861461 : if (sym == NULL)
19448 : return 0;
19449 1860323 : attr = sym->attr;
19450 1860323 : if (attr.flavor == FL_PROCEDURE && attr.pure)
19451 : return 1;
19452 : }
19453 : return 0;
19454 : }
19455 :
19456 999207 : attr = sym->attr;
19457 :
19458 999207 : return attr.flavor == FL_PROCEDURE && attr.pure;
19459 : }
19460 :
19461 :
19462 : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
19463 : checks if the current namespace is implicitly pure. Note that this
19464 : function returns false for a PURE procedure. */
19465 :
19466 : bool
19467 719260 : gfc_implicit_pure (gfc_symbol *sym)
19468 : {
19469 719260 : gfc_namespace *ns;
19470 :
19471 719260 : if (sym == NULL)
19472 : {
19473 : /* Check if the current procedure is implicit_pure. Walk up
19474 : the procedure list until we find a procedure. */
19475 991007 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19476 : {
19477 707398 : sym = ns->proc_name;
19478 707398 : if (sym == NULL)
19479 : return 0;
19480 :
19481 707325 : if (sym->attr.flavor == FL_PROCEDURE)
19482 : break;
19483 : }
19484 : }
19485 :
19486 435575 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
19487 746110 : && !sym->attr.pure;
19488 : }
19489 :
19490 :
19491 : void
19492 421113 : gfc_unset_implicit_pure (gfc_symbol *sym)
19493 : {
19494 421113 : gfc_namespace *ns;
19495 :
19496 421113 : if (sym == NULL)
19497 : {
19498 : /* Check if the current procedure is implicit_pure. Walk up
19499 : the procedure list until we find a procedure. */
19500 688360 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19501 : {
19502 425669 : sym = ns->proc_name;
19503 425669 : if (sym == NULL)
19504 : return;
19505 :
19506 424839 : if (sym->attr.flavor == FL_PROCEDURE)
19507 : break;
19508 : }
19509 : }
19510 :
19511 420283 : if (sym->attr.flavor == FL_PROCEDURE)
19512 149450 : sym->attr.implicit_pure = 0;
19513 : else
19514 270833 : sym->attr.pure = 0;
19515 : }
19516 :
19517 :
19518 : /* Test whether the current procedure is elemental or not. */
19519 :
19520 : bool
19521 1340173 : gfc_elemental (gfc_symbol *sym)
19522 : {
19523 1340173 : symbol_attribute attr;
19524 :
19525 1340173 : if (sym == NULL)
19526 0 : sym = gfc_current_ns->proc_name;
19527 0 : if (sym == NULL)
19528 : return 0;
19529 1340173 : attr = sym->attr;
19530 :
19531 1340173 : return attr.flavor == FL_PROCEDURE && attr.elemental;
19532 : }
19533 :
19534 :
19535 : /* Warn about unused labels. */
19536 :
19537 : static void
19538 4656 : warn_unused_fortran_label (gfc_st_label *label)
19539 : {
19540 4682 : if (label == NULL)
19541 : return;
19542 :
19543 27 : warn_unused_fortran_label (label->left);
19544 :
19545 27 : if (label->defined == ST_LABEL_UNKNOWN)
19546 : return;
19547 :
19548 26 : switch (label->referenced)
19549 : {
19550 2 : case ST_LABEL_UNKNOWN:
19551 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
19552 : label->value, &label->where);
19553 2 : break;
19554 :
19555 1 : case ST_LABEL_BAD_TARGET:
19556 1 : gfc_warning (OPT_Wunused_label,
19557 : "Label %d at %L defined but cannot be used",
19558 : label->value, &label->where);
19559 1 : break;
19560 :
19561 : default:
19562 : break;
19563 : }
19564 :
19565 26 : warn_unused_fortran_label (label->right);
19566 : }
19567 :
19568 :
19569 : /* Returns the sequence type of a symbol or sequence. */
19570 :
19571 : static seq_type
19572 1076 : sequence_type (gfc_typespec ts)
19573 : {
19574 1076 : seq_type result;
19575 1076 : gfc_component *c;
19576 :
19577 1076 : switch (ts.type)
19578 : {
19579 49 : case BT_DERIVED:
19580 :
19581 49 : if (ts.u.derived->components == NULL)
19582 : return SEQ_NONDEFAULT;
19583 :
19584 49 : result = sequence_type (ts.u.derived->components->ts);
19585 103 : for (c = ts.u.derived->components->next; c; c = c->next)
19586 67 : if (sequence_type (c->ts) != result)
19587 : return SEQ_MIXED;
19588 :
19589 : return result;
19590 :
19591 129 : case BT_CHARACTER:
19592 129 : if (ts.kind != gfc_default_character_kind)
19593 0 : return SEQ_NONDEFAULT;
19594 :
19595 : return SEQ_CHARACTER;
19596 :
19597 240 : case BT_INTEGER:
19598 240 : if (ts.kind != gfc_default_integer_kind)
19599 25 : return SEQ_NONDEFAULT;
19600 :
19601 : return SEQ_NUMERIC;
19602 :
19603 559 : case BT_REAL:
19604 559 : if (!(ts.kind == gfc_default_real_kind
19605 269 : || ts.kind == gfc_default_double_kind))
19606 0 : return SEQ_NONDEFAULT;
19607 :
19608 : return SEQ_NUMERIC;
19609 :
19610 81 : case BT_COMPLEX:
19611 81 : if (ts.kind != gfc_default_complex_kind)
19612 48 : return SEQ_NONDEFAULT;
19613 :
19614 : return SEQ_NUMERIC;
19615 :
19616 17 : case BT_LOGICAL:
19617 17 : if (ts.kind != gfc_default_logical_kind)
19618 0 : return SEQ_NONDEFAULT;
19619 :
19620 : return SEQ_NUMERIC;
19621 :
19622 : default:
19623 : return SEQ_NONDEFAULT;
19624 : }
19625 : }
19626 :
19627 :
19628 : /* Resolve derived type EQUIVALENCE object. */
19629 :
19630 : static bool
19631 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
19632 : {
19633 80 : gfc_component *c = derived->components;
19634 :
19635 80 : if (!derived)
19636 : return true;
19637 :
19638 : /* Shall not be an object of nonsequence derived type. */
19639 80 : if (!derived->attr.sequence)
19640 : {
19641 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
19642 : "attribute to be an EQUIVALENCE object", sym->name,
19643 : &e->where);
19644 0 : return false;
19645 : }
19646 :
19647 : /* Shall not have allocatable components. */
19648 80 : if (derived->attr.alloc_comp)
19649 : {
19650 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
19651 : "components to be an EQUIVALENCE object",sym->name,
19652 : &e->where);
19653 1 : return false;
19654 : }
19655 :
19656 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
19657 : {
19658 1 : gfc_error ("Derived type variable %qs at %L with default "
19659 : "initialization cannot be in EQUIVALENCE with a variable "
19660 : "in COMMON", sym->name, &e->where);
19661 1 : return false;
19662 : }
19663 :
19664 245 : for (; c ; c = c->next)
19665 : {
19666 167 : if (gfc_bt_struct (c->ts.type)
19667 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
19668 : return false;
19669 :
19670 : /* Shall not be an object of sequence derived type containing a pointer
19671 : in the structure. */
19672 167 : if (c->attr.pointer)
19673 : {
19674 0 : gfc_error ("Derived type variable %qs at %L with pointer "
19675 : "component(s) cannot be an EQUIVALENCE object",
19676 : sym->name, &e->where);
19677 0 : return false;
19678 : }
19679 : }
19680 : return true;
19681 : }
19682 :
19683 :
19684 : /* Resolve equivalence object.
19685 : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
19686 : an allocatable array, an object of nonsequence derived type, an object of
19687 : sequence derived type containing a pointer at any level of component
19688 : selection, an automatic object, a function name, an entry name, a result
19689 : name, a named constant, a structure component, or a subobject of any of
19690 : the preceding objects. A substring shall not have length zero. A
19691 : derived type shall not have components with default initialization nor
19692 : shall two objects of an equivalence group be initialized.
19693 : Either all or none of the objects shall have an protected attribute.
19694 : The simple constraints are done in symbol.cc(check_conflict) and the rest
19695 : are implemented here. */
19696 :
19697 : static void
19698 1565 : resolve_equivalence (gfc_equiv *eq)
19699 : {
19700 1565 : gfc_symbol *sym;
19701 1565 : gfc_symbol *first_sym;
19702 1565 : gfc_expr *e;
19703 1565 : gfc_ref *r;
19704 1565 : locus *last_where = NULL;
19705 1565 : seq_type eq_type, last_eq_type;
19706 1565 : gfc_typespec *last_ts;
19707 1565 : int object, cnt_protected;
19708 1565 : const char *msg;
19709 :
19710 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
19711 :
19712 1565 : first_sym = eq->expr->symtree->n.sym;
19713 :
19714 1565 : cnt_protected = 0;
19715 :
19716 4727 : for (object = 1; eq; eq = eq->eq, object++)
19717 : {
19718 3171 : e = eq->expr;
19719 :
19720 3171 : e->ts = e->symtree->n.sym->ts;
19721 : /* match_varspec might not know yet if it is seeing
19722 : array reference or substring reference, as it doesn't
19723 : know the types. */
19724 3171 : if (e->ref && e->ref->type == REF_ARRAY)
19725 : {
19726 2152 : gfc_ref *ref = e->ref;
19727 2152 : sym = e->symtree->n.sym;
19728 :
19729 2152 : if (sym->attr.dimension)
19730 : {
19731 1855 : ref->u.ar.as = sym->as;
19732 1855 : ref = ref->next;
19733 : }
19734 :
19735 : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
19736 2152 : if (e->ts.type == BT_CHARACTER
19737 592 : && ref
19738 371 : && ref->type == REF_ARRAY
19739 371 : && ref->u.ar.dimen == 1
19740 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
19741 371 : && ref->u.ar.stride[0] == NULL)
19742 : {
19743 370 : gfc_expr *start = ref->u.ar.start[0];
19744 370 : gfc_expr *end = ref->u.ar.end[0];
19745 370 : void *mem = NULL;
19746 :
19747 : /* Optimize away the (:) reference. */
19748 370 : if (start == NULL && end == NULL)
19749 : {
19750 9 : if (e->ref == ref)
19751 0 : e->ref = ref->next;
19752 : else
19753 9 : e->ref->next = ref->next;
19754 : mem = ref;
19755 : }
19756 : else
19757 : {
19758 361 : ref->type = REF_SUBSTRING;
19759 361 : if (start == NULL)
19760 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
19761 : NULL, 1);
19762 361 : ref->u.ss.start = start;
19763 361 : if (end == NULL && e->ts.u.cl)
19764 27 : end = gfc_copy_expr (e->ts.u.cl->length);
19765 361 : ref->u.ss.end = end;
19766 361 : ref->u.ss.length = e->ts.u.cl;
19767 361 : e->ts.u.cl = NULL;
19768 : }
19769 370 : ref = ref->next;
19770 370 : free (mem);
19771 : }
19772 :
19773 : /* Any further ref is an error. */
19774 1930 : if (ref)
19775 : {
19776 1 : gcc_assert (ref->type == REF_ARRAY);
19777 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
19778 : &ref->u.ar.where);
19779 1 : continue;
19780 : }
19781 : }
19782 :
19783 3170 : if (!gfc_resolve_expr (e))
19784 2 : continue;
19785 :
19786 3168 : sym = e->symtree->n.sym;
19787 :
19788 3168 : if (sym->attr.is_protected)
19789 2 : cnt_protected++;
19790 3168 : if (cnt_protected > 0 && cnt_protected != object)
19791 : {
19792 2 : gfc_error ("Either all or none of the objects in the "
19793 : "EQUIVALENCE set at %L shall have the "
19794 : "PROTECTED attribute",
19795 : &e->where);
19796 2 : break;
19797 : }
19798 :
19799 : /* Shall not equivalence common block variables in a PURE procedure. */
19800 3166 : if (sym->ns->proc_name
19801 3150 : && sym->ns->proc_name->attr.pure
19802 7 : && sym->attr.in_common)
19803 : {
19804 : /* Need to check for symbols that may have entered the pure
19805 : procedure via a USE statement. */
19806 7 : bool saw_sym = false;
19807 7 : if (sym->ns->use_stmts)
19808 : {
19809 6 : gfc_use_rename *r;
19810 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
19811 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
19812 : }
19813 : else
19814 : saw_sym = true;
19815 :
19816 6 : if (saw_sym)
19817 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
19818 : "EQUIVALENCE object in the pure procedure %qs",
19819 : sym->name, &e->where, sym->ns->proc_name->name);
19820 : break;
19821 : }
19822 :
19823 : /* Shall not be a named constant. */
19824 3159 : if (e->expr_type == EXPR_CONSTANT)
19825 : {
19826 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
19827 : "object", sym->name, &e->where);
19828 0 : continue;
19829 : }
19830 :
19831 3161 : if (e->ts.type == BT_DERIVED
19832 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
19833 2 : continue;
19834 :
19835 : /* Check that the types correspond correctly:
19836 : Note 5.28:
19837 : A numeric sequence structure may be equivalenced to another sequence
19838 : structure, an object of default integer type, default real type, double
19839 : precision real type, default logical type such that components of the
19840 : structure ultimately only become associated to objects of the same
19841 : kind. A character sequence structure may be equivalenced to an object
19842 : of default character kind or another character sequence structure.
19843 : Other objects may be equivalenced only to objects of the same type and
19844 : kind parameters. */
19845 :
19846 : /* Identical types are unconditionally OK. */
19847 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
19848 2677 : goto identical_types;
19849 :
19850 480 : last_eq_type = sequence_type (*last_ts);
19851 480 : eq_type = sequence_type (sym->ts);
19852 :
19853 : /* Since the pair of objects is not of the same type, mixed or
19854 : non-default sequences can be rejected. */
19855 :
19856 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
19857 : "statement at %L with different type objects");
19858 481 : if ((object ==2
19859 480 : && last_eq_type == SEQ_MIXED
19860 7 : && last_where
19861 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19862 486 : || (eq_type == SEQ_MIXED
19863 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19864 1 : continue;
19865 :
19866 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
19867 : "statement at %L with objects of different type");
19868 483 : if ((object ==2
19869 479 : && last_eq_type == SEQ_NONDEFAULT
19870 50 : && last_where
19871 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19872 525 : || (eq_type == SEQ_NONDEFAULT
19873 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19874 4 : continue;
19875 :
19876 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
19877 : "EQUIVALENCE statement at %L");
19878 479 : if (last_eq_type == SEQ_CHARACTER
19879 475 : && eq_type != SEQ_CHARACTER
19880 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19881 4 : continue;
19882 :
19883 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
19884 : "EQUIVALENCE statement at %L");
19885 473 : if (last_eq_type == SEQ_NUMERIC
19886 471 : && eq_type != SEQ_NUMERIC
19887 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19888 2 : continue;
19889 :
19890 3146 : identical_types:
19891 :
19892 3146 : last_ts =&sym->ts;
19893 3146 : last_where = &e->where;
19894 :
19895 3146 : if (!e->ref)
19896 1003 : continue;
19897 :
19898 : /* Shall not be an automatic array. */
19899 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
19900 : {
19901 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
19902 : "an EQUIVALENCE object", sym->name, &e->where);
19903 3 : continue;
19904 : }
19905 :
19906 2140 : r = e->ref;
19907 4326 : while (r)
19908 : {
19909 : /* Shall not be a structure component. */
19910 2187 : if (r->type == REF_COMPONENT)
19911 : {
19912 0 : gfc_error ("Structure component %qs at %L cannot be an "
19913 : "EQUIVALENCE object",
19914 0 : r->u.c.component->name, &e->where);
19915 0 : break;
19916 : }
19917 :
19918 : /* A substring shall not have length zero. */
19919 2187 : if (r->type == REF_SUBSTRING)
19920 : {
19921 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
19922 : {
19923 1 : gfc_error ("Substring at %L has length zero",
19924 : &r->u.ss.start->where);
19925 1 : break;
19926 : }
19927 : }
19928 2186 : r = r->next;
19929 : }
19930 : }
19931 1565 : }
19932 :
19933 :
19934 : /* Function called by resolve_fntype to flag other symbols used in the
19935 : length type parameter specification of function results. */
19936 :
19937 : static bool
19938 4136 : flag_fn_result_spec (gfc_expr *expr,
19939 : gfc_symbol *sym,
19940 : int *f ATTRIBUTE_UNUSED)
19941 : {
19942 4136 : gfc_namespace *ns;
19943 4136 : gfc_symbol *s;
19944 :
19945 4136 : if (expr->expr_type == EXPR_VARIABLE)
19946 : {
19947 1378 : s = expr->symtree->n.sym;
19948 2153 : for (ns = s->ns; ns; ns = ns->parent)
19949 2153 : if (!ns->parent)
19950 : break;
19951 :
19952 1378 : if (sym == s)
19953 : {
19954 1 : gfc_error ("Self reference in character length expression "
19955 : "for %qs at %L", sym->name, &expr->where);
19956 1 : return true;
19957 : }
19958 :
19959 1377 : if (!s->fn_result_spec
19960 1377 : && s->attr.flavor == FL_PARAMETER)
19961 : {
19962 : /* Function contained in a module.... */
19963 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
19964 : {
19965 32 : gfc_symtree *st;
19966 32 : s->fn_result_spec = 1;
19967 : /* Make sure that this symbol is translated as a module
19968 : variable. */
19969 32 : st = gfc_get_unique_symtree (ns);
19970 32 : st->n.sym = s;
19971 32 : s->refs++;
19972 32 : }
19973 : /* ... which is use associated and called. */
19974 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
19975 0 : ||
19976 : /* External function matched with an interface. */
19977 0 : (s->ns->proc_name
19978 0 : && ((s->ns == ns
19979 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
19980 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
19981 0 : && s->ns->proc_name->attr.function))
19982 31 : s->fn_result_spec = 1;
19983 : }
19984 : }
19985 : return false;
19986 : }
19987 :
19988 :
19989 : /* Resolve function and ENTRY types, issue diagnostics if needed. */
19990 :
19991 : static void
19992 341858 : resolve_fntype (gfc_namespace *ns)
19993 : {
19994 341858 : gfc_entry_list *el;
19995 341858 : gfc_symbol *sym;
19996 :
19997 341858 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
19998 : return;
19999 :
20000 : /* If there are any entries, ns->proc_name is the entry master
20001 : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
20002 178235 : if (ns->entries)
20003 564 : sym = ns->entries->sym;
20004 : else
20005 : sym = ns->proc_name;
20006 178235 : if (sym->result == sym
20007 143265 : && sym->ts.type == BT_UNKNOWN
20008 6 : && !gfc_set_default_type (sym, 0, NULL)
20009 178239 : && !sym->attr.untyped)
20010 : {
20011 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
20012 : sym->name, &sym->declared_at);
20013 3 : sym->attr.untyped = 1;
20014 : }
20015 :
20016 13513 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
20017 1761 : && !sym->attr.contained
20018 291 : && !gfc_check_symbol_access (sym->ts.u.derived)
20019 178235 : && gfc_check_symbol_access (sym))
20020 : {
20021 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
20022 : "%L of PRIVATE type %qs", sym->name,
20023 0 : &sym->declared_at, sym->ts.u.derived->name);
20024 : }
20025 :
20026 178235 : if (ns->entries)
20027 1189 : for (el = ns->entries->next; el; el = el->next)
20028 : {
20029 625 : if (el->sym->result == el->sym
20030 413 : && el->sym->ts.type == BT_UNKNOWN
20031 2 : && !gfc_set_default_type (el->sym, 0, NULL)
20032 627 : && !el->sym->attr.untyped)
20033 : {
20034 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
20035 : el->sym->name, &el->sym->declared_at);
20036 2 : el->sym->attr.untyped = 1;
20037 : }
20038 : }
20039 :
20040 178235 : if (sym->ts.type == BT_CHARACTER
20041 6876 : && sym->ts.u.cl->length
20042 1788 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
20043 1783 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
20044 : }
20045 :
20046 :
20047 : /* 12.3.2.1.1 Defined operators. */
20048 :
20049 : static bool
20050 452 : check_uop_procedure (gfc_symbol *sym, locus where)
20051 : {
20052 452 : gfc_formal_arglist *formal;
20053 :
20054 452 : if (!sym->attr.function)
20055 : {
20056 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
20057 : sym->name, &where);
20058 4 : return false;
20059 : }
20060 :
20061 448 : if (sym->ts.type == BT_CHARACTER
20062 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
20063 2 : && !(sym->result && ((sym->result->ts.u.cl
20064 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
20065 : {
20066 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
20067 : "character length", sym->name, &where);
20068 2 : return false;
20069 : }
20070 :
20071 446 : formal = gfc_sym_get_dummy_args (sym);
20072 446 : if (!formal || !formal->sym)
20073 : {
20074 1 : gfc_error ("User operator procedure %qs at %L must have at least "
20075 : "one argument", sym->name, &where);
20076 1 : return false;
20077 : }
20078 :
20079 445 : if (formal->sym->attr.intent != INTENT_IN)
20080 : {
20081 0 : gfc_error ("First argument of operator interface at %L must be "
20082 : "INTENT(IN)", &where);
20083 0 : return false;
20084 : }
20085 :
20086 445 : if (formal->sym->attr.optional)
20087 : {
20088 0 : gfc_error ("First argument of operator interface at %L cannot be "
20089 : "optional", &where);
20090 0 : return false;
20091 : }
20092 :
20093 445 : formal = formal->next;
20094 445 : if (!formal || !formal->sym)
20095 : return true;
20096 :
20097 295 : if (formal->sym->attr.intent != INTENT_IN)
20098 : {
20099 0 : gfc_error ("Second argument of operator interface at %L must be "
20100 : "INTENT(IN)", &where);
20101 0 : return false;
20102 : }
20103 :
20104 295 : if (formal->sym->attr.optional)
20105 : {
20106 1 : gfc_error ("Second argument of operator interface at %L cannot be "
20107 : "optional", &where);
20108 1 : return false;
20109 : }
20110 :
20111 294 : if (formal->next)
20112 : {
20113 2 : gfc_error ("Operator interface at %L must have, at most, two "
20114 : "arguments", &where);
20115 2 : return false;
20116 : }
20117 :
20118 : return true;
20119 : }
20120 :
20121 : static void
20122 342618 : gfc_resolve_uops (gfc_symtree *symtree)
20123 : {
20124 342618 : gfc_interface *itr;
20125 :
20126 342618 : if (symtree == NULL)
20127 : return;
20128 :
20129 380 : gfc_resolve_uops (symtree->left);
20130 380 : gfc_resolve_uops (symtree->right);
20131 :
20132 773 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
20133 393 : check_uop_procedure (itr->sym, itr->sym->declared_at);
20134 : }
20135 :
20136 :
20137 : /* Examine all of the expressions associated with a program unit,
20138 : assign types to all intermediate expressions, make sure that all
20139 : assignments are to compatible types and figure out which names
20140 : refer to which functions or subroutines. It doesn't check code
20141 : block, which is handled by gfc_resolve_code. */
20142 :
20143 : static void
20144 344340 : resolve_types (gfc_namespace *ns)
20145 : {
20146 344340 : gfc_namespace *n;
20147 344340 : gfc_charlen *cl;
20148 344340 : gfc_data *d;
20149 344340 : gfc_equiv *eq;
20150 344340 : gfc_namespace* old_ns = gfc_current_ns;
20151 344340 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
20152 :
20153 344340 : if (ns->types_resolved)
20154 : return;
20155 :
20156 : /* Check that all IMPLICIT types are ok. */
20157 341859 : if (!ns->seen_implicit_none)
20158 : {
20159 : unsigned letter;
20160 8601985 : for (letter = 0; letter != GFC_LETTERS; ++letter)
20161 8283393 : if (ns->set_flag[letter]
20162 8283393 : && !resolve_typespec_used (&ns->default_type[letter],
20163 : &ns->implicit_loc[letter], NULL))
20164 : return;
20165 : }
20166 :
20167 341858 : gfc_current_ns = ns;
20168 :
20169 341858 : resolve_entries (ns);
20170 :
20171 341858 : resolve_common_vars (&ns->blank_common, false);
20172 341858 : resolve_common_blocks (ns->common_root);
20173 :
20174 341858 : resolve_contained_functions (ns);
20175 :
20176 341858 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
20177 292344 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
20178 191258 : gfc_resolve_formal_arglist (ns->proc_name);
20179 :
20180 341858 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
20181 :
20182 436500 : for (cl = ns->cl_list; cl; cl = cl->next)
20183 94642 : resolve_charlen (cl);
20184 :
20185 341858 : gfc_traverse_ns (ns, resolve_symbol);
20186 :
20187 341858 : resolve_fntype (ns);
20188 :
20189 389289 : for (n = ns->contained; n; n = n->sibling)
20190 : {
20191 : /* Exclude final wrappers with the test for the artificial attribute. */
20192 47431 : if (gfc_pure (ns->proc_name)
20193 5 : && !gfc_pure (n->proc_name)
20194 47431 : && !n->proc_name->attr.artificial)
20195 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20196 : "also be PURE", n->proc_name->name,
20197 : &n->proc_name->declared_at);
20198 :
20199 47431 : resolve_types (n);
20200 : }
20201 :
20202 341858 : forall_flag = 0;
20203 341858 : gfc_do_concurrent_flag = 0;
20204 341858 : gfc_check_interfaces (ns);
20205 :
20206 341858 : gfc_traverse_ns (ns, resolve_values);
20207 :
20208 341858 : if (ns->save_all || (!flag_automatic && !recursive))
20209 313 : gfc_save_all (ns);
20210 :
20211 341858 : iter_stack = NULL;
20212 344376 : for (d = ns->data; d; d = d->next)
20213 2518 : resolve_data (d);
20214 :
20215 341858 : iter_stack = NULL;
20216 341858 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20217 :
20218 341858 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20219 :
20220 343423 : for (eq = ns->equiv; eq; eq = eq->next)
20221 1565 : resolve_equivalence (eq);
20222 :
20223 : /* Warn about unused labels. */
20224 341858 : if (warn_unused_label)
20225 4629 : warn_unused_fortran_label (ns->st_labels);
20226 :
20227 341858 : gfc_resolve_uops (ns->uop_root);
20228 :
20229 341858 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20230 :
20231 341858 : gfc_resolve_omp_declare (ns);
20232 :
20233 341858 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20234 :
20235 341858 : ns->types_resolved = 1;
20236 :
20237 341858 : gfc_current_ns = old_ns;
20238 : }
20239 :
20240 :
20241 : /* Call gfc_resolve_code recursively. */
20242 :
20243 : static void
20244 344396 : resolve_codes (gfc_namespace *ns)
20245 : {
20246 344396 : gfc_namespace *n;
20247 344396 : bitmap_obstack old_obstack;
20248 :
20249 344396 : if (ns->resolved == 1)
20250 13767 : return;
20251 :
20252 378116 : for (n = ns->contained; n; n = n->sibling)
20253 47487 : resolve_codes (n);
20254 :
20255 330629 : gfc_current_ns = ns;
20256 :
20257 : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20258 330629 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20259 318639 : cs_base = NULL;
20260 :
20261 : /* Set to an out of range value. */
20262 330629 : current_entry_id = -1;
20263 :
20264 330629 : old_obstack = labels_obstack;
20265 330629 : bitmap_obstack_initialize (&labels_obstack);
20266 :
20267 330629 : gfc_resolve_oacc_declare (ns);
20268 330629 : gfc_resolve_oacc_routines (ns);
20269 330629 : gfc_resolve_omp_local_vars (ns);
20270 330629 : if (ns->omp_allocate)
20271 62 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20272 330629 : gfc_resolve_code (ns->code, ns);
20273 :
20274 330628 : bitmap_obstack_release (&labels_obstack);
20275 330628 : labels_obstack = old_obstack;
20276 : }
20277 :
20278 :
20279 : /* This function is called after a complete program unit has been compiled.
20280 : Its purpose is to examine all of the expressions associated with a program
20281 : unit, assign types to all intermediate expressions, make sure that all
20282 : assignments are to compatible types and figure out which names refer to
20283 : which functions or subroutines. */
20284 :
20285 : void
20286 301458 : gfc_resolve (gfc_namespace *ns)
20287 : {
20288 301458 : gfc_namespace *old_ns;
20289 301458 : code_stack *old_cs_base;
20290 301458 : struct gfc_omp_saved_state old_omp_state;
20291 :
20292 301458 : if (ns->resolved)
20293 4549 : return;
20294 :
20295 296909 : ns->resolved = -1;
20296 296909 : old_ns = gfc_current_ns;
20297 296909 : old_cs_base = cs_base;
20298 :
20299 : /* As gfc_resolve can be called during resolution of an OpenMP construct
20300 : body, we should clear any state associated to it, so that say NS's
20301 : DO loops are not interpreted as OpenMP loops. */
20302 296909 : if (!ns->construct_entities)
20303 284919 : gfc_omp_save_and_clear_state (&old_omp_state);
20304 :
20305 296909 : resolve_types (ns);
20306 296909 : component_assignment_level = 0;
20307 296909 : resolve_codes (ns);
20308 :
20309 296908 : if (ns->omp_assumes)
20310 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
20311 :
20312 296908 : gfc_current_ns = old_ns;
20313 296908 : cs_base = old_cs_base;
20314 296908 : ns->resolved = 1;
20315 :
20316 296908 : gfc_run_passes (ns);
20317 :
20318 296908 : if (!ns->construct_entities)
20319 284918 : gfc_omp_restore_state (&old_omp_state);
20320 : }
|
