Line data Source code
1 : /* Perform type resolution on the various structures.
2 : Copyright (C) 2001-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : #include "config.h"
22 : #include "system.h"
23 : #include "coretypes.h"
24 : #include "options.h"
25 : #include "bitmap.h"
26 : #include "gfortran.h"
27 : #include "arith.h" /* For gfc_compare_expr(). */
28 : #include "dependency.h"
29 : #include "data.h"
30 : #include "target-memory.h" /* for gfc_simplify_transfer */
31 : #include "constructor.h"
32 :
33 : /* Types used in equivalence statements. */
34 :
35 : enum seq_type
36 : {
37 : SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 : };
39 :
40 : /* Stack to keep track of the nesting of blocks as we move through the
41 : code. See resolve_branch() and gfc_resolve_code(). */
42 :
43 : typedef struct code_stack
44 : {
45 : struct gfc_code *head, *current;
46 : struct code_stack *prev;
47 :
48 : /* This bitmap keeps track of the targets valid for a branch from
49 : inside this block except for END {IF|SELECT}s of enclosing
50 : blocks. */
51 : bitmap reachable_labels;
52 : }
53 : code_stack;
54 :
55 : static code_stack *cs_base = NULL;
56 :
57 : struct check_default_none_data
58 : {
59 : gfc_code *code;
60 : hash_set<gfc_symbol *> *sym_hash;
61 : gfc_namespace *ns;
62 : bool default_none;
63 : };
64 :
65 : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
66 :
67 : static int forall_flag;
68 : int gfc_do_concurrent_flag;
69 :
70 : /* True when we are resolving an expression that is an actual argument to
71 : a procedure. */
72 : static bool actual_arg = false;
73 : /* True when we are resolving an expression that is the first actual argument
74 : to a procedure. */
75 : static bool first_actual_arg = false;
76 :
77 :
78 : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
79 :
80 : static int omp_workshare_flag;
81 :
82 :
83 : /* True if we are resolving a specification expression. */
84 : static bool specification_expr = false;
85 : /* The dummy whose character length or array bounds are currently being
86 : resolved as a specification expression. */
87 : static gfc_symbol *specification_expr_symbol = NULL;
88 :
89 : /* The id of the last entry seen. */
90 : static int current_entry_id;
91 :
92 : /* We use bitmaps to determine if a branch target is valid. */
93 : static bitmap_obstack labels_obstack;
94 :
95 : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
96 : static bool inquiry_argument = false;
97 :
98 : static bool
99 464 : entry_dummy_seen_p (gfc_symbol *sym)
100 : {
101 464 : gfc_entry_list *entry;
102 464 : gfc_formal_arglist *formal;
103 :
104 464 : gcc_checking_assert (sym->attr.dummy && sym->ns == gfc_current_ns);
105 :
106 464 : for (entry = gfc_current_ns->entries;
107 471 : entry && entry->id <= current_entry_id;
108 7 : entry = entry->next)
109 765 : for (formal = entry->sym->formal; formal; formal = formal->next)
110 758 : if (formal->sym && sym->name == formal->sym->name)
111 : return true;
112 :
113 : return false;
114 : }
115 :
116 :
117 : /* Is the symbol host associated? */
118 : static bool
119 53333 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
120 : {
121 58190 : for (ns = ns->parent; ns; ns = ns->parent)
122 : {
123 5115 : if (sym->ns == ns)
124 : return true;
125 : }
126 :
127 : return false;
128 : }
129 :
130 : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
131 : an ABSTRACT derived-type. If where is not NULL, an error message with that
132 : locus is printed, optionally using name. */
133 :
134 : static bool
135 1588415 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
136 : {
137 1588415 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
138 : {
139 5 : if (where)
140 : {
141 5 : if (name)
142 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
143 : name, where, ts->u.derived->name);
144 : else
145 1 : gfc_error ("ABSTRACT type %qs used at %L",
146 : ts->u.derived->name, where);
147 : }
148 :
149 5 : return false;
150 : }
151 :
152 : return true;
153 : }
154 :
155 :
156 : static bool
157 5644 : check_proc_interface (gfc_symbol *ifc, locus *where)
158 : {
159 : /* Several checks for F08:C1216. */
160 5644 : if (ifc->attr.procedure)
161 : {
162 2 : gfc_error ("Interface %qs at %L is declared "
163 : "in a later PROCEDURE statement", ifc->name, where);
164 2 : return false;
165 : }
166 5642 : if (ifc->generic)
167 : {
168 : /* For generic interfaces, check if there is
169 : a specific procedure with the same name. */
170 : gfc_interface *gen = ifc->generic;
171 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
172 5 : gen = gen->next;
173 7 : if (!gen)
174 : {
175 4 : gfc_error ("Interface %qs at %L may not be generic",
176 : ifc->name, where);
177 4 : return false;
178 : }
179 : }
180 5638 : if (ifc->attr.proc == PROC_ST_FUNCTION)
181 : {
182 4 : gfc_error ("Interface %qs at %L may not be a statement function",
183 : ifc->name, where);
184 4 : return false;
185 : }
186 5634 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
187 5634 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
188 17 : ifc->attr.intrinsic = 1;
189 5634 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
190 : {
191 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
192 : "PROCEDURE statement at %L", ifc->name, where);
193 3 : return false;
194 : }
195 5631 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
196 : {
197 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
198 7 : return false;
199 : }
200 : return true;
201 : }
202 :
203 :
204 : static void resolve_symbol (gfc_symbol *sym);
205 :
206 :
207 : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
208 :
209 : static bool
210 2116 : resolve_procedure_interface (gfc_symbol *sym)
211 : {
212 2116 : gfc_symbol *ifc = sym->ts.interface;
213 :
214 2116 : if (!ifc)
215 : return true;
216 :
217 1956 : if (ifc == sym)
218 : {
219 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
220 : sym->name, &sym->declared_at);
221 2 : return false;
222 : }
223 1954 : if (!check_proc_interface (ifc, &sym->declared_at))
224 : return false;
225 :
226 1945 : if (ifc->attr.if_source || ifc->attr.intrinsic)
227 : {
228 : /* Resolve interface and copy attributes. */
229 1666 : resolve_symbol (ifc);
230 1666 : if (ifc->attr.intrinsic)
231 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
232 :
233 1666 : if (ifc->result)
234 : {
235 779 : sym->ts = ifc->result->ts;
236 779 : sym->attr.allocatable = ifc->result->attr.allocatable;
237 779 : sym->attr.pointer = ifc->result->attr.pointer;
238 779 : sym->attr.dimension = ifc->result->attr.dimension;
239 779 : sym->attr.class_ok = ifc->result->attr.class_ok;
240 779 : sym->as = gfc_copy_array_spec (ifc->result->as);
241 779 : sym->result = sym;
242 : }
243 : else
244 : {
245 887 : sym->ts = ifc->ts;
246 887 : sym->attr.allocatable = ifc->attr.allocatable;
247 887 : sym->attr.pointer = ifc->attr.pointer;
248 887 : sym->attr.dimension = ifc->attr.dimension;
249 887 : sym->attr.class_ok = ifc->attr.class_ok;
250 887 : sym->as = gfc_copy_array_spec (ifc->as);
251 : }
252 1666 : sym->ts.interface = ifc;
253 1666 : sym->attr.function = ifc->attr.function;
254 1666 : sym->attr.subroutine = ifc->attr.subroutine;
255 :
256 1666 : sym->attr.pure = ifc->attr.pure;
257 1666 : sym->attr.elemental = ifc->attr.elemental;
258 1666 : sym->attr.contiguous = ifc->attr.contiguous;
259 1666 : sym->attr.recursive = ifc->attr.recursive;
260 1666 : sym->attr.always_explicit = ifc->attr.always_explicit;
261 1666 : sym->attr.ext_attr |= ifc->attr.ext_attr;
262 1666 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
263 : /* Copy char length. */
264 1666 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
265 : {
266 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
267 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
268 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
269 : return false;
270 : }
271 : }
272 :
273 : return true;
274 : }
275 :
276 :
277 : /* Resolve types of formal argument lists. These have to be done early so that
278 : the formal argument lists of module procedures can be copied to the
279 : containing module before the individual procedures are resolved
280 : individually. We also resolve argument lists of procedures in interface
281 : blocks because they are self-contained scoping units.
282 :
283 : Since a dummy argument cannot be a non-dummy procedure, the only
284 : resort left for untyped names are the IMPLICIT types. */
285 :
286 : void
287 551240 : gfc_resolve_formal_arglist (gfc_symbol *proc)
288 : {
289 551240 : gfc_formal_arglist *f;
290 551240 : gfc_symbol *sym;
291 551240 : bool saved_specification_expr;
292 551240 : int i;
293 :
294 551240 : if (proc->result != NULL)
295 344303 : sym = proc->result;
296 : else
297 : sym = proc;
298 :
299 551240 : if (gfc_elemental (proc)
300 388688 : || sym->attr.pointer || sym->attr.allocatable
301 927594 : || (sym->as && sym->as->rank != 0))
302 : {
303 177216 : proc->attr.always_explicit = 1;
304 177216 : sym->attr.always_explicit = 1;
305 : }
306 :
307 551240 : gfc_namespace *orig_current_ns = gfc_current_ns;
308 551240 : gfc_current_ns = gfc_get_procedure_ns (proc);
309 :
310 1428214 : for (f = proc->formal; f; f = f->next)
311 : {
312 876976 : gfc_array_spec *as;
313 876976 : gfc_symbol *saved_specification_expr_symbol;
314 :
315 876976 : sym = f->sym;
316 :
317 876976 : if (sym == NULL)
318 : {
319 : /* Alternate return placeholder. */
320 171 : if (gfc_elemental (proc))
321 1 : gfc_error ("Alternate return specifier in elemental subroutine "
322 : "%qs at %L is not allowed", proc->name,
323 : &proc->declared_at);
324 171 : if (proc->attr.function)
325 1 : gfc_error ("Alternate return specifier in function "
326 : "%qs at %L is not allowed", proc->name,
327 : &proc->declared_at);
328 171 : continue;
329 : }
330 :
331 599 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
332 877404 : && !resolve_procedure_interface (sym))
333 : break;
334 :
335 876805 : if (strcmp (proc->name, sym->name) == 0)
336 : {
337 2 : gfc_error ("Self-referential argument "
338 : "%qs at %L is not allowed", sym->name,
339 : &proc->declared_at);
340 2 : break;
341 : }
342 :
343 876803 : if (sym->attr.if_source != IFSRC_UNKNOWN)
344 891 : gfc_resolve_formal_arglist (sym);
345 :
346 876803 : if (sym->attr.subroutine || sym->attr.external)
347 : {
348 901 : if (sym->attr.flavor == FL_UNKNOWN)
349 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
350 : }
351 : else
352 : {
353 875902 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
354 3663 : && (!sym->attr.function || sym->result == sym))
355 3625 : gfc_set_default_type (sym, 1, sym->ns);
356 : }
357 :
358 876803 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
359 890878 : ? CLASS_DATA (sym)->as : sym->as;
360 :
361 876803 : saved_specification_expr = specification_expr;
362 876803 : saved_specification_expr_symbol = specification_expr_symbol;
363 876803 : specification_expr = true;
364 876803 : specification_expr_symbol = sym;
365 876803 : gfc_resolve_array_spec (as, 0);
366 876803 : specification_expr = saved_specification_expr;
367 876803 : specification_expr_symbol = saved_specification_expr_symbol;
368 :
369 : /* We can't tell if an array with dimension (:) is assumed or deferred
370 : shape until we know if it has the pointer or allocatable attributes.
371 : */
372 876803 : if (as && as->rank > 0 && as->type == AS_DEFERRED
373 12442 : && ((sym->ts.type != BT_CLASS
374 11316 : && !(sym->attr.pointer || sym->attr.allocatable))
375 5385 : || (sym->ts.type == BT_CLASS
376 1126 : && !(CLASS_DATA (sym)->attr.class_pointer
377 926 : || CLASS_DATA (sym)->attr.allocatable)))
378 7568 : && sym->attr.flavor != FL_PROCEDURE)
379 : {
380 7567 : as->type = AS_ASSUMED_SHAPE;
381 17579 : for (i = 0; i < as->rank; i++)
382 10012 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
383 : }
384 :
385 138221 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
386 124335 : || (as && as->type == AS_ASSUMED_RANK)
387 823190 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
388 813012 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
389 11860 : && (CLASS_DATA (sym)->attr.class_pointer
390 11377 : || CLASS_DATA (sym)->attr.allocatable
391 10473 : || CLASS_DATA (sym)->attr.target))
392 811625 : || sym->attr.optional)
393 : {
394 80538 : proc->attr.always_explicit = 1;
395 80538 : if (proc->result)
396 36635 : proc->result->attr.always_explicit = 1;
397 : }
398 :
399 : /* If the flavor is unknown at this point, it has to be a variable.
400 : A procedure specification would have already set the type. */
401 :
402 876803 : if (sym->attr.flavor == FL_UNKNOWN)
403 52081 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
404 :
405 876803 : if (gfc_pure (proc))
406 : {
407 327925 : if (sym->attr.flavor == FL_PROCEDURE)
408 : {
409 : /* F08:C1279. */
410 29 : if (!gfc_pure (sym))
411 : {
412 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
413 : "also be PURE", sym->name, &sym->declared_at);
414 1 : continue;
415 : }
416 : }
417 327896 : else if (!sym->attr.pointer)
418 : {
419 327882 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
420 : {
421 111 : if (sym->attr.value)
422 110 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
423 : " of pure function %qs at %L with VALUE "
424 : "attribute but without INTENT(IN)",
425 : sym->name, proc->name, &sym->declared_at);
426 : else
427 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
428 : "be INTENT(IN) or VALUE", sym->name, proc->name,
429 : &sym->declared_at);
430 : }
431 :
432 327882 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
433 : {
434 159 : if (sym->attr.value)
435 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
436 : " of pure subroutine %qs at %L with VALUE "
437 : "attribute but without INTENT", sym->name,
438 : proc->name, &sym->declared_at);
439 : else
440 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
441 : "must have its INTENT specified or have the "
442 : "VALUE attribute", sym->name, proc->name,
443 : &sym->declared_at);
444 : }
445 : }
446 :
447 : /* F08:C1278a. */
448 327924 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
449 : {
450 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
451 : " may not be polymorphic", sym->name, proc->name,
452 : &sym->declared_at);
453 1 : continue;
454 : }
455 : }
456 :
457 876801 : if (proc->attr.implicit_pure)
458 : {
459 25301 : if (sym->attr.flavor == FL_PROCEDURE)
460 : {
461 331 : if (!gfc_pure (sym))
462 299 : proc->attr.implicit_pure = 0;
463 : }
464 24970 : else if (!sym->attr.pointer)
465 : {
466 24189 : if (proc->attr.function && sym->attr.intent != INTENT_IN
467 2747 : && !sym->value)
468 2747 : proc->attr.implicit_pure = 0;
469 :
470 24189 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
471 4211 : && !sym->value)
472 4211 : proc->attr.implicit_pure = 0;
473 : }
474 : }
475 :
476 876801 : if (gfc_elemental (proc))
477 : {
478 : /* F08:C1289. */
479 302300 : if (sym->attr.codimension
480 302299 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
481 965 : && CLASS_DATA (sym)->attr.codimension))
482 : {
483 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
484 : "procedure", sym->name, &sym->declared_at);
485 3 : continue;
486 : }
487 :
488 302297 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
489 963 : && CLASS_DATA (sym)->as))
490 : {
491 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
492 : "be scalar", sym->name, &sym->declared_at);
493 2 : continue;
494 : }
495 :
496 302295 : if (sym->attr.allocatable
497 302294 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
498 962 : && CLASS_DATA (sym)->attr.allocatable))
499 : {
500 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
501 : "have the ALLOCATABLE attribute", sym->name,
502 : &sym->declared_at);
503 2 : continue;
504 : }
505 :
506 302293 : if (sym->attr.pointer
507 302292 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
508 961 : && CLASS_DATA (sym)->attr.class_pointer))
509 : {
510 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
511 : "have the POINTER attribute", sym->name,
512 : &sym->declared_at);
513 2 : continue;
514 : }
515 :
516 302291 : if (sym->attr.flavor == FL_PROCEDURE)
517 : {
518 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
519 : "procedure %qs at %L", sym->name, proc->name,
520 : &sym->declared_at);
521 2 : continue;
522 : }
523 :
524 : /* Fortran 2008 Corrigendum 1, C1290a. */
525 302289 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
526 : {
527 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
528 : "have its INTENT specified or have the VALUE "
529 : "attribute", sym->name, proc->name,
530 : &sym->declared_at);
531 2 : continue;
532 : }
533 : }
534 :
535 : /* Each dummy shall be specified to be scalar. */
536 876788 : if (proc->attr.proc == PROC_ST_FUNCTION)
537 : {
538 307 : if (sym->as != NULL)
539 : {
540 : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
541 : shall be specified, explicitly or implicitly, to be scalar. */
542 1 : gfc_error ("Argument %qs of statement function %qs at %L "
543 : "must be scalar", sym->name, proc->name,
544 : &proc->declared_at);
545 1 : continue;
546 : }
547 :
548 306 : if (sym->ts.type == BT_CHARACTER)
549 : {
550 48 : gfc_charlen *cl = sym->ts.u.cl;
551 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
552 : {
553 0 : gfc_error ("Character-valued argument %qs of statement "
554 : "function at %L must have constant length",
555 : sym->name, &sym->declared_at);
556 0 : continue;
557 : }
558 : }
559 : }
560 : }
561 551240 : if (sym)
562 551148 : sym->formal_resolved = 1;
563 551240 : gfc_current_ns = orig_current_ns;
564 551240 : }
565 :
566 :
567 : /* Work function called when searching for symbols that have argument lists
568 : associated with them. */
569 :
570 : static void
571 1909067 : find_arglists (gfc_symbol *sym)
572 : {
573 1909067 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
574 346354 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
575 : return;
576 :
577 343987 : gfc_resolve_formal_arglist (sym);
578 : }
579 :
580 :
581 : /* Given a namespace, resolve all formal argument lists within the namespace.
582 : */
583 :
584 : static void
585 360463 : resolve_formal_arglists (gfc_namespace *ns)
586 : {
587 0 : if (ns == NULL)
588 : return;
589 :
590 360463 : gfc_traverse_ns (ns, find_arglists);
591 : }
592 :
593 :
594 : static void
595 37608 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
596 : {
597 37608 : bool t;
598 :
599 37608 : if (sym && sym->attr.flavor == FL_PROCEDURE
600 37608 : && sym->ns->parent
601 1446 : && sym->ns->parent->proc_name
602 1446 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
603 0 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
604 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
605 : "encompassing procedure", sym->name, &sym->declared_at);
606 :
607 : /* If this namespace is not a function or an entry master function,
608 : ignore it. */
609 37608 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
610 11046 : || sym->attr.entry_master)
611 26751 : return;
612 :
613 10857 : if (!sym->result)
614 : return;
615 :
616 : /* Try to find out of what the return type is. */
617 10857 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
618 : {
619 57 : t = gfc_set_default_type (sym->result, 0, ns);
620 :
621 57 : if (!t && !sym->result->attr.untyped)
622 : {
623 19 : if (sym->result == sym)
624 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
625 : sym->name, &sym->declared_at);
626 18 : else if (!sym->result->attr.proc_pointer)
627 0 : gfc_error ("Result %qs of contained function %qs at %L has "
628 : "no IMPLICIT type", sym->result->name, sym->name,
629 : &sym->result->declared_at);
630 19 : sym->result->attr.untyped = 1;
631 : }
632 : }
633 :
634 : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
635 : type, lists the only ways a character length value of * can be used:
636 : dummy arguments of procedures, named constants, function results and
637 : in allocate statements if the allocate_object is an assumed length dummy
638 : in external functions. Internal function results and results of module
639 : procedures are not on this list, ergo, not permitted. */
640 :
641 10857 : if (sym->result->ts.type == BT_CHARACTER)
642 : {
643 1211 : gfc_charlen *cl = sym->result->ts.u.cl;
644 1211 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
645 : {
646 : /* See if this is a module-procedure and adapt error message
647 : accordingly. */
648 4 : bool module_proc;
649 4 : gcc_assert (ns->parent && ns->parent->proc_name);
650 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
651 :
652 7 : gfc_error (module_proc
653 : ? G_("Character-valued module procedure %qs at %L"
654 : " must not be assumed length")
655 : : G_("Character-valued internal function %qs at %L"
656 : " must not be assumed length"),
657 : sym->name, &sym->declared_at);
658 : }
659 : }
660 : }
661 :
662 :
663 : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
664 : introduce duplicates. */
665 :
666 : static void
667 1491 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
668 : {
669 1491 : gfc_formal_arglist *f, *new_arglist;
670 1491 : gfc_symbol *new_sym;
671 :
672 2644 : for (; new_args != NULL; new_args = new_args->next)
673 : {
674 1153 : new_sym = new_args->sym;
675 : /* See if this arg is already in the formal argument list. */
676 2186 : for (f = proc->formal; f; f = f->next)
677 : {
678 1481 : if (new_sym == f->sym)
679 : break;
680 : }
681 :
682 1153 : if (f)
683 448 : continue;
684 :
685 : /* Add a new argument. Argument order is not important. */
686 705 : new_arglist = gfc_get_formal_arglist ();
687 705 : new_arglist->sym = new_sym;
688 705 : new_arglist->next = proc->formal;
689 705 : proc->formal = new_arglist;
690 : }
691 1491 : }
692 :
693 :
694 : /* Flag the arguments that are not present in all entries. */
695 :
696 : static void
697 1491 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
698 : {
699 1491 : gfc_formal_arglist *f, *head;
700 1491 : head = new_args;
701 :
702 3086 : for (f = proc->formal; f; f = f->next)
703 : {
704 1595 : if (f->sym == NULL)
705 36 : continue;
706 :
707 2738 : for (new_args = head; new_args; new_args = new_args->next)
708 : {
709 2287 : if (new_args->sym == f->sym)
710 : break;
711 : }
712 :
713 1559 : if (new_args)
714 1108 : continue;
715 :
716 451 : f->sym->attr.not_always_present = 1;
717 : }
718 1491 : }
719 :
720 :
721 : /* Resolve alternate entry points. If a symbol has multiple entry points we
722 : create a new master symbol for the main routine, and turn the existing
723 : symbol into an entry point. */
724 :
725 : static void
726 397564 : resolve_entries (gfc_namespace *ns)
727 : {
728 397564 : gfc_namespace *old_ns;
729 397564 : gfc_code *c;
730 397564 : gfc_symbol *proc;
731 397564 : gfc_entry_list *el;
732 : /* Provide sufficient space to hold "master.%d.%s". */
733 397564 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
734 397564 : static int master_count = 0;
735 :
736 397564 : if (ns->proc_name == NULL)
737 396861 : return;
738 :
739 : /* No need to do anything if this procedure doesn't have alternate entry
740 : points. */
741 397515 : if (!ns->entries)
742 : return;
743 :
744 : /* We may already have resolved alternate entry points. */
745 954 : if (ns->proc_name->attr.entry_master)
746 : return;
747 :
748 : /* If this isn't a procedure something has gone horribly wrong. */
749 703 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
750 :
751 : /* Remember the current namespace. */
752 703 : old_ns = gfc_current_ns;
753 :
754 703 : gfc_current_ns = ns;
755 :
756 : /* Add the main entry point to the list of entry points. */
757 703 : el = gfc_get_entry_list ();
758 703 : el->sym = ns->proc_name;
759 703 : el->id = 0;
760 703 : el->next = ns->entries;
761 703 : ns->entries = el;
762 703 : ns->proc_name->attr.entry = 1;
763 :
764 : /* If it is a module function, it needs to be in the right namespace
765 : so that gfc_get_fake_result_decl can gather up the results. The
766 : need for this arose in get_proc_name, where these beasts were
767 : left in their own namespace, to keep prior references linked to
768 : the entry declaration.*/
769 703 : if (ns->proc_name->attr.function
770 596 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
771 189 : el->sym->ns = ns;
772 :
773 : /* Do the same for entries where the master is not a module
774 : procedure. These are retained in the module namespace because
775 : of the module procedure declaration. */
776 1491 : for (el = el->next; el; el = el->next)
777 788 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
778 0 : && el->sym->attr.mod_proc)
779 0 : el->sym->ns = ns;
780 703 : el = ns->entries;
781 :
782 : /* Add an entry statement for it. */
783 703 : c = gfc_get_code (EXEC_ENTRY);
784 703 : c->ext.entry = el;
785 703 : c->next = ns->code;
786 703 : ns->code = c;
787 :
788 : /* Create a new symbol for the master function. */
789 : /* Give the internal function a unique name (within this file).
790 : Also include the function name so the user has some hope of figuring
791 : out what is going on. */
792 703 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
793 703 : master_count++, ns->proc_name->name);
794 703 : gfc_get_ha_symbol (name, &proc);
795 703 : gcc_assert (proc != NULL);
796 :
797 703 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
798 703 : if (ns->proc_name->attr.subroutine)
799 107 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
800 : else
801 : {
802 596 : gfc_symbol *sym;
803 596 : gfc_typespec *ts, *fts;
804 596 : gfc_array_spec *as, *fas;
805 596 : gfc_add_function (&proc->attr, proc->name, NULL);
806 596 : proc->result = proc;
807 596 : fas = ns->entries->sym->as;
808 596 : fas = fas ? fas : ns->entries->sym->result->as;
809 596 : fts = &ns->entries->sym->result->ts;
810 596 : if (fts->type == BT_UNKNOWN)
811 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
812 1120 : for (el = ns->entries->next; el; el = el->next)
813 : {
814 635 : ts = &el->sym->result->ts;
815 635 : as = el->sym->as;
816 635 : as = as ? as : el->sym->result->as;
817 635 : if (ts->type == BT_UNKNOWN)
818 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
819 :
820 635 : if (! gfc_compare_types (ts, fts)
821 527 : || (el->sym->result->attr.dimension
822 527 : != ns->entries->sym->result->attr.dimension)
823 635 : || (el->sym->result->attr.pointer
824 527 : != ns->entries->sym->result->attr.pointer))
825 : break;
826 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
827 589 : && gfc_compare_array_spec (as, fas) == 0)
828 5 : gfc_error ("Function %s at %L has entries with mismatched "
829 : "array specifications", ns->entries->sym->name,
830 5 : &ns->entries->sym->declared_at);
831 : /* The characteristics need to match and thus both need to have
832 : the same string length, i.e. both len=*, or both len=4.
833 : Having both len=<variable> is also possible, but difficult to
834 : check at compile time. */
835 522 : else if (ts->type == BT_CHARACTER
836 113 : && (el->sym->result->attr.allocatable
837 113 : != ns->entries->sym->result->attr.allocatable))
838 : {
839 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
840 : "characteristics", ns->entries->sym->name,
841 : &ns->entries->sym->declared_at, el->sym->name);
842 3 : goto cleanup;
843 : }
844 519 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
845 110 : && (((ts->u.cl->length && !fts->u.cl->length)
846 109 : ||(!ts->u.cl->length && fts->u.cl->length))
847 90 : || (ts->u.cl->length
848 53 : && ts->u.cl->length->expr_type
849 53 : != fts->u.cl->length->expr_type)
850 90 : || (ts->u.cl->length
851 53 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
852 52 : && mpz_cmp (ts->u.cl->length->value.integer,
853 52 : fts->u.cl->length->value.integer) != 0)))
854 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
855 : "entries returning variables of different "
856 : "string lengths", ns->entries->sym->name,
857 21 : &ns->entries->sym->declared_at);
858 498 : else if (el->sym->result->attr.allocatable
859 498 : != ns->entries->sym->result->attr.allocatable)
860 : break;
861 : }
862 :
863 593 : if (el == NULL)
864 : {
865 485 : sym = ns->entries->sym->result;
866 : /* All result types the same. */
867 485 : proc->ts = *fts;
868 485 : if (sym->attr.dimension)
869 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
870 485 : if (sym->attr.pointer)
871 78 : gfc_add_pointer (&proc->attr, NULL);
872 485 : if (sym->attr.allocatable)
873 24 : gfc_add_allocatable (&proc->attr, NULL);
874 : }
875 : else
876 : {
877 : /* Otherwise the result will be passed through a union by
878 : reference. */
879 108 : proc->attr.mixed_entry_master = 1;
880 346 : for (el = ns->entries; el; el = el->next)
881 : {
882 238 : sym = el->sym->result;
883 238 : if (sym->attr.dimension)
884 : {
885 1 : if (el == ns->entries)
886 0 : gfc_error ("FUNCTION result %s cannot be an array in "
887 : "FUNCTION %s at %L", sym->name,
888 0 : ns->entries->sym->name, &sym->declared_at);
889 : else
890 1 : gfc_error ("ENTRY result %s cannot be an array in "
891 : "FUNCTION %s at %L", sym->name,
892 1 : ns->entries->sym->name, &sym->declared_at);
893 : }
894 237 : else if (sym->attr.pointer)
895 : {
896 1 : if (el == ns->entries)
897 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
898 : "FUNCTION %s at %L", sym->name,
899 1 : ns->entries->sym->name, &sym->declared_at);
900 : else
901 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
902 : "FUNCTION %s at %L", sym->name,
903 0 : ns->entries->sym->name, &sym->declared_at);
904 : }
905 236 : else if (sym->attr.allocatable)
906 : {
907 0 : if (el == ns->entries)
908 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
909 : "FUNCTION %s at %L", sym->name,
910 0 : ns->entries->sym->name, &sym->declared_at);
911 : else
912 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
913 : "FUNCTION %s at %L", sym->name,
914 0 : ns->entries->sym->name, &sym->declared_at);
915 : }
916 : else
917 : {
918 236 : ts = &sym->ts;
919 236 : if (ts->type == BT_UNKNOWN)
920 9 : ts = gfc_get_default_type (sym->name, NULL);
921 236 : switch (ts->type)
922 : {
923 85 : case BT_INTEGER:
924 85 : if (ts->kind == gfc_default_integer_kind)
925 : sym = NULL;
926 : break;
927 100 : case BT_REAL:
928 100 : if (ts->kind == gfc_default_real_kind
929 18 : || ts->kind == gfc_default_double_kind)
930 : sym = NULL;
931 : break;
932 20 : case BT_COMPLEX:
933 20 : if (ts->kind == gfc_default_complex_kind)
934 : sym = NULL;
935 : break;
936 28 : case BT_LOGICAL:
937 28 : if (ts->kind == gfc_default_logical_kind)
938 : sym = NULL;
939 : break;
940 : case BT_UNKNOWN:
941 : /* We will issue error elsewhere. */
942 : sym = NULL;
943 : break;
944 : default:
945 : break;
946 : }
947 3 : if (sym)
948 : {
949 3 : if (el == ns->entries)
950 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
951 : "in FUNCTION %s at %L", sym->name,
952 1 : gfc_typename (ts), ns->entries->sym->name,
953 : &sym->declared_at);
954 : else
955 2 : gfc_error ("ENTRY result %s cannot be of type %s "
956 : "in FUNCTION %s at %L", sym->name,
957 2 : gfc_typename (ts), ns->entries->sym->name,
958 : &sym->declared_at);
959 : }
960 : }
961 : }
962 : }
963 : }
964 :
965 108 : cleanup:
966 703 : proc->attr.access = ACCESS_PRIVATE;
967 703 : proc->attr.entry_master = 1;
968 :
969 : /* Merge all the entry point arguments. */
970 2194 : for (el = ns->entries; el; el = el->next)
971 1491 : merge_argument_lists (proc, el->sym->formal);
972 :
973 : /* Check the master formal arguments for any that are not
974 : present in all entry points. */
975 2194 : for (el = ns->entries; el; el = el->next)
976 1491 : check_argument_lists (proc, el->sym->formal);
977 :
978 : /* Use the master function for the function body. */
979 703 : ns->proc_name = proc;
980 :
981 : /* Finalize the new symbols. */
982 703 : gfc_commit_symbols ();
983 :
984 : /* Restore the original namespace. */
985 703 : gfc_current_ns = old_ns;
986 : }
987 :
988 :
989 : /* Forward declaration. */
990 : static bool is_non_constant_shape_array (gfc_symbol *sym);
991 :
992 :
993 : /* Resolve common variables. */
994 : static void
995 362440 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
996 : {
997 362440 : gfc_symbol *csym = common_block->head;
998 362440 : gfc_gsymbol *gsym;
999 :
1000 368492 : for (; csym; csym = csym->common_next)
1001 : {
1002 6052 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
1003 6052 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
1004 : {
1005 3 : if (csym->common_block)
1006 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1007 : "COMMON block at %L", gsym->name,
1008 : &gsym->where, &csym->common_block->where);
1009 : else
1010 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
1011 : "COMMON block", gsym->name, &gsym->where);
1012 : }
1013 :
1014 : /* gfc_add_in_common may have been called before, but the reported errors
1015 : have been ignored to continue parsing.
1016 : We do the checks again here, unless the symbol is USE associated. */
1017 6052 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
1018 : {
1019 5779 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
1020 5779 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
1021 : &common_block->where);
1022 : }
1023 :
1024 6052 : if (csym->value || csym->attr.data)
1025 : {
1026 149 : if (!csym->ns->is_block_data)
1027 33 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1028 : "but only in BLOCK DATA initialization is "
1029 : "allowed", csym->name, &csym->declared_at);
1030 116 : else if (!named_common)
1031 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1032 : "in a blank COMMON but initialization is only "
1033 : "allowed in named common blocks", csym->name,
1034 : &csym->declared_at);
1035 : }
1036 :
1037 6052 : if (UNLIMITED_POLY (csym))
1038 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1039 : "[F2008:C5100]", csym->name, &csym->declared_at);
1040 :
1041 6052 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1042 : {
1043 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1044 : "COMMON at %L", csym->name, &csym->declared_at,
1045 : &common_block->where);
1046 : /* Avoid confusing follow-on error. */
1047 1 : csym->error = 1;
1048 : }
1049 :
1050 6052 : if (csym->ts.type != BT_DERIVED)
1051 6005 : continue;
1052 :
1053 47 : if (!(csym->ts.u.derived->attr.sequence
1054 3 : || csym->ts.u.derived->attr.is_bind_c))
1055 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1056 : "has neither the SEQUENCE nor the BIND(C) "
1057 : "attribute", csym->name, &csym->declared_at);
1058 47 : if (csym->ts.u.derived->attr.alloc_comp)
1059 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1060 : "has an ultimate component that is "
1061 : "allocatable", csym->name, &csym->declared_at);
1062 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1063 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1064 : "may not have default initializer", csym->name,
1065 : &csym->declared_at);
1066 :
1067 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1068 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1069 : }
1070 362440 : }
1071 :
1072 : /* Resolve common blocks. */
1073 : static void
1074 360993 : resolve_common_blocks (gfc_symtree *common_root)
1075 : {
1076 360993 : gfc_symbol *sym = NULL;
1077 360993 : gfc_gsymbol * gsym;
1078 :
1079 360993 : if (common_root == NULL)
1080 360871 : return;
1081 :
1082 1977 : if (common_root->left)
1083 257 : resolve_common_blocks (common_root->left);
1084 1977 : if (common_root->right)
1085 273 : resolve_common_blocks (common_root->right);
1086 :
1087 1977 : resolve_common_vars (common_root->n.common, true);
1088 :
1089 : /* The common name is a global name - in Fortran 2003 also if it has a
1090 : C binding name, since Fortran 2008 only the C binding name is a global
1091 : identifier. */
1092 1977 : if (!common_root->n.common->binding_label
1093 1977 : || gfc_notification_std (GFC_STD_F2008))
1094 : {
1095 3810 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1096 1905 : common_root->n.common->name);
1097 :
1098 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1099 14 : && gsym->type == GSYM_COMMON
1100 1918 : && ((common_root->n.common->binding_label
1101 6 : && (!gsym->binding_label
1102 0 : || strcmp (common_root->n.common->binding_label,
1103 : gsym->binding_label) != 0))
1104 7 : || (!common_root->n.common->binding_label
1105 7 : && gsym->binding_label)))
1106 : {
1107 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1108 : "identifier and must thus have the same binding name "
1109 : "as the same-named COMMON block at %L: %s vs %s",
1110 6 : common_root->n.common->name, &common_root->n.common->where,
1111 : &gsym->where,
1112 : common_root->n.common->binding_label
1113 : ? common_root->n.common->binding_label : "(blank)",
1114 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1115 6 : return;
1116 : }
1117 :
1118 1899 : if (gsym && gsym->type != GSYM_COMMON
1119 1 : && !common_root->n.common->binding_label)
1120 : {
1121 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1122 : "as entity at %L",
1123 0 : common_root->n.common->name, &common_root->n.common->where,
1124 : &gsym->where);
1125 0 : return;
1126 : }
1127 814 : if (gsym && gsym->type != GSYM_COMMON)
1128 : {
1129 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1130 : "%L sharing the identifier with global non-COMMON-block "
1131 1 : "entity at %L", common_root->n.common->name,
1132 1 : &common_root->n.common->where, &gsym->where);
1133 1 : return;
1134 : }
1135 1085 : if (!gsym)
1136 : {
1137 1085 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1138 1085 : gsym->type = GSYM_COMMON;
1139 1085 : gsym->where = common_root->n.common->where;
1140 1085 : gsym->defined = 1;
1141 : }
1142 1898 : gsym->used = 1;
1143 : }
1144 :
1145 1970 : if (common_root->n.common->binding_label)
1146 : {
1147 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1148 : common_root->n.common->binding_label);
1149 76 : if (gsym && gsym->type != GSYM_COMMON)
1150 : {
1151 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1152 : "global identifier as entity at %L",
1153 : &common_root->n.common->where,
1154 1 : common_root->n.common->binding_label, &gsym->where);
1155 1 : return;
1156 : }
1157 57 : if (!gsym)
1158 : {
1159 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1160 57 : gsym->type = GSYM_COMMON;
1161 57 : gsym->where = common_root->n.common->where;
1162 57 : gsym->defined = 1;
1163 : }
1164 75 : gsym->used = 1;
1165 : }
1166 :
1167 1969 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1168 1969 : if (sym == NULL)
1169 : return;
1170 :
1171 122 : if (sym->attr.flavor == FL_PARAMETER)
1172 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1173 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1174 :
1175 122 : if (sym->attr.external)
1176 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1177 1 : sym->name, &common_root->n.common->where);
1178 :
1179 122 : if (sym->attr.intrinsic)
1180 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1181 2 : sym->name, &common_root->n.common->where);
1182 120 : else if (sym->attr.result
1183 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1184 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1185 : "that is also a function result", sym->name,
1186 1 : &common_root->n.common->where);
1187 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1188 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1189 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1190 : "that is also a global procedure", sym->name,
1191 3 : &common_root->n.common->where);
1192 : }
1193 :
1194 :
1195 : /* Resolve contained function types. Because contained functions can call one
1196 : another, they have to be worked out before any of the contained procedures
1197 : can be resolved.
1198 :
1199 : The good news is that if a function doesn't already have a type, the only
1200 : way it can get one is through an IMPLICIT type or a RESULT variable, because
1201 : by definition contained functions are contained namespace they're contained
1202 : in, not in a sibling or parent namespace. */
1203 :
1204 : static void
1205 360463 : resolve_contained_functions (gfc_namespace *ns)
1206 : {
1207 360463 : gfc_namespace *child;
1208 360463 : gfc_entry_list *el;
1209 :
1210 360463 : resolve_formal_arglists (ns);
1211 :
1212 397564 : for (child = ns->contained; child; child = child->sibling)
1213 : {
1214 : /* Resolve alternate entry points first. */
1215 37101 : resolve_entries (child);
1216 :
1217 : /* Then check function return types. */
1218 37101 : resolve_contained_fntype (child->proc_name, child);
1219 37608 : for (el = child->entries; el; el = el->next)
1220 507 : resolve_contained_fntype (el->sym, child);
1221 : }
1222 360463 : }
1223 :
1224 :
1225 :
1226 : /* A Parameterized Derived Type constructor must contain values for
1227 : the PDT KIND parameters or they must have a default initializer.
1228 : Go through the constructor picking out the KIND expressions,
1229 : storing them in 'param_list' and then call gfc_get_pdt_instance
1230 : to obtain the PDT instance. */
1231 :
1232 : static gfc_actual_arglist *param_list, *param_tail, *param;
1233 :
1234 : static bool
1235 308 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1236 : {
1237 308 : param = gfc_get_actual_arglist ();
1238 308 : if (!param_list)
1239 252 : param_list = param_tail = param;
1240 : else
1241 : {
1242 56 : param_tail->next = param;
1243 56 : param_tail = param_tail->next;
1244 : }
1245 :
1246 308 : param_tail->name = c->name;
1247 308 : if (expr)
1248 308 : param_tail->expr = gfc_copy_expr (expr);
1249 0 : else if (c->initializer)
1250 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1251 : else
1252 : {
1253 0 : param_tail->spec_type = SPEC_ASSUMED;
1254 0 : if (c->attr.pdt_kind)
1255 : {
1256 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1257 : "at %C has no value", param->name);
1258 0 : return false;
1259 : }
1260 : }
1261 :
1262 : return true;
1263 : }
1264 :
1265 : static bool
1266 288 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1267 : gfc_symbol *derived)
1268 : {
1269 288 : gfc_constructor *cons = NULL;
1270 288 : gfc_component *comp;
1271 288 : bool t = true;
1272 :
1273 288 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1274 252 : cons = gfc_constructor_first (expr->value.constructor);
1275 36 : else if (constr)
1276 36 : cons = *constr;
1277 288 : gcc_assert (cons);
1278 :
1279 288 : comp = derived->components;
1280 :
1281 880 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1282 : {
1283 592 : if (cons->expr
1284 592 : && cons->expr->expr_type == EXPR_STRUCTURE
1285 0 : && comp->ts.type == BT_DERIVED)
1286 : {
1287 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1288 0 : if (!t)
1289 : return t;
1290 : }
1291 592 : else if (comp->ts.type == BT_DERIVED)
1292 : {
1293 36 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1294 36 : if (!t)
1295 : return t;
1296 : }
1297 556 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1298 308 : && derived->attr.pdt_template)
1299 : {
1300 308 : t = get_pdt_spec_expr (comp, cons->expr);
1301 308 : if (!t)
1302 : return t;
1303 : }
1304 : }
1305 : return t;
1306 : }
1307 :
1308 :
1309 : static bool resolve_fl_derived0 (gfc_symbol *sym);
1310 : static bool resolve_fl_struct (gfc_symbol *sym);
1311 :
1312 :
1313 : /* Resolve all of the elements of a structure constructor and make sure that
1314 : the types are correct. The 'init' flag indicates that the given
1315 : constructor is an initializer. */
1316 :
1317 : static bool
1318 63651 : resolve_structure_cons (gfc_expr *expr, int init)
1319 : {
1320 63651 : gfc_constructor *cons;
1321 63651 : gfc_component *comp;
1322 63651 : bool t;
1323 63651 : symbol_attribute a;
1324 :
1325 63651 : t = true;
1326 :
1327 63651 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1328 : {
1329 60751 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1330 60601 : resolve_fl_derived0 (expr->ts.u.derived);
1331 : else
1332 150 : resolve_fl_struct (expr->ts.u.derived);
1333 :
1334 : /* If this is a Parameterized Derived Type template, find the
1335 : instance corresponding to the PDT kind parameters. */
1336 60751 : if (expr->ts.u.derived->attr.pdt_template)
1337 : {
1338 252 : param_list = NULL;
1339 252 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1340 252 : if (!t)
1341 : return t;
1342 252 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1343 :
1344 252 : expr->param_list = gfc_copy_actual_arglist (param_list);
1345 :
1346 252 : if (param_list)
1347 252 : gfc_free_actual_arglist (param_list);
1348 :
1349 252 : if (!expr->ts.u.derived->attr.pdt_type)
1350 : return false;
1351 : }
1352 : }
1353 :
1354 : /* A constructor may have references if it is the result of substituting a
1355 : parameter variable. In this case we just pull out the component we
1356 : want. */
1357 63651 : if (expr->ref)
1358 160 : comp = expr->ref->u.c.sym->components;
1359 63491 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1360 : || expr->ts.type == BT_UNION)
1361 63489 : && expr->ts.u.derived)
1362 63489 : comp = expr->ts.u.derived->components;
1363 : else
1364 : return false;
1365 :
1366 63649 : cons = gfc_constructor_first (expr->value.constructor);
1367 :
1368 212277 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1369 : {
1370 148630 : int rank;
1371 :
1372 148630 : if (!cons->expr)
1373 9834 : continue;
1374 :
1375 : /* Unions use an EXPR_NULL contrived expression to tell the translation
1376 : phase to generate an initializer of the appropriate length.
1377 : Ignore it here. */
1378 138796 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1379 15 : continue;
1380 :
1381 138781 : if (!gfc_resolve_expr (cons->expr))
1382 : {
1383 0 : t = false;
1384 0 : continue;
1385 : }
1386 :
1387 138781 : rank = comp->as ? comp->as->rank : 0;
1388 138781 : if (comp->ts.type == BT_CLASS
1389 1789 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1390 1788 : && CLASS_DATA (comp)->as)
1391 537 : rank = CLASS_DATA (comp)->as->rank;
1392 :
1393 138781 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1394 228 : gfc_find_vtab (&cons->expr->ts);
1395 :
1396 138781 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1397 527 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1398 : {
1399 4 : gfc_error ("The rank of the element in the structure "
1400 : "constructor at %L does not match that of the "
1401 : "component (%d/%d)", &cons->expr->where,
1402 : cons->expr->rank, rank);
1403 4 : t = false;
1404 : }
1405 :
1406 : /* If we don't have the right type, try to convert it. */
1407 :
1408 242485 : if (!comp->attr.proc_pointer &&
1409 103704 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1410 : {
1411 12699 : if (strcmp (comp->name, "_extends") == 0)
1412 : {
1413 : /* Can afford to be brutal with the _extends initializer.
1414 : The derived type can get lost because it is PRIVATE
1415 : but it is not usage constrained by the standard. */
1416 9311 : cons->expr->ts = comp->ts;
1417 : }
1418 3388 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1419 : {
1420 2 : gfc_error ("The element in the structure constructor at %L, "
1421 : "for pointer component %qs, is %s but should be %s",
1422 2 : &cons->expr->where, comp->name,
1423 2 : gfc_basic_typename (cons->expr->ts.type),
1424 : gfc_basic_typename (comp->ts.type));
1425 2 : t = false;
1426 : }
1427 3386 : else if (!UNLIMITED_POLY (comp))
1428 : {
1429 3323 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1430 3323 : if (t)
1431 138781 : t = t2;
1432 : }
1433 : }
1434 :
1435 : /* For strings, the length of the constructor should be the same as
1436 : the one of the structure, ensure this if the lengths are known at
1437 : compile time and when we are dealing with PARAMETER or structure
1438 : constructors. */
1439 138781 : if (cons->expr->ts.type == BT_CHARACTER
1440 3914 : && comp->ts.type == BT_CHARACTER
1441 3888 : && comp->ts.u.cl && comp->ts.u.cl->length
1442 2504 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1443 2469 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1444 926 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1445 926 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1446 926 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1447 926 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1448 926 : comp->ts.u.cl->length->value.integer) != 0)
1449 : {
1450 11 : if (comp->attr.pointer)
1451 : {
1452 3 : HOST_WIDE_INT la, lb;
1453 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1454 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1455 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1456 : "component %qs in constructor at %L",
1457 3 : la, lb, comp->name, &cons->expr->where);
1458 3 : t = false;
1459 : }
1460 :
1461 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1462 4 : && cons->expr->rank != 0
1463 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1464 : {
1465 : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1466 : to make use of the gfc_resolve_character_array_constructor
1467 : machinery. The expression is later simplified away to
1468 : an array of string literals. */
1469 1 : gfc_expr *para = cons->expr;
1470 1 : cons->expr = gfc_get_expr ();
1471 1 : cons->expr->ts = para->ts;
1472 1 : cons->expr->where = para->where;
1473 1 : cons->expr->expr_type = EXPR_ARRAY;
1474 1 : cons->expr->rank = para->rank;
1475 1 : cons->expr->corank = para->corank;
1476 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1477 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1478 1 : para, &cons->expr->where);
1479 : }
1480 :
1481 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1482 : {
1483 : /* Rely on the cleanup of the namespace to deal correctly with
1484 : the old charlen. (There was a block here that attempted to
1485 : remove the charlen but broke the chain in so doing.) */
1486 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1487 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1488 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1489 5 : gfc_resolve_character_array_constructor (cons->expr);
1490 : }
1491 : }
1492 :
1493 138781 : if (cons->expr->expr_type == EXPR_NULL
1494 41705 : && !(comp->attr.pointer || comp->attr.allocatable
1495 20757 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1496 1136 : || (comp->ts.type == BT_CLASS
1497 1134 : && (CLASS_DATA (comp)->attr.class_pointer
1498 917 : || CLASS_DATA (comp)->attr.allocatable))))
1499 : {
1500 2 : t = false;
1501 2 : gfc_error ("The NULL in the structure constructor at %L is "
1502 : "being applied to component %qs, which is neither "
1503 : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1504 : comp->name);
1505 : }
1506 :
1507 138781 : if (comp->attr.proc_pointer && comp->ts.interface)
1508 : {
1509 : /* Check procedure pointer interface. */
1510 15783 : gfc_symbol *s2 = NULL;
1511 15783 : gfc_component *c2;
1512 15783 : const char *name;
1513 15783 : char err[200];
1514 :
1515 15783 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1516 15783 : if (c2)
1517 : {
1518 12 : s2 = c2->ts.interface;
1519 12 : name = c2->name;
1520 : }
1521 15771 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1522 : {
1523 0 : s2 = cons->expr->symtree->n.sym->result;
1524 0 : name = cons->expr->symtree->n.sym->result->name;
1525 : }
1526 15771 : else if (cons->expr->expr_type != EXPR_NULL)
1527 : {
1528 15351 : s2 = cons->expr->symtree->n.sym;
1529 15351 : name = cons->expr->symtree->n.sym->name;
1530 : }
1531 :
1532 15363 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1533 : err, sizeof (err), NULL, NULL))
1534 : {
1535 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1536 : "component %qs in structure constructor at %L:"
1537 2 : " %s", comp->name, &cons->expr->where, err);
1538 2 : return false;
1539 : }
1540 : }
1541 :
1542 : /* Validate shape, except for dynamic or PDT arrays. */
1543 138779 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1544 2270 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1545 1526 : && !comp->attr.pdt_array)
1546 : {
1547 1279 : mpz_t len;
1548 1279 : mpz_init (len);
1549 2651 : for (int n = 0; n < rank; n++)
1550 : {
1551 1377 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1552 1372 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1553 : {
1554 5 : gfc_error ("Bad array spec of component %qs referenced in "
1555 : "structure constructor at %L",
1556 5 : comp->name, &cons->expr->where);
1557 5 : t = false;
1558 5 : break;
1559 1372 : };
1560 1372 : if (cons->expr->shape == NULL)
1561 12 : continue;
1562 1360 : mpz_set_ui (len, 1);
1563 1360 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1564 1360 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1565 1360 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1566 : {
1567 9 : gfc_error ("The shape of component %qs in the structure "
1568 : "constructor at %L differs from the shape of the "
1569 : "declared component for dimension %d (%ld/%ld)",
1570 : comp->name, &cons->expr->where, n+1,
1571 : mpz_get_si (cons->expr->shape[n]),
1572 : mpz_get_si (len));
1573 9 : t = false;
1574 : }
1575 : }
1576 1279 : mpz_clear (len);
1577 : }
1578 :
1579 138779 : if (!comp->attr.pointer || comp->attr.proc_pointer
1580 22391 : || cons->expr->expr_type == EXPR_NULL)
1581 128485 : continue;
1582 :
1583 10294 : a = gfc_expr_attr (cons->expr);
1584 :
1585 10294 : if (!a.pointer && !a.target)
1586 : {
1587 1 : t = false;
1588 1 : gfc_error ("The element in the structure constructor at %L, "
1589 : "for pointer component %qs should be a POINTER or "
1590 1 : "a TARGET", &cons->expr->where, comp->name);
1591 : }
1592 :
1593 10294 : if (init)
1594 : {
1595 : /* F08:C461. Additional checks for pointer initialization. */
1596 10226 : if (a.allocatable)
1597 : {
1598 0 : t = false;
1599 0 : gfc_error ("Pointer initialization target at %L "
1600 0 : "must not be ALLOCATABLE", &cons->expr->where);
1601 : }
1602 10226 : if (!a.save)
1603 : {
1604 0 : t = false;
1605 0 : gfc_error ("Pointer initialization target at %L "
1606 0 : "must have the SAVE attribute", &cons->expr->where);
1607 : }
1608 : }
1609 :
1610 : /* F2023:C770: A designator that is an initial-data-target shall ...
1611 : not have a vector subscript. */
1612 10294 : if (comp->attr.pointer && (a.pointer || a.target)
1613 20587 : && gfc_has_vector_index (cons->expr))
1614 : {
1615 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1616 1 : &cons->expr->where);
1617 1 : t = false;
1618 : }
1619 :
1620 : /* F2003, C1272 (3). */
1621 10294 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1622 10294 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1623 10257 : || gfc_is_coindexed (cons->expr));
1624 34 : if (impure && gfc_pure (NULL))
1625 : {
1626 1 : t = false;
1627 1 : gfc_error ("Invalid expression in the structure constructor for "
1628 : "pointer component %qs at %L in PURE procedure",
1629 1 : comp->name, &cons->expr->where);
1630 : }
1631 :
1632 10294 : if (impure)
1633 34 : gfc_unset_implicit_pure (NULL);
1634 : }
1635 :
1636 : return t;
1637 : }
1638 :
1639 :
1640 : /****************** Expression name resolution ******************/
1641 :
1642 : /* Returns 0 if a symbol was not declared with a type or
1643 : attribute declaration statement, nonzero otherwise. */
1644 :
1645 : static bool
1646 748823 : was_declared (gfc_symbol *sym)
1647 : {
1648 748823 : symbol_attribute a;
1649 :
1650 748823 : a = sym->attr;
1651 :
1652 748823 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1653 : return 1;
1654 :
1655 634287 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1656 625485 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1657 625483 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1658 625429 : || a.asynchronous || a.codimension || a.subroutine || a.result)
1659 95535 : return 1;
1660 :
1661 : return 0;
1662 : }
1663 :
1664 :
1665 : /* Determine if a symbol is generic or not. */
1666 :
1667 : static int
1668 416228 : generic_sym (gfc_symbol *sym)
1669 : {
1670 416228 : gfc_symbol *s;
1671 :
1672 416228 : if (sym->attr.generic ||
1673 386421 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1674 30921 : return 1;
1675 :
1676 385307 : if (was_declared (sym) || sym->ns->parent == NULL)
1677 : return 0;
1678 :
1679 78029 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1680 :
1681 78029 : if (s != NULL)
1682 : {
1683 135 : if (s == sym)
1684 : return 0;
1685 : else
1686 134 : return generic_sym (s);
1687 : }
1688 :
1689 : return 0;
1690 : }
1691 :
1692 :
1693 : /* Determine if a symbol is specific or not. */
1694 :
1695 : static int
1696 385219 : specific_sym (gfc_symbol *sym)
1697 : {
1698 385219 : gfc_symbol *s;
1699 :
1700 385219 : if (sym->attr.if_source == IFSRC_IFBODY
1701 373800 : || sym->attr.proc == PROC_MODULE
1702 345435 : || sym->attr.proc == PROC_INTERNAL
1703 297162 : || sym->attr.proc == PROC_ST_FUNCTION
1704 296872 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1705 681360 : || sym->attr.external)
1706 91487 : return 1;
1707 :
1708 293732 : if (was_declared (sym) || sym->ns->parent == NULL)
1709 : return 0;
1710 :
1711 77927 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1712 :
1713 77927 : return (s == NULL) ? 0 : specific_sym (s);
1714 : }
1715 :
1716 :
1717 : /* Figure out if the procedure is specific, generic or unknown. */
1718 :
1719 : enum proc_type
1720 : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1721 :
1722 : static proc_type
1723 415945 : procedure_kind (gfc_symbol *sym)
1724 : {
1725 415945 : if (generic_sym (sym))
1726 : return PTYPE_GENERIC;
1727 :
1728 385170 : if (specific_sym (sym))
1729 91487 : return PTYPE_SPECIFIC;
1730 :
1731 : return PTYPE_UNKNOWN;
1732 : }
1733 :
1734 : /* Check references to assumed size arrays. The flag need_full_assumed_size
1735 : is nonzero when matching actual arguments. */
1736 :
1737 : static int need_full_assumed_size = 0;
1738 :
1739 : static bool
1740 1435050 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1741 : {
1742 1435050 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1743 : return false;
1744 :
1745 : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1746 : What should it be? */
1747 3800 : if (e->ref
1748 3798 : && e->ref->u.ar.as
1749 3797 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1750 3302 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1751 3302 : && (e->ref->u.ar.type == AR_FULL))
1752 : {
1753 25 : gfc_error ("The upper bound in the last dimension must "
1754 : "appear in the reference to the assumed size "
1755 : "array %qs at %L", sym->name, &e->where);
1756 25 : return true;
1757 : }
1758 : return false;
1759 : }
1760 :
1761 :
1762 : /* Look for bad assumed size array references in argument expressions
1763 : of elemental and array valued intrinsic procedures. Since this is
1764 : called from procedure resolution functions, it only recurses at
1765 : operators. */
1766 :
1767 : static bool
1768 230870 : resolve_assumed_size_actual (gfc_expr *e)
1769 : {
1770 230870 : if (e == NULL)
1771 : return false;
1772 :
1773 230303 : switch (e->expr_type)
1774 : {
1775 111038 : case EXPR_VARIABLE:
1776 111038 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1777 : return true;
1778 : break;
1779 :
1780 48910 : case EXPR_OP:
1781 48910 : if (resolve_assumed_size_actual (e->value.op.op1)
1782 48910 : || resolve_assumed_size_actual (e->value.op.op2))
1783 0 : return true;
1784 : break;
1785 :
1786 : default:
1787 : break;
1788 : }
1789 : return false;
1790 : }
1791 :
1792 :
1793 : /* Check a generic procedure, passed as an actual argument, to see if
1794 : there is a matching specific name. If none, it is an error, and if
1795 : more than one, the reference is ambiguous. */
1796 : static int
1797 8 : count_specific_procs (gfc_expr *e)
1798 : {
1799 8 : int n;
1800 8 : gfc_interface *p;
1801 8 : gfc_symbol *sym;
1802 :
1803 8 : n = 0;
1804 8 : sym = e->symtree->n.sym;
1805 :
1806 22 : for (p = sym->generic; p; p = p->next)
1807 14 : if (strcmp (sym->name, p->sym->name) == 0)
1808 : {
1809 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1810 : sym->name);
1811 8 : n++;
1812 : }
1813 :
1814 8 : if (n > 1)
1815 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1816 : &e->where);
1817 :
1818 8 : if (n == 0)
1819 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1820 : "argument at %L", sym->name, &e->where);
1821 :
1822 8 : return n;
1823 : }
1824 :
1825 :
1826 : /* See if a call to sym could possibly be a not allowed RECURSION because of
1827 : a missing RECURSIVE declaration. This means that either sym is the current
1828 : context itself, or sym is the parent of a contained procedure calling its
1829 : non-RECURSIVE containing procedure.
1830 : This also works if sym is an ENTRY. */
1831 :
1832 : static bool
1833 153375 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1834 : {
1835 153375 : gfc_symbol* proc_sym;
1836 153375 : gfc_symbol* context_proc;
1837 153375 : gfc_namespace* real_context;
1838 :
1839 153375 : if (sym->attr.flavor == FL_PROGRAM
1840 : || gfc_fl_struct (sym->attr.flavor))
1841 : return false;
1842 :
1843 : /* If we've got an ENTRY, find real procedure. */
1844 153374 : if (sym->attr.entry && sym->ns->entries)
1845 45 : proc_sym = sym->ns->entries->sym;
1846 : else
1847 : proc_sym = sym;
1848 :
1849 : /* If sym is RECURSIVE, all is well of course. */
1850 153374 : if (proc_sym->attr.recursive || flag_recursive)
1851 : return false;
1852 :
1853 : /* Find the context procedure's "real" symbol if it has entries.
1854 : We look for a procedure symbol, so recurse on the parents if we don't
1855 : find one (like in case of a BLOCK construct). */
1856 1965 : for (real_context = context; ; real_context = real_context->parent)
1857 : {
1858 : /* We should find something, eventually! */
1859 129758 : gcc_assert (real_context);
1860 :
1861 129758 : context_proc = (real_context->entries ? real_context->entries->sym
1862 : : real_context->proc_name);
1863 :
1864 : /* In some special cases, there may not be a proc_name, like for this
1865 : invalid code:
1866 : real(bad_kind()) function foo () ...
1867 : when checking the call to bad_kind ().
1868 : In these cases, we simply return here and assume that the
1869 : call is ok. */
1870 129758 : if (!context_proc)
1871 : return false;
1872 :
1873 129494 : if (context_proc->attr.flavor != FL_LABEL)
1874 : break;
1875 : }
1876 :
1877 : /* A call from sym's body to itself is recursion, of course. */
1878 127529 : if (context_proc == proc_sym)
1879 : return true;
1880 :
1881 : /* The same is true if context is a contained procedure and sym the
1882 : containing one. */
1883 127514 : if (context_proc->attr.contained)
1884 : {
1885 21514 : gfc_symbol* parent_proc;
1886 :
1887 21514 : gcc_assert (context->parent);
1888 21514 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1889 : : context->parent->proc_name);
1890 :
1891 21514 : if (parent_proc == proc_sym)
1892 9 : return true;
1893 : }
1894 :
1895 : return false;
1896 : }
1897 :
1898 :
1899 : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1900 : its typespec and formal argument list. */
1901 :
1902 : bool
1903 47228 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1904 : {
1905 47228 : gfc_intrinsic_sym* isym = NULL;
1906 47228 : const char* symstd;
1907 :
1908 47228 : if (sym->resolve_symbol_called >= 2)
1909 : return true;
1910 :
1911 37186 : sym->resolve_symbol_called = 2;
1912 :
1913 : /* Already resolved. */
1914 37186 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1915 : return true;
1916 :
1917 : /* We already know this one is an intrinsic, so we don't call
1918 : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1919 : gfc_find_subroutine directly to check whether it is a function or
1920 : subroutine. */
1921 :
1922 29120 : if (sym->intmod_sym_id && sym->attr.subroutine)
1923 : {
1924 12697 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1925 12697 : isym = gfc_intrinsic_subroutine_by_id (id);
1926 12697 : }
1927 16423 : else if (sym->intmod_sym_id)
1928 : {
1929 12628 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1930 12628 : isym = gfc_intrinsic_function_by_id (id);
1931 : }
1932 3795 : else if (!sym->attr.subroutine)
1933 3708 : isym = gfc_find_function (sym->name);
1934 :
1935 29033 : if (isym && !sym->attr.subroutine)
1936 : {
1937 16291 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1938 24 : && !sym->attr.implicit_type)
1939 10 : gfc_warning (OPT_Wsurprising,
1940 : "Type specified for intrinsic function %qs at %L is"
1941 : " ignored", sym->name, &sym->declared_at);
1942 :
1943 20676 : if (!sym->attr.function &&
1944 4385 : !gfc_add_function(&sym->attr, sym->name, loc))
1945 : return false;
1946 :
1947 16291 : sym->ts = isym->ts;
1948 : }
1949 12829 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1950 : {
1951 12826 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1952 : {
1953 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1954 : " specifier", sym->name, &sym->declared_at);
1955 1 : return false;
1956 : }
1957 :
1958 12866 : if (!sym->attr.subroutine &&
1959 41 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1960 : return false;
1961 : }
1962 : else
1963 : {
1964 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1965 : &sym->declared_at);
1966 3 : return false;
1967 : }
1968 :
1969 29115 : gfc_copy_formal_args_intr (sym, isym, NULL);
1970 :
1971 29115 : sym->attr.pure = isym->pure;
1972 29115 : sym->attr.elemental = isym->elemental;
1973 :
1974 : /* Check it is actually available in the standard settings. */
1975 29115 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1976 : {
1977 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1978 : "available in the current standard settings but %s. Use "
1979 : "an appropriate %<-std=*%> option or enable "
1980 : "%<-fall-intrinsics%> in order to use it.",
1981 : sym->name, &sym->declared_at, symstd);
1982 31 : return false;
1983 : }
1984 :
1985 : return true;
1986 : }
1987 :
1988 :
1989 : /* Resolve a procedure expression, like passing it to a called procedure or as
1990 : RHS for a procedure pointer assignment. */
1991 :
1992 : static bool
1993 1337307 : resolve_procedure_expression (gfc_expr* expr)
1994 : {
1995 1337307 : gfc_symbol* sym;
1996 :
1997 1337307 : if (expr->expr_type != EXPR_VARIABLE)
1998 : return true;
1999 1337290 : gcc_assert (expr->symtree);
2000 :
2001 1337290 : sym = expr->symtree->n.sym;
2002 :
2003 1337290 : if (sym->attr.intrinsic)
2004 1360 : gfc_resolve_intrinsic (sym, &expr->where);
2005 :
2006 1337290 : if (sym->attr.flavor != FL_PROCEDURE
2007 32268 : || (sym->attr.function && sym->result == sym))
2008 : return true;
2009 :
2010 : /* A non-RECURSIVE procedure that is used as procedure expression within its
2011 : own body is in danger of being called recursively. */
2012 17522 : if (is_illegal_recursion (sym, gfc_current_ns))
2013 : {
2014 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
2015 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
2016 : " possibly calling itself recursively in procedure %qs. "
2017 : " Declare it RECURSIVE or use %<-frecursive%>",
2018 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
2019 : else
2020 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
2021 : " itself recursively. Declare it RECURSIVE or use"
2022 : " %<-frecursive%>", sym->name, &expr->where);
2023 : }
2024 :
2025 : return true;
2026 : }
2027 :
2028 :
2029 : /* Check that name is not a derived type. */
2030 :
2031 : static bool
2032 3422 : is_dt_name (const char *name)
2033 : {
2034 3422 : gfc_symbol *dt_list, *dt_first;
2035 :
2036 3422 : dt_list = dt_first = gfc_derived_types;
2037 5876 : for (; dt_list; dt_list = dt_list->dt_next)
2038 : {
2039 3577 : if (strcmp(dt_list->name, name) == 0)
2040 : return true;
2041 3574 : if (dt_first == dt_list->dt_next)
2042 : break;
2043 : }
2044 : return false;
2045 : }
2046 :
2047 :
2048 : /* Resolve an actual argument list. Most of the time, this is just
2049 : resolving the expressions in the list.
2050 : The exception is that we sometimes have to decide whether arguments
2051 : that look like procedure arguments are really simple variable
2052 : references. */
2053 :
2054 : static bool
2055 430260 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2056 : bool no_formal_args)
2057 : {
2058 430260 : gfc_symbol *sym = NULL;
2059 430260 : gfc_symtree *parent_st;
2060 430260 : gfc_expr *e;
2061 430260 : gfc_component *comp;
2062 430260 : int save_need_full_assumed_size;
2063 430260 : bool return_value = false;
2064 430260 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2065 :
2066 430260 : actual_arg = true;
2067 430260 : first_actual_arg = true;
2068 :
2069 1103691 : for (; arg; arg = arg->next)
2070 : {
2071 673532 : e = arg->expr;
2072 673532 : if (e == NULL)
2073 : {
2074 : /* Check the label is a valid branching target. */
2075 2473 : if (arg->label)
2076 : {
2077 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2078 : {
2079 0 : gfc_error ("Label %d referenced at %L is never defined",
2080 : arg->label->value, &arg->label->where);
2081 0 : goto cleanup;
2082 : }
2083 : }
2084 2473 : first_actual_arg = false;
2085 2473 : continue;
2086 : }
2087 :
2088 671059 : if (e->expr_type == EXPR_VARIABLE
2089 296120 : && e->symtree->n.sym->attr.generic
2090 8 : && no_formal_args
2091 671064 : && count_specific_procs (e) != 1)
2092 2 : goto cleanup;
2093 :
2094 671057 : if (e->ts.type != BT_PROCEDURE)
2095 : {
2096 597851 : save_need_full_assumed_size = need_full_assumed_size;
2097 597851 : if (e->expr_type != EXPR_VARIABLE)
2098 374939 : need_full_assumed_size = 0;
2099 597851 : if (!gfc_resolve_expr (e))
2100 60 : goto cleanup;
2101 597791 : need_full_assumed_size = save_need_full_assumed_size;
2102 597791 : goto argument_list;
2103 : }
2104 :
2105 : /* See if the expression node should really be a variable reference. */
2106 :
2107 73206 : sym = e->symtree->n.sym;
2108 :
2109 73206 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2110 : {
2111 3 : gfc_error ("Derived type %qs is used as an actual "
2112 : "argument at %L", sym->name, &e->where);
2113 3 : goto cleanup;
2114 : }
2115 :
2116 73203 : if (sym->attr.flavor == FL_PROCEDURE
2117 69784 : || sym->attr.intrinsic
2118 69784 : || sym->attr.external)
2119 : {
2120 3419 : int actual_ok;
2121 :
2122 : /* If a procedure is not already determined to be something else
2123 : check if it is intrinsic. */
2124 3419 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2125 1254 : sym->attr.intrinsic = 1;
2126 :
2127 3419 : if (sym->attr.proc == PROC_ST_FUNCTION)
2128 : {
2129 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2130 : "actual argument", sym->name, &e->where);
2131 : }
2132 :
2133 6838 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2134 3419 : sym->attr.subroutine);
2135 3419 : if (sym->attr.intrinsic && actual_ok == 0)
2136 : {
2137 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2138 : "actual argument", sym->name, &e->where);
2139 : }
2140 :
2141 3419 : if (sym->attr.contained && !sym->attr.use_assoc
2142 444 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2143 : {
2144 256 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2145 : " used as actual argument at %L",
2146 : sym->name, &e->where))
2147 3 : goto cleanup;
2148 : }
2149 :
2150 3416 : if (sym->attr.elemental && !sym->attr.intrinsic)
2151 : {
2152 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2153 : "allowed as an actual argument at %L", sym->name,
2154 : &e->where);
2155 : }
2156 :
2157 : /* Check if a generic interface has a specific procedure
2158 : with the same name before emitting an error. */
2159 3416 : if (sym->attr.generic && count_specific_procs (e) != 1)
2160 0 : goto cleanup;
2161 :
2162 : /* Just in case a specific was found for the expression. */
2163 3416 : sym = e->symtree->n.sym;
2164 :
2165 : /* If the symbol is the function that names the current (or
2166 : parent) scope, then we really have a variable reference. */
2167 :
2168 3416 : if (gfc_is_function_return_value (sym, sym->ns))
2169 0 : goto got_variable;
2170 :
2171 : /* If all else fails, see if we have a specific intrinsic. */
2172 3416 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2173 : {
2174 0 : gfc_intrinsic_sym *isym;
2175 :
2176 0 : isym = gfc_find_function (sym->name);
2177 0 : if (isym == NULL || !isym->specific)
2178 : {
2179 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2180 : "for the reference %qs at %L", sym->name,
2181 : &e->where);
2182 0 : goto cleanup;
2183 : }
2184 0 : sym->ts = isym->ts;
2185 0 : sym->attr.intrinsic = 1;
2186 0 : sym->attr.function = 1;
2187 : }
2188 :
2189 3416 : if (!gfc_resolve_expr (e))
2190 0 : goto cleanup;
2191 3416 : goto argument_list;
2192 : }
2193 :
2194 : /* See if the name is a module procedure in a parent unit. */
2195 :
2196 69784 : if (was_declared (sym) || sym->ns->parent == NULL)
2197 69691 : goto got_variable;
2198 :
2199 93 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2200 : {
2201 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2202 0 : goto cleanup;
2203 : }
2204 :
2205 93 : if (parent_st == NULL)
2206 93 : goto got_variable;
2207 :
2208 0 : sym = parent_st->n.sym;
2209 0 : e->symtree = parent_st; /* Point to the right thing. */
2210 :
2211 0 : if (sym->attr.flavor == FL_PROCEDURE
2212 0 : || sym->attr.intrinsic
2213 0 : || sym->attr.external)
2214 : {
2215 0 : if (!gfc_resolve_expr (e))
2216 0 : goto cleanup;
2217 0 : goto argument_list;
2218 : }
2219 :
2220 0 : got_variable:
2221 69784 : e->expr_type = EXPR_VARIABLE;
2222 69784 : e->ts = sym->ts;
2223 69784 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2224 36234 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2225 3894 : && CLASS_DATA (sym)->as))
2226 : {
2227 39198 : gfc_array_spec *as
2228 36374 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2229 36374 : e->rank = as->rank;
2230 36374 : e->corank = as->corank;
2231 36374 : e->ref = gfc_get_ref ();
2232 36374 : e->ref->type = REF_ARRAY;
2233 36374 : e->ref->u.ar.type = AR_FULL;
2234 36374 : e->ref->u.ar.as = as;
2235 : }
2236 :
2237 : /* These symbols are set untyped by calls to gfc_set_default_type
2238 : with 'error_flag' = false. Reset the untyped attribute so that
2239 : the error will be generated in gfc_resolve_expr. */
2240 69784 : if (e->expr_type == EXPR_VARIABLE
2241 69784 : && sym->ts.type == BT_UNKNOWN
2242 36 : && sym->attr.untyped)
2243 5 : sym->attr.untyped = 0;
2244 :
2245 : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2246 : primary.cc (match_actual_arg). If above code determines that it
2247 : is a variable instead, it needs to be resolved as it was not
2248 : done at the beginning of this function. */
2249 69784 : save_need_full_assumed_size = need_full_assumed_size;
2250 69784 : if (e->expr_type != EXPR_VARIABLE)
2251 0 : need_full_assumed_size = 0;
2252 69784 : if (!gfc_resolve_expr (e))
2253 22 : goto cleanup;
2254 69762 : need_full_assumed_size = save_need_full_assumed_size;
2255 :
2256 670969 : argument_list:
2257 : /* Check argument list functions %VAL, %LOC and %REF. There is
2258 : nothing to do for %REF. */
2259 670969 : if (arg->name && arg->name[0] == '%')
2260 : {
2261 42 : if (strcmp ("%VAL", arg->name) == 0)
2262 : {
2263 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2264 : {
2265 2 : gfc_error ("By-value argument at %L is not of numeric "
2266 : "type", &e->where);
2267 2 : goto cleanup;
2268 : }
2269 :
2270 26 : if (e->rank)
2271 : {
2272 1 : gfc_error ("By-value argument at %L cannot be an array or "
2273 : "an array section", &e->where);
2274 1 : goto cleanup;
2275 : }
2276 :
2277 : /* Intrinsics are still PROC_UNKNOWN here. However,
2278 : since same file external procedures are not resolvable
2279 : in gfortran, it is a good deal easier to leave them to
2280 : intrinsic.cc. */
2281 25 : if (ptype != PROC_UNKNOWN
2282 25 : && ptype != PROC_DUMMY
2283 9 : && ptype != PROC_EXTERNAL
2284 9 : && ptype != PROC_MODULE)
2285 : {
2286 3 : gfc_error ("By-value argument at %L is not allowed "
2287 : "in this context", &e->where);
2288 3 : goto cleanup;
2289 : }
2290 : }
2291 :
2292 : /* Statement functions have already been excluded above. */
2293 14 : else if (strcmp ("%LOC", arg->name) == 0
2294 8 : && e->ts.type == BT_PROCEDURE)
2295 : {
2296 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2297 : {
2298 0 : gfc_error ("Passing internal procedure at %L by location "
2299 : "not allowed", &e->where);
2300 0 : goto cleanup;
2301 : }
2302 : }
2303 : }
2304 :
2305 670963 : comp = gfc_get_proc_ptr_comp(e);
2306 670963 : if (e->expr_type == EXPR_VARIABLE
2307 294742 : && comp && comp->attr.elemental)
2308 : {
2309 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2310 : "allowed as an actual argument at %L", comp->name,
2311 : &e->where);
2312 : }
2313 :
2314 : /* Fortran 2008, C1237. */
2315 294742 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2316 671408 : && gfc_has_ultimate_pointer (e))
2317 : {
2318 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2319 : "component", &e->where);
2320 3 : goto cleanup;
2321 : }
2322 :
2323 670960 : if (e->expr_type == EXPR_VARIABLE
2324 294739 : && e->ts.type == BT_PROCEDURE
2325 3416 : && no_formal_args
2326 1505 : && sym->attr.flavor == FL_PROCEDURE
2327 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2328 142 : && !sym->attr.external
2329 2 : && !sym->attr.intrinsic
2330 2 : && !sym->attr.artificial
2331 2 : && !sym->ts.interface)
2332 : {
2333 : /* Emit a warning for -std=legacy and an error otherwise. */
2334 2 : if (gfc_option.warn_std == 0)
2335 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2336 : "does neither have an explicit interface nor the "
2337 : "EXTERNAL attribute", sym->name, &e->where);
2338 : else
2339 : {
2340 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2341 : "does neither have an explicit interface nor the "
2342 : "EXTERNAL attribute", sym->name, &e->where);
2343 2 : goto cleanup;
2344 : }
2345 : }
2346 :
2347 670958 : first_actual_arg = false;
2348 : }
2349 :
2350 : return_value = true;
2351 :
2352 430260 : cleanup:
2353 430260 : actual_arg = actual_arg_sav;
2354 430260 : first_actual_arg = first_actual_arg_sav;
2355 :
2356 430260 : return return_value;
2357 : }
2358 :
2359 :
2360 : /* Do the checks of the actual argument list that are specific to elemental
2361 : procedures. If called with c == NULL, we have a function, otherwise if
2362 : expr == NULL, we have a subroutine. */
2363 :
2364 : static bool
2365 327675 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2366 : {
2367 327675 : gfc_actual_arglist *arg0;
2368 327675 : gfc_actual_arglist *arg;
2369 327675 : gfc_symbol *esym = NULL;
2370 327675 : gfc_intrinsic_sym *isym = NULL;
2371 327675 : gfc_expr *e = NULL;
2372 327675 : gfc_intrinsic_arg *iformal = NULL;
2373 327675 : gfc_formal_arglist *eformal = NULL;
2374 327675 : bool formal_optional = false;
2375 327675 : bool set_by_optional = false;
2376 327675 : int i;
2377 327675 : int rank = 0;
2378 :
2379 : /* Is this an elemental procedure? */
2380 327675 : if (expr && expr->value.function.actual != NULL)
2381 : {
2382 237413 : if (expr->value.function.esym != NULL
2383 44349 : && expr->value.function.esym->attr.elemental)
2384 : {
2385 : arg0 = expr->value.function.actual;
2386 : esym = expr->value.function.esym;
2387 : }
2388 221105 : else if (expr->value.function.isym != NULL
2389 192009 : && expr->value.function.isym->elemental)
2390 : {
2391 : arg0 = expr->value.function.actual;
2392 : isym = expr->value.function.isym;
2393 : }
2394 : else
2395 : return true;
2396 : }
2397 90262 : else if (c && c->ext.actual != NULL)
2398 : {
2399 71328 : arg0 = c->ext.actual;
2400 :
2401 71328 : if (c->resolved_sym)
2402 : esym = c->resolved_sym;
2403 : else
2404 323 : esym = c->symtree->n.sym;
2405 71328 : gcc_assert (esym);
2406 :
2407 71328 : if (!esym->attr.elemental)
2408 : return true;
2409 : }
2410 : else
2411 : return true;
2412 :
2413 : /* The rank of an elemental is the rank of its array argument(s). */
2414 174613 : for (arg = arg0; arg; arg = arg->next)
2415 : {
2416 113136 : if (arg->expr != NULL && arg->expr->rank != 0)
2417 : {
2418 10746 : rank = arg->expr->rank;
2419 10746 : if (arg->expr->expr_type == EXPR_VARIABLE
2420 5490 : && arg->expr->symtree->n.sym->attr.optional)
2421 10746 : set_by_optional = true;
2422 :
2423 : /* Function specific; set the result rank and shape. */
2424 10746 : if (expr)
2425 : {
2426 8338 : expr->rank = rank;
2427 8338 : expr->corank = arg->expr->corank;
2428 8338 : if (!expr->shape && arg->expr->shape)
2429 : {
2430 3968 : expr->shape = gfc_get_shape (rank);
2431 8731 : for (i = 0; i < rank; i++)
2432 4763 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2433 : }
2434 : }
2435 : break;
2436 : }
2437 : }
2438 :
2439 : /* If it is an array, it shall not be supplied as an actual argument
2440 : to an elemental procedure unless an array of the same rank is supplied
2441 : as an actual argument corresponding to a nonoptional dummy argument of
2442 : that elemental procedure(12.4.1.5). */
2443 72223 : formal_optional = false;
2444 72223 : if (isym)
2445 49702 : iformal = isym->formal;
2446 : else
2447 22521 : eformal = esym->formal;
2448 :
2449 190875 : for (arg = arg0; arg; arg = arg->next)
2450 : {
2451 118652 : if (eformal)
2452 : {
2453 40411 : if (eformal->sym && eformal->sym->attr.optional)
2454 40411 : formal_optional = true;
2455 40411 : eformal = eformal->next;
2456 : }
2457 78241 : else if (isym && iformal)
2458 : {
2459 67958 : if (iformal->optional)
2460 13456 : formal_optional = true;
2461 67958 : iformal = iformal->next;
2462 : }
2463 10283 : else if (isym)
2464 10275 : formal_optional = true;
2465 :
2466 118652 : if (pedantic && arg->expr != NULL
2467 67705 : && arg->expr->expr_type == EXPR_VARIABLE
2468 31920 : && arg->expr->symtree->n.sym->attr.optional
2469 572 : && formal_optional
2470 479 : && arg->expr->rank
2471 153 : && (set_by_optional || arg->expr->rank != rank)
2472 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2473 : {
2474 114 : bool t = false;
2475 : gfc_actual_arglist *a;
2476 :
2477 : /* Scan the argument list for a non-optional argument with the
2478 : same rank as arg. */
2479 114 : for (a = arg0; a; a = a->next)
2480 87 : if (a != arg
2481 45 : && a->expr->rank == arg->expr->rank
2482 39 : && (a->expr->expr_type != EXPR_VARIABLE
2483 37 : || (a->expr->expr_type == EXPR_VARIABLE
2484 37 : && !a->expr->symtree->n.sym->attr.optional)))
2485 : {
2486 : t = true;
2487 : break;
2488 : }
2489 :
2490 42 : if (!t)
2491 27 : gfc_warning (OPT_Wpedantic,
2492 : "%qs at %L is an array and OPTIONAL; If it is not "
2493 : "present, then it cannot be the actual argument of "
2494 : "an ELEMENTAL procedure unless there is a non-optional"
2495 : " argument with the same rank "
2496 : "(Fortran 2018, 15.5.2.12)",
2497 : arg->expr->symtree->n.sym->name, &arg->expr->where);
2498 : }
2499 : }
2500 :
2501 190864 : for (arg = arg0; arg; arg = arg->next)
2502 : {
2503 118650 : if (arg->expr == NULL || arg->expr->rank == 0)
2504 105016 : continue;
2505 :
2506 : /* Being elemental, the last upper bound of an assumed size array
2507 : argument must be present. */
2508 13634 : if (resolve_assumed_size_actual (arg->expr))
2509 : return false;
2510 :
2511 : /* Elemental procedure's array actual arguments must conform. */
2512 13631 : if (e != NULL)
2513 : {
2514 2888 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2515 : return false;
2516 : }
2517 : else
2518 10743 : e = arg->expr;
2519 : }
2520 :
2521 : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2522 : is an array, the intent inout/out variable needs to be also an array. */
2523 72214 : if (rank > 0 && esym && expr == NULL)
2524 7333 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2525 4931 : arg = arg->next, eformal = eformal->next)
2526 4933 : if (eformal->sym
2527 4932 : && (eformal->sym->attr.intent == INTENT_OUT
2528 3850 : || eformal->sym->attr.intent == INTENT_INOUT)
2529 1716 : && arg->expr && arg->expr->rank == 0)
2530 : {
2531 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2532 : "ELEMENTAL subroutine %qs is a scalar, but another "
2533 : "actual argument is an array", &arg->expr->where,
2534 : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2535 : : "INOUT", eformal->sym->name, esym->name);
2536 2 : return false;
2537 : }
2538 : return true;
2539 : }
2540 :
2541 :
2542 : /* This function does the checking of references to global procedures
2543 : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2544 : 77 and 95 standards. It checks for a gsymbol for the name, making
2545 : one if it does not already exist. If it already exists, then the
2546 : reference being resolved must correspond to the type of gsymbol.
2547 : Otherwise, the new symbol is equipped with the attributes of the
2548 : reference. The corresponding code that is called in creating
2549 : global entities is parse.cc.
2550 :
2551 : In addition, for all but -std=legacy, the gsymbols are used to
2552 : check the interfaces of external procedures from the same file.
2553 : The namespace of the gsymbol is resolved and then, once this is
2554 : done the interface is checked. */
2555 :
2556 :
2557 : static bool
2558 14961 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2559 : {
2560 14961 : if (!gsym_ns->proc_name->attr.recursive)
2561 : return true;
2562 :
2563 151 : if (sym->ns == gsym_ns)
2564 : return false;
2565 :
2566 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2567 0 : return false;
2568 :
2569 : return true;
2570 : }
2571 :
2572 : static bool
2573 14961 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2574 : {
2575 14961 : if (gsym_ns->entries)
2576 : {
2577 : gfc_entry_list *entry = gsym_ns->entries;
2578 :
2579 3312 : for (; entry; entry = entry->next)
2580 : {
2581 2333 : if (strcmp (sym->name, entry->sym->name) == 0)
2582 : {
2583 971 : if (strcmp (gsym_ns->proc_name->name,
2584 971 : sym->ns->proc_name->name) == 0)
2585 : return false;
2586 :
2587 971 : if (sym->ns->parent
2588 0 : && strcmp (gsym_ns->proc_name->name,
2589 0 : sym->ns->parent->proc_name->name) == 0)
2590 : return false;
2591 : }
2592 : }
2593 : }
2594 : return true;
2595 : }
2596 :
2597 :
2598 : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2599 :
2600 : bool
2601 15801 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2602 : {
2603 15801 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2604 :
2605 59028 : for ( ; arg; arg = arg->next)
2606 : {
2607 27834 : if (!arg->sym)
2608 157 : continue;
2609 :
2610 27677 : if (arg->sym->attr.allocatable) /* (2a) */
2611 : {
2612 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2613 0 : return true;
2614 : }
2615 27677 : else if (arg->sym->attr.asynchronous)
2616 : {
2617 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2618 0 : return true;
2619 : }
2620 27677 : else if (arg->sym->attr.optional)
2621 : {
2622 75 : strncpy (errmsg, _("optional argument"), err_len);
2623 75 : return true;
2624 : }
2625 27602 : else if (arg->sym->attr.pointer)
2626 : {
2627 12 : strncpy (errmsg, _("pointer argument"), err_len);
2628 12 : return true;
2629 : }
2630 27590 : else if (arg->sym->attr.target)
2631 : {
2632 72 : strncpy (errmsg, _("target argument"), err_len);
2633 72 : return true;
2634 : }
2635 27518 : else if (arg->sym->attr.value)
2636 : {
2637 12 : strncpy (errmsg, _("value argument"), err_len);
2638 12 : return true;
2639 : }
2640 27506 : else if (arg->sym->attr.volatile_)
2641 : {
2642 1 : strncpy (errmsg, _("volatile argument"), err_len);
2643 1 : return true;
2644 : }
2645 27505 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2646 : {
2647 69 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2648 69 : return true;
2649 : }
2650 27436 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2651 : {
2652 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2653 1 : return true;
2654 : }
2655 27435 : else if (arg->sym->attr.codimension) /* (2c) */
2656 : {
2657 1 : strncpy (errmsg, _("coarray argument"), err_len);
2658 1 : return true;
2659 : }
2660 27434 : else if (false) /* (2d) TODO: parametrized derived type */
2661 : {
2662 : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2663 : return true;
2664 : }
2665 27434 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2666 : {
2667 164 : strncpy (errmsg, _("polymorphic argument"), err_len);
2668 164 : return true;
2669 : }
2670 27270 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2671 : {
2672 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2673 0 : return true;
2674 : }
2675 27270 : else if (arg->sym->ts.type == BT_ASSUMED)
2676 : {
2677 : /* As assumed-type is unlimited polymorphic (cf. above).
2678 : See also TS 29113, Note 6.1. */
2679 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2680 1 : return true;
2681 : }
2682 : }
2683 :
2684 15393 : if (sym->attr.function)
2685 : {
2686 3485 : gfc_symbol *res = sym->result ? sym->result : sym;
2687 :
2688 3485 : if (res->attr.dimension) /* (3a) */
2689 : {
2690 93 : strncpy (errmsg, _("array result"), err_len);
2691 93 : return true;
2692 : }
2693 3392 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2694 : {
2695 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2696 38 : return true;
2697 : }
2698 3354 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2699 347 : && res->ts.u.cl->length
2700 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2701 : {
2702 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2703 12 : return true;
2704 : }
2705 : }
2706 :
2707 15250 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2708 : {
2709 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2710 7 : return true;
2711 : }
2712 15243 : else if (sym->attr.is_bind_c) /* (5) */
2713 : {
2714 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2715 0 : return true;
2716 : }
2717 :
2718 : return false;
2719 : }
2720 :
2721 :
2722 : static void
2723 29576 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2724 : {
2725 29576 : gfc_gsymbol * gsym;
2726 29576 : gfc_namespace *ns;
2727 29576 : enum gfc_symbol_type type;
2728 29576 : char reason[200];
2729 :
2730 29576 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2731 :
2732 29576 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2733 29576 : sym->binding_label != NULL);
2734 :
2735 29576 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2736 9 : gfc_global_used (gsym, where);
2737 :
2738 29576 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2739 9381 : || sym->attr.if_source == IFSRC_IFBODY)
2740 25122 : && gsym->type != GSYM_UNKNOWN
2741 22940 : && !gsym->binding_label
2742 20623 : && gsym->ns
2743 14961 : && gsym->ns->proc_name
2744 14961 : && not_in_recursive (sym, gsym->ns)
2745 44537 : && not_entry_self_reference (sym, gsym->ns))
2746 : {
2747 14961 : gfc_symbol *def_sym;
2748 14961 : def_sym = gsym->ns->proc_name;
2749 :
2750 14961 : if (gsym->ns->resolved != -1)
2751 : {
2752 :
2753 : /* Resolve the gsymbol namespace if needed. */
2754 14939 : if (!gsym->ns->resolved)
2755 : {
2756 2781 : gfc_symbol *old_dt_list;
2757 :
2758 : /* Stash away derived types so that the backend_decls
2759 : do not get mixed up. */
2760 2781 : old_dt_list = gfc_derived_types;
2761 2781 : gfc_derived_types = NULL;
2762 :
2763 2781 : gfc_resolve (gsym->ns);
2764 :
2765 : /* Store the new derived types with the global namespace. */
2766 2781 : if (gfc_derived_types)
2767 306 : gsym->ns->derived_types = gfc_derived_types;
2768 :
2769 : /* Restore the derived types of this namespace. */
2770 2781 : gfc_derived_types = old_dt_list;
2771 : }
2772 :
2773 : /* Make sure that translation for the gsymbol occurs before
2774 : the procedure currently being resolved. */
2775 14939 : ns = gfc_global_ns_list;
2776 25334 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2777 : {
2778 16930 : if (ns->sibling == gsym->ns)
2779 : {
2780 6535 : ns->sibling = gsym->ns->sibling;
2781 6535 : gsym->ns->sibling = gfc_global_ns_list;
2782 6535 : gfc_global_ns_list = gsym->ns;
2783 6535 : break;
2784 : }
2785 : }
2786 :
2787 : /* This can happen if a binding name has been specified. */
2788 14939 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2789 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2790 : }
2791 :
2792 : /* Look up the specific entry symbol so that interface checks use
2793 : the entry's own formal argument list, not the entry master's.
2794 : This must run even when resolved == -1 (recursive resolution in
2795 : progress), because def_sym starts as the namespace proc_name
2796 : which is the entry master with the combined formals. */
2797 14961 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2798 : {
2799 979 : gfc_entry_list *entry;
2800 1699 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2801 1699 : if (strcmp (entry->sym->name, sym->name) == 0)
2802 : {
2803 979 : def_sym = entry->sym;
2804 979 : break;
2805 : }
2806 : }
2807 :
2808 14961 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2809 : {
2810 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2811 : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2812 6 : gfc_typename (&def_sym->ts));
2813 28 : goto done;
2814 : }
2815 :
2816 14955 : if (sym->attr.if_source == IFSRC_UNKNOWN
2817 14955 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2818 : {
2819 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2820 : sym->name, &sym->declared_at, reason);
2821 8 : goto done;
2822 : }
2823 :
2824 14947 : bool bad_result_characteristics;
2825 14947 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2826 : reason, sizeof(reason), NULL, NULL,
2827 : &bad_result_characteristics))
2828 : {
2829 : /* Turn errors into warnings with -std=gnu and -std=legacy,
2830 : unless a function returns a wrong type, which can lead
2831 : to all kinds of ICEs and wrong code. */
2832 :
2833 14 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2834 2 : && !bad_result_characteristics)
2835 2 : gfc_errors_to_warnings (true);
2836 :
2837 14 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2838 : sym->name, &sym->declared_at, reason);
2839 14 : sym->error = 1;
2840 14 : gfc_errors_to_warnings (false);
2841 14 : goto done;
2842 : }
2843 : }
2844 :
2845 29576 : done:
2846 :
2847 29576 : if (gsym->type == GSYM_UNKNOWN)
2848 : {
2849 4028 : gsym->type = type;
2850 4028 : gsym->where = *where;
2851 : }
2852 :
2853 29576 : gsym->used = 1;
2854 29576 : }
2855 :
2856 :
2857 : /************* Function resolution *************/
2858 :
2859 : /* Resolve a function call known to be generic.
2860 : Section 14.1.2.4.1. */
2861 :
2862 : static match
2863 28038 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2864 : {
2865 28038 : gfc_symbol *s;
2866 :
2867 28038 : if (sym->attr.generic)
2868 : {
2869 26882 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2870 26882 : if (s != NULL)
2871 : {
2872 20197 : expr->value.function.name = s->name;
2873 20197 : expr->value.function.esym = s;
2874 :
2875 20197 : if (s->ts.type != BT_UNKNOWN)
2876 20180 : expr->ts = s->ts;
2877 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2878 15 : expr->ts = s->result->ts;
2879 :
2880 20197 : if (s->as != NULL)
2881 : {
2882 55 : expr->rank = s->as->rank;
2883 55 : expr->corank = s->as->corank;
2884 : }
2885 20142 : else if (s->result != NULL && s->result->as != NULL)
2886 : {
2887 0 : expr->rank = s->result->as->rank;
2888 0 : expr->corank = s->result->as->corank;
2889 : }
2890 :
2891 20197 : gfc_set_sym_referenced (expr->value.function.esym);
2892 :
2893 20197 : return MATCH_YES;
2894 : }
2895 :
2896 : /* TODO: Need to search for elemental references in generic
2897 : interface. */
2898 : }
2899 :
2900 7841 : if (sym->attr.intrinsic)
2901 1113 : return gfc_intrinsic_func_interface (expr, 0);
2902 :
2903 : return MATCH_NO;
2904 : }
2905 :
2906 :
2907 : static bool
2908 27894 : resolve_generic_f (gfc_expr *expr)
2909 : {
2910 27894 : gfc_symbol *sym;
2911 27894 : match m;
2912 27894 : gfc_interface *intr = NULL;
2913 :
2914 27894 : sym = expr->symtree->n.sym;
2915 :
2916 28038 : for (;;)
2917 : {
2918 28038 : m = resolve_generic_f0 (expr, sym);
2919 28038 : if (m == MATCH_YES)
2920 : return true;
2921 6730 : else if (m == MATCH_ERROR)
2922 : return false;
2923 :
2924 6730 : generic:
2925 6733 : if (!intr)
2926 6701 : for (intr = sym->generic; intr; intr = intr->next)
2927 6617 : if (gfc_fl_struct (intr->sym->attr.flavor))
2928 : break;
2929 :
2930 6733 : if (sym->ns->parent == NULL)
2931 : break;
2932 298 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2933 :
2934 298 : if (sym == NULL)
2935 : break;
2936 147 : if (!generic_sym (sym))
2937 3 : goto generic;
2938 : }
2939 :
2940 : /* Last ditch attempt. See if the reference is to an intrinsic
2941 : that possesses a matching interface. 14.1.2.4 */
2942 6586 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2943 : {
2944 5 : if (gfc_init_expr_flag)
2945 1 : gfc_error ("Function %qs in initialization expression at %L "
2946 : "must be an intrinsic function",
2947 1 : expr->symtree->n.sym->name, &expr->where);
2948 : else
2949 4 : gfc_error ("There is no specific function for the generic %qs "
2950 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2951 5 : return false;
2952 : }
2953 :
2954 6581 : if (intr)
2955 : {
2956 6546 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2957 : NULL, false))
2958 : return false;
2959 6519 : if (!gfc_use_derived (expr->ts.u.derived))
2960 : return false;
2961 6519 : return resolve_structure_cons (expr, 0);
2962 : }
2963 :
2964 35 : m = gfc_intrinsic_func_interface (expr, 0);
2965 35 : if (m == MATCH_YES)
2966 : return true;
2967 :
2968 3 : if (m == MATCH_NO)
2969 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2970 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2971 : &expr->where);
2972 :
2973 : return false;
2974 : }
2975 :
2976 :
2977 : /* Resolve a function call known to be specific. */
2978 :
2979 : static match
2980 28331 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2981 : {
2982 28331 : match m;
2983 :
2984 28331 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2985 : {
2986 8197 : if (sym->attr.dummy)
2987 : {
2988 282 : sym->attr.proc = PROC_DUMMY;
2989 282 : goto found;
2990 : }
2991 :
2992 7915 : sym->attr.proc = PROC_EXTERNAL;
2993 7915 : goto found;
2994 : }
2995 :
2996 20134 : if (sym->attr.proc == PROC_MODULE
2997 11267 : || sym->attr.proc == PROC_ST_FUNCTION
2998 10977 : || sym->attr.proc == PROC_INTERNAL)
2999 19396 : goto found;
3000 :
3001 738 : if (sym->attr.intrinsic)
3002 : {
3003 731 : m = gfc_intrinsic_func_interface (expr, 1);
3004 731 : if (m == MATCH_YES)
3005 : return MATCH_YES;
3006 0 : if (m == MATCH_NO)
3007 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
3008 : "with an intrinsic", sym->name, &expr->where);
3009 :
3010 0 : return MATCH_ERROR;
3011 : }
3012 :
3013 : return MATCH_NO;
3014 :
3015 27593 : found:
3016 27593 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3017 :
3018 27593 : if (sym->result)
3019 27593 : expr->ts = sym->result->ts;
3020 : else
3021 0 : expr->ts = sym->ts;
3022 27593 : expr->value.function.name = sym->name;
3023 27593 : expr->value.function.esym = sym;
3024 : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
3025 : error(s). */
3026 27593 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
3027 : return MATCH_ERROR;
3028 27592 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
3029 : {
3030 322 : expr->rank = CLASS_DATA (sym)->as->rank;
3031 322 : expr->corank = CLASS_DATA (sym)->as->corank;
3032 : }
3033 27270 : else if (sym->as != NULL)
3034 : {
3035 2335 : expr->rank = sym->as->rank;
3036 2335 : expr->corank = sym->as->corank;
3037 : }
3038 :
3039 : return MATCH_YES;
3040 : }
3041 :
3042 :
3043 : static bool
3044 28324 : resolve_specific_f (gfc_expr *expr)
3045 : {
3046 28324 : gfc_symbol *sym;
3047 28324 : match m;
3048 :
3049 28324 : sym = expr->symtree->n.sym;
3050 :
3051 28331 : for (;;)
3052 : {
3053 28331 : m = resolve_specific_f0 (sym, expr);
3054 28331 : if (m == MATCH_YES)
3055 : return true;
3056 8 : if (m == MATCH_ERROR)
3057 : return false;
3058 :
3059 7 : if (sym->ns->parent == NULL)
3060 : break;
3061 :
3062 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3063 :
3064 7 : if (sym == NULL)
3065 : break;
3066 : }
3067 :
3068 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3069 0 : expr->symtree->n.sym->name, &expr->where);
3070 :
3071 0 : return true;
3072 : }
3073 :
3074 : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3075 : candidates in CANDIDATES_LEN. */
3076 :
3077 : static void
3078 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3079 : char **&candidates,
3080 : size_t &candidates_len)
3081 : {
3082 388 : gfc_symtree *p;
3083 :
3084 388 : if (sym == NULL)
3085 : return;
3086 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3087 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3088 51 : vec_push (candidates, candidates_len, sym->name);
3089 :
3090 388 : p = sym->left;
3091 388 : if (p)
3092 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3093 :
3094 388 : p = sym->right;
3095 388 : if (p)
3096 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3097 : }
3098 :
3099 :
3100 : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3101 :
3102 : const char*
3103 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3104 : {
3105 57 : char **candidates = NULL;
3106 57 : size_t candidates_len = 0;
3107 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3108 57 : return gfc_closest_fuzzy_match (fn, candidates);
3109 : }
3110 :
3111 :
3112 : /* Resolve a procedure call not known to be generic nor specific. */
3113 :
3114 : static bool
3115 277782 : resolve_unknown_f (gfc_expr *expr)
3116 : {
3117 277782 : gfc_symbol *sym;
3118 277782 : gfc_typespec *ts;
3119 :
3120 277782 : sym = expr->symtree->n.sym;
3121 :
3122 277782 : if (sym->attr.dummy)
3123 : {
3124 289 : sym->attr.proc = PROC_DUMMY;
3125 289 : expr->value.function.name = sym->name;
3126 289 : goto set_type;
3127 : }
3128 :
3129 : /* See if we have an intrinsic function reference. */
3130 :
3131 277493 : if (gfc_is_intrinsic (sym, 0, expr->where))
3132 : {
3133 275236 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3134 : return true;
3135 : return false;
3136 : }
3137 :
3138 : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3139 : /* Intrinsics were handled above, only non-intrinsics left here. */
3140 2257 : if (sym->attr.flavor == FL_PROCEDURE
3141 2254 : && sym->attr.implicit_type
3142 371 : && sym->ns
3143 371 : && sym->ns->has_implicit_none_export)
3144 : {
3145 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3146 : "for symbol %qs at %L", sym->name, &sym->declared_at);
3147 3 : sym->error = 1;
3148 3 : return false;
3149 : }
3150 :
3151 : /* The reference is to an external name. */
3152 :
3153 2254 : sym->attr.proc = PROC_EXTERNAL;
3154 2254 : expr->value.function.name = sym->name;
3155 2254 : expr->value.function.esym = expr->symtree->n.sym;
3156 :
3157 2254 : if (sym->as != NULL)
3158 : {
3159 1 : expr->rank = sym->as->rank;
3160 1 : expr->corank = sym->as->corank;
3161 : }
3162 :
3163 : /* Type of the expression is either the type of the symbol or the
3164 : default type of the symbol. */
3165 :
3166 2253 : set_type:
3167 2543 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3168 :
3169 2543 : if (sym->ts.type != BT_UNKNOWN)
3170 2492 : expr->ts = sym->ts;
3171 : else
3172 : {
3173 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3174 :
3175 51 : if (ts->type == BT_UNKNOWN)
3176 : {
3177 41 : const char *guessed
3178 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3179 41 : if (guessed)
3180 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3181 : "; did you mean %qs?",
3182 : sym->name, &expr->where, guessed);
3183 : else
3184 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3185 : sym->name, &expr->where);
3186 41 : return false;
3187 : }
3188 : else
3189 10 : expr->ts = *ts;
3190 : }
3191 :
3192 : return true;
3193 : }
3194 :
3195 :
3196 : /* Return true, if the symbol is an external procedure. */
3197 : static bool
3198 857865 : is_external_proc (gfc_symbol *sym)
3199 : {
3200 856150 : if (!sym->attr.dummy && !sym->attr.contained
3201 747214 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3202 163442 : && sym->attr.proc != PROC_ST_FUNCTION
3203 162847 : && !sym->attr.proc_pointer
3204 161641 : && !sym->attr.use_assoc
3205 917048 : && sym->name)
3206 : return true;
3207 :
3208 : return false;
3209 : }
3210 :
3211 :
3212 : /* Figure out if a function reference is pure or not. Also set the name
3213 : of the function for a potential error message. Return nonzero if the
3214 : function is PURE, zero if not. */
3215 : static bool
3216 : pure_stmt_function (gfc_expr *, gfc_symbol *);
3217 :
3218 : bool
3219 258072 : gfc_pure_function (gfc_expr *e, const char **name)
3220 : {
3221 258072 : bool pure;
3222 258072 : gfc_component *comp;
3223 :
3224 258072 : *name = NULL;
3225 :
3226 258072 : if (e->symtree != NULL
3227 257716 : && e->symtree->n.sym != NULL
3228 257716 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3229 305 : return pure_stmt_function (e, e->symtree->n.sym);
3230 :
3231 257767 : comp = gfc_get_proc_ptr_comp (e);
3232 257767 : if (comp)
3233 : {
3234 479 : pure = gfc_pure (comp->ts.interface);
3235 479 : *name = comp->name;
3236 : }
3237 257288 : else if (e->value.function.esym)
3238 : {
3239 53384 : pure = gfc_pure (e->value.function.esym);
3240 53384 : *name = e->value.function.esym->name;
3241 : }
3242 203904 : else if (e->value.function.isym)
3243 : {
3244 405668 : pure = e->value.function.isym->pure
3245 202834 : || e->value.function.isym->elemental;
3246 202834 : *name = e->value.function.isym->name;
3247 : }
3248 1070 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3249 : {
3250 : /* The function has been resolved, but esym is not yet set.
3251 : This can happen with functions as dummy argument. */
3252 287 : pure = e->symtree->n.sym->attr.pure;
3253 287 : *name = e->symtree->n.sym->name;
3254 : }
3255 : else
3256 : {
3257 : /* Implicit functions are not pure. */
3258 783 : pure = 0;
3259 783 : *name = e->value.function.name;
3260 : }
3261 :
3262 : return pure;
3263 : }
3264 :
3265 :
3266 : /* Check if the expression is a reference to an implicitly pure function. */
3267 :
3268 : bool
3269 38694 : gfc_implicit_pure_function (gfc_expr *e)
3270 : {
3271 38694 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3272 38694 : if (comp)
3273 463 : return gfc_implicit_pure (comp->ts.interface);
3274 38231 : else if (e->value.function.esym)
3275 32825 : return gfc_implicit_pure (e->value.function.esym);
3276 : else
3277 : return 0;
3278 : }
3279 :
3280 :
3281 : static bool
3282 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3283 : int *f ATTRIBUTE_UNUSED)
3284 : {
3285 981 : const char *name;
3286 :
3287 : /* Don't bother recursing into other statement functions
3288 : since they will be checked individually for purity. */
3289 981 : if (e->expr_type != EXPR_FUNCTION
3290 343 : || !e->symtree
3291 343 : || e->symtree->n.sym == sym
3292 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3293 : return false;
3294 :
3295 19 : return !gfc_pure_function (e, &name);
3296 : }
3297 :
3298 :
3299 : static bool
3300 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3301 : {
3302 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3303 : }
3304 :
3305 :
3306 : /* Check if an impure function is allowed in the current context. */
3307 :
3308 246082 : static bool check_pure_function (gfc_expr *e)
3309 : {
3310 246082 : const char *name = NULL;
3311 246082 : code_stack *stack;
3312 246082 : bool saw_block = false;
3313 :
3314 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3315 : gfc_do_concurrent_flag = 0 when the check for an impure function
3316 : occurs. Check the stack to see if the source code has a nested
3317 : BLOCK construct. */
3318 :
3319 569543 : for (stack = cs_base; stack; stack = stack->prev)
3320 : {
3321 323463 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3322 : {
3323 7469 : saw_block = true;
3324 7469 : continue;
3325 : }
3326 :
3327 5311 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3328 : {
3329 10 : bool is_pure;
3330 323461 : is_pure = (e->value.function.isym
3331 9 : && (e->value.function.isym->pure
3332 1 : || e->value.function.isym->elemental))
3333 11 : || (e->value.function.esym
3334 1 : && (e->value.function.esym->attr.pure
3335 1 : || e->value.function.esym->attr.elemental));
3336 2 : if (!is_pure)
3337 : {
3338 2 : gfc_error ("Reference to impure function at %L inside a "
3339 : "DO CONCURRENT", &e->where);
3340 2 : return false;
3341 : }
3342 : }
3343 : }
3344 :
3345 246080 : if (!gfc_pure_function (e, &name) && name)
3346 : {
3347 37397 : if (forall_flag)
3348 : {
3349 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3350 : "FORALL %s", name, &e->where,
3351 : forall_flag == 2 ? "mask" : "block");
3352 4 : return false;
3353 : }
3354 37393 : else if (gfc_do_concurrent_flag)
3355 : {
3356 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3357 : "DO CONCURRENT %s", name, &e->where,
3358 : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3359 2 : return false;
3360 : }
3361 37391 : else if (gfc_pure (NULL))
3362 : {
3363 5 : gfc_error ("Reference to impure function %qs at %L "
3364 : "within a PURE procedure", name, &e->where);
3365 5 : return false;
3366 : }
3367 37386 : if (!gfc_implicit_pure_function (e))
3368 30866 : gfc_unset_implicit_pure (NULL);
3369 : }
3370 : return true;
3371 : }
3372 :
3373 :
3374 : /* Update current procedure's array_outer_dependency flag, considering
3375 : a call to procedure SYM. */
3376 :
3377 : static void
3378 133791 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3379 : {
3380 : /* Check to see if this is a sibling function that has not yet
3381 : been resolved. */
3382 133791 : gfc_namespace *sibling = gfc_current_ns->sibling;
3383 251684 : for (; sibling; sibling = sibling->sibling)
3384 : {
3385 125067 : if (sibling->proc_name == sym)
3386 : {
3387 7174 : gfc_resolve (sibling);
3388 7174 : break;
3389 : }
3390 : }
3391 :
3392 : /* If SYM has references to outer arrays, so has the procedure calling
3393 : SYM. If SYM is a procedure pointer, we can assume the worst. */
3394 133791 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3395 68686 : && gfc_current_ns->proc_name)
3396 68642 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3397 133791 : }
3398 :
3399 :
3400 : /* Resolve a function call, which means resolving the arguments, then figuring
3401 : out which entity the name refers to. */
3402 :
3403 : static bool
3404 347344 : resolve_function (gfc_expr *expr)
3405 : {
3406 347344 : gfc_actual_arglist *arg;
3407 347344 : gfc_symbol *sym;
3408 347344 : bool t;
3409 347344 : int temp;
3410 347344 : procedure_type p = PROC_INTRINSIC;
3411 347344 : bool no_formal_args;
3412 :
3413 347344 : sym = NULL;
3414 347344 : if (expr->symtree)
3415 346988 : sym = expr->symtree->n.sym;
3416 :
3417 : /* If this is a procedure pointer component, it has already been resolved. */
3418 347344 : if (gfc_is_proc_ptr_comp (expr))
3419 : return true;
3420 :
3421 : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3422 : another caf_get. */
3423 346928 : if (sym && sym->attr.intrinsic
3424 8755 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3425 8755 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3426 : return true;
3427 :
3428 346928 : if (expr->ref)
3429 : {
3430 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3431 : &expr->where);
3432 1 : return false;
3433 : }
3434 :
3435 346571 : if (sym && sym->attr.intrinsic
3436 355682 : && !gfc_resolve_intrinsic (sym, &expr->where))
3437 : return false;
3438 :
3439 346927 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3440 : {
3441 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3442 4 : return false;
3443 : }
3444 :
3445 : /* If this is a deferred TBP with an abstract interface (which may
3446 : of course be referenced), expr->value.function.esym will be set. */
3447 346567 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3448 : {
3449 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3450 : sym->name, &expr->where);
3451 1 : return false;
3452 : }
3453 :
3454 : /* If this is a deferred TBP with an abstract interface, its result
3455 : cannot be an assumed length character (F2003: C418). */
3456 346566 : if (sym && sym->attr.abstract && sym->attr.function
3457 192 : && sym->result->ts.u.cl
3458 158 : && sym->result->ts.u.cl->length == NULL
3459 2 : && !sym->result->ts.deferred)
3460 : {
3461 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3462 : "character length result (F2008: C418)", sym->name,
3463 : &sym->declared_at);
3464 1 : return false;
3465 : }
3466 :
3467 : /* Switch off assumed size checking and do this again for certain kinds
3468 : of procedure, once the procedure itself is resolved. */
3469 346921 : need_full_assumed_size++;
3470 :
3471 346921 : if (expr->symtree && expr->symtree->n.sym)
3472 346565 : p = expr->symtree->n.sym->attr.proc;
3473 :
3474 346921 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3475 1175 : inquiry_argument = true;
3476 346565 : no_formal_args = sym && is_external_proc (sym)
3477 360832 : && gfc_sym_get_dummy_args (sym) == NULL;
3478 :
3479 346921 : if (!resolve_actual_arglist (expr->value.function.actual,
3480 : p, no_formal_args))
3481 : {
3482 67 : inquiry_argument = false;
3483 67 : return false;
3484 : }
3485 :
3486 346854 : inquiry_argument = false;
3487 :
3488 : /* Resume assumed_size checking. */
3489 346854 : need_full_assumed_size--;
3490 :
3491 : /* If the procedure is external, check for usage. */
3492 346854 : if (sym && is_external_proc (sym))
3493 13891 : resolve_global_procedure (sym, &expr->where, 0);
3494 :
3495 346854 : if (sym && sym->ts.type == BT_CHARACTER
3496 3359 : && sym->ts.u.cl
3497 3265 : && sym->ts.u.cl->length == NULL
3498 677 : && !sym->attr.dummy
3499 670 : && !sym->ts.deferred
3500 2 : && expr->value.function.esym == NULL
3501 2 : && !sym->attr.contained)
3502 : {
3503 : /* Internal procedures are taken care of in resolve_contained_fntype. */
3504 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3505 : "be used at %L since it is not a dummy argument",
3506 : sym->name, &expr->where);
3507 1 : return false;
3508 : }
3509 :
3510 : /* Add and check formal interface when -fc-prototypes-external is in
3511 : force, see comment in resolve_call(). */
3512 :
3513 346853 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3514 18 : && sym->attr.external)
3515 : {
3516 18 : if (sym->formal)
3517 : {
3518 6 : bool conflict;
3519 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3520 : sym->formal, 0, 0, 0, NULL);
3521 6 : if (conflict)
3522 : {
3523 6 : sym->ext_dummy_arglist_mismatch = 1;
3524 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3525 : "Different argument lists in external dummy "
3526 : "function %s at %L and %L", sym->name,
3527 : &expr->where, &sym->other_loc);
3528 : }
3529 : }
3530 12 : else if (!sym->formal_resolved)
3531 : {
3532 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3533 6 : sym->other_loc = expr->where;
3534 : }
3535 : }
3536 : /* See if function is already resolved. */
3537 :
3538 346853 : if (expr->value.function.name != NULL
3539 334844 : || expr->value.function.isym != NULL)
3540 : {
3541 12853 : if (expr->ts.type == BT_UNKNOWN)
3542 3 : expr->ts = sym->ts;
3543 : t = true;
3544 : }
3545 : else
3546 : {
3547 : /* Apply the rules of section 14.1.2. */
3548 :
3549 334000 : switch (procedure_kind (sym))
3550 : {
3551 27894 : case PTYPE_GENERIC:
3552 27894 : t = resolve_generic_f (expr);
3553 27894 : break;
3554 :
3555 28324 : case PTYPE_SPECIFIC:
3556 28324 : t = resolve_specific_f (expr);
3557 28324 : break;
3558 :
3559 277782 : case PTYPE_UNKNOWN:
3560 277782 : t = resolve_unknown_f (expr);
3561 277782 : break;
3562 :
3563 : default:
3564 : gfc_internal_error ("resolve_function(): bad function type");
3565 : }
3566 : }
3567 :
3568 : /* If the expression is still a function (it might have simplified),
3569 : then we check to see if we are calling an elemental function. */
3570 :
3571 346853 : if (expr->expr_type != EXPR_FUNCTION)
3572 : return t;
3573 :
3574 : /* Walk the argument list looking for invalid BOZ. */
3575 744128 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3576 498502 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3577 : {
3578 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3579 : "actual argument in a function reference",
3580 : &arg->expr->where);
3581 5 : return false;
3582 : }
3583 :
3584 245626 : temp = need_full_assumed_size;
3585 245626 : need_full_assumed_size = 0;
3586 :
3587 245626 : if (!resolve_elemental_actual (expr, NULL))
3588 : return false;
3589 :
3590 245623 : if (omp_workshare_flag
3591 32 : && expr->value.function.esym
3592 245628 : && ! gfc_elemental (expr->value.function.esym))
3593 : {
3594 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3595 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3596 : &expr->where);
3597 4 : t = false;
3598 : }
3599 :
3600 : #define GENERIC_ID expr->value.function.isym->id
3601 245619 : else if (expr->value.function.actual != NULL
3602 237410 : && expr->value.function.isym != NULL
3603 192008 : && GENERIC_ID != GFC_ISYM_LBOUND
3604 : && GENERIC_ID != GFC_ISYM_LCOBOUND
3605 : && GENERIC_ID != GFC_ISYM_UCOBOUND
3606 : && GENERIC_ID != GFC_ISYM_LEN
3607 : && GENERIC_ID != GFC_ISYM_LOC
3608 : && GENERIC_ID != GFC_ISYM_C_LOC
3609 : && GENERIC_ID != GFC_ISYM_PRESENT)
3610 : {
3611 : /* Array intrinsics must also have the last upper bound of an
3612 : assumed size array argument. UBOUND and SIZE have to be
3613 : excluded from the check if the second argument is anything
3614 : than a constant. */
3615 :
3616 540073 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3617 : {
3618 374087 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3619 45989 : && arg == expr->value.function.actual
3620 16941 : && arg->next != NULL && arg->next->expr)
3621 : {
3622 8345 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3623 : break;
3624 :
3625 8121 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3626 : break;
3627 :
3628 8121 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3629 8121 : < arg->expr->rank)
3630 : break;
3631 : }
3632 :
3633 371672 : if (arg->expr != NULL
3634 247877 : && arg->expr->rank > 0
3635 491088 : && resolve_assumed_size_actual (arg->expr))
3636 : return false;
3637 : }
3638 : }
3639 : #undef GENERIC_ID
3640 :
3641 245620 : need_full_assumed_size = temp;
3642 :
3643 245620 : if (!check_pure_function(expr))
3644 12 : t = false;
3645 :
3646 : /* Functions without the RECURSIVE attribution are not allowed to
3647 : * call themselves. */
3648 245620 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3649 : {
3650 52109 : gfc_symbol *esym;
3651 52109 : esym = expr->value.function.esym;
3652 :
3653 52109 : if (is_illegal_recursion (esym, gfc_current_ns))
3654 : {
3655 5 : if (esym->attr.entry && esym->ns->entries)
3656 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3657 : " function %qs is not RECURSIVE",
3658 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3659 : else
3660 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3661 : " is not RECURSIVE", esym->name, &expr->where);
3662 :
3663 : t = false;
3664 : }
3665 : }
3666 :
3667 : /* Character lengths of use associated functions may contains references to
3668 : symbols not referenced from the current program unit otherwise. Make sure
3669 : those symbols are marked as referenced. */
3670 :
3671 245620 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3672 3463 : && expr->value.function.esym->attr.use_assoc)
3673 : {
3674 1256 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3675 : }
3676 :
3677 : /* Make sure that the expression has a typespec that works. */
3678 245620 : if (expr->ts.type == BT_UNKNOWN)
3679 : {
3680 922 : if (expr->symtree->n.sym->result
3681 913 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3682 561 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3683 561 : expr->ts = expr->symtree->n.sym->result->ts;
3684 : }
3685 :
3686 : /* These derived types with an incomplete namespace, arising from use
3687 : association, cause gfc_get_derived_vtab to segfault. If the function
3688 : namespace does not suffice, something is badly wrong. */
3689 245620 : if (expr->ts.type == BT_DERIVED
3690 9592 : && !expr->ts.u.derived->ns->proc_name)
3691 : {
3692 3 : gfc_symbol *der;
3693 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3694 3 : if (der)
3695 : {
3696 3 : expr->ts.u.derived->refs--;
3697 3 : expr->ts.u.derived = der;
3698 3 : der->refs++;
3699 : }
3700 : else
3701 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3702 : }
3703 :
3704 245620 : if (!expr->ref && !expr->value.function.isym)
3705 : {
3706 53491 : if (expr->value.function.esym)
3707 52421 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3708 : else
3709 1070 : update_current_proc_array_outer_dependency (sym);
3710 : }
3711 192129 : else if (expr->ref)
3712 : /* typebound procedure: Assume the worst. */
3713 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3714 :
3715 245620 : if (expr->value.function.esym
3716 52421 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3717 26 : gfc_warning (OPT_Wdeprecated_declarations,
3718 : "Using function %qs at %L is deprecated",
3719 : sym->name, &expr->where);
3720 :
3721 : /* Check an external function supplied as a dummy argument has an external
3722 : attribute when a program unit uses 'implicit none (external)'. */
3723 245620 : if (expr->expr_type == EXPR_FUNCTION
3724 245620 : && expr->symtree
3725 245264 : && expr->symtree->n.sym->attr.dummy
3726 570 : && expr->symtree->n.sym->ns->has_implicit_none_export
3727 245621 : && !gfc_is_intrinsic(expr->symtree->n.sym, 0, expr->where))
3728 : {
3729 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
3730 : sym->name, &expr->where);
3731 1 : return false;
3732 : }
3733 :
3734 : return t;
3735 : }
3736 :
3737 :
3738 : /************* Subroutine resolution *************/
3739 :
3740 : static bool
3741 77756 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3742 : {
3743 77756 : code_stack *stack;
3744 77756 : bool saw_block = false;
3745 :
3746 77756 : if (gfc_pure (sym))
3747 : return true;
3748 :
3749 : /* A BLOCK construct within a DO CONCURRENT construct leads to
3750 : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3751 : occurs. Walk up the stack to see if the source code has a nested
3752 : construct. */
3753 :
3754 160427 : for (stack = cs_base; stack; stack = stack->prev)
3755 : {
3756 88322 : if (stack->current->op == EXEC_BLOCK)
3757 : {
3758 1924 : saw_block = true;
3759 1924 : continue;
3760 : }
3761 :
3762 86398 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3763 : {
3764 :
3765 2 : bool is_pure = true;
3766 88322 : is_pure = sym->attr.pure || sym->attr.elemental;
3767 :
3768 2 : if (!is_pure)
3769 : {
3770 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3771 : "is not PURE", loc);
3772 2 : return false;
3773 : }
3774 : }
3775 : }
3776 :
3777 72105 : if (forall_flag)
3778 : {
3779 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3780 : name, loc);
3781 0 : return false;
3782 : }
3783 72105 : else if (gfc_do_concurrent_flag)
3784 : {
3785 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3786 : "PURE", name, loc);
3787 6 : return false;
3788 : }
3789 72099 : else if (gfc_pure (NULL))
3790 : {
3791 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3792 4 : return false;
3793 : }
3794 :
3795 72095 : gfc_unset_implicit_pure (NULL);
3796 72095 : return true;
3797 : }
3798 :
3799 :
3800 : static match
3801 2883 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3802 : {
3803 2883 : gfc_symbol *s;
3804 :
3805 2883 : if (sym->attr.generic)
3806 : {
3807 2882 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3808 2882 : if (s != NULL)
3809 : {
3810 2873 : c->resolved_sym = s;
3811 2873 : if (!pure_subroutine (s, s->name, &c->loc))
3812 : return MATCH_ERROR;
3813 2873 : return MATCH_YES;
3814 : }
3815 :
3816 : /* TODO: Need to search for elemental references in generic interface. */
3817 : }
3818 :
3819 10 : if (sym->attr.intrinsic)
3820 1 : return gfc_intrinsic_sub_interface (c, 0);
3821 :
3822 : return MATCH_NO;
3823 : }
3824 :
3825 :
3826 : static bool
3827 2881 : resolve_generic_s (gfc_code *c)
3828 : {
3829 2881 : gfc_symbol *sym;
3830 2881 : match m;
3831 :
3832 2881 : sym = c->symtree->n.sym;
3833 :
3834 2883 : for (;;)
3835 : {
3836 2883 : m = resolve_generic_s0 (c, sym);
3837 2883 : if (m == MATCH_YES)
3838 : return true;
3839 9 : else if (m == MATCH_ERROR)
3840 : return false;
3841 :
3842 9 : generic:
3843 9 : if (sym->ns->parent == NULL)
3844 : break;
3845 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3846 :
3847 3 : if (sym == NULL)
3848 : break;
3849 2 : if (!generic_sym (sym))
3850 0 : goto generic;
3851 : }
3852 :
3853 : /* Last ditch attempt. See if the reference is to an intrinsic
3854 : that possesses a matching interface. 14.1.2.4 */
3855 7 : sym = c->symtree->n.sym;
3856 :
3857 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3858 : {
3859 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3860 : sym->name, &c->loc);
3861 4 : return false;
3862 : }
3863 :
3864 3 : m = gfc_intrinsic_sub_interface (c, 0);
3865 3 : if (m == MATCH_YES)
3866 : return true;
3867 1 : if (m == MATCH_NO)
3868 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3869 : "intrinsic subroutine interface", sym->name, &c->loc);
3870 :
3871 : return false;
3872 : }
3873 :
3874 :
3875 : /* Resolve a subroutine call known to be specific. */
3876 :
3877 : static match
3878 63163 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3879 : {
3880 63163 : match m;
3881 :
3882 63163 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3883 : {
3884 5717 : if (sym->attr.dummy)
3885 : {
3886 257 : sym->attr.proc = PROC_DUMMY;
3887 257 : goto found;
3888 : }
3889 :
3890 5460 : sym->attr.proc = PROC_EXTERNAL;
3891 5460 : goto found;
3892 : }
3893 :
3894 57446 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3895 57446 : goto found;
3896 :
3897 0 : if (sym->attr.intrinsic)
3898 : {
3899 0 : m = gfc_intrinsic_sub_interface (c, 1);
3900 0 : if (m == MATCH_YES)
3901 : return MATCH_YES;
3902 0 : if (m == MATCH_NO)
3903 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3904 : "with an intrinsic", sym->name, &c->loc);
3905 :
3906 0 : return MATCH_ERROR;
3907 : }
3908 :
3909 : return MATCH_NO;
3910 :
3911 63163 : found:
3912 63163 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3913 :
3914 63163 : c->resolved_sym = sym;
3915 63163 : if (!pure_subroutine (sym, sym->name, &c->loc))
3916 : return MATCH_ERROR;
3917 :
3918 : return MATCH_YES;
3919 : }
3920 :
3921 :
3922 : static bool
3923 63163 : resolve_specific_s (gfc_code *c)
3924 : {
3925 63163 : gfc_symbol *sym;
3926 63163 : match m;
3927 :
3928 63163 : sym = c->symtree->n.sym;
3929 :
3930 63163 : for (;;)
3931 : {
3932 63163 : m = resolve_specific_s0 (c, sym);
3933 63163 : if (m == MATCH_YES)
3934 : return true;
3935 7 : if (m == MATCH_ERROR)
3936 : return false;
3937 :
3938 0 : if (sym->ns->parent == NULL)
3939 : break;
3940 :
3941 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3942 :
3943 0 : if (sym == NULL)
3944 : break;
3945 : }
3946 :
3947 0 : sym = c->symtree->n.sym;
3948 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3949 : sym->name, &c->loc);
3950 :
3951 0 : return false;
3952 : }
3953 :
3954 :
3955 : /* Resolve a subroutine call not known to be generic nor specific. */
3956 :
3957 : static bool
3958 15901 : resolve_unknown_s (gfc_code *c)
3959 : {
3960 15901 : gfc_symbol *sym;
3961 :
3962 15901 : sym = c->symtree->n.sym;
3963 :
3964 15901 : if (sym->attr.dummy)
3965 : {
3966 26 : sym->attr.proc = PROC_DUMMY;
3967 26 : goto found;
3968 : }
3969 :
3970 : /* See if we have an intrinsic function reference. */
3971 :
3972 15875 : if (gfc_is_intrinsic (sym, 1, c->loc))
3973 : {
3974 4304 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3975 : return true;
3976 319 : return false;
3977 : }
3978 :
3979 : /* The reference is to an external name. */
3980 :
3981 11571 : found:
3982 11597 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3983 :
3984 11597 : c->resolved_sym = sym;
3985 :
3986 11597 : return pure_subroutine (sym, sym->name, &c->loc);
3987 : }
3988 :
3989 :
3990 :
3991 : static bool
3992 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3993 : gfc_code *c, gfc_namespace *ns)
3994 : {
3995 805 : locus *here;
3996 :
3997 : /* If the type has been imported then its vtype functions are OK. */
3998 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
3999 : return true;
4000 :
4001 : if (e)
4002 791 : here = &e->where;
4003 : else
4004 7 : here = &c->loc;
4005 :
4006 798 : if (s && !s->import_only)
4007 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
4008 :
4009 798 : if (ns->import_state == IMPORT_ONLY
4010 75 : && sym->ns != ns
4011 58 : && (!s || !s->import_only))
4012 : {
4013 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
4014 : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
4015 21 : return false;
4016 : }
4017 777 : else if (ns->import_state == IMPORT_NONE
4018 27 : && sym->ns != ns)
4019 : {
4020 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
4021 : "has IMPORT, NONE", sym->name, here);
4022 12 : return false;
4023 : }
4024 : return true;
4025 : }
4026 :
4027 :
4028 : static bool
4029 7354 : check_import_status (gfc_expr *e)
4030 : {
4031 7354 : gfc_symtree *st;
4032 7354 : gfc_ref *ref;
4033 7354 : gfc_symbol *sym, *der;
4034 7354 : gfc_namespace *ns = gfc_current_ns;
4035 :
4036 7354 : switch (e->expr_type)
4037 : {
4038 727 : case EXPR_VARIABLE:
4039 727 : case EXPR_FUNCTION:
4040 727 : case EXPR_SUBSTRING:
4041 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
4042 :
4043 : /* Check the symbol itself. */
4044 727 : if (sym
4045 727 : && !(ns->proc_name
4046 : && (sym == ns->proc_name))
4047 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4048 : return false;
4049 :
4050 : /* Check the declared derived type. */
4051 717 : if (sym->ts.type == BT_DERIVED)
4052 : {
4053 16 : der = sym->ts.u.derived;
4054 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4055 :
4056 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4057 : return false;
4058 : }
4059 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4060 : {
4061 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4062 : : sym->ts.u.derived;
4063 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4064 :
4065 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4066 : return false;
4067 : }
4068 :
4069 : /* Check the declared derived types of component references. */
4070 724 : for (ref = e->ref; ref; ref = ref->next)
4071 20 : if (ref->type == REF_COMPONENT)
4072 : {
4073 19 : gfc_component *c = ref->u.c.component;
4074 19 : if (c->ts.type == BT_DERIVED)
4075 : {
4076 7 : der = c->ts.u.derived;
4077 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4078 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4079 : return false;
4080 : }
4081 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4082 : {
4083 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4084 : : c->ts.u.derived;
4085 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4086 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4087 : return false;
4088 : }
4089 : }
4090 :
4091 : break;
4092 :
4093 8 : case EXPR_ARRAY:
4094 8 : case EXPR_STRUCTURE:
4095 : /* Check the declared derived type. */
4096 8 : if (e->ts.type == BT_DERIVED)
4097 : {
4098 8 : der = e->ts.u.derived;
4099 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4100 :
4101 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4102 : return false;
4103 : }
4104 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4105 : {
4106 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4107 : : e->ts.u.derived;
4108 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4109 :
4110 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4111 : return false;
4112 : }
4113 :
4114 : break;
4115 :
4116 : /* Either not applicable or resolved away
4117 : case EXPR_OP:
4118 : case EXPR_UNKNOWN:
4119 : case EXPR_CONSTANT:
4120 : case EXPR_NULL:
4121 : case EXPR_COMPCALL:
4122 : case EXPR_PPC: */
4123 :
4124 : default:
4125 : break;
4126 : }
4127 :
4128 : return true;
4129 : }
4130 :
4131 :
4132 : /* If an elemental call has an INTENT_IN argument that has a dependency on an
4133 : argument which is not INTENT_IN and requires a temporary, build a temporary
4134 : for the INTENT_IN actual argument as well. */
4135 :
4136 : static void
4137 : add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **);
4138 :
4139 : static void
4140 5257 : resolve_elemental_dependencies (gfc_code *c)
4141 : {
4142 5257 : gfc_actual_arglist *arg1 = c->ext.actual;
4143 5257 : gfc_actual_arglist *arg2 = NULL;
4144 5257 : gfc_formal_arglist *formal1 = c->resolved_sym->formal;
4145 5257 : gfc_formal_arglist *formal2 = NULL;
4146 5257 : gfc_expr *expr1;
4147 5257 : gfc_expr **expr2;
4148 :
4149 16645 : for (; arg1 && formal1; arg1 = arg1->next, formal1 = formal1->next)
4150 : {
4151 11388 : if (formal1->sym
4152 11388 : && (formal1->sym->attr.intent == INTENT_IN
4153 3536 : || formal1->sym->attr.value))
4154 8110 : continue;
4155 :
4156 3278 : if (!arg1->expr || arg1->expr->expr_type != EXPR_VARIABLE)
4157 0 : continue;
4158 :
4159 3278 : arg2 = c->ext.actual;
4160 3278 : formal2 = c->resolved_sym->formal;
4161 10696 : for (; arg2 && formal2; arg2 = arg2->next, formal2 = formal2->next)
4162 : {
4163 7418 : if (arg2 == arg1 || !arg2->expr
4164 4128 : || !(formal2->sym && formal2->sym->attr.intent == INTENT_IN))
4165 3304 : continue;
4166 :
4167 4114 : expr1 = arg1->expr;
4168 4114 : expr2 = &arg2->expr;
4169 :
4170 : /* If the arg1 has something horrible like a vector index and
4171 : there is a dependency between arg1 and arg2, build a
4172 : temporary from arg2, assign the arg2 to it and use the
4173 : temporary in the call expression. */
4174 2009 : if (expr1->rank && gfc_ref_needs_temporary_p (expr1->ref)
4175 4234 : && gfc_check_dependency (expr1, *expr2, false))
4176 36 : add_temp_assign_before_call (c, gfc_current_ns, expr2);
4177 : }
4178 : }
4179 5257 : }
4180 :
4181 : /* Resolve a subroutine call. Although it was tempting to use the same code
4182 : for functions, subroutines and functions are stored differently and this
4183 : makes things awkward. */
4184 :
4185 :
4186 : static bool
4187 82090 : resolve_call (gfc_code *c)
4188 : {
4189 82090 : bool t;
4190 82090 : procedure_type ptype = PROC_INTRINSIC;
4191 82090 : gfc_symbol *csym, *sym;
4192 82090 : bool no_formal_args;
4193 :
4194 82090 : csym = c->symtree ? c->symtree->n.sym : NULL;
4195 :
4196 82090 : if (csym && csym->ts.type != BT_UNKNOWN)
4197 : {
4198 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4199 : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4200 4 : return false;
4201 : }
4202 :
4203 82086 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4204 : {
4205 17514 : gfc_symtree *st;
4206 17514 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4207 17514 : sym = st ? st->n.sym : NULL;
4208 17514 : if (sym && csym != sym
4209 3 : && sym->ns == gfc_current_ns
4210 3 : && sym->attr.flavor == FL_PROCEDURE
4211 3 : && sym->attr.contained)
4212 : {
4213 3 : sym->refs++;
4214 3 : if (csym->attr.generic)
4215 2 : c->symtree->n.sym = sym;
4216 : else
4217 1 : c->symtree = st;
4218 3 : csym = c->symtree->n.sym;
4219 : }
4220 : }
4221 :
4222 : /* If this ia a deferred TBP, c->expr1 will be set. */
4223 82086 : if (!c->expr1 && csym)
4224 : {
4225 80345 : if (csym->attr.abstract)
4226 : {
4227 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4228 : csym->name, &c->loc);
4229 1 : return false;
4230 : }
4231 :
4232 : /* Subroutines without the RECURSIVE attribution are not allowed to
4233 : call themselves. */
4234 80344 : if (is_illegal_recursion (csym, gfc_current_ns))
4235 : {
4236 4 : if (csym->attr.entry && csym->ns->entries)
4237 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4238 : "as subroutine %qs is not RECURSIVE",
4239 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4240 : else
4241 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4242 : "as it is not RECURSIVE", csym->name, &c->loc);
4243 :
4244 82085 : t = false;
4245 : }
4246 : }
4247 :
4248 : /* Switch off assumed size checking and do this again for certain kinds
4249 : of procedure, once the procedure itself is resolved. */
4250 82085 : need_full_assumed_size++;
4251 :
4252 82085 : if (csym)
4253 82085 : ptype = csym->attr.proc;
4254 :
4255 82085 : no_formal_args = csym && is_external_proc (csym)
4256 15691 : && gfc_sym_get_dummy_args (csym) == NULL;
4257 82085 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4258 : return false;
4259 :
4260 : /* Resume assumed_size checking. */
4261 82051 : need_full_assumed_size--;
4262 :
4263 : /* If 'implicit none (external)' and the symbol is a dummy argument,
4264 : check for an 'external' attribute. */
4265 82051 : if (csym->ns->has_implicit_none_export
4266 4486 : && csym->attr.external == 0 && csym->attr.dummy == 1)
4267 : {
4268 1 : gfc_error ("Dummy procedure %qs at %L requires an EXTERNAL attribute",
4269 : csym->name, &c->loc);
4270 1 : return false;
4271 : }
4272 :
4273 : /* If external, check for usage. */
4274 82050 : if (csym && is_external_proc (csym))
4275 15685 : resolve_global_procedure (csym, &c->loc, 1);
4276 :
4277 : /* If we have an external dummy argument, we want to write out its arguments
4278 : with -fc-prototypes-external. Code like
4279 :
4280 : subroutine foo(a,n)
4281 : external a
4282 : if (n == 1) call a(1)
4283 : if (n == 2) call a(2,3)
4284 : end subroutine foo
4285 :
4286 : is actually legal Fortran, but it is not possible to generate a C23-
4287 : compliant prototype for this, so we just record the fact here and
4288 : handle that during -fc-prototypes-external processing. */
4289 :
4290 82050 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4291 14 : && csym->attr.external)
4292 : {
4293 14 : if (csym->formal)
4294 : {
4295 6 : bool conflict;
4296 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4297 : 0, 0, 0, NULL);
4298 6 : if (conflict)
4299 : {
4300 6 : csym->ext_dummy_arglist_mismatch = 1;
4301 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4302 : "Different argument lists in external dummy "
4303 : "subroutine %s at %L and %L", csym->name,
4304 : &c->loc, &csym->other_loc);
4305 : }
4306 : }
4307 8 : else if (!csym->formal_resolved)
4308 : {
4309 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4310 7 : csym->other_loc = c->loc;
4311 : }
4312 : }
4313 :
4314 82050 : t = true;
4315 82050 : if (c->resolved_sym == NULL)
4316 : {
4317 81945 : c->resolved_isym = NULL;
4318 81945 : switch (procedure_kind (csym))
4319 : {
4320 2881 : case PTYPE_GENERIC:
4321 2881 : t = resolve_generic_s (c);
4322 2881 : break;
4323 :
4324 63163 : case PTYPE_SPECIFIC:
4325 63163 : t = resolve_specific_s (c);
4326 63163 : break;
4327 :
4328 15901 : case PTYPE_UNKNOWN:
4329 15901 : t = resolve_unknown_s (c);
4330 15901 : break;
4331 :
4332 : default:
4333 : gfc_internal_error ("resolve_subroutine(): bad function type");
4334 : }
4335 : }
4336 :
4337 : /* Some checks of elemental subroutine actual arguments. */
4338 82049 : if (!resolve_elemental_actual (NULL, c))
4339 : return false;
4340 :
4341 : /* Deal with complicated dependencies that the scalarizer cannot handle. */
4342 82041 : if (c->resolved_sym && c->resolved_sym->attr.elemental && !no_formal_args
4343 6206 : && c->ext.actual && c->ext.actual->next)
4344 5257 : resolve_elemental_dependencies (c);
4345 :
4346 82041 : if (!c->expr1)
4347 80300 : update_current_proc_array_outer_dependency (csym);
4348 : else
4349 : /* Typebound procedure: Assume the worst. */
4350 1741 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4351 :
4352 82041 : if (c->resolved_sym
4353 81718 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4354 34 : gfc_warning (OPT_Wdeprecated_declarations,
4355 : "Using subroutine %qs at %L is deprecated",
4356 : c->resolved_sym->name, &c->loc);
4357 :
4358 82041 : csym = c->resolved_sym ? c->resolved_sym : csym;
4359 82041 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4360 2 : && csym != gfc_current_ns->proc_name)
4361 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4362 :
4363 : return t;
4364 : }
4365 :
4366 :
4367 : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4368 : op1->shape and op2->shape are non-NULL return true if their shapes
4369 : match. If both op1->shape and op2->shape are non-NULL return false
4370 : if their shapes do not match. If either op1->shape or op2->shape is
4371 : NULL, return true. */
4372 :
4373 : static bool
4374 32732 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4375 : {
4376 32732 : bool t;
4377 32732 : int i;
4378 :
4379 32732 : t = true;
4380 :
4381 32732 : if (op1->shape != NULL && op2->shape != NULL)
4382 : {
4383 43196 : for (i = 0; i < op1->rank; i++)
4384 : {
4385 23035 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4386 : {
4387 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4388 : &op1->where, &op2->where);
4389 3 : t = false;
4390 3 : break;
4391 : }
4392 : }
4393 : }
4394 :
4395 32732 : return t;
4396 : }
4397 :
4398 : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4399 : For example A .AND. B becomes IAND(A, B). */
4400 : static gfc_expr *
4401 668 : logical_to_bitwise (gfc_expr *e)
4402 : {
4403 668 : gfc_expr *tmp, *op1, *op2;
4404 668 : gfc_isym_id isym;
4405 668 : gfc_actual_arglist *args = NULL;
4406 :
4407 668 : gcc_assert (e->expr_type == EXPR_OP);
4408 :
4409 668 : isym = GFC_ISYM_NONE;
4410 668 : op1 = e->value.op.op1;
4411 668 : op2 = e->value.op.op2;
4412 :
4413 668 : switch (e->value.op.op)
4414 : {
4415 : case INTRINSIC_NOT:
4416 : isym = GFC_ISYM_NOT;
4417 : break;
4418 126 : case INTRINSIC_AND:
4419 126 : isym = GFC_ISYM_IAND;
4420 126 : break;
4421 127 : case INTRINSIC_OR:
4422 127 : isym = GFC_ISYM_IOR;
4423 127 : break;
4424 270 : case INTRINSIC_NEQV:
4425 270 : isym = GFC_ISYM_IEOR;
4426 270 : break;
4427 126 : case INTRINSIC_EQV:
4428 : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4429 : Change the old expression to NEQV, which will get replaced by IEOR,
4430 : and wrap it in NOT. */
4431 126 : tmp = gfc_copy_expr (e);
4432 126 : tmp->value.op.op = INTRINSIC_NEQV;
4433 126 : tmp = logical_to_bitwise (tmp);
4434 126 : isym = GFC_ISYM_NOT;
4435 126 : op1 = tmp;
4436 126 : op2 = NULL;
4437 126 : break;
4438 0 : default:
4439 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4440 : }
4441 :
4442 : /* Inherit the original operation's operands as arguments. */
4443 668 : args = gfc_get_actual_arglist ();
4444 668 : args->expr = op1;
4445 668 : if (op2)
4446 : {
4447 523 : args->next = gfc_get_actual_arglist ();
4448 523 : args->next->expr = op2;
4449 : }
4450 :
4451 : /* Convert the expression to a function call. */
4452 668 : e->expr_type = EXPR_FUNCTION;
4453 668 : e->value.function.actual = args;
4454 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4455 668 : e->value.function.name = e->value.function.isym->name;
4456 668 : e->value.function.esym = NULL;
4457 :
4458 : /* Make up a pre-resolved function call symtree if we need to. */
4459 668 : if (!e->symtree || !e->symtree->n.sym)
4460 : {
4461 668 : gfc_symbol *sym;
4462 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4463 668 : sym = e->symtree->n.sym;
4464 668 : sym->result = sym;
4465 668 : sym->attr.flavor = FL_PROCEDURE;
4466 668 : sym->attr.function = 1;
4467 668 : sym->attr.elemental = 1;
4468 668 : sym->attr.pure = 1;
4469 668 : sym->attr.referenced = 1;
4470 668 : gfc_intrinsic_symbol (sym);
4471 668 : gfc_commit_symbol (sym);
4472 : }
4473 :
4474 668 : args->name = e->value.function.isym->formal->name;
4475 668 : if (e->value.function.isym->formal->next)
4476 523 : args->next->name = e->value.function.isym->formal->next->name;
4477 :
4478 668 : return e;
4479 : }
4480 :
4481 : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4482 : candidates in CANDIDATES_LEN. */
4483 : static void
4484 114 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4485 : char **&candidates,
4486 : size_t &candidates_len)
4487 : {
4488 116 : gfc_symtree *p;
4489 :
4490 116 : if (uop == NULL)
4491 : return;
4492 :
4493 : /* Not sure how to properly filter here. Use all for a start.
4494 : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4495 : these as i suppose they don't make terribly sense. */
4496 :
4497 116 : if (uop->n.uop->op != NULL)
4498 2 : vec_push (candidates, candidates_len, uop->name);
4499 :
4500 116 : p = uop->left;
4501 116 : if (p)
4502 36 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4503 :
4504 116 : p = uop->right;
4505 116 : if (p)
4506 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4507 : }
4508 :
4509 : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4510 :
4511 : static const char*
4512 78 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4513 : {
4514 78 : char **candidates = NULL;
4515 78 : size_t candidates_len = 0;
4516 78 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4517 78 : return gfc_closest_fuzzy_match (op, candidates);
4518 : }
4519 :
4520 :
4521 : /* Callback finding an impure function as an operand to an .and. or
4522 : .or. expression. Remember the last function warned about to
4523 : avoid double warnings when recursing. */
4524 :
4525 : static int
4526 193652 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4527 : void *data)
4528 : {
4529 193652 : gfc_expr *f = *e;
4530 193652 : const char *name;
4531 193652 : static gfc_expr *last = NULL;
4532 193652 : bool *found = (bool *) data;
4533 :
4534 193652 : if (f->expr_type == EXPR_FUNCTION)
4535 : {
4536 11961 : *found = 1;
4537 11961 : if (f != last && !gfc_pure_function (f, &name)
4538 13264 : && !gfc_implicit_pure_function (f))
4539 : {
4540 1164 : if (name)
4541 1164 : gfc_warning (OPT_Wfunction_elimination,
4542 : "Impure function %qs at %L might not be evaluated",
4543 : name, &f->where);
4544 : else
4545 0 : gfc_warning (OPT_Wfunction_elimination,
4546 : "Impure function at %L might not be evaluated",
4547 : &f->where);
4548 : }
4549 11961 : last = f;
4550 : }
4551 :
4552 193652 : return 0;
4553 : }
4554 :
4555 : /* Return true if TYPE is character based, false otherwise. */
4556 :
4557 : static int
4558 1373 : is_character_based (bt type)
4559 : {
4560 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4561 : }
4562 :
4563 :
4564 : /* If expression is a hollerith, convert it to character and issue a warning
4565 : for the conversion. */
4566 :
4567 : static void
4568 408 : convert_hollerith_to_character (gfc_expr *e)
4569 : {
4570 408 : if (e->ts.type == BT_HOLLERITH)
4571 : {
4572 108 : gfc_typespec t;
4573 108 : gfc_clear_ts (&t);
4574 108 : t.type = BT_CHARACTER;
4575 108 : t.kind = e->ts.kind;
4576 108 : gfc_convert_type_warn (e, &t, 2, 1);
4577 : }
4578 408 : }
4579 :
4580 : /* Convert to numeric and issue a warning for the conversion. */
4581 :
4582 : static void
4583 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4584 : {
4585 240 : gfc_typespec t;
4586 240 : gfc_clear_ts (&t);
4587 240 : t.type = b->ts.type;
4588 240 : t.kind = b->ts.kind;
4589 240 : gfc_convert_type_warn (a, &t, 2, 1);
4590 240 : }
4591 :
4592 : /* Resolve an operator expression node. This can involve replacing the
4593 : operation with a user defined function call. CHECK_INTERFACES is a
4594 : helper macro. */
4595 :
4596 : #define CHECK_INTERFACES \
4597 : { \
4598 : match m = gfc_extend_expr (e); \
4599 : if (m == MATCH_YES) \
4600 : return true; \
4601 : if (m == MATCH_ERROR) \
4602 : return false; \
4603 : }
4604 :
4605 : static bool
4606 535196 : resolve_operator (gfc_expr *e)
4607 : {
4608 535196 : gfc_expr *op1, *op2;
4609 : /* One error uses 3 names; additional space for wording (also via gettext). */
4610 535196 : bool t = true;
4611 :
4612 : /* Reduce stacked parentheses to single pair */
4613 535196 : while (e->expr_type == EXPR_OP
4614 535354 : && e->value.op.op == INTRINSIC_PARENTHESES
4615 23595 : && e->value.op.op1->expr_type == EXPR_OP
4616 552199 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4617 : {
4618 158 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4619 158 : gfc_replace_expr (e, tmp);
4620 : }
4621 :
4622 : /* Resolve all subnodes-- give them types. */
4623 :
4624 535196 : switch (e->value.op.op)
4625 : {
4626 482966 : default:
4627 482966 : if (!gfc_resolve_expr (e->value.op.op2))
4628 535196 : t = false;
4629 :
4630 : /* Fall through. */
4631 :
4632 535196 : case INTRINSIC_NOT:
4633 535196 : case INTRINSIC_UPLUS:
4634 535196 : case INTRINSIC_UMINUS:
4635 535196 : case INTRINSIC_PARENTHESES:
4636 535196 : if (!gfc_resolve_expr (e->value.op.op1))
4637 : return false;
4638 535035 : if (e->value.op.op1
4639 535026 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4640 : {
4641 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4642 0 : "unary operator %qs", &e->value.op.op1->where,
4643 : gfc_op2string (e->value.op.op));
4644 0 : return false;
4645 : }
4646 535035 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4647 6 : && e->value.op.op == INTRINSIC_UMINUS)
4648 : {
4649 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4650 : &e->value.op.op1->where);
4651 2 : return false;
4652 : }
4653 535033 : break;
4654 : }
4655 :
4656 : /* Typecheck the new node. */
4657 :
4658 535033 : op1 = e->value.op.op1;
4659 535033 : op2 = e->value.op.op2;
4660 535033 : if (op1 == NULL && op2 == NULL)
4661 : return false;
4662 : /* Error out if op2 did not resolve. We already diagnosed op1. */
4663 535024 : if (t == false)
4664 : return false;
4665 :
4666 : /* op1 and op2 cannot both be BOZ. */
4667 534958 : if (op1 && op1->ts.type == BT_BOZ
4668 0 : && op2 && op2->ts.type == BT_BOZ)
4669 : {
4670 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4671 0 : "binary operator %qs", &op1->where, &op2->where,
4672 : gfc_op2string (e->value.op.op));
4673 0 : return false;
4674 : }
4675 :
4676 534958 : if ((op1 && op1->expr_type == EXPR_NULL)
4677 534956 : || (op2 && op2->expr_type == EXPR_NULL))
4678 : {
4679 3 : CHECK_INTERFACES
4680 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4681 3 : return false;
4682 : }
4683 :
4684 534955 : switch (e->value.op.op)
4685 : {
4686 8226 : case INTRINSIC_UPLUS:
4687 8226 : case INTRINSIC_UMINUS:
4688 8226 : if (op1->ts.type == BT_INTEGER
4689 : || op1->ts.type == BT_REAL
4690 : || op1->ts.type == BT_COMPLEX
4691 : || op1->ts.type == BT_UNSIGNED)
4692 : {
4693 8157 : e->ts = op1->ts;
4694 8157 : break;
4695 : }
4696 :
4697 69 : CHECK_INTERFACES
4698 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4699 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4700 43 : return false;
4701 :
4702 155836 : case INTRINSIC_POWER:
4703 155836 : case INTRINSIC_PLUS:
4704 155836 : case INTRINSIC_MINUS:
4705 155836 : case INTRINSIC_TIMES:
4706 155836 : case INTRINSIC_DIVIDE:
4707 :
4708 : /* UNSIGNED cannot appear in a mixed expression without explicit
4709 : conversion. */
4710 155836 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4711 : {
4712 3 : CHECK_INTERFACES
4713 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4714 : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4715 : gfc_typename (op1), gfc_typename (op2));
4716 3 : return false;
4717 : }
4718 :
4719 155833 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4720 : {
4721 : /* Do not perform conversions if operands are not conformable as
4722 : required for the binary intrinsic operators (F2018:10.1.5).
4723 : Defer to a possibly overloading user-defined operator. */
4724 155379 : if (!gfc_op_rank_conformable (op1, op2))
4725 : {
4726 36 : CHECK_INTERFACES
4727 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4728 0 : &op1->where, &op2->where);
4729 0 : return false;
4730 : }
4731 :
4732 155343 : gfc_type_convert_binary (e, 1);
4733 155343 : break;
4734 : }
4735 :
4736 454 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4737 : {
4738 225 : CHECK_INTERFACES
4739 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4740 : "numeric operator %qs at %L",
4741 : gfc_op2string (e->value.op.op), &e->where);
4742 2 : return false;
4743 : }
4744 : else
4745 : {
4746 229 : CHECK_INTERFACES
4747 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4748 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4749 : gfc_typename (op2));
4750 3 : return false;
4751 : }
4752 :
4753 2279 : case INTRINSIC_CONCAT:
4754 2279 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4755 2254 : && op1->ts.kind == op2->ts.kind)
4756 : {
4757 2245 : e->ts.type = BT_CHARACTER;
4758 2245 : e->ts.kind = op1->ts.kind;
4759 2245 : break;
4760 : }
4761 :
4762 34 : CHECK_INTERFACES
4763 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4764 : &e->where, gfc_typename (op1), gfc_typename (op2));
4765 10 : return false;
4766 :
4767 69794 : case INTRINSIC_AND:
4768 69794 : case INTRINSIC_OR:
4769 69794 : case INTRINSIC_EQV:
4770 69794 : case INTRINSIC_NEQV:
4771 69794 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4772 : {
4773 69243 : e->ts.type = BT_LOGICAL;
4774 69243 : e->ts.kind = gfc_kind_max (op1, op2);
4775 69243 : if (op1->ts.kind < e->ts.kind)
4776 140 : gfc_convert_type (op1, &e->ts, 2);
4777 69103 : else if (op2->ts.kind < e->ts.kind)
4778 117 : gfc_convert_type (op2, &e->ts, 2);
4779 :
4780 69243 : if (flag_frontend_optimize &&
4781 58176 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4782 : {
4783 : /* Warn about short-circuiting
4784 : with impure function as second operand. */
4785 52171 : bool op2_f = false;
4786 52171 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4787 : }
4788 : break;
4789 : }
4790 :
4791 : /* Logical ops on integers become bitwise ops with -fdec. */
4792 551 : else if (flag_dec
4793 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4794 : {
4795 523 : e->ts.type = BT_INTEGER;
4796 523 : e->ts.kind = gfc_kind_max (op1, op2);
4797 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4798 289 : gfc_convert_type (op1, &e->ts, 1);
4799 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4800 144 : gfc_convert_type (op2, &e->ts, 1);
4801 523 : e = logical_to_bitwise (e);
4802 523 : goto simplify_op;
4803 : }
4804 :
4805 28 : CHECK_INTERFACES
4806 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4807 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4808 : gfc_typename (op2));
4809 16 : return false;
4810 :
4811 20551 : case INTRINSIC_NOT:
4812 : /* Logical ops on integers become bitwise ops with -fdec. */
4813 20551 : if (flag_dec && op1->ts.type == BT_INTEGER)
4814 : {
4815 19 : e->ts.type = BT_INTEGER;
4816 19 : e->ts.kind = op1->ts.kind;
4817 19 : e = logical_to_bitwise (e);
4818 19 : goto simplify_op;
4819 : }
4820 :
4821 20532 : if (op1->ts.type == BT_LOGICAL)
4822 : {
4823 20526 : e->ts.type = BT_LOGICAL;
4824 20526 : e->ts.kind = op1->ts.kind;
4825 20526 : break;
4826 : }
4827 :
4828 6 : CHECK_INTERFACES
4829 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4830 : gfc_typename (op1));
4831 3 : return false;
4832 :
4833 21517 : case INTRINSIC_GT:
4834 21517 : case INTRINSIC_GT_OS:
4835 21517 : case INTRINSIC_GE:
4836 21517 : case INTRINSIC_GE_OS:
4837 21517 : case INTRINSIC_LT:
4838 21517 : case INTRINSIC_LT_OS:
4839 21517 : case INTRINSIC_LE:
4840 21517 : case INTRINSIC_LE_OS:
4841 21517 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4842 : {
4843 18 : CHECK_INTERFACES
4844 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4845 0 : return false;
4846 : }
4847 :
4848 : /* Fall through. */
4849 :
4850 254550 : case INTRINSIC_EQ:
4851 254550 : case INTRINSIC_EQ_OS:
4852 254550 : case INTRINSIC_NE:
4853 254550 : case INTRINSIC_NE_OS:
4854 :
4855 254550 : if (flag_dec
4856 1038 : && is_character_based (op1->ts.type)
4857 254885 : && is_character_based (op2->ts.type))
4858 : {
4859 204 : convert_hollerith_to_character (op1);
4860 204 : convert_hollerith_to_character (op2);
4861 : }
4862 :
4863 254550 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4864 38565 : && op1->ts.kind == op2->ts.kind)
4865 : {
4866 38528 : e->ts.type = BT_LOGICAL;
4867 38528 : e->ts.kind = gfc_default_logical_kind;
4868 38528 : break;
4869 : }
4870 :
4871 : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4872 216022 : if (op1->ts.type == BT_BOZ)
4873 : {
4874 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4875 : "as an operand of a relational operator"),
4876 : &op1->where))
4877 : return false;
4878 :
4879 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4880 : return false;
4881 :
4882 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4883 : return false;
4884 : }
4885 :
4886 : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4887 216022 : if (op2->ts.type == BT_BOZ)
4888 : {
4889 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4890 : " as an operand of a relational operator"),
4891 : &op2->where))
4892 : return false;
4893 :
4894 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4895 : return false;
4896 :
4897 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4898 : return false;
4899 : }
4900 216022 : if (flag_dec
4901 216022 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4902 120 : convert_to_numeric (op1, op2);
4903 :
4904 216022 : if (flag_dec
4905 216022 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4906 120 : convert_to_numeric (op2, op1);
4907 :
4908 216022 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4909 : {
4910 : /* Do not perform conversions if operands are not conformable as
4911 : required for the binary intrinsic operators (F2018:10.1.5).
4912 : Defer to a possibly overloading user-defined operator. */
4913 214893 : if (!gfc_op_rank_conformable (op1, op2))
4914 : {
4915 70 : CHECK_INTERFACES
4916 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4917 0 : &op1->where, &op2->where);
4918 0 : return false;
4919 : }
4920 :
4921 214823 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4922 : {
4923 1 : CHECK_INTERFACES
4924 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4925 1 : "%s and %s", &op1->where, &op2->where,
4926 : gfc_typename (op1), gfc_typename (op2));
4927 1 : return false;
4928 : }
4929 :
4930 214822 : gfc_type_convert_binary (e, 1);
4931 :
4932 214822 : e->ts.type = BT_LOGICAL;
4933 214822 : e->ts.kind = gfc_default_logical_kind;
4934 :
4935 214822 : if (warn_compare_reals)
4936 : {
4937 70 : gfc_intrinsic_op op = e->value.op.op;
4938 :
4939 : /* Type conversion has made sure that the types of op1 and op2
4940 : agree, so it is only necessary to check the first one. */
4941 70 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4942 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4943 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4944 : {
4945 13 : const char *msg;
4946 :
4947 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4948 : msg = G_("Equality comparison for %s at %L");
4949 : else
4950 6 : msg = G_("Inequality comparison for %s at %L");
4951 :
4952 13 : gfc_warning (OPT_Wcompare_reals, msg,
4953 : gfc_typename (op1), &op1->where);
4954 : }
4955 : }
4956 :
4957 : break;
4958 : }
4959 :
4960 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4961 : {
4962 2 : CHECK_INTERFACES
4963 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4964 : &e->where,
4965 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4966 : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4967 2 : }
4968 : else
4969 : {
4970 1127 : CHECK_INTERFACES
4971 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4972 : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4973 : gfc_typename (op2));
4974 : }
4975 :
4976 : return false;
4977 :
4978 303 : case INTRINSIC_USER:
4979 303 : if (e->value.op.uop->op == NULL)
4980 : {
4981 78 : const char *name = e->value.op.uop->name;
4982 78 : const char *guessed;
4983 78 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4984 78 : CHECK_INTERFACES
4985 5 : if (guessed)
4986 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4987 : "%qs?", name, &e->where, guessed);
4988 : else
4989 4 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4990 : }
4991 225 : else if (op2 == NULL)
4992 : {
4993 48 : CHECK_INTERFACES
4994 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4995 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4996 : }
4997 : else
4998 : {
4999 177 : e->value.op.uop->op->sym->attr.referenced = 1;
5000 177 : CHECK_INTERFACES
5001 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
5002 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
5003 : gfc_typename (op2));
5004 : }
5005 :
5006 : return false;
5007 :
5008 23398 : case INTRINSIC_PARENTHESES:
5009 23398 : e->ts = op1->ts;
5010 23398 : if (e->ts.type == BT_CHARACTER)
5011 321 : e->ts.u.cl = op1->ts.u.cl;
5012 : break;
5013 :
5014 0 : default:
5015 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
5016 : }
5017 :
5018 : /* Deal with arrayness of an operand through an operator. */
5019 :
5020 532262 : switch (e->value.op.op)
5021 : {
5022 480181 : case INTRINSIC_PLUS:
5023 480181 : case INTRINSIC_MINUS:
5024 480181 : case INTRINSIC_TIMES:
5025 480181 : case INTRINSIC_DIVIDE:
5026 480181 : case INTRINSIC_POWER:
5027 480181 : case INTRINSIC_CONCAT:
5028 480181 : case INTRINSIC_AND:
5029 480181 : case INTRINSIC_OR:
5030 480181 : case INTRINSIC_EQV:
5031 480181 : case INTRINSIC_NEQV:
5032 480181 : case INTRINSIC_EQ:
5033 480181 : case INTRINSIC_EQ_OS:
5034 480181 : case INTRINSIC_NE:
5035 480181 : case INTRINSIC_NE_OS:
5036 480181 : case INTRINSIC_GT:
5037 480181 : case INTRINSIC_GT_OS:
5038 480181 : case INTRINSIC_GE:
5039 480181 : case INTRINSIC_GE_OS:
5040 480181 : case INTRINSIC_LT:
5041 480181 : case INTRINSIC_LT_OS:
5042 480181 : case INTRINSIC_LE:
5043 480181 : case INTRINSIC_LE_OS:
5044 :
5045 480181 : if (op1->rank == 0 && op2->rank == 0)
5046 427552 : e->rank = 0;
5047 :
5048 480181 : if (op1->rank == 0 && op2->rank != 0)
5049 : {
5050 2619 : e->rank = op2->rank;
5051 :
5052 2619 : if (e->shape == NULL)
5053 2589 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
5054 : }
5055 :
5056 480181 : if (op1->rank != 0 && op2->rank == 0)
5057 : {
5058 17217 : e->rank = op1->rank;
5059 :
5060 17217 : if (e->shape == NULL)
5061 17193 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5062 : }
5063 :
5064 480181 : if (op1->rank != 0 && op2->rank != 0)
5065 : {
5066 32793 : if (op1->rank == op2->rank)
5067 : {
5068 32793 : e->rank = op1->rank;
5069 32793 : if (e->shape == NULL)
5070 : {
5071 32732 : t = compare_shapes (op1, op2);
5072 32732 : if (!t)
5073 3 : e->shape = NULL;
5074 : else
5075 32729 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5076 : }
5077 : }
5078 : else
5079 : {
5080 : /* Allow higher level expressions to work. */
5081 0 : e->rank = 0;
5082 :
5083 : /* Try user-defined operators, and otherwise throw an error. */
5084 0 : CHECK_INTERFACES
5085 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
5086 0 : &op1->where, &op2->where);
5087 0 : return false;
5088 : }
5089 : }
5090 : break;
5091 :
5092 52081 : case INTRINSIC_PARENTHESES:
5093 52081 : case INTRINSIC_NOT:
5094 52081 : case INTRINSIC_UPLUS:
5095 52081 : case INTRINSIC_UMINUS:
5096 : /* Simply copy arrayness attribute */
5097 52081 : e->rank = op1->rank;
5098 52081 : e->corank = op1->corank;
5099 :
5100 52081 : if (e->shape == NULL)
5101 52073 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
5102 :
5103 : break;
5104 :
5105 : default:
5106 : break;
5107 : }
5108 :
5109 532804 : simplify_op:
5110 :
5111 : /* Attempt to simplify the expression. */
5112 3 : if (t)
5113 : {
5114 532801 : t = gfc_simplify_expr (e, 0);
5115 : /* Some calls do not succeed in simplification and return false
5116 : even though there is no error; e.g. variable references to
5117 : PARAMETER arrays. */
5118 532801 : if (!gfc_is_constant_expr (e))
5119 486773 : t = true;
5120 : }
5121 : return t;
5122 : }
5123 :
5124 : static bool
5125 170 : resolve_conditional (gfc_expr *expr)
5126 : {
5127 170 : gfc_expr *condition, *true_expr, *false_expr;
5128 :
5129 170 : condition = expr->value.conditional.condition;
5130 170 : true_expr = expr->value.conditional.true_expr;
5131 170 : false_expr = expr->value.conditional.false_expr;
5132 :
5133 340 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5134 340 : || !gfc_resolve_expr (false_expr))
5135 0 : return false;
5136 :
5137 170 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5138 : {
5139 2 : gfc_error (
5140 : "Condition in conditional expression must be a scalar logical at %L",
5141 : &condition->where);
5142 2 : return false;
5143 : }
5144 :
5145 168 : if (true_expr->ts.type != false_expr->ts.type)
5146 : {
5147 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5148 : "must have the same declared type",
5149 : &true_expr->where, &false_expr->where);
5150 1 : return false;
5151 : }
5152 :
5153 167 : if (true_expr->ts.kind != false_expr->ts.kind)
5154 : {
5155 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5156 : "must have the same kind parameter",
5157 : &true_expr->where, &false_expr->where);
5158 1 : return false;
5159 : }
5160 :
5161 166 : if (true_expr->rank != false_expr->rank)
5162 : {
5163 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5164 : "must have the same rank",
5165 : &true_expr->where, &false_expr->where);
5166 1 : return false;
5167 : }
5168 :
5169 : /* TODO: support more data types for conditional expressions */
5170 165 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5171 165 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5172 67 : && true_expr->ts.type != BT_CHARACTER)
5173 : {
5174 1 : gfc_error (
5175 : "Sorry, only integer, logical, real, complex and character types are "
5176 : "currently supported for conditional expressions at %L",
5177 : &expr->where);
5178 1 : return false;
5179 : }
5180 :
5181 : /* TODO: support arrays in conditional expressions */
5182 164 : if (true_expr->rank > 0)
5183 : {
5184 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5185 : "expressions at %L",
5186 : &expr->where);
5187 1 : return false;
5188 : }
5189 :
5190 163 : expr->ts = true_expr->ts;
5191 163 : expr->rank = true_expr->rank;
5192 163 : return true;
5193 : }
5194 :
5195 : /************** Array resolution subroutines **************/
5196 :
5197 : enum compare_result
5198 : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5199 :
5200 : /* Compare two integer expressions. */
5201 :
5202 : static compare_result
5203 470019 : compare_bound (gfc_expr *a, gfc_expr *b)
5204 : {
5205 470019 : int i;
5206 :
5207 470019 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5208 309164 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5209 : return CMP_UNKNOWN;
5210 :
5211 : /* If either of the types isn't INTEGER, we must have
5212 : raised an error earlier. */
5213 :
5214 213564 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5215 : return CMP_UNKNOWN;
5216 :
5217 213560 : i = mpz_cmp (a->value.integer, b->value.integer);
5218 :
5219 213560 : if (i < 0)
5220 : return CMP_LT;
5221 100248 : if (i > 0)
5222 39817 : return CMP_GT;
5223 : return CMP_EQ;
5224 : }
5225 :
5226 :
5227 : /* Compare an integer expression with an integer. */
5228 :
5229 : static compare_result
5230 75467 : compare_bound_int (gfc_expr *a, int b)
5231 : {
5232 75467 : int i;
5233 :
5234 75467 : if (a == NULL
5235 32560 : || a->expr_type != EXPR_CONSTANT
5236 29612 : || a->ts.type != BT_INTEGER)
5237 : return CMP_UNKNOWN;
5238 :
5239 29612 : i = mpz_cmp_si (a->value.integer, b);
5240 :
5241 29612 : if (i < 0)
5242 : return CMP_LT;
5243 25138 : if (i > 0)
5244 21603 : return CMP_GT;
5245 : return CMP_EQ;
5246 : }
5247 :
5248 :
5249 : /* Compare an integer expression with a mpz_t. */
5250 :
5251 : static compare_result
5252 70214 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5253 : {
5254 70214 : int i;
5255 :
5256 70214 : if (a == NULL
5257 57345 : || a->expr_type != EXPR_CONSTANT
5258 55222 : || a->ts.type != BT_INTEGER)
5259 : return CMP_UNKNOWN;
5260 :
5261 55219 : i = mpz_cmp (a->value.integer, b);
5262 :
5263 55219 : if (i < 0)
5264 : return CMP_LT;
5265 25143 : if (i > 0)
5266 10734 : return CMP_GT;
5267 : return CMP_EQ;
5268 : }
5269 :
5270 :
5271 : /* Compute the last value of a sequence given by a triplet.
5272 : Return 0 if it wasn't able to compute the last value, or if the
5273 : sequence if empty, and 1 otherwise. */
5274 :
5275 : static int
5276 52395 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5277 : gfc_expr *stride, mpz_t last)
5278 : {
5279 52395 : mpz_t rem;
5280 :
5281 52395 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5282 37230 : || end == NULL || end->expr_type != EXPR_CONSTANT
5283 32520 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5284 : return 0;
5285 :
5286 32201 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5287 32200 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5288 : return 0;
5289 :
5290 6701 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5291 : {
5292 25625 : if (compare_bound (start, end) == CMP_GT)
5293 : return 0;
5294 24236 : mpz_set (last, end->value.integer);
5295 24236 : return 1;
5296 : }
5297 :
5298 6575 : if (compare_bound_int (stride, 0) == CMP_GT)
5299 : {
5300 : /* Stride is positive */
5301 5210 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5302 : return 0;
5303 : }
5304 : else
5305 : {
5306 : /* Stride is negative */
5307 1365 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5308 : return 0;
5309 : }
5310 :
5311 6555 : mpz_init (rem);
5312 6555 : mpz_sub (rem, end->value.integer, start->value.integer);
5313 6555 : mpz_tdiv_r (rem, rem, stride->value.integer);
5314 6555 : mpz_sub (last, end->value.integer, rem);
5315 6555 : mpz_clear (rem);
5316 :
5317 6555 : return 1;
5318 : }
5319 :
5320 :
5321 : /* Compare a single dimension of an array reference to the array
5322 : specification. */
5323 :
5324 : static bool
5325 217912 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5326 : {
5327 217912 : mpz_t last_value;
5328 :
5329 217912 : if (ar->dimen_type[i] == DIMEN_STAR)
5330 : {
5331 541 : gcc_assert (ar->stride[i] == NULL);
5332 : /* This implies [*] as [*:] and [*:3] are not possible. */
5333 541 : if (ar->start[i] == NULL)
5334 : {
5335 449 : gcc_assert (ar->end[i] == NULL);
5336 : return true;
5337 : }
5338 : }
5339 :
5340 : /* Given start, end and stride values, calculate the minimum and
5341 : maximum referenced indexes. */
5342 :
5343 217463 : switch (ar->dimen_type[i])
5344 : {
5345 : case DIMEN_VECTOR:
5346 : case DIMEN_THIS_IMAGE:
5347 : break;
5348 :
5349 156657 : case DIMEN_STAR:
5350 156657 : case DIMEN_ELEMENT:
5351 156657 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5352 : {
5353 2 : if (i < as->rank)
5354 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5355 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5356 2 : mpz_get_si (ar->start[i]->value.integer),
5357 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5358 : else
5359 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5360 : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5361 0 : mpz_get_si (ar->start[i]->value.integer),
5362 0 : mpz_get_si (as->lower[i]->value.integer),
5363 0 : i + 1 - as->rank);
5364 2 : return true;
5365 : }
5366 156655 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5367 : {
5368 39 : if (i < as->rank)
5369 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5370 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5371 39 : mpz_get_si (ar->start[i]->value.integer),
5372 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5373 : else
5374 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5375 : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5376 0 : mpz_get_si (ar->start[i]->value.integer),
5377 0 : mpz_get_si (as->upper[i]->value.integer),
5378 0 : i + 1 - as->rank);
5379 39 : return true;
5380 : }
5381 :
5382 : break;
5383 :
5384 52440 : case DIMEN_RANGE:
5385 52440 : {
5386 : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5387 : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5388 :
5389 52440 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5390 52440 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5391 :
5392 : /* Check for zero stride, which is not allowed. */
5393 52440 : if (comp_stride_zero == CMP_EQ)
5394 : {
5395 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5396 1 : return false;
5397 : }
5398 :
5399 : /* if start == end || (stride > 0 && start < end)
5400 : || (stride < 0 && start > end),
5401 : then the array section contains at least one element. In this
5402 : case, there is an out-of-bounds access if
5403 : (start < lower || start > upper). */
5404 52439 : if (comp_start_end == CMP_EQ
5405 51677 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5406 48888 : && comp_start_end == CMP_LT)
5407 22947 : || (comp_stride_zero == CMP_LT
5408 22947 : && comp_start_end == CMP_GT))
5409 : {
5410 30837 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5411 : {
5412 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5413 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5414 27 : mpz_get_si (AR_START->value.integer),
5415 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5416 27 : return true;
5417 : }
5418 30810 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5419 : {
5420 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5421 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5422 17 : mpz_get_si (AR_START->value.integer),
5423 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5424 17 : return true;
5425 : }
5426 : }
5427 :
5428 : /* If we can compute the highest index of the array section,
5429 : then it also has to be between lower and upper. */
5430 52395 : mpz_init (last_value);
5431 52395 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5432 : last_value))
5433 : {
5434 30791 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5435 : {
5436 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5437 : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5438 : mpz_get_si (last_value),
5439 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5440 3 : mpz_clear (last_value);
5441 3 : return true;
5442 : }
5443 30788 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5444 : {
5445 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5446 : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5447 : mpz_get_si (last_value),
5448 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5449 7 : mpz_clear (last_value);
5450 7 : return true;
5451 : }
5452 : }
5453 52385 : mpz_clear (last_value);
5454 :
5455 : #undef AR_START
5456 : #undef AR_END
5457 : }
5458 52385 : break;
5459 :
5460 0 : default:
5461 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5462 : }
5463 :
5464 : return true;
5465 : }
5466 :
5467 :
5468 : /* Compare an array reference with an array specification. */
5469 :
5470 : static bool
5471 429261 : compare_spec_to_ref (gfc_array_ref *ar)
5472 : {
5473 429261 : gfc_array_spec *as;
5474 429261 : int i;
5475 :
5476 429261 : as = ar->as;
5477 429261 : i = as->rank - 1;
5478 : /* TODO: Full array sections are only allowed as actual parameters. */
5479 429261 : if (as->type == AS_ASSUMED_SIZE
5480 5804 : && (/*ar->type == AR_FULL
5481 5804 : ||*/ (ar->type == AR_SECTION
5482 517 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5483 : {
5484 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5485 : "not specified at %L", &ar->where);
5486 5 : return false;
5487 : }
5488 :
5489 429256 : if (ar->type == AR_FULL)
5490 : return true;
5491 :
5492 165604 : if (as->rank != ar->dimen)
5493 : {
5494 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5495 : &ar->where, ar->dimen, as->rank);
5496 28 : return false;
5497 : }
5498 :
5499 : /* ar->codimen == 0 is a local array. */
5500 165576 : if (as->corank != ar->codimen && ar->codimen != 0)
5501 : {
5502 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5503 : &ar->where, ar->codimen, as->corank);
5504 0 : return false;
5505 : }
5506 :
5507 373513 : for (i = 0; i < as->rank; i++)
5508 207938 : if (!check_dimension (i, ar, as))
5509 : return false;
5510 :
5511 : /* Local access has no coarray spec. */
5512 165575 : if (ar->codimen != 0)
5513 19190 : for (i = as->rank; i < as->rank + as->corank; i++)
5514 : {
5515 9976 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5516 6948 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5517 : {
5518 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5519 2 : i + 1 - as->rank, &ar->where);
5520 2 : return false;
5521 : }
5522 9974 : if (!check_dimension (i, ar, as))
5523 : return false;
5524 : }
5525 :
5526 : return true;
5527 : }
5528 :
5529 :
5530 : /* Resolve one part of an array index. */
5531 :
5532 : static bool
5533 739183 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5534 : int force_index_integer_kind)
5535 : {
5536 739183 : gfc_typespec ts;
5537 :
5538 739183 : if (index == NULL)
5539 : return true;
5540 :
5541 219343 : if (!gfc_resolve_expr (index))
5542 : return false;
5543 :
5544 219332 : if (check_scalar && index->rank != 0)
5545 : {
5546 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5547 2 : return false;
5548 : }
5549 :
5550 219330 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5551 : {
5552 4 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5553 : &index->where, gfc_basic_typename (index->ts.type));
5554 4 : return false;
5555 : }
5556 :
5557 219326 : if (index->ts.type == BT_REAL)
5558 339 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5559 : &index->where))
5560 : return false;
5561 :
5562 219326 : if ((index->ts.kind != gfc_index_integer_kind
5563 214277 : && force_index_integer_kind)
5564 187775 : || (index->ts.type != BT_INTEGER
5565 : && index->ts.type != BT_UNKNOWN))
5566 : {
5567 31889 : gfc_clear_ts (&ts);
5568 31889 : ts.type = BT_INTEGER;
5569 31889 : ts.kind = gfc_index_integer_kind;
5570 :
5571 31889 : gfc_convert_type_warn (index, &ts, 2, 0);
5572 : }
5573 :
5574 : return true;
5575 : }
5576 :
5577 : /* Resolve one part of an array index. */
5578 :
5579 : bool
5580 493047 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5581 : {
5582 493047 : return gfc_resolve_index_1 (index, check_scalar, 1);
5583 : }
5584 :
5585 : /* Resolve a dim argument to an intrinsic function. */
5586 :
5587 : bool
5588 23915 : gfc_resolve_dim_arg (gfc_expr *dim)
5589 : {
5590 23915 : if (dim == NULL)
5591 : return true;
5592 :
5593 23915 : if (!gfc_resolve_expr (dim))
5594 : return false;
5595 :
5596 23915 : if (dim->rank != 0)
5597 : {
5598 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5599 0 : return false;
5600 :
5601 : }
5602 :
5603 23915 : if (dim->ts.type != BT_INTEGER)
5604 : {
5605 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5606 0 : return false;
5607 : }
5608 :
5609 23915 : if (dim->ts.kind != gfc_index_integer_kind)
5610 : {
5611 15306 : gfc_typespec ts;
5612 :
5613 15306 : gfc_clear_ts (&ts);
5614 15306 : ts.type = BT_INTEGER;
5615 15306 : ts.kind = gfc_index_integer_kind;
5616 :
5617 15306 : gfc_convert_type_warn (dim, &ts, 2, 0);
5618 : }
5619 :
5620 : return true;
5621 : }
5622 :
5623 : /* Given an expression that contains array references, update those array
5624 : references to point to the right array specifications. While this is
5625 : filled in during matching, this information is difficult to save and load
5626 : in a module, so we take care of it here.
5627 :
5628 : The idea here is that the original array reference comes from the
5629 : base symbol. We traverse the list of reference structures, setting
5630 : the stored reference to references. Component references can
5631 : provide an additional array specification. */
5632 : static void
5633 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5634 :
5635 : static bool
5636 914 : find_array_spec (gfc_expr *e)
5637 : {
5638 914 : gfc_array_spec *as;
5639 914 : gfc_component *c;
5640 914 : gfc_ref *ref;
5641 914 : bool class_as = false;
5642 :
5643 914 : if (e->symtree->n.sym->assoc)
5644 : {
5645 217 : if (e->symtree->n.sym->assoc->target)
5646 217 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5647 217 : resolve_assoc_var (e->symtree->n.sym, false);
5648 : }
5649 :
5650 914 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5651 : {
5652 124 : as = CLASS_DATA (e->symtree->n.sym)->as;
5653 124 : class_as = true;
5654 : }
5655 : else
5656 790 : as = e->symtree->n.sym->as;
5657 :
5658 2085 : for (ref = e->ref; ref; ref = ref->next)
5659 1178 : switch (ref->type)
5660 : {
5661 916 : case REF_ARRAY:
5662 916 : if (as == NULL)
5663 : {
5664 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5665 14 : ? ref->u.ar.where : e->where);
5666 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5667 : &loc);
5668 7 : return false;
5669 : }
5670 :
5671 909 : ref->u.ar.as = as;
5672 909 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5673 : as = NULL;
5674 : break;
5675 :
5676 238 : case REF_COMPONENT:
5677 238 : c = ref->u.c.component;
5678 238 : if (c->attr.dimension)
5679 : {
5680 107 : if (as != NULL && !(class_as && as == c->as))
5681 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5682 107 : as = c->as;
5683 : }
5684 :
5685 : break;
5686 :
5687 : case REF_SUBSTRING:
5688 : case REF_INQUIRY:
5689 : break;
5690 : }
5691 :
5692 907 : if (as != NULL)
5693 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5694 :
5695 : return true;
5696 : }
5697 :
5698 :
5699 : /* Resolve an array reference. */
5700 :
5701 : static bool
5702 429975 : resolve_array_ref (gfc_array_ref *ar)
5703 : {
5704 429975 : int i, check_scalar;
5705 429975 : gfc_expr *e;
5706 :
5707 676094 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5708 : {
5709 246136 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5710 :
5711 : /* Do not force gfc_index_integer_kind for the start. We can
5712 : do fine with any integer kind. This avoids temporary arrays
5713 : created for indexing with a vector. */
5714 246136 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5715 : return false;
5716 246121 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5717 : return false;
5718 246119 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5719 : return false;
5720 :
5721 246119 : e = ar->start[i];
5722 :
5723 246119 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5724 146725 : switch (e->rank)
5725 : {
5726 145633 : case 0:
5727 145633 : ar->dimen_type[i] = DIMEN_ELEMENT;
5728 145633 : break;
5729 :
5730 1092 : case 1:
5731 1092 : ar->dimen_type[i] = DIMEN_VECTOR;
5732 1092 : if (e->expr_type == EXPR_VARIABLE
5733 470 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5734 13 : ar->start[i] = gfc_get_parentheses (e);
5735 : break;
5736 :
5737 0 : default:
5738 0 : gfc_error ("Array index at %L is an array of rank %d",
5739 : &ar->c_where[i], e->rank);
5740 0 : return false;
5741 : }
5742 :
5743 : /* Fill in the upper bound, which may be lower than the
5744 : specified one for something like a(2:10:5), which is
5745 : identical to a(2:7:5). Only relevant for strides not equal
5746 : to one. Don't try a division by zero. */
5747 246119 : if (ar->dimen_type[i] == DIMEN_RANGE
5748 72261 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5749 8439 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5750 8292 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5751 : {
5752 8291 : mpz_t size, end;
5753 :
5754 8291 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5755 : {
5756 6585 : if (ar->end[i] == NULL)
5757 : {
5758 8022 : ar->end[i] =
5759 4011 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5760 : &ar->where);
5761 4011 : mpz_set (ar->end[i]->value.integer, end);
5762 : }
5763 2574 : else if (ar->end[i]->ts.type == BT_INTEGER
5764 2574 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5765 : {
5766 2574 : mpz_set (ar->end[i]->value.integer, end);
5767 : }
5768 : else
5769 0 : gcc_unreachable ();
5770 :
5771 6585 : mpz_clear (size);
5772 6585 : mpz_clear (end);
5773 : }
5774 : }
5775 : }
5776 :
5777 429958 : if (ar->type == AR_FULL)
5778 : {
5779 267155 : if (ar->as->rank == 0)
5780 3469 : ar->type = AR_ELEMENT;
5781 :
5782 : /* Make sure array is the same as array(:,:), this way
5783 : we don't need to special case all the time. */
5784 267155 : ar->dimen = ar->as->rank;
5785 636586 : for (i = 0; i < ar->dimen; i++)
5786 : {
5787 369431 : ar->dimen_type[i] = DIMEN_RANGE;
5788 :
5789 369431 : gcc_assert (ar->start[i] == NULL);
5790 369431 : gcc_assert (ar->end[i] == NULL);
5791 369431 : gcc_assert (ar->stride[i] == NULL);
5792 : }
5793 : }
5794 :
5795 : /* If the reference type is unknown, figure out what kind it is. */
5796 :
5797 429958 : if (ar->type == AR_UNKNOWN)
5798 : {
5799 149671 : ar->type = AR_ELEMENT;
5800 289590 : for (i = 0; i < ar->dimen; i++)
5801 178243 : if (ar->dimen_type[i] == DIMEN_RANGE
5802 178243 : || ar->dimen_type[i] == DIMEN_VECTOR)
5803 : {
5804 38324 : ar->type = AR_SECTION;
5805 38324 : break;
5806 : }
5807 : }
5808 :
5809 429958 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5810 : return false;
5811 :
5812 429922 : if (ar->as->corank && ar->codimen == 0)
5813 : {
5814 2089 : int n;
5815 2089 : ar->codimen = ar->as->corank;
5816 5944 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5817 3855 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5818 : }
5819 :
5820 429922 : if (ar->codimen)
5821 : {
5822 13837 : if (ar->team_type == TEAM_NUMBER)
5823 : {
5824 60 : if (!gfc_resolve_expr (ar->team))
5825 : return false;
5826 :
5827 60 : if (ar->team->rank != 0)
5828 : {
5829 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5830 : &ar->team->where);
5831 0 : return false;
5832 : }
5833 :
5834 60 : if (ar->team->ts.type != BT_INTEGER)
5835 : {
5836 6 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5837 : "type, found %s",
5838 6 : &ar->team->where,
5839 : gfc_basic_typename (ar->team->ts.type));
5840 6 : return false;
5841 : }
5842 : }
5843 13777 : else if (ar->team_type == TEAM_TEAM)
5844 : {
5845 42 : if (!gfc_resolve_expr (ar->team))
5846 : return false;
5847 :
5848 42 : if (ar->team->rank != 0)
5849 : {
5850 3 : gfc_error ("TEAM argument at %L must be scalar",
5851 : &ar->team->where);
5852 3 : return false;
5853 : }
5854 :
5855 39 : if (ar->team->ts.type != BT_DERIVED
5856 36 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5857 36 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5858 : {
5859 3 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5860 : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5861 3 : &ar->team->where,
5862 : gfc_basic_typename (ar->team->ts.type));
5863 3 : return false;
5864 : }
5865 : }
5866 13825 : if (ar->stat)
5867 : {
5868 62 : if (!gfc_resolve_expr (ar->stat))
5869 : return false;
5870 :
5871 62 : if (ar->stat->rank != 0)
5872 : {
5873 3 : gfc_error ("STAT argument at %L must be scalar",
5874 : &ar->stat->where);
5875 3 : return false;
5876 : }
5877 :
5878 59 : if (ar->stat->ts.type != BT_INTEGER)
5879 : {
5880 3 : gfc_error ("STAT argument at %L must be of INTEGER "
5881 : "type, found %s",
5882 3 : &ar->stat->where,
5883 : gfc_basic_typename (ar->stat->ts.type));
5884 3 : return false;
5885 : }
5886 :
5887 56 : if (ar->stat->expr_type != EXPR_VARIABLE)
5888 : {
5889 0 : gfc_error ("STAT's expression at %L must be a variable",
5890 : &ar->stat->where);
5891 0 : return false;
5892 : }
5893 : }
5894 : }
5895 : return true;
5896 : }
5897 :
5898 :
5899 : bool
5900 8836 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5901 : {
5902 8836 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5903 :
5904 8836 : if (ref->u.ss.start != NULL)
5905 : {
5906 8836 : if (!gfc_resolve_expr (ref->u.ss.start))
5907 : return false;
5908 :
5909 8836 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5910 : {
5911 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5912 : &ref->u.ss.start->where);
5913 1 : return false;
5914 : }
5915 :
5916 8835 : if (ref->u.ss.start->rank != 0)
5917 : {
5918 0 : gfc_error ("Substring start index at %L must be scalar",
5919 : &ref->u.ss.start->where);
5920 0 : return false;
5921 : }
5922 :
5923 8835 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5924 8835 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5925 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5926 : {
5927 1 : gfc_error ("Substring start index at %L is less than one",
5928 : &ref->u.ss.start->where);
5929 1 : return false;
5930 : }
5931 : }
5932 :
5933 8834 : if (ref->u.ss.end != NULL)
5934 : {
5935 8640 : if (!gfc_resolve_expr (ref->u.ss.end))
5936 : return false;
5937 :
5938 8640 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5939 : {
5940 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5941 : &ref->u.ss.end->where);
5942 1 : return false;
5943 : }
5944 :
5945 8639 : if (ref->u.ss.end->rank != 0)
5946 : {
5947 0 : gfc_error ("Substring end index at %L must be scalar",
5948 : &ref->u.ss.end->where);
5949 0 : return false;
5950 : }
5951 :
5952 8639 : if (ref->u.ss.length != NULL
5953 8303 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5954 8651 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5955 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5956 : {
5957 4 : gfc_error ("Substring end index at %L exceeds the string length",
5958 : &ref->u.ss.start->where);
5959 4 : return false;
5960 : }
5961 :
5962 8635 : if (compare_bound_mpz_t (ref->u.ss.end,
5963 8635 : gfc_integer_kinds[k].huge) == CMP_GT
5964 8635 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5965 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5966 : {
5967 4 : gfc_error ("Substring end index at %L is too large",
5968 : &ref->u.ss.end->where);
5969 4 : return false;
5970 : }
5971 : /* If the substring has the same length as the original
5972 : variable, the reference itself can be deleted. */
5973 :
5974 8631 : if (ref->u.ss.length != NULL
5975 8295 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5976 9547 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5977 230 : *equal_length = true;
5978 : }
5979 :
5980 : return true;
5981 : }
5982 :
5983 :
5984 : /* This function supplies missing substring charlens. */
5985 :
5986 : void
5987 4564 : gfc_resolve_substring_charlen (gfc_expr *e)
5988 : {
5989 4564 : gfc_ref *char_ref;
5990 4564 : gfc_expr *start, *end;
5991 4564 : gfc_typespec *ts = NULL;
5992 4564 : mpz_t diff;
5993 :
5994 8889 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5995 : {
5996 7042 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5997 : break;
5998 4325 : if (char_ref->type == REF_COMPONENT)
5999 328 : ts = &char_ref->u.c.component->ts;
6000 : }
6001 :
6002 4564 : if (!char_ref || char_ref->type == REF_INQUIRY)
6003 1909 : return;
6004 :
6005 2717 : gcc_assert (char_ref->next == NULL);
6006 :
6007 2717 : if (e->ts.u.cl)
6008 : {
6009 120 : if (e->ts.u.cl->length)
6010 108 : gfc_free_expr (e->ts.u.cl->length);
6011 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
6012 : return;
6013 : }
6014 :
6015 2705 : if (!e->ts.u.cl)
6016 2597 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6017 :
6018 2705 : if (char_ref->u.ss.start)
6019 2705 : start = gfc_copy_expr (char_ref->u.ss.start);
6020 : else
6021 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
6022 :
6023 2705 : if (char_ref->u.ss.end)
6024 2655 : end = gfc_copy_expr (char_ref->u.ss.end);
6025 50 : else if (e->expr_type == EXPR_VARIABLE)
6026 : {
6027 50 : if (!ts)
6028 32 : ts = &e->symtree->n.sym->ts;
6029 50 : end = gfc_copy_expr (ts->u.cl->length);
6030 : }
6031 : else
6032 : end = NULL;
6033 :
6034 2705 : if (!start || !end)
6035 : {
6036 50 : gfc_free_expr (start);
6037 50 : gfc_free_expr (end);
6038 50 : return;
6039 : }
6040 :
6041 : /* Length = (end - start + 1).
6042 : Check first whether it has a constant length. */
6043 2655 : if (gfc_dep_difference (end, start, &diff))
6044 : {
6045 2539 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
6046 : &e->where);
6047 :
6048 2539 : mpz_add_ui (len->value.integer, diff, 1);
6049 2539 : mpz_clear (diff);
6050 2539 : e->ts.u.cl->length = len;
6051 : /* The check for length < 0 is handled below */
6052 : }
6053 : else
6054 : {
6055 116 : e->ts.u.cl->length = gfc_subtract (end, start);
6056 116 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
6057 : gfc_get_int_expr (gfc_charlen_int_kind,
6058 : NULL, 1));
6059 : }
6060 :
6061 : /* F2008, 6.4.1: Both the starting point and the ending point shall
6062 : be within the range 1, 2, ..., n unless the starting point exceeds
6063 : the ending point, in which case the substring has length zero. */
6064 :
6065 2655 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
6066 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
6067 :
6068 2655 : e->ts.u.cl->length->ts.type = BT_INTEGER;
6069 2655 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6070 :
6071 : /* Make sure that the length is simplified. */
6072 2655 : gfc_simplify_expr (e->ts.u.cl->length, 1);
6073 2655 : gfc_resolve_expr (e->ts.u.cl->length);
6074 : }
6075 :
6076 :
6077 : /* Convert an array reference to an array element so that PDT KIND and LEN
6078 : or inquiry references are always scalar. */
6079 :
6080 : static void
6081 21 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
6082 : {
6083 21 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6084 21 : int dim;
6085 :
6086 21 : array_ref->u.ar.type = AR_ELEMENT;
6087 21 : expr->rank = 0;
6088 : /* Suppress the runtime bounds check. */
6089 21 : expr->no_bounds_check = 1;
6090 42 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
6091 : {
6092 21 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
6093 21 : if (array_ref->u.ar.start[dim])
6094 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
6095 :
6096 21 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
6097 9 : array_ref->u.ar.start[dim]
6098 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
6099 : else
6100 12 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
6101 :
6102 21 : if (array_ref->u.ar.end[dim])
6103 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
6104 21 : if (array_ref->u.ar.stride[dim])
6105 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
6106 : }
6107 21 : gfc_free_expr (unity);
6108 21 : }
6109 :
6110 :
6111 : /* Resolve subtype references. */
6112 :
6113 : bool
6114 547623 : gfc_resolve_ref (gfc_expr *expr)
6115 : {
6116 547623 : int current_part_dimension, n_components, seen_part_dimension;
6117 547623 : gfc_ref *ref, **prev, *array_ref;
6118 547623 : bool equal_length;
6119 547623 : gfc_symbol *last_pdt = NULL;
6120 :
6121 1075859 : for (ref = expr->ref; ref; ref = ref->next)
6122 529150 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6123 : {
6124 914 : if (!find_array_spec (expr))
6125 : return false;
6126 : break;
6127 : }
6128 :
6129 1605843 : for (prev = &expr->ref; *prev != NULL;
6130 529216 : prev = *prev == NULL ? prev : &(*prev)->next)
6131 529295 : switch ((*prev)->type)
6132 : {
6133 429975 : case REF_ARRAY:
6134 429975 : if (!resolve_array_ref (&(*prev)->u.ar))
6135 : return false;
6136 : break;
6137 :
6138 : case REF_COMPONENT:
6139 : case REF_INQUIRY:
6140 : break;
6141 :
6142 8555 : case REF_SUBSTRING:
6143 8555 : equal_length = false;
6144 8555 : if (!gfc_resolve_substring (*prev, &equal_length))
6145 : return false;
6146 :
6147 8547 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6148 : {
6149 : /* Remove the reference and move the charlen, if any. */
6150 205 : ref = *prev;
6151 205 : *prev = ref->next;
6152 205 : ref->next = NULL;
6153 205 : expr->ts.u.cl = ref->u.ss.length;
6154 205 : ref->u.ss.length = NULL;
6155 205 : gfc_free_ref_list (ref);
6156 : }
6157 : break;
6158 : }
6159 :
6160 : /* Check constraints on part references. */
6161 :
6162 547537 : current_part_dimension = 0;
6163 547537 : seen_part_dimension = 0;
6164 547537 : n_components = 0;
6165 547537 : array_ref = NULL;
6166 :
6167 : /* Use the declared type of the base symbol to initialize last_pdt when the
6168 : expression is not itself a PDT. This matters for ASSOCIATE variables whose
6169 : component reference may still point to a PDT template. */
6170 547537 : if (expr->expr_type == EXPR_VARIABLE
6171 454209 : && (IS_PDT (expr)
6172 453639 : || (expr->ref && expr->symtree && IS_PDT (expr->symtree->n.sym))))
6173 2267 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6174 :
6175 1076523 : for (ref = expr->ref; ref; ref = ref->next)
6176 : {
6177 528997 : switch (ref->type)
6178 : {
6179 429897 : case REF_ARRAY:
6180 429897 : array_ref = ref;
6181 429897 : switch (ref->u.ar.type)
6182 : {
6183 263684 : case AR_FULL:
6184 : /* Coarray scalar. */
6185 263684 : if (ref->u.ar.as->rank == 0)
6186 : {
6187 : current_part_dimension = 0;
6188 : break;
6189 : }
6190 : /* Fall through. */
6191 305084 : case AR_SECTION:
6192 305084 : current_part_dimension = 1;
6193 305084 : break;
6194 :
6195 124813 : case AR_ELEMENT:
6196 124813 : array_ref = NULL;
6197 124813 : current_part_dimension = 0;
6198 124813 : break;
6199 :
6200 0 : case AR_UNKNOWN:
6201 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6202 : }
6203 :
6204 : break;
6205 :
6206 89937 : case REF_COMPONENT:
6207 89937 : if (current_part_dimension || seen_part_dimension)
6208 : {
6209 : /* F03:C614. */
6210 6863 : if (ref->u.c.component->attr.pointer
6211 6860 : || ref->u.c.component->attr.proc_pointer
6212 6859 : || (ref->u.c.component->ts.type == BT_CLASS
6213 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6214 : {
6215 4 : gfc_error ("Component to the right of a part reference "
6216 : "with nonzero rank must not have the POINTER "
6217 : "attribute at %L", &expr->where);
6218 4 : return false;
6219 : }
6220 6859 : else if (ref->u.c.component->attr.allocatable
6221 6853 : || (ref->u.c.component->ts.type == BT_CLASS
6222 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6223 :
6224 : {
6225 7 : gfc_error ("Component to the right of a part reference "
6226 : "with nonzero rank must not have the ALLOCATABLE "
6227 : "attribute at %L", &expr->where);
6228 7 : return false;
6229 : }
6230 : }
6231 :
6232 : /* Sometimes the component in a component reference is that of the
6233 : pdt_template. Point to the component of pdt_type instead. This
6234 : ensures that the component gets a backend_decl in translation. */
6235 89926 : if (last_pdt)
6236 : {
6237 2198 : gfc_component *cmp = last_pdt->components;
6238 5397 : for (; cmp; cmp = cmp->next)
6239 5272 : if (!strcmp (cmp->name, ref->u.c.component->name))
6240 : {
6241 2073 : ref->u.c.component = cmp;
6242 2073 : break;
6243 : }
6244 2198 : ref->u.c.sym = last_pdt;
6245 : }
6246 :
6247 : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6248 89926 : if (ref->u.c.component->ts.type == BT_DERIVED)
6249 : {
6250 20852 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6251 : {
6252 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6253 : &ref->u.c.component->ts.u.derived,
6254 : NULL) != MATCH_YES)
6255 : return false;
6256 0 : last_pdt = ref->u.c.component->ts.u.derived;
6257 : }
6258 20852 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6259 521 : last_pdt = ref->u.c.component->ts.u.derived;
6260 : else
6261 : last_pdt = NULL;
6262 : }
6263 :
6264 : /* The F08 standard requires(See R425, R431, R435, and in particular
6265 : Note 6.7) that a PDT parameter reference be a scalar even if
6266 : the designator is an array." */
6267 89926 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6268 149 : && (ref->u.c.component->attr.pdt_kind
6269 149 : || ref->u.c.component->attr.pdt_len))
6270 7 : reset_array_ref_to_scalar (expr, array_ref);
6271 :
6272 89926 : n_components++;
6273 89926 : break;
6274 :
6275 : case REF_SUBSTRING:
6276 : break;
6277 :
6278 821 : case REF_INQUIRY:
6279 : /* Implement requirement in note 9.7 of F2018 that the result of the
6280 : LEN inquiry be a scalar. */
6281 821 : if (ref->u.i == INQUIRY_LEN && array_ref
6282 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6283 40 : || expr->ts.type == BT_INTEGER))
6284 14 : reset_array_ref_to_scalar (expr, array_ref);
6285 : break;
6286 : }
6287 :
6288 528986 : if (((ref->type == REF_COMPONENT && n_components > 1)
6289 515669 : || ref->next == NULL)
6290 : && current_part_dimension
6291 463461 : && seen_part_dimension)
6292 : {
6293 0 : gfc_error ("Two or more part references with nonzero rank must "
6294 : "not be specified at %L", &expr->where);
6295 0 : return false;
6296 : }
6297 :
6298 528986 : if (ref->type == REF_COMPONENT)
6299 : {
6300 89926 : if (current_part_dimension)
6301 6665 : seen_part_dimension = 1;
6302 :
6303 : /* reset to make sure */
6304 : current_part_dimension = 0;
6305 : }
6306 : }
6307 :
6308 : return true;
6309 : }
6310 :
6311 :
6312 : /* Given an expression, determine its shape. This is easier than it sounds.
6313 : Leaves the shape array NULL if it is not possible to determine the shape. */
6314 :
6315 : static void
6316 2616398 : expression_shape (gfc_expr *e)
6317 : {
6318 2616398 : mpz_t array[GFC_MAX_DIMENSIONS];
6319 2616398 : int i;
6320 :
6321 2616398 : if (e->rank <= 0 || e->shape != NULL)
6322 2438301 : return;
6323 :
6324 711090 : for (i = 0; i < e->rank; i++)
6325 480310 : if (!gfc_array_dimen_size (e, i, &array[i]))
6326 178097 : goto fail;
6327 :
6328 230780 : e->shape = gfc_get_shape (e->rank);
6329 :
6330 230780 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6331 :
6332 230780 : return;
6333 :
6334 178097 : fail:
6335 179768 : for (i--; i >= 0; i--)
6336 1671 : mpz_clear (array[i]);
6337 : }
6338 :
6339 :
6340 : /* Given a variable expression node, compute the rank of the expression by
6341 : examining the base symbol and any reference structures it may have. */
6342 :
6343 : void
6344 2616398 : gfc_expression_rank (gfc_expr *e)
6345 : {
6346 2616398 : gfc_ref *ref, *last_arr_ref = nullptr;
6347 2616398 : int i, rank, corank;
6348 :
6349 : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6350 : could lead to serious confusion... */
6351 2616398 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6352 :
6353 2616398 : if (e->ref == NULL)
6354 : {
6355 1928483 : if (e->expr_type == EXPR_ARRAY)
6356 72847 : goto done;
6357 : /* Constructors can have a rank different from one via RESHAPE(). */
6358 :
6359 1855636 : if (e->symtree != NULL)
6360 : {
6361 : /* After errors the ts.u.derived of a CLASS might not be set. */
6362 1855624 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6363 13911 : && e->symtree->n.sym->ts.u.derived
6364 13906 : && CLASS_DATA (e->symtree->n.sym))
6365 1855624 : ? CLASS_DATA (e->symtree->n.sym)->as
6366 : : e->symtree->n.sym->as;
6367 1855624 : if (as)
6368 : {
6369 626 : e->rank = as->rank;
6370 626 : e->corank = as->corank;
6371 626 : goto done;
6372 : }
6373 : }
6374 1855010 : e->rank = 0;
6375 1855010 : e->corank = 0;
6376 1855010 : goto done;
6377 : }
6378 :
6379 : rank = 0;
6380 : corank = 0;
6381 :
6382 1088216 : for (ref = e->ref; ref; ref = ref->next)
6383 : {
6384 796750 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6385 568 : && ref->u.c.component->attr.function && !ref->next)
6386 : {
6387 372 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6388 372 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6389 : }
6390 :
6391 796750 : if (ref->type != REF_ARRAY)
6392 159461 : continue;
6393 :
6394 637289 : last_arr_ref = ref;
6395 637289 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6396 : {
6397 350350 : rank = ref->u.ar.as->rank;
6398 350350 : break;
6399 : }
6400 :
6401 286939 : if (ref->u.ar.type == AR_SECTION)
6402 : {
6403 : /* Figure out the rank of the section. */
6404 46099 : if (rank != 0)
6405 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6406 :
6407 114860 : for (i = 0; i < ref->u.ar.dimen; i++)
6408 68761 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6409 68761 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6410 59915 : rank++;
6411 :
6412 : break;
6413 : }
6414 : }
6415 687915 : if (last_arr_ref && last_arr_ref->u.ar.as
6416 617094 : && last_arr_ref->u.ar.as->rank != -1)
6417 : {
6418 19521 : for (i = last_arr_ref->u.ar.as->rank;
6419 628362 : i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
6420 : {
6421 : /* For unknown dimen in non-resolved as assume full corank. */
6422 20454 : if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
6423 19844 : || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6424 323 : && !last_arr_ref->u.ar.as->resolved))
6425 : {
6426 : corank = last_arr_ref->u.ar.as->corank;
6427 : break;
6428 : }
6429 19521 : else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6430 19521 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6431 19423 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6432 16932 : corank++;
6433 2589 : else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6434 0 : gfc_internal_error ("Illegal coarray index");
6435 : }
6436 : }
6437 :
6438 687915 : e->rank = rank;
6439 687915 : e->corank = corank;
6440 :
6441 2616398 : done:
6442 2616398 : expression_shape (e);
6443 2616398 : }
6444 :
6445 :
6446 : /* Given two expressions, check that their rank is conformable, i.e. either
6447 : both have the same rank or at least one is a scalar. */
6448 :
6449 : bool
6450 12244379 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6451 : {
6452 12244379 : if (op1->expr_type == EXPR_VARIABLE)
6453 738996 : gfc_expression_rank (op1);
6454 12244379 : if (op2->expr_type == EXPR_VARIABLE)
6455 447467 : gfc_expression_rank (op2);
6456 :
6457 77605 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6458 12321658 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6459 30 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6460 : }
6461 :
6462 : /* Resolve a variable expression. */
6463 :
6464 : static bool
6465 1338193 : resolve_variable (gfc_expr *e)
6466 : {
6467 1338193 : gfc_symbol *sym;
6468 1338193 : bool t;
6469 :
6470 1338193 : t = true;
6471 :
6472 1338193 : if (e->symtree == NULL)
6473 : return false;
6474 1337748 : sym = e->symtree->n.sym;
6475 :
6476 : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6477 : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6478 1337748 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6479 : {
6480 183 : if (!actual_arg || inquiry_argument)
6481 : {
6482 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6483 : "be used as actual argument", sym->name, &e->where);
6484 2 : return false;
6485 : }
6486 : }
6487 : /* TS 29113, 407b. */
6488 1337565 : else if (e->ts.type == BT_ASSUMED)
6489 : {
6490 571 : if (!actual_arg)
6491 : {
6492 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6493 : "as actual argument", sym->name, &e->where);
6494 20 : return false;
6495 : }
6496 551 : else if (inquiry_argument && !first_actual_arg)
6497 : {
6498 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6499 : for all inquiry functions in resolve_function; the reason is
6500 : that the function-name resolution happens too late in that
6501 : function. */
6502 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6503 : "an inquiry function shall be the first argument",
6504 : sym->name, &e->where);
6505 0 : return false;
6506 : }
6507 : }
6508 : /* TS 29113, C535b. */
6509 1336994 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6510 37575 : && sym->ts.u.derived && CLASS_DATA (sym)
6511 37570 : && CLASS_DATA (sym)->as
6512 14692 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6513 1336030 : || (sym->ts.type != BT_CLASS && sym->as
6514 365774 : && sym->as->type == AS_ASSUMED_RANK))
6515 8045 : && !sym->attr.select_rank_temporary
6516 8045 : && !(sym->assoc && sym->assoc->ar))
6517 : {
6518 8045 : if (!actual_arg
6519 1265 : && !(cs_base && cs_base->current
6520 1264 : && (cs_base->current->op == EXEC_SELECT_RANK
6521 188 : || sym->attr.target)))
6522 : {
6523 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6524 : "actual argument", sym->name, &e->where);
6525 144 : return false;
6526 : }
6527 7901 : else if (inquiry_argument && !first_actual_arg)
6528 : {
6529 : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6530 : for all inquiry functions in resolve_function; the reason is
6531 : that the function-name resolution happens too late in that
6532 : function. */
6533 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6534 : "to an inquiry function shall be the first argument",
6535 : sym->name, &e->where);
6536 0 : return false;
6537 : }
6538 : }
6539 :
6540 1337582 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6541 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6542 180 : && e->ref->next == NULL))
6543 : {
6544 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6545 : "a subobject reference", sym->name, &e->ref->u.ar.where);
6546 1 : return false;
6547 : }
6548 : /* TS 29113, 407b. */
6549 1337581 : else if (e->ts.type == BT_ASSUMED && e->ref
6550 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6551 680 : && e->ref->next == NULL))
6552 : {
6553 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6554 : "reference", sym->name, &e->ref->u.ar.where);
6555 7 : return false;
6556 : }
6557 :
6558 : /* TS 29113, C535b. */
6559 1337574 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6560 37575 : && sym->ts.u.derived && CLASS_DATA (sym)
6561 37570 : && CLASS_DATA (sym)->as
6562 14692 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6563 1336610 : || (sym->ts.type != BT_CLASS && sym->as
6564 366310 : && sym->as->type == AS_ASSUMED_RANK))
6565 8185 : && !(sym->assoc && sym->assoc->ar)
6566 8185 : && e->ref
6567 8185 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6568 8181 : && e->ref->next == NULL))
6569 : {
6570 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6571 : "reference", sym->name, &e->ref->u.ar.where);
6572 4 : return false;
6573 : }
6574 :
6575 : /* Guessed type variables are associate_names whose selector had not been
6576 : parsed at the time that the construct was parsed. Now the namespace is
6577 : being resolved, the TKR of the selector will be available for fixup of
6578 : the associate_name. */
6579 1337570 : if (IS_INFERRED_TYPE (e) && e->ref)
6580 : {
6581 410 : gfc_fixup_inferred_type_refs (e);
6582 : /* KIND inquiry ref returns the kind of the target. */
6583 410 : if (e->expr_type == EXPR_CONSTANT)
6584 : return true;
6585 : }
6586 1337160 : else if (IS_INFERRED_TYPE (e)
6587 489 : && sym->ts.type != BT_UNKNOWN
6588 489 : && (sym->ts.type != e->ts.type || sym->ts.kind != e->ts.kind))
6589 : /* No subobject ref, but the expression's typespec was set at parse
6590 : time before the target's actual type/kind was known. Refresh from
6591 : the now-resolved associate-name symbol. */
6592 192 : e->ts = sym->ts;
6593 1336968 : else if (sym->attr.select_type_temporary
6594 9050 : && sym->ns->assoc_name_inferred)
6595 92 : gfc_fixup_inferred_type_refs (e);
6596 :
6597 : /* For variables that are used in an associate (target => object) where
6598 : the object's basetype is array valued while the target is scalar,
6599 : the ts' type of the component refs is still array valued, which
6600 : can't be translated that way. */
6601 1337558 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6602 605 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6603 605 : && sym->assoc->target->ts.u.derived
6604 605 : && CLASS_DATA (sym->assoc->target)
6605 605 : && CLASS_DATA (sym->assoc->target)->as)
6606 : {
6607 : gfc_ref *ref = e->ref;
6608 701 : while (ref)
6609 : {
6610 542 : switch (ref->type)
6611 : {
6612 237 : case REF_COMPONENT:
6613 237 : ref->u.c.sym = sym->ts.u.derived;
6614 : /* Stop the loop. */
6615 237 : ref = NULL;
6616 237 : break;
6617 305 : default:
6618 305 : ref = ref->next;
6619 305 : break;
6620 : }
6621 : }
6622 : }
6623 :
6624 : /* If this is an associate-name, it may be parsed with an array reference
6625 : in error even though the target is scalar. Fail directly in this case.
6626 : TODO Understand why class scalar expressions must be excluded. */
6627 1337558 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6628 : {
6629 11920 : if (sym->ts.type == BT_CLASS)
6630 245 : gfc_fix_class_refs (e);
6631 11920 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6632 2204 : && e->ref->type == REF_ARRAY)
6633 : {
6634 : /* Unambiguously scalar! */
6635 3 : if (sym->assoc->target
6636 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6637 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6638 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6639 : sym->name, &e->where);
6640 3 : return false;
6641 : }
6642 11917 : else if ((sym->attr.dimension || sym->attr.codimension)
6643 7038 : && (!e->ref || e->ref->type != REF_ARRAY))
6644 : {
6645 : /* This can happen because the parser did not detect that the
6646 : associate name is an array and the expression had no array
6647 : part_ref. */
6648 141 : gfc_ref *ref = gfc_get_ref ();
6649 141 : ref->type = REF_ARRAY;
6650 141 : ref->u.ar.type = AR_FULL;
6651 141 : if (sym->as)
6652 : {
6653 140 : ref->u.ar.as = sym->as;
6654 140 : ref->u.ar.dimen = sym->as->rank;
6655 : }
6656 141 : ref->next = e->ref;
6657 141 : e->ref = ref;
6658 : }
6659 : }
6660 :
6661 1337555 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6662 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6663 :
6664 : /* On the other hand, the parser may not have known this is an array;
6665 : in this case, we have to add a FULL reference. */
6666 1337555 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6667 : {
6668 0 : e->ref = gfc_get_ref ();
6669 0 : e->ref->type = REF_ARRAY;
6670 0 : e->ref->u.ar.type = AR_FULL;
6671 0 : e->ref->u.ar.dimen = 0;
6672 : }
6673 :
6674 : /* Like above, but for class types, where the checking whether an array
6675 : ref is present is more complicated. Furthermore make sure not to add
6676 : the full array ref to _vptr or _len refs. */
6677 1337555 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6678 1023 : && CLASS_DATA (sym)
6679 1023 : && (CLASS_DATA (sym)->attr.dimension
6680 449 : || CLASS_DATA (sym)->attr.codimension)
6681 580 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6682 : {
6683 555 : gfc_ref *ref, *newref;
6684 :
6685 555 : newref = gfc_get_ref ();
6686 555 : newref->type = REF_ARRAY;
6687 555 : newref->u.ar.type = AR_FULL;
6688 555 : newref->u.ar.dimen = 0;
6689 :
6690 : /* Because this is an associate var and the first ref either is a ref to
6691 : the _data component or not, no traversal of the ref chain is
6692 : needed. The array ref needs to be inserted after the _data ref,
6693 : or when that is not present, which may happened for polymorphic
6694 : types, then at the first position. */
6695 555 : ref = e->ref;
6696 555 : if (!ref)
6697 18 : e->ref = newref;
6698 537 : else if (ref->type == REF_COMPONENT
6699 232 : && strcmp ("_data", ref->u.c.component->name) == 0)
6700 : {
6701 232 : if (!ref->next || ref->next->type != REF_ARRAY)
6702 : {
6703 12 : newref->next = ref->next;
6704 12 : ref->next = newref;
6705 : }
6706 : else
6707 : /* Array ref present already. */
6708 220 : gfc_free_ref_list (newref);
6709 : }
6710 305 : else if (ref->type == REF_ARRAY)
6711 : /* Array ref present already. */
6712 305 : gfc_free_ref_list (newref);
6713 : else
6714 : {
6715 0 : newref->next = ref;
6716 0 : e->ref = newref;
6717 : }
6718 : }
6719 1337000 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6720 : {
6721 498 : gfc_ref *ref;
6722 922 : for (ref = e->ref; ref; ref = ref->next)
6723 454 : if (ref->type == REF_SUBSTRING)
6724 : break;
6725 498 : if (ref == NULL)
6726 468 : e->ts = sym->ts;
6727 : }
6728 :
6729 1337555 : if (e->ref && !gfc_resolve_ref (e))
6730 : return false;
6731 :
6732 1337462 : if (sym->attr.flavor == FL_PROCEDURE
6733 32286 : && (!sym->attr.function
6734 18965 : || (sym->attr.function && sym->result
6735 18510 : && sym->result->attr.proc_pointer
6736 726 : && !sym->result->attr.function)))
6737 : {
6738 13321 : e->ts.type = BT_PROCEDURE;
6739 13321 : goto resolve_procedure;
6740 : }
6741 :
6742 1324141 : if (sym->ts.type != BT_UNKNOWN)
6743 1323369 : gfc_variable_attr (e, &e->ts);
6744 772 : else if (sym->attr.flavor == FL_PROCEDURE
6745 12 : && sym->attr.function && sym->result
6746 12 : && sym->result->ts.type != BT_UNKNOWN
6747 10 : && sym->result->attr.proc_pointer)
6748 10 : e->ts = sym->result->ts;
6749 : else
6750 : {
6751 : /* Must be a simple variable reference. */
6752 762 : if (!gfc_set_default_type (sym, 1, sym->ns))
6753 : return false;
6754 633 : e->ts = sym->ts;
6755 : }
6756 :
6757 1324012 : if (check_assumed_size_reference (sym, e))
6758 : return false;
6759 :
6760 : /* Deal with forward references to entries during gfc_resolve_code, to
6761 : satisfy, at least partially, 12.5.2.5. */
6762 1323993 : if (gfc_current_ns->entries
6763 3229 : && current_entry_id == sym->entry_id
6764 1050 : && cs_base
6765 964 : && cs_base->current
6766 964 : && cs_base->current->op != EXEC_ENTRY)
6767 : {
6768 964 : int n;
6769 964 : bool saved_specification_expr;
6770 964 : gfc_symbol *saved_specification_expr_symbol;
6771 :
6772 : /* If the symbol is a dummy... */
6773 964 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6774 : {
6775 : /* If it has not been seen as a dummy, this is an error. */
6776 462 : if (!entry_dummy_seen_p (sym))
6777 : {
6778 5 : if (specification_expr
6779 4 : && specification_expr_symbol
6780 4 : && specification_expr_symbol->attr.dummy
6781 2 : && specification_expr_symbol->ns == gfc_current_ns
6782 7 : && !entry_dummy_seen_p (specification_expr_symbol))
6783 : ;
6784 3 : else if (specification_expr)
6785 2 : gfc_error ("Variable %qs, used in a specification expression"
6786 : ", is referenced at %L before the ENTRY statement "
6787 : "in which it is a parameter",
6788 : sym->name, &cs_base->current->loc);
6789 : else
6790 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6791 : "statement in which it is a parameter",
6792 : sym->name, &cs_base->current->loc);
6793 : t = false;
6794 : }
6795 : }
6796 :
6797 : /* Now do the same check on the specification expressions. */
6798 964 : saved_specification_expr = specification_expr;
6799 964 : saved_specification_expr_symbol = specification_expr_symbol;
6800 964 : specification_expr = true;
6801 964 : specification_expr_symbol = sym;
6802 964 : if (sym->ts.type == BT_CHARACTER
6803 964 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6804 : t = false;
6805 :
6806 964 : if (sym->as)
6807 : {
6808 279 : for (n = 0; n < sym->as->rank; n++)
6809 : {
6810 164 : if (!gfc_resolve_expr (sym->as->lower[n]))
6811 0 : t = false;
6812 164 : if (!gfc_resolve_expr (sym->as->upper[n]))
6813 1 : t = false;
6814 : }
6815 : }
6816 964 : specification_expr = saved_specification_expr;
6817 964 : specification_expr_symbol = saved_specification_expr_symbol;
6818 :
6819 964 : if (t)
6820 : /* Update the symbol's entry level. */
6821 957 : sym->entry_id = current_entry_id + 1;
6822 : }
6823 :
6824 : /* If a symbol has been host_associated mark it. This is used latter,
6825 : to identify if aliasing is possible via host association. */
6826 1323993 : if (sym->attr.flavor == FL_VARIABLE
6827 1285380 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6828 6224 : || !sym->ns->code->ext.block.assoc)
6829 1283282 : && gfc_current_ns->parent
6830 612227 : && (gfc_current_ns->parent == sym->ns
6831 573602 : || (gfc_current_ns->parent->parent
6832 12251 : && gfc_current_ns->parent->parent == sym->ns)))
6833 45276 : sym->attr.host_assoc = 1;
6834 :
6835 1323993 : if (gfc_current_ns->proc_name
6836 1319815 : && sym->attr.dimension
6837 359686 : && (sym->ns != gfc_current_ns
6838 335688 : || sym->attr.use_assoc
6839 331701 : || sym->attr.in_common))
6840 32774 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6841 :
6842 1337314 : resolve_procedure:
6843 1337314 : if (t && !resolve_procedure_expression (e))
6844 : t = false;
6845 :
6846 : /* F2008, C617 and C1229. */
6847 1336204 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6848 1436828 : && gfc_is_coindexed (e))
6849 : {
6850 359 : gfc_ref *ref, *ref2 = NULL;
6851 :
6852 442 : for (ref = e->ref; ref; ref = ref->next)
6853 : {
6854 442 : if (ref->type == REF_COMPONENT)
6855 83 : ref2 = ref;
6856 442 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6857 : break;
6858 : }
6859 :
6860 718 : for ( ; ref; ref = ref->next)
6861 371 : if (ref->type == REF_COMPONENT)
6862 : break;
6863 :
6864 : /* Expression itself is not coindexed object. */
6865 359 : if (ref && e->ts.type == BT_CLASS)
6866 : {
6867 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6868 : &e->where);
6869 3 : t = false;
6870 : }
6871 :
6872 : /* Expression itself is coindexed object. */
6873 347 : if (ref == NULL)
6874 : {
6875 347 : gfc_component *c;
6876 347 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6877 467 : for ( ; c; c = c->next)
6878 120 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6879 : {
6880 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6881 : "subcomponent at %L", &e->where);
6882 0 : t = false;
6883 0 : break;
6884 : }
6885 : }
6886 : }
6887 :
6888 1337314 : if (t)
6889 1337304 : gfc_expression_rank (e);
6890 :
6891 1337314 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6892 3 : gfc_warning (OPT_Wdeprecated_declarations,
6893 : "Using variable %qs at %L is deprecated",
6894 : sym->name, &e->where);
6895 : /* Simplify cases where access to a parameter array results in a
6896 : single constant. Suppress errors since those will have been
6897 : issued before, as warnings. */
6898 1337314 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6899 : {
6900 2731 : gfc_push_suppress_errors ();
6901 2731 : gfc_simplify_expr (e, 1);
6902 2731 : gfc_pop_suppress_errors ();
6903 : }
6904 :
6905 : return t;
6906 : }
6907 :
6908 :
6909 : /* 'sym' was initially guessed to be derived type but has been corrected
6910 : in resolve_assoc_var to be a class entity or the derived type correcting.
6911 : If a class entity it will certainly need the _data reference or the
6912 : reference derived type symbol correcting in the first component ref if
6913 : a derived type. */
6914 :
6915 : void
6916 920 : gfc_fixup_inferred_type_refs (gfc_expr *e)
6917 : {
6918 920 : gfc_ref *ref, *new_ref;
6919 920 : gfc_symbol *sym, *derived;
6920 920 : gfc_expr *target;
6921 920 : sym = e->symtree->n.sym;
6922 :
6923 : /* An associate_name whose selector is (i) a component ref of a selector
6924 : that is a inferred type associate_name; or (ii) an intrinsic type that
6925 : has been inferred from an inquiry ref. */
6926 920 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
6927 : {
6928 318 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
6929 318 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
6930 318 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
6931 : {
6932 60 : ref = e->ref;
6933 : /* A substring misidentified as an array section. */
6934 60 : if (sym->ts.type == BT_CHARACTER
6935 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
6936 6 : && !ref->u.ar.stride[0])
6937 : {
6938 6 : new_ref = gfc_get_ref ();
6939 6 : new_ref->type = REF_SUBSTRING;
6940 6 : new_ref->u.ss.start = ref->u.ar.start[0];
6941 6 : new_ref->u.ss.end = ref->u.ar.end[0];
6942 6 : new_ref->u.ss.length = sym->ts.u.cl;
6943 6 : *ref = *new_ref;
6944 6 : free (new_ref);
6945 : }
6946 : else
6947 : {
6948 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
6949 24 : gfc_error ("Invalid array reference at %L", &e->where);
6950 54 : e->ref = ref->next;
6951 54 : free (ref);
6952 : }
6953 : }
6954 :
6955 : /* It is possible for an inquiry reference to be mistaken for a
6956 : component reference. Correct this now. */
6957 318 : ref = e->ref;
6958 318 : if (ref && ref->type == REF_ARRAY)
6959 138 : ref = ref->next;
6960 186 : if (ref && ref->type == REF_COMPONENT
6961 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
6962 : {
6963 12 : e->symtree->n.sym = sym;
6964 12 : *ref = *new_ref;
6965 12 : gfc_free_ref_list (new_ref);
6966 : }
6967 :
6968 : /* The kind of the associate name is best evaluated directly from the
6969 : selector because of the guesses made in primary.cc, when the type
6970 : is still unknown. */
6971 318 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
6972 : {
6973 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6974 12 : sym->assoc->target->ts.kind);
6975 12 : gfc_replace_expr (e, ne);
6976 12 : }
6977 174 : else if (ref && ref->type == REF_INQUIRY
6978 150 : && (ref->u.i == INQUIRY_RE || ref->u.i == INQUIRY_IM)
6979 114 : && sym->ts.type == BT_COMPLEX
6980 114 : && e->ts.type == BT_REAL
6981 114 : && e->ts.kind != sym->ts.kind)
6982 : /* primary.cc set the inquiry-result kind to the default real kind
6983 : when the associate-name's type was inferred from %re/%im before
6984 : the target was resolved. Now use the (resolved) selector kind. */
6985 24 : e->ts.kind = sym->ts.kind;
6986 :
6987 : /* Now that the references are all sorted out, set the expression rank
6988 : and return. */
6989 318 : gfc_expression_rank (e);
6990 318 : return;
6991 : }
6992 :
6993 602 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
6994 : : sym->ts.u.derived;
6995 :
6996 : /* Ensure that class symbols have an array spec and ensure that there
6997 : is a _data field reference following class type references. */
6998 602 : if (sym->ts.type == BT_CLASS
6999 196 : && sym->assoc->target->ts.type == BT_CLASS)
7000 : {
7001 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
7002 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
7003 196 : sym->attr.dimension = 0;
7004 196 : sym->attr.codimension = 0;
7005 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
7006 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
7007 196 : if (e->ref && (e->ref->type != REF_COMPONENT
7008 160 : || e->ref->u.c.component->name[0] != '_'))
7009 : {
7010 82 : ref = gfc_get_ref ();
7011 82 : ref->type = REF_COMPONENT;
7012 82 : ref->next = e->ref;
7013 82 : e->ref = ref;
7014 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
7015 : true, true, NULL);
7016 82 : ref->u.c.sym = sym->ts.u.derived;
7017 : }
7018 : }
7019 :
7020 : /* Proceed as far as the first component reference and ensure that the
7021 : correct derived type is being used. */
7022 865 : for (ref = e->ref; ref; ref = ref->next)
7023 829 : if (ref->type == REF_COMPONENT)
7024 : {
7025 566 : if (ref->u.c.component->name[0] != '_')
7026 370 : ref->u.c.sym = derived;
7027 : else
7028 196 : ref->u.c.sym = sym->ts.u.derived;
7029 : break;
7030 : }
7031 :
7032 : /* Verify that the type inference mechanism has not introduced a spurious
7033 : array reference. This can happen with an associate name, whose selector
7034 : is an element of another inferred type. */
7035 602 : target = e->symtree->n.sym->assoc->target;
7036 602 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
7037 190 : && e != target && !target->rank)
7038 : {
7039 : /* First case: array ref after the scalar class or derived
7040 : associate_name. */
7041 190 : if (e->ref && e->ref->type == REF_ARRAY
7042 7 : && e->ref->u.ar.type != AR_ELEMENT)
7043 : {
7044 7 : ref = e->ref;
7045 7 : if (ref->u.ar.type == AR_UNKNOWN)
7046 1 : gfc_error ("Invalid array reference at %L", &e->where);
7047 7 : e->ref = ref->next;
7048 7 : free (ref);
7049 :
7050 : /* If it hasn't a ref to the '_data' field supply one. */
7051 7 : if (sym->ts.type == BT_CLASS
7052 0 : && !(e->ref->type == REF_COMPONENT
7053 0 : && strcmp (e->ref->u.c.component->name, "_data")))
7054 : {
7055 0 : gfc_ref *new_ref;
7056 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
7057 : "_data", true, true, &new_ref);
7058 0 : new_ref->next = e->ref;
7059 0 : e->ref = new_ref;
7060 : }
7061 : }
7062 : /* 2nd case: a ref to the '_data' field followed by an array ref. */
7063 183 : else if (e->ref && e->ref->type == REF_COMPONENT
7064 183 : && strcmp (e->ref->u.c.component->name, "_data") == 0
7065 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
7066 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
7067 : {
7068 0 : ref = e->ref->next;
7069 0 : if (ref->u.ar.type == AR_UNKNOWN)
7070 0 : gfc_error ("Invalid array reference at %L", &e->where);
7071 0 : e->ref->next = e->ref->next->next;
7072 0 : free (ref);
7073 : }
7074 : }
7075 :
7076 : /* Now that all the references are OK, get the expression rank. */
7077 602 : gfc_expression_rank (e);
7078 : }
7079 :
7080 :
7081 : /* Checks to see that the correct symbol has been host associated.
7082 : The only situations where this arises are:
7083 : (i) That in which a twice contained function is parsed after
7084 : the host association is made. On detecting this, change
7085 : the symbol in the expression and convert the array reference
7086 : into an actual arglist if the old symbol is a variable; or
7087 : (ii) That in which an external function is typed but not declared
7088 : explicitly to be external. Here, the old symbol is changed
7089 : from a variable to an external function. */
7090 : static bool
7091 1685537 : check_host_association (gfc_expr *e)
7092 : {
7093 1685537 : gfc_symbol *sym, *old_sym;
7094 1685537 : gfc_symtree *st;
7095 1685537 : int n;
7096 1685537 : gfc_ref *ref;
7097 1685537 : gfc_actual_arglist *arg, *tail = NULL;
7098 1685537 : bool retval = e->expr_type == EXPR_FUNCTION;
7099 :
7100 : /* If the expression is the result of substitution in
7101 : interface.cc(gfc_extend_expr) because there is no way in
7102 : which the host association can be wrong. */
7103 1685537 : if (e->symtree == NULL
7104 1684736 : || e->symtree->n.sym == NULL
7105 1684736 : || e->user_operator)
7106 : return retval;
7107 :
7108 1682956 : old_sym = e->symtree->n.sym;
7109 :
7110 1682956 : if (gfc_current_ns->parent
7111 739159 : && old_sym->ns != gfc_current_ns)
7112 : {
7113 : /* Use the 'USE' name so that renamed module symbols are
7114 : correctly handled. */
7115 92390 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7116 :
7117 92390 : if (sym && old_sym != sym
7118 702 : && sym->attr.flavor == FL_PROCEDURE
7119 105 : && sym->attr.contained)
7120 : {
7121 : /* Clear the shape, since it might not be valid. */
7122 83 : gfc_free_shape (&e->shape, e->rank);
7123 :
7124 : /* Give the expression the right symtree! */
7125 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7126 83 : gcc_assert (st != NULL);
7127 :
7128 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7129 59 : || e->expr_type == EXPR_FUNCTION)
7130 : {
7131 : /* Original was function so point to the new symbol, since
7132 : the actual argument list is already attached to the
7133 : expression. */
7134 30 : e->value.function.esym = NULL;
7135 30 : e->symtree = st;
7136 : }
7137 : else
7138 : {
7139 : /* Original was variable so convert array references into
7140 : an actual arglist. This does not need any checking now
7141 : since resolve_function will take care of it. */
7142 53 : e->value.function.actual = NULL;
7143 53 : e->expr_type = EXPR_FUNCTION;
7144 53 : e->symtree = st;
7145 :
7146 : /* Ambiguity will not arise if the array reference is not
7147 : the last reference. */
7148 55 : for (ref = e->ref; ref; ref = ref->next)
7149 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7150 : break;
7151 :
7152 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7153 17 : && sym->attr.proc == PROC_INTERNAL)
7154 : {
7155 4 : gfc_error ("%qs at %L is host associated at %L into "
7156 : "a contained procedure with an internal "
7157 : "procedure of the same name", sym->name,
7158 : &old_sym->declared_at, &e->where);
7159 4 : return false;
7160 : }
7161 :
7162 13 : if (ref == NULL)
7163 : return false;
7164 :
7165 36 : gcc_assert (ref->type == REF_ARRAY);
7166 :
7167 : /* Grab the start expressions from the array ref and
7168 : copy them into actual arguments. */
7169 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7170 : {
7171 48 : arg = gfc_get_actual_arglist ();
7172 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7173 48 : if (e->value.function.actual == NULL)
7174 36 : tail = e->value.function.actual = arg;
7175 : else
7176 : {
7177 12 : tail->next = arg;
7178 12 : tail = arg;
7179 : }
7180 : }
7181 :
7182 : /* Dump the reference list and set the rank. */
7183 36 : gfc_free_ref_list (e->ref);
7184 36 : e->ref = NULL;
7185 36 : e->rank = sym->as ? sym->as->rank : 0;
7186 36 : e->corank = sym->as ? sym->as->corank : 0;
7187 : }
7188 :
7189 66 : gfc_resolve_expr (e);
7190 66 : sym->refs++;
7191 : }
7192 : /* This case corresponds to a call, from a block or a contained
7193 : procedure, to an external function, which has not been declared
7194 : as being external in the main program but has been typed. */
7195 92307 : else if (sym && old_sym != sym
7196 619 : && !e->ref
7197 347 : && sym->ts.type == BT_UNKNOWN
7198 21 : && old_sym->ts.type != BT_UNKNOWN
7199 19 : && sym->attr.flavor == FL_PROCEDURE
7200 19 : && old_sym->attr.flavor == FL_VARIABLE
7201 7 : && sym->ns->parent == old_sym->ns
7202 7 : && sym->ns->proc_name
7203 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7204 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7205 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7206 : {
7207 6 : old_sym->attr.flavor = FL_PROCEDURE;
7208 6 : old_sym->attr.external = 1;
7209 6 : old_sym->attr.function = 1;
7210 6 : old_sym->result = old_sym;
7211 6 : gfc_resolve_expr (e);
7212 : }
7213 : }
7214 : /* This might have changed! */
7215 1682939 : return e->expr_type == EXPR_FUNCTION;
7216 : }
7217 :
7218 :
7219 : static void
7220 1454 : gfc_resolve_character_operator (gfc_expr *e)
7221 : {
7222 1454 : gfc_expr *op1 = e->value.op.op1;
7223 1454 : gfc_expr *op2 = e->value.op.op2;
7224 1454 : gfc_expr *e1 = NULL;
7225 1454 : gfc_expr *e2 = NULL;
7226 :
7227 1454 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7228 :
7229 1454 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7230 767 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7231 687 : else if (op1->expr_type == EXPR_CONSTANT)
7232 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7233 268 : op1->value.character.length);
7234 :
7235 1454 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7236 755 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7237 699 : else if (op2->expr_type == EXPR_CONSTANT)
7238 468 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7239 468 : op2->value.character.length);
7240 :
7241 1454 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7242 :
7243 1454 : if (!e1 || !e2)
7244 : {
7245 547 : gfc_free_expr (e1);
7246 547 : gfc_free_expr (e2);
7247 :
7248 547 : return;
7249 : }
7250 :
7251 907 : e->ts.u.cl->length = gfc_add (e1, e2);
7252 907 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7253 907 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7254 907 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7255 907 : gfc_resolve_expr (e->ts.u.cl->length);
7256 :
7257 907 : return;
7258 : }
7259 :
7260 :
7261 : /* Ensure that an character expression has a charlen and, if possible, a
7262 : length expression. */
7263 :
7264 : static void
7265 184854 : fixup_charlen (gfc_expr *e)
7266 : {
7267 : /* The cases fall through so that changes in expression type and the need
7268 : for multiple fixes are picked up. In all circumstances, a charlen should
7269 : be available for the middle end to hang a backend_decl on. */
7270 184854 : switch (e->expr_type)
7271 : {
7272 1454 : case EXPR_OP:
7273 1454 : gfc_resolve_character_operator (e);
7274 : /* FALLTHRU */
7275 :
7276 1521 : case EXPR_ARRAY:
7277 1521 : if (e->expr_type == EXPR_ARRAY)
7278 67 : gfc_resolve_character_array_constructor (e);
7279 : /* FALLTHRU */
7280 :
7281 1978 : case EXPR_SUBSTRING:
7282 1978 : if (!e->ts.u.cl && e->ref)
7283 453 : gfc_resolve_substring_charlen (e);
7284 : /* FALLTHRU */
7285 :
7286 184854 : default:
7287 184854 : if (!e->ts.u.cl)
7288 182880 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7289 :
7290 184854 : break;
7291 : }
7292 184854 : }
7293 :
7294 :
7295 : /* Update an actual argument to include the passed-object for type-bound
7296 : procedures at the right position. */
7297 :
7298 : static gfc_actual_arglist*
7299 3038 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7300 : const char *name)
7301 : {
7302 3062 : gcc_assert (argpos > 0);
7303 :
7304 3062 : if (argpos == 1)
7305 : {
7306 2913 : gfc_actual_arglist* result;
7307 :
7308 2913 : result = gfc_get_actual_arglist ();
7309 2913 : result->expr = po;
7310 2913 : result->next = lst;
7311 2913 : if (name)
7312 514 : result->name = name;
7313 :
7314 2913 : return result;
7315 : }
7316 :
7317 149 : if (lst)
7318 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7319 : else
7320 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7321 : return lst;
7322 : }
7323 :
7324 :
7325 : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7326 :
7327 : static gfc_expr*
7328 7395 : extract_compcall_passed_object (gfc_expr* e)
7329 : {
7330 7395 : gfc_expr* po;
7331 :
7332 7395 : if (e->expr_type == EXPR_UNKNOWN)
7333 : {
7334 0 : gfc_error ("Error in typebound call at %L",
7335 : &e->where);
7336 0 : return NULL;
7337 : }
7338 :
7339 7395 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7340 :
7341 7395 : if (e->value.compcall.base_object)
7342 1656 : po = gfc_copy_expr (e->value.compcall.base_object);
7343 : else
7344 : {
7345 5739 : po = gfc_get_expr ();
7346 5739 : po->expr_type = EXPR_VARIABLE;
7347 5739 : po->symtree = e->symtree;
7348 5739 : po->ref = gfc_copy_ref (e->ref);
7349 5739 : po->where = e->where;
7350 : }
7351 :
7352 7395 : if (!gfc_resolve_expr (po))
7353 : return NULL;
7354 :
7355 : return po;
7356 : }
7357 :
7358 :
7359 : /* Update the arglist of an EXPR_COMPCALL expression to include the
7360 : passed-object. */
7361 :
7362 : static bool
7363 3402 : update_compcall_arglist (gfc_expr* e)
7364 : {
7365 3402 : gfc_expr* po;
7366 3402 : gfc_typebound_proc* tbp;
7367 :
7368 3402 : tbp = e->value.compcall.tbp;
7369 :
7370 3402 : if (tbp->error)
7371 : return false;
7372 :
7373 3401 : po = extract_compcall_passed_object (e);
7374 3401 : if (!po)
7375 : return false;
7376 :
7377 3401 : if (tbp->nopass || e->value.compcall.ignore_pass)
7378 : {
7379 1152 : gfc_free_expr (po);
7380 1152 : return true;
7381 : }
7382 :
7383 2249 : if (tbp->pass_arg_num <= 0)
7384 : return false;
7385 :
7386 2248 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7387 : tbp->pass_arg_num,
7388 : tbp->pass_arg);
7389 :
7390 2248 : return true;
7391 : }
7392 :
7393 :
7394 : /* Extract the passed object from a PPC call (a copy of it). */
7395 :
7396 : static gfc_expr*
7397 85 : extract_ppc_passed_object (gfc_expr *e)
7398 : {
7399 85 : gfc_expr *po;
7400 85 : gfc_ref **ref;
7401 :
7402 85 : po = gfc_get_expr ();
7403 85 : po->expr_type = EXPR_VARIABLE;
7404 85 : po->symtree = e->symtree;
7405 85 : po->ref = gfc_copy_ref (e->ref);
7406 85 : po->where = e->where;
7407 :
7408 : /* Remove PPC reference. */
7409 85 : ref = &po->ref;
7410 91 : while ((*ref)->next)
7411 6 : ref = &(*ref)->next;
7412 85 : gfc_free_ref_list (*ref);
7413 85 : *ref = NULL;
7414 :
7415 85 : if (!gfc_resolve_expr (po))
7416 0 : return NULL;
7417 :
7418 : return po;
7419 : }
7420 :
7421 :
7422 : /* Update the actual arglist of a procedure pointer component to include the
7423 : passed-object. */
7424 :
7425 : static bool
7426 588 : update_ppc_arglist (gfc_expr* e)
7427 : {
7428 588 : gfc_expr* po;
7429 588 : gfc_component *ppc;
7430 588 : gfc_typebound_proc* tb;
7431 :
7432 588 : ppc = gfc_get_proc_ptr_comp (e);
7433 588 : if (!ppc)
7434 : return false;
7435 :
7436 588 : tb = ppc->tb;
7437 :
7438 588 : if (tb->error)
7439 : return false;
7440 586 : else if (tb->nopass)
7441 : return true;
7442 :
7443 85 : po = extract_ppc_passed_object (e);
7444 85 : if (!po)
7445 : return false;
7446 :
7447 : /* F08:R739. */
7448 85 : if (po->rank != 0)
7449 : {
7450 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7451 0 : return false;
7452 : }
7453 :
7454 : /* F08:C611. */
7455 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7456 : {
7457 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7458 : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7459 1 : return false;
7460 : }
7461 :
7462 84 : gcc_assert (tb->pass_arg_num > 0);
7463 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7464 : tb->pass_arg_num,
7465 : tb->pass_arg);
7466 :
7467 84 : return true;
7468 : }
7469 :
7470 :
7471 : /* Check that the object a TBP is called on is valid, i.e. it must not be
7472 : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7473 :
7474 : static bool
7475 3413 : check_typebound_baseobject (gfc_expr* e)
7476 : {
7477 3413 : gfc_expr* base;
7478 3413 : bool return_value = false;
7479 :
7480 3413 : base = extract_compcall_passed_object (e);
7481 3413 : if (!base)
7482 : return false;
7483 :
7484 3410 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7485 : {
7486 1 : gfc_error ("Error in typebound call at %L", &e->where);
7487 1 : goto cleanup;
7488 : }
7489 :
7490 3409 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7491 1 : return false;
7492 :
7493 : /* F08:C611. */
7494 3408 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7495 : {
7496 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7497 : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7498 3 : goto cleanup;
7499 : }
7500 :
7501 : /* F08:C1230. If the procedure called is NOPASS,
7502 : the base object must be scalar. */
7503 3405 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7504 : {
7505 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7506 : " be scalar", &e->where);
7507 1 : goto cleanup;
7508 : }
7509 :
7510 : return_value = true;
7511 :
7512 3409 : cleanup:
7513 3409 : gfc_free_expr (base);
7514 3409 : return return_value;
7515 : }
7516 :
7517 :
7518 : /* Resolve a call to a type-bound procedure, either function or subroutine,
7519 : statically from the data in an EXPR_COMPCALL expression. The adapted
7520 : arglist and the target-procedure symtree are returned. */
7521 :
7522 : static bool
7523 3402 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7524 : gfc_actual_arglist** actual)
7525 : {
7526 3402 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7527 3402 : gcc_assert (!e->value.compcall.tbp->is_generic);
7528 :
7529 : /* Update the actual arglist for PASS. */
7530 3402 : if (!update_compcall_arglist (e))
7531 : return false;
7532 :
7533 3400 : *actual = e->value.compcall.actual;
7534 3400 : *target = e->value.compcall.tbp->u.specific;
7535 :
7536 3400 : gfc_free_ref_list (e->ref);
7537 3400 : e->ref = NULL;
7538 3400 : e->value.compcall.actual = NULL;
7539 :
7540 : /* If we find a deferred typebound procedure, check for derived types
7541 : that an overriding typebound procedure has not been missed. */
7542 3400 : if (e->value.compcall.name
7543 3400 : && !e->value.compcall.tbp->non_overridable
7544 3382 : && e->value.compcall.base_object
7545 828 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7546 : {
7547 535 : gfc_symtree *st;
7548 535 : gfc_symbol *derived;
7549 :
7550 : /* Use the derived type of the base_object. */
7551 535 : derived = e->value.compcall.base_object->ts.u.derived;
7552 535 : st = NULL;
7553 :
7554 : /* If necessary, go through the inheritance chain. */
7555 1613 : while (!st && derived)
7556 : {
7557 : /* Look for the typebound procedure 'name'. */
7558 543 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7559 535 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7560 : e->value.compcall.name);
7561 543 : if (!st)
7562 8 : derived = gfc_get_derived_super_type (derived);
7563 : }
7564 :
7565 : /* Now find the specific name in the derived type namespace. */
7566 535 : if (st && st->n.tb && st->n.tb->u.specific)
7567 535 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7568 535 : derived->ns, 1, &st);
7569 535 : if (st)
7570 535 : *target = st;
7571 : }
7572 :
7573 3400 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7574 3400 : && !e->value.compcall.tbp->deferred)
7575 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7576 : " itself recursively. Declare it RECURSIVE or use"
7577 : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7578 :
7579 : return true;
7580 : }
7581 :
7582 :
7583 : /* Get the ultimate declared type from an expression. In addition,
7584 : return the last class/derived type reference and the copy of the
7585 : reference list. If check_types is set true, derived types are
7586 : identified as well as class references. */
7587 : static gfc_symbol*
7588 3321 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7589 : gfc_expr *e, bool check_types)
7590 : {
7591 3321 : gfc_symbol *declared;
7592 3321 : gfc_ref *ref;
7593 :
7594 3321 : declared = NULL;
7595 3321 : if (class_ref)
7596 2888 : *class_ref = NULL;
7597 3321 : if (new_ref)
7598 2595 : *new_ref = gfc_copy_ref (e->ref);
7599 :
7600 4116 : for (ref = e->ref; ref; ref = ref->next)
7601 : {
7602 795 : if (ref->type != REF_COMPONENT)
7603 292 : continue;
7604 :
7605 503 : if ((ref->u.c.component->ts.type == BT_CLASS
7606 256 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7607 428 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7608 : {
7609 354 : declared = ref->u.c.component->ts.u.derived;
7610 354 : if (class_ref)
7611 332 : *class_ref = ref;
7612 : }
7613 : }
7614 :
7615 3321 : if (declared == NULL)
7616 2993 : declared = e->symtree->n.sym->ts.u.derived;
7617 :
7618 3321 : return declared;
7619 : }
7620 :
7621 :
7622 : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7623 : which of the specific bindings (if any) matches the arglist and transform
7624 : the expression into a call of that binding. */
7625 :
7626 : static bool
7627 3404 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7628 : {
7629 3404 : gfc_typebound_proc* genproc;
7630 3404 : const char* genname;
7631 3404 : gfc_symtree *st;
7632 3404 : gfc_symbol *derived;
7633 :
7634 3404 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7635 3404 : genname = e->value.compcall.name;
7636 3404 : genproc = e->value.compcall.tbp;
7637 :
7638 3404 : if (!genproc->is_generic)
7639 : return true;
7640 :
7641 : /* Try the bindings on this type and in the inheritance hierarchy. */
7642 445 : for (; genproc; genproc = genproc->overridden)
7643 : {
7644 443 : gfc_tbp_generic* g;
7645 :
7646 443 : gcc_assert (genproc->is_generic);
7647 677 : for (g = genproc->u.generic; g; g = g->next)
7648 : {
7649 667 : gfc_symbol* target;
7650 667 : gfc_actual_arglist* args;
7651 667 : bool matches;
7652 :
7653 667 : gcc_assert (g->specific);
7654 :
7655 667 : if (g->specific->error)
7656 0 : continue;
7657 :
7658 667 : target = g->specific->u.specific->n.sym;
7659 :
7660 : /* Get the right arglist by handling PASS/NOPASS. */
7661 667 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7662 667 : if (!g->specific->nopass)
7663 : {
7664 581 : gfc_expr* po;
7665 581 : po = extract_compcall_passed_object (e);
7666 581 : if (!po)
7667 : {
7668 0 : gfc_free_actual_arglist (args);
7669 0 : return false;
7670 : }
7671 :
7672 581 : gcc_assert (g->specific->pass_arg_num > 0);
7673 581 : gcc_assert (!g->specific->error);
7674 581 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7675 : g->specific->pass_arg);
7676 : }
7677 667 : resolve_actual_arglist (args, target->attr.proc,
7678 667 : is_external_proc (target)
7679 667 : && gfc_sym_get_dummy_args (target) == NULL);
7680 :
7681 : /* Check if this arglist matches the formal. */
7682 667 : matches = gfc_arglist_matches_symbol (&args, target);
7683 :
7684 : /* Clean up and break out of the loop if we've found it. */
7685 667 : gfc_free_actual_arglist (args);
7686 667 : if (matches)
7687 : {
7688 433 : e->value.compcall.tbp = g->specific;
7689 433 : genname = g->specific_st->name;
7690 : /* Pass along the name for CLASS methods, where the vtab
7691 : procedure pointer component has to be referenced. */
7692 433 : if (name)
7693 161 : *name = genname;
7694 433 : goto success;
7695 : }
7696 : }
7697 : }
7698 :
7699 : /* Nothing matching found! */
7700 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7701 : " %qs at %L", genname, &e->where);
7702 2 : return false;
7703 :
7704 433 : success:
7705 : /* Make sure that we have the right specific instance for the name. */
7706 433 : derived = get_declared_from_expr (NULL, NULL, e, true);
7707 :
7708 433 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7709 433 : if (st)
7710 433 : e->value.compcall.tbp = st->n.tb;
7711 :
7712 : return true;
7713 : }
7714 :
7715 :
7716 : /* Resolve a call to a type-bound subroutine. */
7717 :
7718 : static bool
7719 1756 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7720 : {
7721 1756 : gfc_actual_arglist* newactual;
7722 1756 : gfc_symtree* target;
7723 :
7724 : /* Check that's really a SUBROUTINE. */
7725 1756 : if (!c->expr1->value.compcall.tbp->subroutine)
7726 : {
7727 17 : if (!c->expr1->value.compcall.tbp->is_generic
7728 15 : && c->expr1->value.compcall.tbp->u.specific
7729 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7730 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7731 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7732 : else
7733 : {
7734 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7735 : c->expr1->value.compcall.name, &c->loc);
7736 5 : return false;
7737 : }
7738 : }
7739 :
7740 1751 : if (!check_typebound_baseobject (c->expr1))
7741 : return false;
7742 :
7743 : /* Pass along the name for CLASS methods, where the vtab
7744 : procedure pointer component has to be referenced. */
7745 1744 : if (name)
7746 480 : *name = c->expr1->value.compcall.name;
7747 :
7748 1744 : if (!resolve_typebound_generic_call (c->expr1, name))
7749 : return false;
7750 :
7751 : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7752 1743 : if (overridable)
7753 371 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7754 :
7755 : /* Transform into an ordinary EXEC_CALL for now. */
7756 :
7757 1743 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7758 : return false;
7759 :
7760 1741 : c->ext.actual = newactual;
7761 1741 : c->symtree = target;
7762 1741 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7763 :
7764 1741 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7765 :
7766 1741 : gfc_free_expr (c->expr1);
7767 1741 : c->expr1 = gfc_get_expr ();
7768 1741 : c->expr1->expr_type = EXPR_FUNCTION;
7769 1741 : c->expr1->symtree = target;
7770 1741 : c->expr1->where = c->loc;
7771 :
7772 1741 : return resolve_call (c);
7773 : }
7774 :
7775 :
7776 : /* Resolve a component-call expression. */
7777 : static bool
7778 1669 : resolve_compcall (gfc_expr* e, const char **name)
7779 : {
7780 1669 : gfc_actual_arglist* newactual;
7781 1669 : gfc_symtree* target;
7782 :
7783 : /* Check that's really a FUNCTION. */
7784 1669 : if (!e->value.compcall.tbp->function)
7785 : {
7786 7 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7787 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7788 : &e->where);
7789 7 : return false;
7790 : }
7791 :
7792 :
7793 : /* These must not be assign-calls! */
7794 1662 : gcc_assert (!e->value.compcall.assign);
7795 :
7796 1662 : if (!check_typebound_baseobject (e))
7797 : return false;
7798 :
7799 : /* Pass along the name for CLASS methods, where the vtab
7800 : procedure pointer component has to be referenced. */
7801 1660 : if (name)
7802 864 : *name = e->value.compcall.name;
7803 :
7804 1660 : if (!resolve_typebound_generic_call (e, name))
7805 : return false;
7806 1659 : gcc_assert (!e->value.compcall.tbp->is_generic);
7807 :
7808 : /* Take the rank from the function's symbol. */
7809 1659 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7810 : {
7811 155 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7812 155 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7813 : }
7814 :
7815 : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7816 : arglist to the TBP's binding target. */
7817 :
7818 1659 : if (!resolve_typebound_static (e, &target, &newactual))
7819 : return false;
7820 :
7821 1659 : e->value.function.actual = newactual;
7822 1659 : e->value.function.name = NULL;
7823 1659 : e->value.function.esym = target->n.sym;
7824 1659 : e->value.function.isym = NULL;
7825 1659 : e->symtree = target;
7826 1659 : e->ts = target->n.sym->ts;
7827 1659 : e->expr_type = EXPR_FUNCTION;
7828 :
7829 : /* Resolution is not necessary if this is a class subroutine; this
7830 : function only has to identify the specific proc. Resolution of
7831 : the call will be done next in resolve_typebound_call. */
7832 1659 : return gfc_resolve_expr (e);
7833 : }
7834 :
7835 :
7836 : static bool resolve_fl_derived (gfc_symbol *sym);
7837 :
7838 :
7839 : /* Resolve a typebound function, or 'method'. First separate all
7840 : the non-CLASS references by calling resolve_compcall directly. */
7841 :
7842 : static bool
7843 1669 : resolve_typebound_function (gfc_expr* e)
7844 : {
7845 1669 : gfc_symbol *declared;
7846 1669 : gfc_component *c;
7847 1669 : gfc_ref *new_ref;
7848 1669 : gfc_ref *class_ref;
7849 1669 : gfc_symtree *st;
7850 1669 : const char *name;
7851 1669 : gfc_typespec ts;
7852 1669 : gfc_expr *expr;
7853 1669 : bool overridable;
7854 :
7855 1669 : st = e->symtree;
7856 :
7857 : /* Deal with typebound operators for CLASS objects. */
7858 1669 : expr = e->value.compcall.base_object;
7859 1669 : overridable = !e->value.compcall.tbp->non_overridable;
7860 1669 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7861 : {
7862 : /* Since the typebound operators are generic, we have to ensure
7863 : that any delays in resolution are corrected and that the vtab
7864 : is present. */
7865 184 : ts = expr->ts;
7866 184 : declared = ts.u.derived;
7867 184 : if (!resolve_fl_derived (declared))
7868 : return false;
7869 :
7870 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7871 184 : if (c->ts.u.derived == NULL)
7872 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7873 :
7874 184 : if (!resolve_compcall (e, &name))
7875 : return false;
7876 :
7877 : /* Use the generic name if it is there. */
7878 184 : name = name ? name : e->value.function.esym->name;
7879 184 : e->symtree = expr->symtree;
7880 184 : e->ref = gfc_copy_ref (expr->ref);
7881 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7882 :
7883 : /* Trim away the extraneous references that emerge from nested
7884 : use of interface.cc (extend_expr). */
7885 184 : if (class_ref && class_ref->next)
7886 : {
7887 0 : gfc_free_ref_list (class_ref->next);
7888 0 : class_ref->next = NULL;
7889 : }
7890 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7891 : {
7892 0 : gfc_free_ref_list (e->ref);
7893 0 : e->ref = NULL;
7894 : }
7895 :
7896 184 : gfc_add_vptr_component (e);
7897 184 : gfc_add_component_ref (e, name);
7898 184 : e->value.function.esym = NULL;
7899 184 : if (expr->expr_type != EXPR_VARIABLE)
7900 80 : e->base_expr = expr;
7901 184 : return true;
7902 : }
7903 :
7904 1485 : if (st == NULL)
7905 195 : return resolve_compcall (e, NULL);
7906 :
7907 1290 : if (!gfc_resolve_ref (e))
7908 : return false;
7909 :
7910 : /* It can happen that a generic, typebound procedure is marked as overridable
7911 : with all of the specific procedures being non-overridable. If this is the
7912 : case, it is safe to resolve the compcall. */
7913 1290 : if (!expr && overridable
7914 1282 : && e->value.compcall.tbp->is_generic
7915 198 : && e->value.compcall.tbp->u.generic->specific
7916 197 : && e->value.compcall.tbp->u.generic->specific->non_overridable)
7917 : {
7918 : gfc_tbp_generic *g = e->value.compcall.tbp->u.generic;
7919 6 : for (; g; g = g->next)
7920 4 : if (!g->specific->non_overridable)
7921 : break;
7922 2 : if (g == NULL && resolve_compcall (e, &name))
7923 : return true;
7924 : }
7925 :
7926 : /* Get the CLASS declared type. */
7927 1288 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
7928 :
7929 1288 : if (!resolve_fl_derived (declared))
7930 : return false;
7931 :
7932 : /* Weed out cases of the ultimate component being a derived type. */
7933 1288 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7934 1194 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7935 : {
7936 608 : gfc_free_ref_list (new_ref);
7937 608 : return resolve_compcall (e, NULL);
7938 : }
7939 :
7940 680 : c = gfc_find_component (declared, "_data", true, true, NULL);
7941 :
7942 : /* Treat the call as if it is a typebound procedure, in order to roll
7943 : out the correct name for the specific function. */
7944 680 : if (!resolve_compcall (e, &name))
7945 : {
7946 3 : gfc_free_ref_list (new_ref);
7947 3 : return false;
7948 : }
7949 677 : ts = e->ts;
7950 :
7951 677 : if (overridable)
7952 : {
7953 : /* Convert the expression to a procedure pointer component call. */
7954 675 : e->value.function.esym = NULL;
7955 675 : e->symtree = st;
7956 :
7957 675 : if (new_ref)
7958 125 : e->ref = new_ref;
7959 :
7960 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7961 675 : gfc_add_vptr_component (e);
7962 675 : gfc_add_component_ref (e, name);
7963 :
7964 : /* Recover the typespec for the expression. This is really only
7965 : necessary for generic procedures, where the additional call
7966 : to gfc_add_component_ref seems to throw the collection of the
7967 : correct typespec. */
7968 675 : e->ts = ts;
7969 : }
7970 2 : else if (new_ref)
7971 0 : gfc_free_ref_list (new_ref);
7972 :
7973 : return true;
7974 : }
7975 :
7976 : /* Resolve a typebound subroutine, or 'method'. First separate all
7977 : the non-CLASS references by calling resolve_typebound_call
7978 : directly. */
7979 :
7980 : static bool
7981 1756 : resolve_typebound_subroutine (gfc_code *code)
7982 : {
7983 1756 : gfc_symbol *declared;
7984 1756 : gfc_component *c;
7985 1756 : gfc_ref *new_ref;
7986 1756 : gfc_ref *class_ref;
7987 1756 : gfc_symtree *st;
7988 1756 : const char *name;
7989 1756 : gfc_typespec ts;
7990 1756 : gfc_expr *expr;
7991 1756 : bool overridable;
7992 :
7993 1756 : st = code->expr1->symtree;
7994 :
7995 : /* Deal with typebound operators for CLASS objects. */
7996 1756 : expr = code->expr1->value.compcall.base_object;
7997 1756 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
7998 1756 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7999 : {
8000 : /* If the base_object is not a variable, the corresponding actual
8001 : argument expression must be stored in e->base_expression so
8002 : that the corresponding tree temporary can be used as the base
8003 : object in gfc_conv_procedure_call. */
8004 109 : if (expr->expr_type != EXPR_VARIABLE)
8005 : {
8006 : gfc_actual_arglist *args;
8007 :
8008 : args= code->expr1->value.function.actual;
8009 : for (; args; args = args->next)
8010 : if (expr == args->expr)
8011 : expr = args->expr;
8012 : }
8013 :
8014 : /* Since the typebound operators are generic, we have to ensure
8015 : that any delays in resolution are corrected and that the vtab
8016 : is present. */
8017 109 : declared = expr->ts.u.derived;
8018 109 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
8019 109 : if (c->ts.u.derived == NULL)
8020 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
8021 :
8022 109 : if (!resolve_typebound_call (code, &name, NULL))
8023 : return false;
8024 :
8025 : /* Use the generic name if it is there. */
8026 109 : name = name ? name : code->expr1->value.function.esym->name;
8027 109 : code->expr1->symtree = expr->symtree;
8028 109 : code->expr1->ref = gfc_copy_ref (expr->ref);
8029 :
8030 : /* Trim away the extraneous references that emerge from nested
8031 : use of interface.cc (extend_expr). */
8032 109 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
8033 109 : if (class_ref && class_ref->next)
8034 : {
8035 0 : gfc_free_ref_list (class_ref->next);
8036 0 : class_ref->next = NULL;
8037 : }
8038 109 : else if (code->expr1->ref && !class_ref)
8039 : {
8040 18 : gfc_free_ref_list (code->expr1->ref);
8041 18 : code->expr1->ref = NULL;
8042 : }
8043 :
8044 : /* Now use the procedure in the vtable. */
8045 109 : gfc_add_vptr_component (code->expr1);
8046 109 : gfc_add_component_ref (code->expr1, name);
8047 109 : code->expr1->value.function.esym = NULL;
8048 109 : if (expr->expr_type != EXPR_VARIABLE)
8049 0 : code->expr1->base_expr = expr;
8050 109 : return true;
8051 : }
8052 :
8053 1647 : if (st == NULL)
8054 340 : return resolve_typebound_call (code, NULL, NULL);
8055 :
8056 1307 : if (!gfc_resolve_ref (code->expr1))
8057 : return false;
8058 :
8059 : /* Get the CLASS declared type. */
8060 1307 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
8061 :
8062 : /* Weed out cases of the ultimate component being a derived type. */
8063 1307 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8064 1242 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8065 : {
8066 931 : gfc_free_ref_list (new_ref);
8067 931 : return resolve_typebound_call (code, NULL, NULL);
8068 : }
8069 :
8070 376 : if (!resolve_typebound_call (code, &name, &overridable))
8071 : {
8072 5 : gfc_free_ref_list (new_ref);
8073 5 : return false;
8074 : }
8075 371 : ts = code->expr1->ts;
8076 :
8077 371 : if (overridable)
8078 : {
8079 : /* Convert the expression to a procedure pointer component call. */
8080 369 : code->expr1->value.function.esym = NULL;
8081 369 : code->expr1->symtree = st;
8082 :
8083 369 : if (new_ref)
8084 93 : code->expr1->ref = new_ref;
8085 :
8086 : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8087 369 : gfc_add_vptr_component (code->expr1);
8088 369 : gfc_add_component_ref (code->expr1, name);
8089 :
8090 : /* Recover the typespec for the expression. This is really only
8091 : necessary for generic procedures, where the additional call
8092 : to gfc_add_component_ref seems to throw the collection of the
8093 : correct typespec. */
8094 369 : code->expr1->ts = ts;
8095 : }
8096 2 : else if (new_ref)
8097 0 : gfc_free_ref_list (new_ref);
8098 :
8099 : return true;
8100 : }
8101 :
8102 :
8103 : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8104 :
8105 : static bool
8106 124 : resolve_ppc_call (gfc_code* c)
8107 : {
8108 124 : gfc_component *comp;
8109 :
8110 124 : comp = gfc_get_proc_ptr_comp (c->expr1);
8111 124 : gcc_assert (comp != NULL);
8112 :
8113 124 : c->resolved_sym = c->expr1->symtree->n.sym;
8114 124 : c->expr1->expr_type = EXPR_VARIABLE;
8115 :
8116 124 : if (!comp->attr.subroutine)
8117 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8118 :
8119 124 : if (!gfc_resolve_ref (c->expr1))
8120 : return false;
8121 :
8122 124 : if (!update_ppc_arglist (c->expr1))
8123 : return false;
8124 :
8125 123 : c->ext.actual = c->expr1->value.compcall.actual;
8126 :
8127 123 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8128 123 : !(comp->ts.interface
8129 93 : && comp->ts.interface->formal)))
8130 : return false;
8131 :
8132 123 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8133 : return false;
8134 :
8135 122 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8136 :
8137 122 : return true;
8138 : }
8139 :
8140 :
8141 : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8142 :
8143 : static bool
8144 464 : resolve_expr_ppc (gfc_expr* e)
8145 : {
8146 464 : gfc_component *comp;
8147 :
8148 464 : comp = gfc_get_proc_ptr_comp (e);
8149 464 : gcc_assert (comp != NULL);
8150 :
8151 : /* Convert to EXPR_FUNCTION. */
8152 464 : e->expr_type = EXPR_FUNCTION;
8153 464 : e->value.function.isym = NULL;
8154 464 : e->value.function.actual = e->value.compcall.actual;
8155 464 : e->ts = comp->ts;
8156 464 : if (comp->as != NULL)
8157 : {
8158 28 : e->rank = comp->as->rank;
8159 28 : e->corank = comp->as->corank;
8160 : }
8161 :
8162 464 : if (!comp->attr.function)
8163 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8164 :
8165 464 : if (!gfc_resolve_ref (e))
8166 : return false;
8167 :
8168 464 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8169 464 : !(comp->ts.interface
8170 463 : && comp->ts.interface->formal)))
8171 : return false;
8172 :
8173 464 : if (!update_ppc_arglist (e))
8174 : return false;
8175 :
8176 462 : if (!check_pure_function(e))
8177 : return false;
8178 :
8179 461 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8180 :
8181 461 : return true;
8182 : }
8183 :
8184 :
8185 : static bool
8186 12121 : gfc_is_expandable_expr (gfc_expr *e)
8187 : {
8188 12121 : gfc_constructor *con;
8189 :
8190 12121 : if (e->expr_type == EXPR_ARRAY)
8191 : {
8192 : /* Traverse the constructor looking for variables that are flavor
8193 : parameter. Parameters must be expanded since they are fully used at
8194 : compile time. */
8195 12121 : con = gfc_constructor_first (e->value.constructor);
8196 32082 : for (; con; con = gfc_constructor_next (con))
8197 : {
8198 14050 : if (con->expr->expr_type == EXPR_VARIABLE
8199 5425 : && con->expr->symtree
8200 5425 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8201 5425 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8202 : return true;
8203 8625 : if (con->expr->expr_type == EXPR_ARRAY
8204 8625 : && gfc_is_expandable_expr (con->expr))
8205 : return true;
8206 : }
8207 : }
8208 :
8209 : return false;
8210 : }
8211 :
8212 :
8213 : /* Sometimes variables in specification expressions of the result
8214 : of module procedures in submodules wind up not being the 'real'
8215 : dummy. Find this, if possible, in the namespace of the first
8216 : formal argument. */
8217 :
8218 : static void
8219 4919 : fixup_unique_dummy (gfc_expr *e)
8220 : {
8221 4919 : gfc_symtree *st = NULL;
8222 4919 : gfc_symbol *s = NULL;
8223 :
8224 4919 : if (e->symtree->n.sym->ns->proc_name
8225 4889 : && e->symtree->n.sym->ns->proc_name->formal)
8226 4889 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8227 :
8228 4889 : if (s != NULL)
8229 4889 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8230 :
8231 4919 : if (st != NULL
8232 14 : && st->n.sym != NULL
8233 14 : && st->n.sym->attr.dummy)
8234 14 : e->symtree = st;
8235 4919 : }
8236 :
8237 :
8238 : /* Resolve an expression. That is, make sure that types of operands agree
8239 : with their operators, intrinsic operators are converted to function calls
8240 : for overloaded types and unresolved function references are resolved. */
8241 :
8242 : bool
8243 7038223 : gfc_resolve_expr (gfc_expr *e)
8244 : {
8245 7038223 : bool t;
8246 7038223 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8247 :
8248 7038223 : if (e == NULL || e->do_not_resolve_again)
8249 : return true;
8250 :
8251 : /* inquiry_argument only applies to variables. */
8252 5097488 : inquiry_save = inquiry_argument;
8253 5097488 : actual_arg_save = actual_arg;
8254 5097488 : first_actual_arg_save = first_actual_arg;
8255 :
8256 5097488 : if (e->expr_type != EXPR_VARIABLE)
8257 : {
8258 3759259 : inquiry_argument = false;
8259 3759259 : actual_arg = false;
8260 3759259 : first_actual_arg = false;
8261 : }
8262 1338229 : else if (e->symtree != NULL
8263 1337784 : && *e->symtree->name == '@'
8264 5649 : && e->symtree->n.sym->attr.dummy)
8265 : {
8266 : /* Deal with submodule specification expressions that are not
8267 : found to be referenced in module.cc(read_cleanup). */
8268 4919 : fixup_unique_dummy (e);
8269 : }
8270 :
8271 5097488 : switch (e->expr_type)
8272 : {
8273 535196 : case EXPR_OP:
8274 535196 : t = resolve_operator (e);
8275 535196 : break;
8276 :
8277 170 : case EXPR_CONDITIONAL:
8278 170 : t = resolve_conditional (e);
8279 170 : break;
8280 :
8281 1685537 : case EXPR_FUNCTION:
8282 1685537 : case EXPR_VARIABLE:
8283 :
8284 1685537 : if (check_host_association (e))
8285 347344 : t = resolve_function (e);
8286 : else
8287 1338193 : t = resolve_variable (e);
8288 :
8289 1685537 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8290 7368 : && e->ref->type != REF_SUBSTRING)
8291 2162 : gfc_resolve_substring_charlen (e);
8292 :
8293 : break;
8294 :
8295 1669 : case EXPR_COMPCALL:
8296 1669 : t = resolve_typebound_function (e);
8297 1669 : break;
8298 :
8299 508 : case EXPR_SUBSTRING:
8300 508 : t = gfc_resolve_ref (e);
8301 508 : break;
8302 :
8303 : case EXPR_CONSTANT:
8304 : case EXPR_NULL:
8305 : t = true;
8306 : break;
8307 :
8308 464 : case EXPR_PPC:
8309 464 : t = resolve_expr_ppc (e);
8310 464 : break;
8311 :
8312 73076 : case EXPR_ARRAY:
8313 73076 : t = false;
8314 73076 : if (!gfc_resolve_ref (e))
8315 : break;
8316 :
8317 73076 : t = gfc_resolve_array_constructor (e);
8318 : /* Also try to expand a constructor. */
8319 73076 : if (t)
8320 : {
8321 72974 : gfc_expression_rank (e);
8322 72974 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8323 68309 : gfc_expand_constructor (e, false);
8324 : }
8325 :
8326 : /* This provides the opportunity for the length of constructors with
8327 : character valued function elements to propagate the string length
8328 : to the expression. */
8329 72974 : if (t && e->ts.type == BT_CHARACTER)
8330 : {
8331 : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8332 : here rather then add a duplicate test for it above. */
8333 10810 : gfc_expand_constructor (e, false);
8334 10810 : t = gfc_resolve_character_array_constructor (e);
8335 : }
8336 :
8337 : break;
8338 :
8339 16680 : case EXPR_STRUCTURE:
8340 16680 : t = gfc_resolve_ref (e);
8341 16680 : if (!t)
8342 : break;
8343 :
8344 16680 : t = resolve_structure_cons (e, 0);
8345 16680 : if (!t)
8346 : break;
8347 :
8348 16668 : t = gfc_simplify_expr (e, 0);
8349 16668 : break;
8350 :
8351 0 : default:
8352 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8353 : }
8354 :
8355 5097488 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8356 184854 : fixup_charlen (e);
8357 :
8358 5097488 : inquiry_argument = inquiry_save;
8359 5097488 : actual_arg = actual_arg_save;
8360 5097488 : first_actual_arg = first_actual_arg_save;
8361 :
8362 : /* For some reason, resolving these expressions a second time mangles
8363 : the typespec of the expression itself. */
8364 5097488 : if (t && e->expr_type == EXPR_VARIABLE
8365 1335347 : && e->symtree->n.sym->attr.select_rank_temporary
8366 3452 : && UNLIMITED_POLY (e->symtree->n.sym))
8367 83 : e->do_not_resolve_again = 1;
8368 :
8369 5094956 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8370 7354 : t = check_import_status (e);
8371 :
8372 : return t;
8373 : }
8374 :
8375 :
8376 : /* Resolve an expression from an iterator. They must be scalar and have
8377 : INTEGER or (optionally) REAL type. */
8378 :
8379 : static bool
8380 153993 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8381 : const char *name_msgid)
8382 : {
8383 153993 : if (!gfc_resolve_expr (expr))
8384 : return false;
8385 :
8386 153988 : if (expr->rank != 0)
8387 : {
8388 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8389 0 : return false;
8390 : }
8391 :
8392 153988 : if (expr->ts.type != BT_INTEGER)
8393 : {
8394 277 : if (expr->ts.type == BT_REAL)
8395 : {
8396 277 : if (real_ok)
8397 274 : return gfc_notify_std (GFC_STD_F95_DEL,
8398 : "%s at %L must be integer",
8399 274 : _(name_msgid), &expr->where);
8400 : else
8401 : {
8402 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8403 : &expr->where);
8404 3 : return false;
8405 : }
8406 : }
8407 : else
8408 : {
8409 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8410 0 : return false;
8411 : }
8412 : }
8413 : return true;
8414 : }
8415 :
8416 :
8417 : /* Resolve the expressions in an iterator structure. If REAL_OK is
8418 : false allow only INTEGER type iterators, otherwise allow REAL types.
8419 : Set own_scope to true for ac-implied-do and data-implied-do as those
8420 : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8421 :
8422 : bool
8423 38507 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8424 : {
8425 38507 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8426 : return false;
8427 :
8428 38503 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8429 38503 : _("iterator variable")))
8430 : return false;
8431 :
8432 38497 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8433 : "Start expression in DO loop"))
8434 : return false;
8435 :
8436 38496 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8437 : "End expression in DO loop"))
8438 : return false;
8439 :
8440 38493 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8441 : "Step expression in DO loop"))
8442 : return false;
8443 :
8444 : /* Convert start, end, and step to the same type as var. */
8445 38492 : if (iter->start->ts.kind != iter->var->ts.kind
8446 38163 : || iter->start->ts.type != iter->var->ts.type)
8447 364 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8448 :
8449 38492 : if (iter->end->ts.kind != iter->var->ts.kind
8450 38190 : || iter->end->ts.type != iter->var->ts.type)
8451 327 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8452 :
8453 38492 : if (iter->step->ts.kind != iter->var->ts.kind
8454 38200 : || iter->step->ts.type != iter->var->ts.type)
8455 329 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8456 :
8457 38492 : if (iter->step->expr_type == EXPR_CONSTANT)
8458 : {
8459 37369 : if ((iter->step->ts.type == BT_INTEGER
8460 37285 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8461 74652 : || (iter->step->ts.type == BT_REAL
8462 84 : && mpfr_sgn (iter->step->value.real) == 0))
8463 : {
8464 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8465 3 : &iter->step->where);
8466 3 : return false;
8467 : }
8468 : }
8469 :
8470 38489 : if (iter->start->expr_type == EXPR_CONSTANT
8471 35352 : && iter->end->expr_type == EXPR_CONSTANT
8472 27649 : && iter->step->expr_type == EXPR_CONSTANT)
8473 : {
8474 27382 : int sgn, cmp;
8475 27382 : if (iter->start->ts.type == BT_INTEGER)
8476 : {
8477 27327 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8478 27327 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8479 : }
8480 : else
8481 : {
8482 55 : sgn = mpfr_sgn (iter->step->value.real);
8483 55 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8484 : }
8485 27382 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8486 146 : gfc_warning (OPT_Wzerotrip,
8487 : "DO loop at %L will be executed zero times",
8488 146 : &iter->step->where);
8489 : }
8490 :
8491 38489 : if (iter->end->expr_type == EXPR_CONSTANT
8492 28017 : && iter->end->ts.type == BT_INTEGER
8493 27962 : && iter->step->expr_type == EXPR_CONSTANT
8494 27652 : && iter->step->ts.type == BT_INTEGER
8495 27652 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8496 27281 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8497 : {
8498 26495 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8499 26495 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8500 :
8501 26495 : if (is_step_positive
8502 26124 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8503 7 : gfc_warning (OPT_Wundefined_do_loop,
8504 : "DO loop at %L is undefined as it overflows",
8505 7 : &iter->step->where);
8506 : else if (!is_step_positive
8507 371 : && mpz_cmp (iter->end->value.integer,
8508 371 : gfc_integer_kinds[k].min_int) == 0)
8509 7 : gfc_warning (OPT_Wundefined_do_loop,
8510 : "DO loop at %L is undefined as it underflows",
8511 7 : &iter->step->where);
8512 : }
8513 :
8514 38489 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
8515 : VALUE_USED);
8516 38489 : gfc_value_used_expr (iter->start, VALUE_USED);
8517 38489 : gfc_value_used_expr (iter->end, VALUE_USED);
8518 38489 : gfc_value_used_expr (iter->step, VALUE_USED);
8519 :
8520 38489 : return true;
8521 : }
8522 :
8523 :
8524 : /* Traversal function for find_forall_index. f == 2 signals that
8525 : that variable itself is not to be checked - only the references. */
8526 :
8527 : static bool
8528 42682 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8529 : {
8530 42682 : if (expr->expr_type != EXPR_VARIABLE)
8531 : return false;
8532 :
8533 : /* A scalar assignment */
8534 18195 : if (!expr->ref || *f == 1)
8535 : {
8536 12133 : if (expr->symtree->n.sym == sym)
8537 : return true;
8538 : else
8539 : return false;
8540 : }
8541 :
8542 6062 : if (*f == 2)
8543 1731 : *f = 1;
8544 : return false;
8545 : }
8546 :
8547 :
8548 : /* Check whether the FORALL index appears in the expression or not.
8549 : Returns true if SYM is found in EXPR. */
8550 :
8551 : bool
8552 27060 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8553 : {
8554 27060 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8555 : return true;
8556 : else
8557 : return false;
8558 : }
8559 :
8560 : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8561 : This constraint specifies rules for variables in locality-specs. */
8562 :
8563 : static int
8564 765 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8565 : {
8566 765 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8567 :
8568 765 : if ((*expr)->expr_type == EXPR_VARIABLE)
8569 : {
8570 22 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8571 22 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8572 24 : list; list = list->next)
8573 : {
8574 5 : if (list->expr->symtree->n.sym == sym)
8575 : {
8576 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8577 : "must not appear in LOCAL locality-spec at %L",
8578 : sym->name, &(*expr)->where, &list->expr->where);
8579 3 : *walk_subtrees = 0;
8580 3 : return 1;
8581 : }
8582 : }
8583 : }
8584 :
8585 762 : *walk_subtrees = 1;
8586 762 : return 0;
8587 : }
8588 :
8589 : static int
8590 4058 : check_default_none_expr (gfc_expr **e, int *, void *data)
8591 : {
8592 4058 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8593 :
8594 4058 : if ((*e)->expr_type == EXPR_VARIABLE)
8595 : {
8596 1866 : gfc_symbol *sym = (*e)->symtree->n.sym;
8597 :
8598 1866 : if (d->sym_hash->contains (sym))
8599 1275 : sym->mark = 1;
8600 :
8601 591 : else if (d->default_none)
8602 : {
8603 8 : gfc_namespace *ns2 = d->ns;
8604 13 : while (ns2)
8605 : {
8606 8 : if (ns2 == sym->ns)
8607 : break;
8608 5 : ns2 = ns2->parent;
8609 : }
8610 :
8611 : /* A DO CONCURRENT iterator cannot appear in a locality spec.
8612 : Use d->code (the DO CONCURRENT node) rather than sym->ns->code,
8613 : which may be a different code type (e.g. EXEC_ASSOCIATE) whose
8614 : ext union would be read incorrectly. */
8615 8 : for (gfc_forall_iterator *iter = d->code->ext.concur.forall_iterator;
8616 17 : iter; iter = iter->next)
8617 : {
8618 10 : if (!iter->var || !iter->var->symtree)
8619 0 : continue;
8620 10 : const char *iter_name = iter->var->symtree->name;
8621 : /* Shadow iterators (from inline type-spec: integer :: i = ...)
8622 : store the iterator with a leading underscore internally; the
8623 : user-visible name does not have the underscore. */
8624 10 : if (iter->shadow)
8625 0 : iter_name++;
8626 10 : if (strcmp (sym->name, iter_name) == 0)
8627 1 : return 0;
8628 : }
8629 :
8630 : /* A named constant is not a variable, so skip test. */
8631 7 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8632 : {
8633 2 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8634 : "of DO CONCURRENT at %L but required due to "
8635 : "DEFAULT (NONE)",
8636 : sym->name, &(*e)->where, &d->code->loc);
8637 2 : d->sym_hash->add (sym);
8638 : }
8639 : }
8640 : }
8641 : return 0;
8642 : }
8643 :
8644 : static void
8645 224 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8646 : {
8647 224 : struct check_default_none_data data;
8648 224 : data.code = code;
8649 224 : data.sym_hash = new hash_set<gfc_symbol *>;
8650 224 : data.ns = ns;
8651 224 : data.default_none = code->ext.concur.default_none;
8652 :
8653 1120 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8654 : {
8655 896 : const char *name;
8656 896 : switch (locality)
8657 : {
8658 : case LOCALITY_LOCAL: name = "LOCAL"; break;
8659 224 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8660 224 : case LOCALITY_SHARED: name = "SHARED"; break;
8661 224 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8662 : default: gcc_unreachable ();
8663 : }
8664 :
8665 1287 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8666 391 : list = list->next)
8667 : {
8668 391 : gfc_expr *expr = list->expr;
8669 :
8670 391 : if (locality == LOCALITY_REDUCE
8671 72 : && (expr->expr_type == EXPR_FUNCTION
8672 48 : || expr->expr_type == EXPR_OP))
8673 35 : continue;
8674 :
8675 367 : if (!gfc_resolve_expr (expr))
8676 3 : continue;
8677 :
8678 364 : if (expr->expr_type != EXPR_VARIABLE
8679 364 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8680 364 : || (expr->ref
8681 151 : && (expr->ref->type != REF_ARRAY
8682 151 : || expr->ref->u.ar.type != AR_FULL
8683 147 : || expr->ref->next)))
8684 : {
8685 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8686 : name, &expr->where);
8687 4 : continue;
8688 : }
8689 :
8690 360 : gfc_symbol *sym = expr->symtree->n.sym;
8691 :
8692 360 : if (data.sym_hash->contains (sym))
8693 : {
8694 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8695 : "locality-spec", sym->name, &expr->where);
8696 4 : continue;
8697 : }
8698 :
8699 356 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8700 716 : iter; iter = iter->next)
8701 : {
8702 360 : if (iter->var->symtree->n.sym == sym)
8703 : {
8704 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8705 : "locality-spec", sym->name, &expr->where);
8706 1 : continue;
8707 : }
8708 :
8709 359 : data.sym_hash->add (iter->var->symtree->n.sym);
8710 : }
8711 :
8712 356 : if (locality == LOCALITY_LOCAL
8713 356 : || locality == LOCALITY_LOCAL_INIT
8714 356 : || locality == LOCALITY_REDUCE)
8715 : {
8716 198 : if (sym->attr.optional)
8717 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8718 : "locality-spec at %L",
8719 : sym->name, name, &expr->where);
8720 :
8721 198 : if (sym->attr.dimension
8722 66 : && sym->as
8723 66 : && sym->as->type == AS_ASSUMED_SIZE)
8724 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8725 : "locality-spec at %L",
8726 : sym->name, name, &expr->where);
8727 :
8728 198 : gfc_check_vardef_context (expr, false, false, false, name);
8729 : }
8730 :
8731 198 : if (locality == LOCALITY_LOCAL
8732 : || locality == LOCALITY_LOCAL_INIT)
8733 : {
8734 181 : symbol_attribute attr = gfc_expr_attr (expr);
8735 :
8736 181 : if (attr.allocatable)
8737 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8738 : "locality-spec at %L",
8739 : sym->name, name, &expr->where);
8740 :
8741 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8742 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8743 : " for %qs in %s locality-spec at %L",
8744 : sym->name, name, &expr->where);
8745 :
8746 177 : else if (attr.codimension)
8747 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8748 : "at %L",
8749 : sym->name, name, &expr->where);
8750 :
8751 177 : else if (expr->ts.type == BT_DERIVED
8752 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8753 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8754 : "locality-spec at %L",
8755 : sym->name, name, &expr->where);
8756 :
8757 177 : else if (gfc_has_ultimate_allocatable (expr))
8758 4 : gfc_error ("Type with ultimate allocatable component not "
8759 : "permitted for %qs in %s locality-spec at %L",
8760 : sym->name, name, &expr->where);
8761 : }
8762 :
8763 175 : else if (locality == LOCALITY_REDUCE)
8764 : {
8765 17 : if (sym->attr.asynchronous)
8766 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8767 : "REDUCE locality-spec at %L",
8768 : sym->name, &expr->where);
8769 17 : if (sym->attr.volatile_)
8770 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8771 : "locality-spec at %L", sym->name, &expr->where);
8772 : }
8773 :
8774 356 : data.sym_hash->add (sym);
8775 : }
8776 :
8777 896 : if (locality == LOCALITY_LOCAL)
8778 : {
8779 224 : gcc_assert (locality == 0);
8780 :
8781 224 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8782 467 : iter; iter = iter->next)
8783 : {
8784 243 : gfc_expr_walker (&iter->start,
8785 : do_concur_locality_specs_f2023,
8786 : &data);
8787 :
8788 243 : gfc_expr_walker (&iter->end,
8789 : do_concur_locality_specs_f2023,
8790 : &data);
8791 :
8792 243 : gfc_expr_walker (&iter->stride,
8793 : do_concur_locality_specs_f2023,
8794 : &data);
8795 : }
8796 :
8797 224 : if (code->expr1)
8798 7 : gfc_expr_walker (&code->expr1,
8799 : do_concur_locality_specs_f2023,
8800 : &data);
8801 : }
8802 : }
8803 :
8804 224 : gfc_expr *reduce_op = NULL;
8805 :
8806 224 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8807 272 : list; list = list->next)
8808 : {
8809 48 : gfc_expr *expr = list->expr;
8810 :
8811 48 : if (expr->expr_type != EXPR_VARIABLE)
8812 : {
8813 24 : reduce_op = expr;
8814 24 : continue;
8815 : }
8816 :
8817 24 : if (reduce_op->expr_type == EXPR_OP)
8818 : {
8819 17 : switch (reduce_op->value.op.op)
8820 : {
8821 17 : case INTRINSIC_PLUS:
8822 17 : case INTRINSIC_TIMES:
8823 17 : if (!gfc_numeric_ts (&expr->ts))
8824 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8825 3 : "got %s", expr->symtree->n.sym->name,
8826 : &expr->where, gfc_basic_typename (expr->ts.type));
8827 : break;
8828 0 : case INTRINSIC_AND:
8829 0 : case INTRINSIC_OR:
8830 0 : case INTRINSIC_EQV:
8831 0 : case INTRINSIC_NEQV:
8832 0 : if (expr->ts.type != BT_LOGICAL)
8833 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8834 0 : "got %qs", expr->symtree->n.sym->name,
8835 : &expr->where, gfc_basic_typename (expr->ts.type));
8836 : break;
8837 0 : default:
8838 0 : gcc_unreachable ();
8839 : }
8840 : }
8841 :
8842 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8843 : {
8844 7 : switch (reduce_op->value.function.isym->id)
8845 : {
8846 6 : case GFC_ISYM_MIN:
8847 6 : case GFC_ISYM_MAX:
8848 6 : if (expr->ts.type != BT_INTEGER
8849 : && expr->ts.type != BT_REAL
8850 : && expr->ts.type != BT_CHARACTER)
8851 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8852 : "in REDUCE with MIN/MAX at %L, got %s",
8853 2 : expr->symtree->n.sym->name, &expr->where,
8854 : gfc_basic_typename (expr->ts.type));
8855 : break;
8856 1 : case GFC_ISYM_IAND:
8857 1 : case GFC_ISYM_IOR:
8858 1 : case GFC_ISYM_IEOR:
8859 1 : if (expr->ts.type != BT_INTEGER)
8860 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8861 : "IAND/IOR/IEOR at %L, got %s",
8862 1 : expr->symtree->n.sym->name, &expr->where,
8863 : gfc_basic_typename (expr->ts.type));
8864 : break;
8865 0 : default:
8866 0 : gcc_unreachable ();
8867 : }
8868 : }
8869 :
8870 : else
8871 0 : gcc_unreachable ();
8872 : }
8873 :
8874 1120 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8875 : {
8876 1287 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8877 391 : list = list->next)
8878 : {
8879 391 : if (list->expr->expr_type == EXPR_VARIABLE)
8880 367 : list->expr->symtree->n.sym->mark = 0;
8881 : }
8882 : }
8883 :
8884 224 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8885 : check_default_none_expr, &data);
8886 :
8887 1120 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8888 : {
8889 896 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8890 1287 : while (*plist)
8891 : {
8892 391 : gfc_expr *expr = (*plist)->expr;
8893 391 : if (expr->expr_type == EXPR_VARIABLE)
8894 : {
8895 367 : gfc_symbol *sym = expr->symtree->n.sym;
8896 367 : if (sym->mark == 0)
8897 : {
8898 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8899 : "locality-spec at %L is not used",
8900 : sym->name, &expr->where);
8901 70 : gfc_expr_list *tmp = *plist;
8902 70 : *plist = (*plist)->next;
8903 70 : gfc_free_expr (tmp->expr);
8904 70 : free (tmp);
8905 70 : continue;
8906 70 : }
8907 : }
8908 321 : plist = &((*plist)->next);
8909 : }
8910 : }
8911 :
8912 448 : delete data.sym_hash;
8913 224 : }
8914 :
8915 : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
8916 : to be a scalar INTEGER variable. The subscripts and stride are scalar
8917 : INTEGERs, and if stride is a constant it must be nonzero.
8918 : Furthermore "A subscript or stride in a forall-triplet-spec shall
8919 : not contain a reference to any index-name in the
8920 : forall-triplet-spec-list in which it appears." (7.5.4.1) */
8921 :
8922 : static void
8923 2217 : resolve_forall_iterators (gfc_forall_iterator *it)
8924 : {
8925 2217 : gfc_forall_iterator *iter, *iter2;
8926 :
8927 6352 : for (iter = it; iter; iter = iter->next)
8928 : {
8929 4135 : if (gfc_resolve_expr (iter->var)
8930 4135 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
8931 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
8932 : &iter->var->where);
8933 :
8934 4135 : if (gfc_resolve_expr (iter->start)
8935 4135 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
8936 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
8937 : &iter->start->where);
8938 4135 : if (iter->var->ts.kind != iter->start->ts.kind)
8939 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8940 :
8941 4135 : if (gfc_resolve_expr (iter->end)
8942 4135 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
8943 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
8944 : &iter->end->where);
8945 4135 : if (iter->var->ts.kind != iter->end->ts.kind)
8946 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8947 :
8948 4135 : if (gfc_resolve_expr (iter->stride))
8949 : {
8950 4135 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
8951 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
8952 : &iter->stride->where, "INTEGER");
8953 :
8954 4135 : if (iter->stride->expr_type == EXPR_CONSTANT
8955 4131 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
8956 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
8957 : &iter->stride->where);
8958 : }
8959 4135 : if (iter->var->ts.kind != iter->stride->ts.kind)
8960 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
8961 :
8962 4135 : gfc_value_set_and_used (iter->var, &iter->var->where, VALUE_VARDEF,
8963 : VALUE_USED);
8964 4135 : gfc_value_used_expr (iter->start, VALUE_USED);
8965 4135 : gfc_value_used_expr (iter->end, VALUE_USED);
8966 4135 : gfc_value_used_expr (iter->stride, VALUE_USED);
8967 : }
8968 :
8969 6352 : for (iter = it; iter; iter = iter->next)
8970 11114 : for (iter2 = iter; iter2; iter2 = iter2->next)
8971 : {
8972 6979 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
8973 6977 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
8974 13954 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
8975 6 : gfc_error ("FORALL index %qs may not appear in triplet "
8976 6 : "specification at %L", iter->var->symtree->name,
8977 6 : &iter2->start->where);
8978 : }
8979 2217 : }
8980 :
8981 :
8982 : /* Given a pointer to a symbol that is a derived type, see if it's
8983 : inaccessible, i.e. if it's defined in another module and the components are
8984 : PRIVATE. The search is recursive if necessary. Returns zero if no
8985 : inaccessible components are found, nonzero otherwise. */
8986 :
8987 : static bool
8988 1358 : derived_inaccessible (gfc_symbol *sym)
8989 : {
8990 1358 : gfc_component *c;
8991 :
8992 1358 : if (sym->attr.use_assoc && sym->attr.private_comp)
8993 : return 1;
8994 :
8995 4013 : for (c = sym->components; c; c = c->next)
8996 : {
8997 : /* Prevent an infinite loop through this function. */
8998 2668 : if (c->ts.type == BT_DERIVED
8999 289 : && (c->attr.pointer || c->attr.allocatable)
9000 72 : && sym == c->ts.u.derived)
9001 72 : continue;
9002 :
9003 2596 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
9004 : return 1;
9005 : }
9006 :
9007 : return 0;
9008 : }
9009 :
9010 :
9011 : /* Resolve the argument of a deallocate expression. The expression must be
9012 : a pointer or a full array. */
9013 :
9014 : static bool
9015 8439 : resolve_deallocate_expr (gfc_expr *e)
9016 : {
9017 8439 : symbol_attribute attr;
9018 8439 : int allocatable, pointer;
9019 8439 : gfc_ref *ref;
9020 8439 : gfc_symbol *sym;
9021 8439 : gfc_component *c;
9022 8439 : bool unlimited;
9023 :
9024 8439 : if (!gfc_resolve_expr (e))
9025 : return false;
9026 :
9027 8439 : if (e->expr_type != EXPR_VARIABLE)
9028 0 : goto bad;
9029 :
9030 8439 : sym = e->symtree->n.sym;
9031 8439 : unlimited = UNLIMITED_POLY(sym);
9032 :
9033 8439 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
9034 : {
9035 1574 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9036 1574 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9037 : }
9038 : else
9039 : {
9040 6865 : allocatable = sym->attr.allocatable;
9041 6865 : pointer = sym->attr.pointer;
9042 : }
9043 16963 : for (ref = e->ref; ref; ref = ref->next)
9044 : {
9045 8524 : switch (ref->type)
9046 : {
9047 6360 : case REF_ARRAY:
9048 6360 : if (ref->u.ar.type != AR_FULL
9049 6598 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
9050 238 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
9051 : allocatable = 0;
9052 : break;
9053 :
9054 2164 : case REF_COMPONENT:
9055 2164 : c = ref->u.c.component;
9056 2164 : if (c->ts.type == BT_CLASS)
9057 : {
9058 303 : allocatable = CLASS_DATA (c)->attr.allocatable;
9059 303 : pointer = CLASS_DATA (c)->attr.class_pointer;
9060 : }
9061 : else
9062 : {
9063 1861 : allocatable = c->attr.allocatable;
9064 1861 : pointer = c->attr.pointer;
9065 : }
9066 : break;
9067 :
9068 : case REF_SUBSTRING:
9069 : case REF_INQUIRY:
9070 519 : allocatable = 0;
9071 : break;
9072 : }
9073 : }
9074 :
9075 8439 : attr = gfc_expr_attr (e);
9076 :
9077 8439 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
9078 : {
9079 3 : bad:
9080 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9081 : &e->where);
9082 3 : return false;
9083 : }
9084 :
9085 : /* F2008, C644. */
9086 8436 : if (gfc_is_coindexed (e))
9087 : {
9088 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
9089 1 : return false;
9090 : }
9091 :
9092 8435 : if (pointer
9093 10827 : && !gfc_check_vardef_context (e, true, true, false,
9094 2392 : _("DEALLOCATE object")))
9095 : return false;
9096 8433 : if (!gfc_check_vardef_context (e, false, true, false,
9097 8433 : _("DEALLOCATE object")))
9098 : return false;
9099 :
9100 : return true;
9101 : }
9102 :
9103 :
9104 : /* Returns true if the expression e contains a reference to the symbol sym. */
9105 : static bool
9106 47397 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
9107 : {
9108 47397 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
9109 2081 : return true;
9110 :
9111 : return false;
9112 : }
9113 :
9114 : bool
9115 20080 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
9116 : {
9117 20080 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
9118 : }
9119 :
9120 : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
9121 : of character expressions. */
9122 : static bool
9123 20493 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
9124 : {
9125 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
9126 : }
9127 :
9128 :
9129 : /* Given the expression node e for an allocatable/pointer of derived type to be
9130 : allocated, get the expression node to be initialized afterwards (needed for
9131 : derived types with default initializers, and derived types with allocatable
9132 : components that need nullification.) */
9133 :
9134 : gfc_expr *
9135 5831 : gfc_expr_to_initialize (gfc_expr *e)
9136 : {
9137 5831 : gfc_expr *result;
9138 5831 : gfc_ref *ref;
9139 5831 : int i;
9140 :
9141 5831 : result = gfc_copy_expr (e);
9142 :
9143 : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
9144 11512 : for (ref = result->ref; ref; ref = ref->next)
9145 9063 : if (ref->type == REF_ARRAY && ref->next == NULL)
9146 : {
9147 3382 : if (ref->u.ar.dimen == 0
9148 89 : && ref->u.ar.as && ref->u.ar.as->corank)
9149 : return result;
9150 :
9151 3293 : ref->u.ar.type = AR_FULL;
9152 :
9153 7438 : for (i = 0; i < ref->u.ar.dimen; i++)
9154 4145 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
9155 :
9156 : break;
9157 : }
9158 :
9159 5742 : gfc_free_shape (&result->shape, result->rank);
9160 :
9161 : /* Recalculate rank, shape, etc. */
9162 5742 : gfc_resolve_expr (result);
9163 5742 : return result;
9164 : }
9165 :
9166 :
9167 : /* If the last ref of an expression is an array ref, return a copy of the
9168 : expression with that one removed. Otherwise, a copy of the original
9169 : expression. This is used for allocate-expressions and pointer assignment
9170 : LHS, where there may be an array specification that needs to be stripped
9171 : off when using gfc_check_vardef_context. */
9172 :
9173 : static gfc_expr*
9174 27919 : remove_last_array_ref (gfc_expr* e)
9175 : {
9176 27919 : gfc_expr* e2;
9177 27919 : gfc_ref** r;
9178 :
9179 27919 : e2 = gfc_copy_expr (e);
9180 36166 : for (r = &e2->ref; *r; r = &(*r)->next)
9181 24767 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9182 : {
9183 16520 : gfc_free_ref_list (*r);
9184 16520 : *r = NULL;
9185 16520 : break;
9186 : }
9187 :
9188 27919 : return e2;
9189 : }
9190 :
9191 :
9192 : /* Used in resolve_allocate_expr to check that a allocation-object and
9193 : a source-expr are conformable. This does not catch all possible
9194 : cases; in particular a runtime checking is needed. */
9195 :
9196 : static bool
9197 1910 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9198 : {
9199 1910 : gfc_ref *tail;
9200 1910 : bool scalar;
9201 :
9202 2642 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9203 :
9204 : /* If MOLD= is present and is not scalar, and the allocate-object has an
9205 : explicit-shape-spec, the ranks need not agree. This may be unintended,
9206 : so let's emit a warning if -Wsurprising is given. */
9207 1910 : scalar = !tail || tail->type == REF_COMPONENT;
9208 1910 : if (e1->mold && e1->rank > 0
9209 166 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9210 : {
9211 27 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9212 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9213 : "but MOLD= expression at %L has rank %d",
9214 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9215 : &e1->where, e1->rank);
9216 30 : return true;
9217 : }
9218 :
9219 : /* First compare rank. */
9220 1880 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9221 2 : || (!tail && e1->rank != e2->rank))
9222 : {
9223 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9224 : "same rank as the allocate-object at %L",
9225 : &e1->where, &e2->where);
9226 7 : return false;
9227 : }
9228 :
9229 1873 : if (e1->shape)
9230 : {
9231 1373 : int i;
9232 1373 : mpz_t s;
9233 :
9234 1373 : mpz_init (s);
9235 :
9236 3165 : for (i = 0; i < e1->rank; i++)
9237 : {
9238 1379 : if (tail->u.ar.start[i] == NULL)
9239 : break;
9240 :
9241 419 : if (tail->u.ar.end[i])
9242 : {
9243 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9244 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9245 54 : mpz_add_ui (s, s, 1);
9246 : }
9247 : else
9248 : {
9249 365 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9250 : }
9251 :
9252 419 : if (mpz_cmp (e1->shape[i], s) != 0)
9253 : {
9254 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9255 : "have the same shape", &e1->where, &e2->where);
9256 0 : mpz_clear (s);
9257 0 : return false;
9258 : }
9259 : }
9260 :
9261 1373 : mpz_clear (s);
9262 : }
9263 :
9264 : return true;
9265 : }
9266 :
9267 :
9268 : /* Resolve the expression in an ALLOCATE statement, doing the additional
9269 : checks to see whether the expression is OK or not. The expression must
9270 : have a trailing array reference that gives the size of the array. */
9271 :
9272 : static bool
9273 17513 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9274 : {
9275 17513 : int i, pointer, allocatable, dimension, is_abstract;
9276 17513 : int codimension;
9277 17513 : bool coindexed;
9278 17513 : bool unlimited;
9279 17513 : symbol_attribute attr;
9280 17513 : gfc_ref *ref, *ref2;
9281 17513 : gfc_expr *e2;
9282 17513 : gfc_array_ref *ar;
9283 17513 : gfc_symbol *sym = NULL;
9284 17513 : gfc_alloc *a;
9285 17513 : gfc_component *c;
9286 17513 : bool t;
9287 :
9288 : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9289 : checking of coarrays. */
9290 22401 : for (ref = e->ref; ref; ref = ref->next)
9291 18198 : if (ref->next == NULL)
9292 : break;
9293 :
9294 17513 : if (ref && ref->type == REF_ARRAY)
9295 12115 : ref->u.ar.in_allocate = true;
9296 :
9297 17513 : if (!gfc_resolve_expr (e))
9298 1 : goto failure;
9299 :
9300 : /* Make sure the expression is allocatable or a pointer. If it is
9301 : pointer, the next-to-last reference must be a pointer. */
9302 :
9303 17512 : ref2 = NULL;
9304 17512 : if (e->symtree)
9305 17512 : sym = e->symtree->n.sym;
9306 :
9307 : /* Check whether ultimate component is abstract and CLASS. */
9308 35024 : is_abstract = 0;
9309 :
9310 : /* Is the allocate-object unlimited polymorphic? */
9311 17512 : unlimited = UNLIMITED_POLY(e);
9312 :
9313 17512 : if (e->expr_type != EXPR_VARIABLE)
9314 : {
9315 0 : allocatable = 0;
9316 0 : attr = gfc_expr_attr (e);
9317 0 : pointer = attr.pointer;
9318 0 : dimension = attr.dimension;
9319 0 : codimension = attr.codimension;
9320 : }
9321 : else
9322 : {
9323 17512 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9324 : {
9325 3432 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9326 3432 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9327 3432 : dimension = CLASS_DATA (sym)->attr.dimension;
9328 3432 : codimension = CLASS_DATA (sym)->attr.codimension;
9329 3432 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9330 : }
9331 : else
9332 : {
9333 14080 : allocatable = sym->attr.allocatable;
9334 14080 : pointer = sym->attr.pointer;
9335 14080 : dimension = sym->attr.dimension;
9336 14080 : codimension = sym->attr.codimension;
9337 : }
9338 :
9339 17512 : coindexed = false;
9340 :
9341 35704 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9342 : {
9343 18194 : switch (ref->type)
9344 : {
9345 13598 : case REF_ARRAY:
9346 13598 : if (ref->u.ar.codimen > 0)
9347 : {
9348 803 : int n;
9349 1104 : for (n = ref->u.ar.dimen;
9350 1104 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9351 844 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9352 : {
9353 : coindexed = true;
9354 : break;
9355 : }
9356 : }
9357 :
9358 13598 : if (ref->next != NULL)
9359 1485 : pointer = 0;
9360 : break;
9361 :
9362 4596 : case REF_COMPONENT:
9363 : /* F2008, C644. */
9364 4596 : if (coindexed)
9365 : {
9366 2 : gfc_error ("Coindexed allocatable object at %L",
9367 : &e->where);
9368 2 : goto failure;
9369 : }
9370 :
9371 4594 : c = ref->u.c.component;
9372 4594 : if (c->ts.type == BT_CLASS)
9373 : {
9374 1000 : allocatable = CLASS_DATA (c)->attr.allocatable;
9375 1000 : pointer = CLASS_DATA (c)->attr.class_pointer;
9376 1000 : dimension = CLASS_DATA (c)->attr.dimension;
9377 1000 : codimension = CLASS_DATA (c)->attr.codimension;
9378 1000 : is_abstract = CLASS_DATA (c)->attr.abstract;
9379 : }
9380 : else
9381 : {
9382 3594 : allocatable = c->attr.allocatable;
9383 3594 : pointer = c->attr.pointer;
9384 3594 : dimension = c->attr.dimension;
9385 3594 : codimension = c->attr.codimension;
9386 3594 : is_abstract = c->attr.abstract;
9387 : }
9388 : break;
9389 :
9390 0 : case REF_SUBSTRING:
9391 0 : case REF_INQUIRY:
9392 0 : allocatable = 0;
9393 0 : pointer = 0;
9394 0 : break;
9395 : }
9396 : }
9397 : }
9398 :
9399 : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9400 : pointer or an allocatable variable. */
9401 17510 : if (allocatable == 0 && pointer == 0)
9402 : {
9403 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9404 : &e->where);
9405 4 : goto failure;
9406 : }
9407 :
9408 : /* Some checks for the SOURCE tag. */
9409 17506 : if (code->expr3)
9410 : {
9411 : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9412 : rank as allocate-object". This would require the MOLD argument to
9413 : NULL() as source-expr for subsequent checking. However, even the
9414 : resulting disassociated pointer or unallocated array has no shape that
9415 : could be used for SOURCE= or MOLD=. */
9416 3882 : if (code->expr3->expr_type == EXPR_NULL)
9417 : {
9418 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9419 : &code->expr3->where);
9420 4 : goto failure;
9421 : }
9422 :
9423 : /* Check F03:C631. */
9424 3878 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9425 : {
9426 10 : gfc_error ("Type of entity at %L is type incompatible with "
9427 10 : "source-expr at %L", &e->where, &code->expr3->where);
9428 10 : goto failure;
9429 : }
9430 :
9431 : /* Check F03:C632 and restriction following Note 6.18. */
9432 3868 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9433 7 : goto failure;
9434 :
9435 : /* Check F03:C633. */
9436 3861 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9437 : {
9438 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9439 : "shall have the same kind type parameter",
9440 : &e->where, &code->expr3->where);
9441 1 : goto failure;
9442 : }
9443 :
9444 : /* Check F2008, C642. */
9445 3860 : if (code->expr3->ts.type == BT_DERIVED
9446 3860 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9447 1198 : || (code->expr3->ts.u.derived->from_intmod
9448 : == INTMOD_ISO_FORTRAN_ENV
9449 0 : && code->expr3->ts.u.derived->intmod_sym_id
9450 : == ISOFORTRAN_LOCK_TYPE)))
9451 : {
9452 0 : gfc_error ("The source-expr at %L shall neither be of type "
9453 : "LOCK_TYPE nor have a LOCK_TYPE component if "
9454 : "allocate-object at %L is a coarray",
9455 0 : &code->expr3->where, &e->where);
9456 0 : goto failure;
9457 : }
9458 :
9459 : /* Check F2008:C639: "Corresponding kind type parameters of
9460 : allocate-object and source-expr shall have the same values." */
9461 3860 : if (e->ts.type == BT_CHARACTER
9462 816 : && !e->ts.deferred
9463 162 : && e->ts.u.cl->length
9464 162 : && code->expr3->ts.type == BT_CHARACTER
9465 4022 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9466 : "SOURCE= or MOLD= specifier"))
9467 17 : goto failure;
9468 :
9469 : /* Check TS18508, C702/C703. */
9470 3843 : if (code->expr3->ts.type == BT_DERIVED
9471 5041 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9472 1198 : || (code->expr3->ts.u.derived->from_intmod
9473 : == INTMOD_ISO_FORTRAN_ENV
9474 0 : && code->expr3->ts.u.derived->intmod_sym_id
9475 : == ISOFORTRAN_EVENT_TYPE)))
9476 : {
9477 0 : gfc_error ("The source-expr at %L shall neither be of type "
9478 : "EVENT_TYPE nor have a EVENT_TYPE component if "
9479 : "allocate-object at %L is a coarray",
9480 0 : &code->expr3->where, &e->where);
9481 0 : goto failure;
9482 : }
9483 : }
9484 :
9485 : /* Check F08:C629. */
9486 17467 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9487 153 : && !code->expr3)
9488 : {
9489 2 : gcc_assert (e->ts.type == BT_CLASS);
9490 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9491 : "type-spec or source-expr", sym->name, &e->where);
9492 2 : goto failure;
9493 : }
9494 :
9495 : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9496 : if and only if each allocate-object is a dummy argument for which the
9497 : corresponding type parameter is assumed. */
9498 17465 : if (code->ext.alloc.ts.type == BT_CHARACTER
9499 515 : && code->ext.alloc.ts.u.cl->length != NULL
9500 500 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9501 23 : && e->ts.u.cl->length == NULL
9502 2 : && e->symtree->n.sym->attr.dummy)
9503 : {
9504 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9505 : "shall be an asterisk as allocate object %qs at %L is a "
9506 : "dummy argument with assumed type parameter",
9507 : sym->name, &e->where);
9508 2 : goto failure;
9509 : }
9510 :
9511 : /* Check F08:C632. */
9512 17463 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9513 60 : && !UNLIMITED_POLY (e))
9514 : {
9515 36 : int cmp;
9516 :
9517 36 : if (!e->ts.u.cl->length)
9518 15 : goto failure;
9519 :
9520 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9521 21 : code->ext.alloc.ts.u.cl->length);
9522 21 : if (cmp == 1 || cmp == -1 || cmp == -3)
9523 : {
9524 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9525 : "character-length parameter as in the declaration",
9526 : sym->name, &e->where);
9527 2 : goto failure;
9528 : }
9529 : }
9530 :
9531 : /* In the variable definition context checks, gfc_expr_attr is used
9532 : on the expression. This is fooled by the array specification
9533 : present in e, thus we have to eliminate that one temporarily. */
9534 17446 : e2 = remove_last_array_ref (e);
9535 17446 : t = true;
9536 17446 : if (t && pointer)
9537 3921 : t = gfc_check_vardef_context (e2, true, true, false,
9538 3921 : _("ALLOCATE object"));
9539 3921 : if (t)
9540 17438 : t = gfc_check_vardef_context (e2, false, true, false,
9541 17438 : _("ALLOCATE object"));
9542 17446 : gfc_free_expr (e2);
9543 17446 : if (!t)
9544 11 : goto failure;
9545 :
9546 17435 : code->ext.alloc.expr3_not_explicit = 0;
9547 17435 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9548 1629 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9549 : {
9550 : /* For class arrays, the initialization with SOURCE is done
9551 : using _copy and trans_call. It is convenient to exploit that
9552 : when the allocated type is different from the declared type but
9553 : no SOURCE exists by setting expr3. */
9554 305 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9555 305 : code->ext.alloc.expr3_not_explicit = 1;
9556 : }
9557 17130 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9558 2653 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9559 6 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9560 : {
9561 : /* We have to zero initialize the integer variable. */
9562 2 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9563 2 : code->ext.alloc.expr3_not_explicit = 1;
9564 : }
9565 :
9566 17435 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9567 : {
9568 : /* Make sure the vtab symbol is present when
9569 : the module variables are generated. */
9570 3002 : gfc_typespec ts = e->ts;
9571 3002 : if (code->expr3)
9572 1337 : ts = code->expr3->ts;
9573 1665 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9574 732 : ts = code->ext.alloc.ts;
9575 :
9576 : /* Finding the vtab also publishes the type's symbol. Therefore this
9577 : statement is necessary. */
9578 3002 : gfc_find_derived_vtab (ts.u.derived);
9579 3002 : }
9580 14433 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9581 : {
9582 : /* Again, make sure the vtab symbol is present when
9583 : the module variables are generated. */
9584 440 : gfc_typespec *ts = NULL;
9585 440 : if (code->expr3)
9586 353 : ts = &code->expr3->ts;
9587 : else
9588 87 : ts = &code->ext.alloc.ts;
9589 :
9590 440 : gcc_assert (ts);
9591 :
9592 : /* Finding the vtab also publishes the type's symbol. Therefore this
9593 : statement is necessary. */
9594 440 : gfc_find_vtab (ts);
9595 : }
9596 :
9597 17435 : if (dimension == 0 && codimension == 0)
9598 5351 : goto success;
9599 :
9600 : /* Make sure the last reference node is an array specification. */
9601 :
9602 12084 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9603 10851 : || (dimension && ref2->u.ar.dimen == 0))
9604 : {
9605 : /* F08:C633. */
9606 1233 : if (code->expr3)
9607 : {
9608 1232 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9609 : "in ALLOCATE statement at %L", &e->where))
9610 0 : goto failure;
9611 1232 : if (code->expr3->rank != 0)
9612 1231 : *array_alloc_wo_spec = true;
9613 : else
9614 : {
9615 1 : gfc_error ("Array specification or array-valued SOURCE= "
9616 : "expression required in ALLOCATE statement at %L",
9617 : &e->where);
9618 1 : goto failure;
9619 : }
9620 : }
9621 : else
9622 : {
9623 1 : gfc_error ("Array specification required in ALLOCATE statement "
9624 : "at %L", &e->where);
9625 1 : goto failure;
9626 : }
9627 : }
9628 :
9629 : /* Make sure that the array section reference makes sense in the
9630 : context of an ALLOCATE specification. */
9631 :
9632 12082 : ar = &ref2->u.ar;
9633 :
9634 12082 : if (codimension)
9635 1265 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9636 : {
9637 735 : switch (ar->dimen_type[i])
9638 : {
9639 2 : case DIMEN_THIS_IMAGE:
9640 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9641 : "at %L", &e->where);
9642 2 : goto failure;
9643 :
9644 98 : case DIMEN_RANGE:
9645 : /* F2018:R937:
9646 : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9647 : */
9648 98 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9649 : {
9650 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9651 : "at %L", &e->where);
9652 8 : goto failure;
9653 : }
9654 90 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9655 : {
9656 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9657 2 : &ar->start[i]->where);
9658 2 : goto failure;
9659 : }
9660 : break;
9661 :
9662 105 : case DIMEN_ELEMENT:
9663 105 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9664 : {
9665 97 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9666 97 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9667 : {
9668 1 : gfc_error ("Upper cobound is less than lower cobound "
9669 : "of 1 at %L", &ar->start[i]->where);
9670 1 : goto failure;
9671 : }
9672 : }
9673 : break;
9674 :
9675 : case DIMEN_STAR:
9676 : break;
9677 :
9678 0 : default:
9679 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9680 : &e->where);
9681 0 : goto failure;
9682 :
9683 : }
9684 : }
9685 29491 : for (i = 0; i < ar->dimen; i++)
9686 : {
9687 17426 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9688 14687 : goto check_symbols;
9689 :
9690 2739 : switch (ar->dimen_type[i])
9691 : {
9692 : case DIMEN_ELEMENT:
9693 : break;
9694 :
9695 2473 : case DIMEN_RANGE:
9696 2473 : if (ar->start[i] != NULL
9697 2473 : && ar->end[i] != NULL
9698 2472 : && ar->stride[i] == NULL)
9699 : break;
9700 :
9701 : /* Fall through. */
9702 :
9703 1 : case DIMEN_UNKNOWN:
9704 1 : case DIMEN_VECTOR:
9705 1 : case DIMEN_STAR:
9706 1 : case DIMEN_THIS_IMAGE:
9707 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9708 : &e->where);
9709 1 : goto failure;
9710 : }
9711 :
9712 2472 : check_symbols:
9713 45287 : for (a = code->ext.alloc.list; a; a = a->next)
9714 : {
9715 27865 : sym = a->expr->symtree->n.sym;
9716 :
9717 : /* TODO - check derived type components. */
9718 27865 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9719 9414 : continue;
9720 :
9721 18451 : if ((ar->start[i] != NULL
9722 17770 : && gfc_find_var_in_expr (sym, ar->start[i]))
9723 36218 : || (ar->end[i] != NULL
9724 2723 : && gfc_find_var_in_expr (sym, ar->end[i])))
9725 : {
9726 3 : gfc_error ("%qs must not appear in the array specification at "
9727 : "%L in the same ALLOCATE statement where it is "
9728 : "itself allocated", sym->name, &ar->where);
9729 3 : goto failure;
9730 : }
9731 : }
9732 : }
9733 :
9734 12256 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9735 : {
9736 911 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9737 720 : || ar->dimen_type[i] == DIMEN_RANGE)
9738 : {
9739 191 : if (i == (ar->dimen + ar->codimen - 1))
9740 : {
9741 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9742 : "statement at %L", &e->where);
9743 0 : goto failure;
9744 : }
9745 191 : continue;
9746 : }
9747 :
9748 529 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9749 529 : && ar->stride[i] == NULL)
9750 : break;
9751 :
9752 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9753 : &e->where);
9754 0 : goto failure;
9755 : }
9756 :
9757 12065 : success:
9758 17416 : gfc_used_in_allocate_expr (e, &e->where, ALLOCATED_ALLOCATE_STMT);
9759 :
9760 17416 : if (code->expr3)
9761 4038 : gfc_value_set_at (e->symtree->n.sym, &code->expr3->where, VALUE_VARDEF);
9762 :
9763 : return true;
9764 :
9765 : failure:
9766 : return false;
9767 : }
9768 :
9769 :
9770 : static void
9771 20630 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9772 : {
9773 20630 : gfc_expr *stat, *errmsg, *pe, *qe;
9774 20630 : gfc_alloc *a, *p, *q;
9775 :
9776 20630 : stat = code->expr1;
9777 20630 : errmsg = code->expr2;
9778 :
9779 : /* Check the stat variable. */
9780 20630 : if (stat)
9781 : {
9782 661 : if (!gfc_check_vardef_context (stat, false, false, false,
9783 661 : _("STAT variable")))
9784 8 : goto done_stat;
9785 :
9786 653 : if (stat->ts.type != BT_INTEGER
9787 644 : || stat->rank > 0)
9788 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9789 : "variable", &stat->where);
9790 :
9791 653 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9792 0 : goto done_stat;
9793 :
9794 : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9795 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9796 : */
9797 1354 : for (p = code->ext.alloc.list; p; p = p->next)
9798 708 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9799 : {
9800 9 : gfc_ref *ref1, *ref2;
9801 9 : bool found = true;
9802 :
9803 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9804 7 : ref1 = ref1->next, ref2 = ref2->next)
9805 : {
9806 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9807 5 : continue;
9808 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9809 : {
9810 : found = false;
9811 : break;
9812 : }
9813 : }
9814 :
9815 9 : if (found)
9816 : {
9817 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9818 : "the same %s statement", &stat->where, fcn, fcn);
9819 7 : break;
9820 : }
9821 : }
9822 : }
9823 :
9824 19969 : done_stat:
9825 :
9826 : /* Check the errmsg variable. */
9827 20630 : if (errmsg)
9828 : {
9829 150 : if (!stat)
9830 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9831 : &errmsg->where);
9832 :
9833 150 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9834 150 : _("ERRMSG variable")))
9835 6 : goto done_errmsg;
9836 :
9837 : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9838 : F18:R930 errmsg-variable is scalar-default-char-variable
9839 : F18:R906 default-char-variable is variable
9840 : F18:C906 default-char-variable shall be default character. */
9841 144 : if (errmsg->ts.type != BT_CHARACTER
9842 142 : || errmsg->rank > 0
9843 141 : || errmsg->ts.kind != gfc_default_character_kind)
9844 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9845 : "variable", &errmsg->where);
9846 :
9847 144 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9848 0 : goto done_errmsg;
9849 :
9850 : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9851 : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9852 : */
9853 286 : for (p = code->ext.alloc.list; p; p = p->next)
9854 147 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9855 : {
9856 9 : gfc_ref *ref1, *ref2;
9857 9 : bool found = true;
9858 :
9859 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9860 7 : ref1 = ref1->next, ref2 = ref2->next)
9861 : {
9862 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9863 4 : continue;
9864 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9865 : {
9866 : found = false;
9867 : break;
9868 : }
9869 : }
9870 :
9871 9 : if (found)
9872 : {
9873 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9874 : "the same %s statement", &errmsg->where, fcn, fcn);
9875 5 : break;
9876 : }
9877 : }
9878 : }
9879 :
9880 20480 : done_errmsg:
9881 :
9882 : /* Check that an allocate-object appears only once in the statement. */
9883 :
9884 46582 : for (p = code->ext.alloc.list; p; p = p->next)
9885 : {
9886 25952 : pe = p->expr;
9887 35252 : for (q = p->next; q; q = q->next)
9888 : {
9889 9300 : qe = q->expr;
9890 9300 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9891 : {
9892 : /* This is a potential collision. */
9893 2094 : gfc_ref *pr = pe->ref;
9894 2094 : gfc_ref *qr = qe->ref;
9895 :
9896 : /* Follow the references until
9897 : a) They start to differ, in which case there is no error;
9898 : you can deallocate a%b and a%c in a single statement
9899 : b) Both of them stop, which is an error
9900 : c) One of them stops, which is also an error. */
9901 4518 : while (1)
9902 : {
9903 3306 : if (pr == NULL && qr == NULL)
9904 : {
9905 7 : gfc_error ("Allocate-object at %L also appears at %L",
9906 : &pe->where, &qe->where);
9907 7 : break;
9908 : }
9909 3299 : else if (pr != NULL && qr == NULL)
9910 : {
9911 2 : gfc_error ("Allocate-object at %L is subobject of"
9912 : " object at %L", &pe->where, &qe->where);
9913 2 : break;
9914 : }
9915 3297 : else if (pr == NULL && qr != NULL)
9916 : {
9917 2 : gfc_error ("Allocate-object at %L is subobject of"
9918 : " object at %L", &qe->where, &pe->where);
9919 2 : break;
9920 : }
9921 : /* Here, pr != NULL && qr != NULL */
9922 3295 : gcc_assert(pr->type == qr->type);
9923 3295 : if (pr->type == REF_ARRAY)
9924 : {
9925 : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
9926 : which are legal. */
9927 1065 : gcc_assert (qr->type == REF_ARRAY);
9928 :
9929 1065 : if (pr->next && qr->next)
9930 : {
9931 : int i;
9932 : gfc_array_ref *par = &(pr->u.ar);
9933 : gfc_array_ref *qar = &(qr->u.ar);
9934 :
9935 1840 : for (i=0; i<par->dimen; i++)
9936 : {
9937 954 : if ((par->start[i] != NULL
9938 0 : || qar->start[i] != NULL)
9939 1908 : && gfc_dep_compare_expr (par->start[i],
9940 954 : qar->start[i]) != 0)
9941 168 : goto break_label;
9942 : }
9943 : }
9944 : }
9945 : else
9946 : {
9947 2230 : if (pr->u.c.component->name != qr->u.c.component->name)
9948 : break;
9949 : }
9950 :
9951 1212 : pr = pr->next;
9952 1212 : qr = qr->next;
9953 1212 : }
9954 9300 : break_label:
9955 : ;
9956 : }
9957 : }
9958 : }
9959 :
9960 20630 : if (strcmp (fcn, "ALLOCATE") == 0)
9961 : {
9962 14467 : bool arr_alloc_wo_spec = false;
9963 :
9964 : /* Resolve and mark as used the length of the type spec. */
9965 14467 : if (code->ext.alloc.ts.type == BT_CHARACTER)
9966 : {
9967 473 : gfc_expr *length = code->ext.alloc.ts.u.cl->length;
9968 473 : gfc_resolve_expr (length);
9969 473 : gfc_value_used_expr (length, VALUE_USED);
9970 : }
9971 :
9972 : /* Resolving the expr3 in the loop over all objects to allocate would
9973 : execute loop invariant code for each loop item. Therefore do it just
9974 : once here. */
9975 14467 : if (code->expr3 && code->expr3->mold
9976 363 : && code->expr3->ts.type == BT_DERIVED
9977 30 : && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
9978 : {
9979 : /* Default initialization via MOLD (non-polymorphic). */
9980 28 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
9981 28 : if (rhs != NULL)
9982 : {
9983 9 : gfc_resolve_expr (rhs);
9984 9 : gfc_free_expr (code->expr3);
9985 9 : code->expr3 = rhs;
9986 : }
9987 : }
9988 31980 : for (a = code->ext.alloc.list; a; a = a->next)
9989 17513 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
9990 :
9991 14467 : if (arr_alloc_wo_spec && code->expr3)
9992 : {
9993 : /* Mark the allocate to have to take the array specification
9994 : from the expr3. */
9995 1225 : code->ext.alloc.arr_spec_from_expr3 = 1;
9996 : }
9997 : }
9998 : else
9999 : {
10000 14602 : for (a = code->ext.alloc.list; a; a = a->next)
10001 8439 : resolve_deallocate_expr (a->expr);
10002 : }
10003 20630 : }
10004 :
10005 :
10006 : /************ SELECT CASE resolution subroutines ************/
10007 :
10008 : /* Callback function for our mergesort variant. Determines interval
10009 : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
10010 : op1 > op2. Assumes we're not dealing with the default case.
10011 : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
10012 : There are nine situations to check. */
10013 :
10014 : static int
10015 1582 : compare_cases (const gfc_case *op1, const gfc_case *op2)
10016 : {
10017 1582 : int retval;
10018 :
10019 1582 : if (op1->low == NULL) /* op1 = (:L) */
10020 : {
10021 : /* op2 = (:N), so overlap. */
10022 52 : retval = 0;
10023 : /* op2 = (M:) or (M:N), L < M */
10024 52 : if (op2->low != NULL
10025 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10026 : retval = -1;
10027 : }
10028 1530 : else if (op1->high == NULL) /* op1 = (K:) */
10029 : {
10030 : /* op2 = (M:), so overlap. */
10031 10 : retval = 0;
10032 : /* op2 = (:N) or (M:N), K > N */
10033 10 : if (op2->high != NULL
10034 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10035 : retval = 1;
10036 : }
10037 : else /* op1 = (K:L) */
10038 : {
10039 1520 : if (op2->low == NULL) /* op2 = (:N), K > N */
10040 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10041 18 : ? 1 : 0;
10042 1502 : else if (op2->high == NULL) /* op2 = (M:), L < M */
10043 14 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10044 10 : ? -1 : 0;
10045 : else /* op2 = (M:N) */
10046 : {
10047 1492 : retval = 0;
10048 : /* L < M */
10049 1492 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
10050 : retval = -1;
10051 : /* K > N */
10052 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
10053 438 : retval = 1;
10054 : }
10055 : }
10056 :
10057 1582 : return retval;
10058 : }
10059 :
10060 :
10061 : /* Merge-sort a double linked case list, detecting overlap in the
10062 : process. LIST is the head of the double linked case list before it
10063 : is sorted. Returns the head of the sorted list if we don't see any
10064 : overlap, or NULL otherwise. */
10065 :
10066 : static gfc_case *
10067 647 : check_case_overlap (gfc_case *list)
10068 : {
10069 647 : gfc_case *p, *q, *e, *tail;
10070 647 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
10071 :
10072 : /* If the passed list was empty, return immediately. */
10073 647 : if (!list)
10074 : return NULL;
10075 :
10076 : overlap_seen = 0;
10077 : insize = 1;
10078 :
10079 : /* Loop unconditionally. The only exit from this loop is a return
10080 : statement, when we've finished sorting the case list. */
10081 1353 : for (;;)
10082 : {
10083 1000 : p = list;
10084 1000 : list = NULL;
10085 1000 : tail = NULL;
10086 :
10087 : /* Count the number of merges we do in this pass. */
10088 1000 : nmerges = 0;
10089 :
10090 : /* Loop while there exists a merge to be done. */
10091 2528 : while (p)
10092 : {
10093 1528 : int i;
10094 :
10095 : /* Count this merge. */
10096 1528 : nmerges++;
10097 :
10098 : /* Cut the list in two pieces by stepping INSIZE places
10099 : forward in the list, starting from P. */
10100 1528 : psize = 0;
10101 1528 : q = p;
10102 3215 : for (i = 0; i < insize; i++)
10103 : {
10104 2247 : psize++;
10105 2247 : q = q->right;
10106 2247 : if (!q)
10107 : break;
10108 : }
10109 : qsize = insize;
10110 :
10111 : /* Now we have two lists. Merge them! */
10112 5024 : while (psize > 0 || (qsize > 0 && q != NULL))
10113 : {
10114 : /* See from which the next case to merge comes from. */
10115 811 : if (psize == 0)
10116 : {
10117 : /* P is empty so the next case must come from Q. */
10118 811 : e = q;
10119 811 : q = q->right;
10120 811 : qsize--;
10121 : }
10122 2685 : else if (qsize == 0 || q == NULL)
10123 : {
10124 : /* Q is empty. */
10125 1103 : e = p;
10126 1103 : p = p->right;
10127 1103 : psize--;
10128 : }
10129 : else
10130 : {
10131 1582 : cmp = compare_cases (p, q);
10132 1582 : if (cmp < 0)
10133 : {
10134 : /* The whole case range for P is less than the
10135 : one for Q. */
10136 1140 : e = p;
10137 1140 : p = p->right;
10138 1140 : psize--;
10139 : }
10140 442 : else if (cmp > 0)
10141 : {
10142 : /* The whole case range for Q is greater than
10143 : the case range for P. */
10144 438 : e = q;
10145 438 : q = q->right;
10146 438 : qsize--;
10147 : }
10148 : else
10149 : {
10150 : /* The cases overlap, or they are the same
10151 : element in the list. Either way, we must
10152 : issue an error and get the next case from P. */
10153 : /* FIXME: Sort P and Q by line number. */
10154 4 : gfc_error ("CASE label at %L overlaps with CASE "
10155 : "label at %L", &p->where, &q->where);
10156 4 : overlap_seen = 1;
10157 4 : e = p;
10158 4 : p = p->right;
10159 4 : psize--;
10160 : }
10161 : }
10162 :
10163 : /* Add the next element to the merged list. */
10164 3496 : if (tail)
10165 2496 : tail->right = e;
10166 : else
10167 : list = e;
10168 3496 : e->left = tail;
10169 3496 : tail = e;
10170 : }
10171 :
10172 : /* P has now stepped INSIZE places along, and so has Q. So
10173 : they're the same. */
10174 : p = q;
10175 : }
10176 1000 : tail->right = NULL;
10177 :
10178 : /* If we have done only one merge or none at all, we've
10179 : finished sorting the cases. */
10180 1000 : if (nmerges <= 1)
10181 : {
10182 647 : if (!overlap_seen)
10183 : return list;
10184 : else
10185 : return NULL;
10186 : }
10187 :
10188 : /* Otherwise repeat, merging lists twice the size. */
10189 353 : insize *= 2;
10190 353 : }
10191 : }
10192 :
10193 :
10194 : /* Check to see if an expression is suitable for use in a CASE statement.
10195 : Makes sure that all case expressions are scalar constants of the same
10196 : type. Return false if anything is wrong. */
10197 :
10198 : static bool
10199 3315 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10200 : {
10201 3315 : if (e == NULL) return true;
10202 :
10203 3222 : if (e->ts.type != case_expr->ts.type)
10204 : {
10205 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10206 : &e->where, gfc_basic_typename (case_expr->ts.type));
10207 4 : return false;
10208 : }
10209 :
10210 : /* C805 (R808) For a given case-construct, each case-value shall be of
10211 : the same type as case-expr. For character type, length differences
10212 : are allowed, but the kind type parameters shall be the same. */
10213 :
10214 3218 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10215 : {
10216 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10217 : &e->where, case_expr->ts.kind);
10218 4 : return false;
10219 : }
10220 :
10221 : /* Convert the case value kind to that of case expression kind,
10222 : if needed */
10223 :
10224 3214 : if (e->ts.kind != case_expr->ts.kind)
10225 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10226 :
10227 3214 : if (e->rank != 0)
10228 : {
10229 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10230 : &e->where);
10231 0 : return false;
10232 : }
10233 :
10234 : return true;
10235 : }
10236 :
10237 :
10238 : /* Given a completely parsed select statement, we:
10239 :
10240 : - Validate all expressions and code within the SELECT.
10241 : - Make sure that the selection expression is not of the wrong type.
10242 : - Make sure that no case ranges overlap.
10243 : - Eliminate unreachable cases and unreachable code resulting from
10244 : removing case labels.
10245 :
10246 : The standard does allow unreachable cases, e.g. CASE (5:3). But
10247 : they are a hassle for code generation, and to prevent that, we just
10248 : cut them out here. This is not necessary for overlapping cases
10249 : because they are illegal and we never even try to generate code.
10250 :
10251 : We have the additional caveat that a SELECT construct could have
10252 : been a computed GOTO in the source code. Fortunately we can fairly
10253 : easily work around that here: The case_expr for a "real" SELECT CASE
10254 : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10255 : we have to do is make sure that the case_expr is a scalar integer
10256 : expression. */
10257 :
10258 : static void
10259 688 : resolve_select (gfc_code *code, bool select_type)
10260 : {
10261 688 : gfc_code *body;
10262 688 : gfc_expr *case_expr;
10263 688 : gfc_case *cp, *default_case, *tail, *head;
10264 688 : int seen_unreachable;
10265 688 : int seen_logical;
10266 688 : int ncases;
10267 688 : bt type;
10268 688 : bool t;
10269 :
10270 688 : if (code->expr1 == NULL)
10271 : {
10272 : /* This was actually a computed GOTO statement. */
10273 5 : case_expr = code->expr2;
10274 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10275 3 : gfc_error ("Selection expression in computed GOTO statement "
10276 : "at %L must be a scalar integer expression",
10277 : &case_expr->where);
10278 :
10279 : /* Further checking is not necessary because this SELECT was built
10280 : by the compiler, so it should always be OK. Just move the
10281 : case_expr from expr2 to expr so that we can handle computed
10282 : GOTOs as normal SELECTs from here on. */
10283 5 : code->expr1 = code->expr2;
10284 5 : code->expr2 = NULL;
10285 5 : gfc_value_used_expr (code->expr1, VALUE_USED);
10286 5 : return;
10287 : }
10288 :
10289 683 : case_expr = code->expr1;
10290 683 : type = case_expr->ts.type;
10291 :
10292 : /* F08:C830. */
10293 683 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10294 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10295 :
10296 : {
10297 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10298 : &case_expr->where, gfc_typename (case_expr));
10299 :
10300 : /* Punt. Going on here just produce more garbage error messages. */
10301 0 : return;
10302 : }
10303 :
10304 : /* F08:R842. */
10305 683 : if (!select_type && case_expr->rank != 0)
10306 : {
10307 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10308 : "expression", &case_expr->where);
10309 :
10310 : /* Punt. */
10311 1 : return;
10312 : }
10313 :
10314 : /* Raise a warning if an INTEGER case value exceeds the range of
10315 : the case-expr. Later, all expressions will be promoted to the
10316 : largest kind of all case-labels. */
10317 :
10318 682 : if (type == BT_INTEGER)
10319 1933 : for (body = code->block; body; body = body->block)
10320 2862 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10321 : {
10322 1467 : if (cp->low
10323 1467 : && gfc_check_integer_range (cp->low->value.integer,
10324 : case_expr->ts.kind) != ARITH_OK)
10325 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10326 6 : "not in the range of %s", &cp->low->where,
10327 : gfc_typename (case_expr));
10328 :
10329 1467 : if (cp->high
10330 1182 : && cp->low != cp->high
10331 1575 : && gfc_check_integer_range (cp->high->value.integer,
10332 : case_expr->ts.kind) != ARITH_OK)
10333 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10334 0 : "not in the range of %s", &cp->high->where,
10335 : gfc_typename (case_expr));
10336 : }
10337 :
10338 : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10339 : of the SELECT CASE expression and its CASE values. Walk the lists
10340 : of case values, and if we find a mismatch, promote case_expr to
10341 : the appropriate kind. */
10342 :
10343 682 : if (type == BT_LOGICAL || type == BT_INTEGER)
10344 : {
10345 2119 : for (body = code->block; body; body = body->block)
10346 : {
10347 : /* Walk the case label list. */
10348 3123 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10349 : {
10350 : /* Intercept the DEFAULT case. It does not have a kind. */
10351 1602 : if (cp->low == NULL && cp->high == NULL)
10352 293 : continue;
10353 :
10354 : /* Unreachable case ranges are discarded, so ignore. */
10355 1264 : if (cp->low != NULL && cp->high != NULL
10356 1216 : && cp->low != cp->high
10357 1374 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10358 33 : continue;
10359 :
10360 1276 : if (cp->low != NULL
10361 1276 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10362 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10363 :
10364 1276 : if (cp->high != NULL
10365 1276 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10366 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10367 : }
10368 : }
10369 : }
10370 :
10371 : /* Assume there is no DEFAULT case. */
10372 682 : default_case = NULL;
10373 682 : head = tail = NULL;
10374 682 : ncases = 0;
10375 682 : seen_logical = 0;
10376 :
10377 2508 : for (body = code->block; body; body = body->block)
10378 : {
10379 : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10380 1826 : t = true;
10381 1826 : seen_unreachable = 0;
10382 :
10383 : /* Walk the case label list, making sure that all case labels
10384 : are legal. */
10385 3839 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10386 : {
10387 : /* Count the number of cases in the whole construct. */
10388 2024 : ncases++;
10389 :
10390 : /* Intercept the DEFAULT case. */
10391 2024 : if (cp->low == NULL && cp->high == NULL)
10392 : {
10393 363 : if (default_case != NULL)
10394 : {
10395 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10396 : "by a second DEFAULT CASE at %L",
10397 : &default_case->where, &cp->where);
10398 0 : t = false;
10399 0 : break;
10400 : }
10401 : else
10402 : {
10403 363 : default_case = cp;
10404 363 : continue;
10405 : }
10406 : }
10407 :
10408 : /* Deal with single value cases and case ranges. Errors are
10409 : issued from the validation function. */
10410 1661 : if (!validate_case_label_expr (cp->low, case_expr)
10411 1661 : || !validate_case_label_expr (cp->high, case_expr))
10412 : {
10413 : t = false;
10414 : break;
10415 : }
10416 :
10417 1653 : if (type == BT_LOGICAL
10418 78 : && ((cp->low == NULL || cp->high == NULL)
10419 76 : || cp->low != cp->high))
10420 : {
10421 2 : gfc_error ("Logical range in CASE statement at %L is not "
10422 : "allowed",
10423 1 : cp->low ? &cp->low->where : &cp->high->where);
10424 2 : t = false;
10425 2 : break;
10426 : }
10427 :
10428 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10429 : {
10430 76 : int value;
10431 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10432 76 : if (value & seen_logical)
10433 : {
10434 1 : gfc_error ("Constant logical value in CASE statement "
10435 : "is repeated at %L",
10436 : &cp->low->where);
10437 1 : t = false;
10438 1 : break;
10439 : }
10440 75 : seen_logical |= value;
10441 : }
10442 :
10443 1606 : if (cp->low != NULL && cp->high != NULL
10444 1559 : && cp->low != cp->high
10445 1762 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10446 : {
10447 35 : if (warn_surprising)
10448 1 : gfc_warning (OPT_Wsurprising,
10449 : "Range specification at %L can never be matched",
10450 : &cp->where);
10451 :
10452 35 : cp->unreachable = 1;
10453 35 : seen_unreachable = 1;
10454 : }
10455 : else
10456 : {
10457 : /* If the case range can be matched, it can also overlap with
10458 : other cases. To make sure it does not, we put it in a
10459 : double linked list here. We sort that with a merge sort
10460 : later on to detect any overlapping cases. */
10461 1615 : if (!head)
10462 : {
10463 647 : head = tail = cp;
10464 647 : head->right = head->left = NULL;
10465 : }
10466 : else
10467 : {
10468 968 : tail->right = cp;
10469 968 : tail->right->left = tail;
10470 968 : tail = tail->right;
10471 968 : tail->right = NULL;
10472 : }
10473 : }
10474 : }
10475 :
10476 : /* It there was a failure in the previous case label, give up
10477 : for this case label list. Continue with the next block. */
10478 1826 : if (!t)
10479 11 : continue;
10480 :
10481 : /* See if any case labels that are unreachable have been seen.
10482 : If so, we eliminate them. This is a bit of a kludge because
10483 : the case lists for a single case statement (label) is a
10484 : single forward linked lists. */
10485 1815 : if (seen_unreachable)
10486 : {
10487 : /* Advance until the first case in the list is reachable. */
10488 69 : while (body->ext.block.case_list != NULL
10489 69 : && body->ext.block.case_list->unreachable)
10490 : {
10491 34 : gfc_case *n = body->ext.block.case_list;
10492 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10493 34 : n->next = NULL;
10494 34 : gfc_free_case_list (n);
10495 : }
10496 :
10497 : /* Strip all other unreachable cases. */
10498 35 : if (body->ext.block.case_list)
10499 : {
10500 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10501 : {
10502 1 : if (cp->next->unreachable)
10503 : {
10504 1 : gfc_case *n = cp->next;
10505 1 : cp->next = cp->next->next;
10506 1 : n->next = NULL;
10507 1 : gfc_free_case_list (n);
10508 : }
10509 : }
10510 : }
10511 : }
10512 : }
10513 :
10514 : /* See if there were overlapping cases. If the check returns NULL,
10515 : there was overlap. In that case we don't do anything. If head
10516 : is non-NULL, we prepend the DEFAULT case. The sorted list can
10517 : then used during code generation for SELECT CASE constructs with
10518 : a case expression of a CHARACTER type. */
10519 682 : if (head)
10520 : {
10521 647 : head = check_case_overlap (head);
10522 :
10523 : /* Prepend the default_case if it is there. */
10524 647 : if (head != NULL && default_case)
10525 : {
10526 346 : default_case->left = NULL;
10527 346 : default_case->right = head;
10528 346 : head->left = default_case;
10529 : }
10530 : }
10531 :
10532 : /* Eliminate dead blocks that may be the result if we've seen
10533 : unreachable case labels for a block. */
10534 2474 : for (body = code; body && body->block; body = body->block)
10535 : {
10536 1792 : if (body->block->ext.block.case_list == NULL)
10537 : {
10538 : /* Cut the unreachable block from the code chain. */
10539 34 : gfc_code *c = body->block;
10540 34 : body->block = c->block;
10541 :
10542 : /* Kill the dead block, but not the blocks below it. */
10543 34 : c->block = NULL;
10544 34 : gfc_free_statements (c);
10545 : }
10546 : }
10547 :
10548 : /* More than two cases is legal but insane for logical selects.
10549 : Issue a warning for it. */
10550 682 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10551 0 : gfc_warning (OPT_Wsurprising,
10552 : "Logical SELECT CASE block at %L has more that two cases",
10553 : &code->loc);
10554 :
10555 : /* Finally, mark the expression as used. */
10556 682 : gfc_value_used_expr (case_expr, VALUE_USED);
10557 : }
10558 :
10559 :
10560 : /* Check if a derived type is extensible. */
10561 :
10562 : bool
10563 24286 : gfc_type_is_extensible (gfc_symbol *sym)
10564 : {
10565 24286 : return !(sym->attr.is_bind_c || sym->attr.sequence
10566 24270 : || (sym->attr.is_class
10567 2196 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10568 : }
10569 :
10570 :
10571 : static void
10572 : resolve_types (gfc_namespace *ns);
10573 :
10574 : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10575 : correct as well as possibly the array-spec. */
10576 :
10577 : static void
10578 13051 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10579 : {
10580 13051 : gfc_expr* target;
10581 13051 : bool parentheses = false;
10582 :
10583 13051 : gcc_assert (sym->assoc);
10584 13051 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10585 :
10586 13051 : if (sym->assoc->target
10587 7815 : && sym->assoc->target->expr_type == EXPR_FUNCTION
10588 598 : && sym->assoc->target->symtree
10589 598 : && sym->assoc->target->symtree->n.sym
10590 598 : && sym->assoc->target->symtree->n.sym->attr.generic)
10591 : {
10592 33 : if (gfc_resolve_expr (sym->assoc->target))
10593 33 : sym->ts = sym->assoc->target->ts;
10594 : else
10595 : {
10596 0 : gfc_error ("%s could not be resolved to a specific function at %L",
10597 0 : sym->assoc->target->symtree->n.sym->name,
10598 0 : &sym->assoc->target->where);
10599 0 : return;
10600 : }
10601 : }
10602 :
10603 : /* If this is for SELECT TYPE, the target may not yet be set. In that
10604 : case, return. Resolution will be called later manually again when
10605 : this is done. */
10606 13051 : target = sym->assoc->target;
10607 13051 : if (!target)
10608 : return;
10609 7815 : gcc_assert (!sym->assoc->dangling);
10610 :
10611 7815 : if (target->expr_type == EXPR_OP
10612 267 : && target->value.op.op == INTRINSIC_PARENTHESES
10613 42 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
10614 : {
10615 23 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
10616 23 : gfc_free_expr (target);
10617 23 : target = sym->assoc->target;
10618 23 : parentheses = true;
10619 : }
10620 :
10621 7815 : if (resolve_target && !gfc_resolve_expr (target))
10622 : return;
10623 :
10624 7810 : if (sym->assoc->ar)
10625 : {
10626 : int dim;
10627 : gfc_array_ref *ar = sym->assoc->ar;
10628 68 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10629 : {
10630 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10631 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10632 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10633 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10634 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10635 : "remapping of associate name %s at %L",
10636 : sym->name, &sym->declared_at);
10637 : }
10638 : }
10639 :
10640 : /* For variable targets, we get some attributes from the target. */
10641 7810 : if (target->expr_type == EXPR_VARIABLE)
10642 : {
10643 6761 : gfc_symbol *tsym, *dsym;
10644 :
10645 6761 : gcc_assert (target->symtree);
10646 6761 : tsym = target->symtree->n.sym;
10647 :
10648 6761 : if (gfc_expr_attr (target).proc_pointer)
10649 : {
10650 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10651 : tsym->name, &target->where);
10652 0 : return;
10653 : }
10654 :
10655 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10656 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10657 6762 : && dsym->attr.flavor == FL_DERIVED)
10658 : {
10659 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10660 : tsym->name, &target->where);
10661 1 : return;
10662 : }
10663 :
10664 6760 : if (tsym->attr.flavor == FL_PROCEDURE)
10665 : {
10666 73 : bool is_error = true;
10667 73 : if (tsym->attr.function && tsym->result == tsym)
10668 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10669 137 : if (tsym == ns->proc_name)
10670 : {
10671 : is_error = false;
10672 : break;
10673 : }
10674 64 : if (is_error)
10675 : {
10676 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10677 : tsym->name, &target->where);
10678 13 : return;
10679 : }
10680 : }
10681 :
10682 6747 : sym->attr.asynchronous = tsym->attr.asynchronous;
10683 6747 : sym->attr.volatile_ = tsym->attr.volatile_;
10684 :
10685 13494 : sym->attr.target = tsym->attr.target
10686 6747 : || gfc_expr_attr (target).pointer;
10687 6747 : if (is_subref_array (target))
10688 402 : sym->attr.subref_array_pointer = 1;
10689 : }
10690 1049 : else if (target->ts.type == BT_PROCEDURE)
10691 : {
10692 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10693 : &target->where);
10694 0 : return;
10695 : }
10696 :
10697 7796 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10698 : {
10699 : /* By now, the type of the target has been fixed up. */
10700 314 : symbol_attribute attr;
10701 :
10702 314 : if (sym->ts.type == BT_DERIVED
10703 181 : && target->ts.type == BT_CLASS
10704 31 : && !UNLIMITED_POLY (target))
10705 : {
10706 : /* Inferred to be derived type but the target has type class. */
10707 31 : sym->ts = CLASS_DATA (target)->ts;
10708 31 : if (!sym->as)
10709 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10710 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10711 31 : sym->attr.dimension = target->rank ? 1 : 0;
10712 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10713 : target->corank);
10714 31 : sym->as = NULL;
10715 : }
10716 283 : else if (target->ts.type == BT_DERIVED
10717 150 : && target->symtree && target->symtree->n.sym
10718 126 : && target->symtree->n.sym->ts.type == BT_CLASS
10719 0 : && IS_INFERRED_TYPE (target)
10720 0 : && target->ref && target->ref->next
10721 0 : && target->ref->next->type == REF_ARRAY
10722 0 : && !target->ref->next->next)
10723 : {
10724 : /* A inferred type selector whose symbol has been determined to be
10725 : a class array but which only has an array reference. Change the
10726 : associate name and the selector to class type. */
10727 0 : sym->ts = target->ts;
10728 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10729 0 : sym->attr.dimension = target->rank ? 1 : 0;
10730 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10731 : target->corank);
10732 0 : sym->as = NULL;
10733 0 : target->ts = sym->ts;
10734 : }
10735 283 : else if ((target->ts.type == BT_DERIVED)
10736 133 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10737 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10738 : /* Confirmed to be either a derived type or misidentified to be a
10739 : scalar class object, when the selector is a class array. */
10740 156 : sym->ts = target->ts;
10741 127 : else if (sym->assoc->inferred_type
10742 120 : && (sym->ts.type == BT_COMPLEX
10743 78 : || sym->ts.type == BT_CHARACTER)
10744 66 : && target->ts.type == sym->ts.type
10745 66 : && sym->ts.kind != target->ts.kind)
10746 : /* The inferred type was set from a %re, %im or %len inquiry on
10747 : the associate name with the default kind, before the target's
10748 : actual type was known. Now that the target has been resolved,
10749 : update the kind to match. */
10750 6 : sym->ts = target->ts;
10751 : }
10752 :
10753 :
10754 7796 : if (target->expr_type == EXPR_NULL)
10755 : {
10756 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10757 1 : return;
10758 : }
10759 7795 : else if (target->ts.type == BT_UNKNOWN)
10760 : {
10761 2 : gfc_error ("Selector at %L has no type", &target->where);
10762 2 : return;
10763 : }
10764 :
10765 : /* Get type if this was not already set. Note that it can be
10766 : some other type than the target in case this is a SELECT TYPE
10767 : selector! So we must not update when the type is already there. */
10768 7793 : if (sym->ts.type == BT_UNKNOWN)
10769 259 : sym->ts = target->ts;
10770 :
10771 7793 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10772 :
10773 : /* See if this is a valid association-to-variable. */
10774 15586 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10775 6747 : && !parentheses
10776 6726 : && !gfc_has_vector_subscript (target))
10777 7841 : || gfc_is_ptr_fcn (target));
10778 :
10779 : /* Finally resolve if this is an array or not. */
10780 7793 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10781 237 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10782 : {
10783 142 : gfc_expression_rank (target);
10784 142 : if (target->ts.type == BT_DERIVED
10785 95 : && !sym->as
10786 95 : && target->symtree->n.sym->as)
10787 : {
10788 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10789 0 : sym->attr.dimension = 1;
10790 : }
10791 142 : else if (target->ts.type == BT_CLASS
10792 47 : && CLASS_DATA (target)->as)
10793 : {
10794 0 : target->rank = CLASS_DATA (target)->as->rank;
10795 0 : target->corank = CLASS_DATA (target)->as->corank;
10796 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10797 : {
10798 0 : sym->ts = target->ts;
10799 0 : sym->attr.dimension = 0;
10800 : }
10801 : }
10802 : }
10803 :
10804 :
10805 7793 : if (sym->attr.dimension && target->rank == 0)
10806 : {
10807 : /* primary.cc makes the assumption that a reference to an associate
10808 : name followed by a left parenthesis is an array reference. */
10809 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10810 : {
10811 12 : gfc_expression_rank (sym->assoc->target);
10812 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10813 12 : if (!sym->attr.dimension && sym->as)
10814 0 : sym->as = NULL;
10815 : }
10816 :
10817 17 : if (sym->attr.dimension && target->rank == 0)
10818 : {
10819 5 : if (sym->ts.type != BT_CHARACTER)
10820 5 : gfc_error ("Associate-name %qs at %L is used as array",
10821 : sym->name, &sym->declared_at);
10822 5 : sym->attr.dimension = 0;
10823 5 : return;
10824 : }
10825 : }
10826 :
10827 : /* We cannot deal with class selectors that need temporaries. */
10828 7788 : if (target->ts.type == BT_CLASS
10829 7788 : && gfc_ref_needs_temporary_p (target->ref))
10830 : {
10831 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10832 : "yet implemented", &target->where);
10833 1 : return;
10834 : }
10835 :
10836 7787 : if (target->ts.type == BT_CLASS)
10837 2848 : gfc_fix_class_refs (target);
10838 :
10839 7787 : if ((target->rank > 0 || target->corank > 0)
10840 2766 : && !sym->attr.select_rank_temporary)
10841 : {
10842 2766 : gfc_array_spec *as;
10843 : /* The rank may be incorrectly guessed at parsing, therefore make sure
10844 : it is corrected now. */
10845 2766 : if (sym->ts.type != BT_CLASS
10846 2175 : && (!sym->as || sym->as->corank != target->corank))
10847 : {
10848 135 : if (!sym->as)
10849 128 : sym->as = gfc_get_array_spec ();
10850 135 : as = sym->as;
10851 135 : as->rank = target->rank;
10852 135 : as->type = AS_DEFERRED;
10853 135 : as->corank = target->corank;
10854 135 : sym->attr.dimension = 1;
10855 135 : if (as->corank != 0)
10856 7 : sym->attr.codimension = 1;
10857 : }
10858 2631 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10859 590 : && (!CLASS_DATA (sym)->as
10860 590 : || CLASS_DATA (sym)->as->corank != target->corank))
10861 : {
10862 0 : if (!CLASS_DATA (sym)->as)
10863 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10864 0 : as = CLASS_DATA (sym)->as;
10865 0 : as->rank = target->rank;
10866 0 : as->type = AS_DEFERRED;
10867 0 : as->corank = target->corank;
10868 0 : CLASS_DATA (sym)->attr.dimension = 1;
10869 0 : if (as->corank != 0)
10870 0 : CLASS_DATA (sym)->attr.codimension = 1;
10871 : }
10872 : }
10873 5021 : else if (!sym->attr.select_rank_temporary)
10874 : {
10875 : /* target's rank is 0, but the type of the sym is still array valued,
10876 : which has to be corrected. */
10877 3608 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10878 730 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10879 : {
10880 24 : gfc_array_spec *as;
10881 24 : symbol_attribute attr;
10882 : /* The associated variable's type is still the array type
10883 : correct this now. */
10884 24 : gfc_typespec *ts = &target->ts;
10885 24 : gfc_ref *ref;
10886 : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10887 : */
10888 24 : bool internal_ref = true;
10889 :
10890 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10891 : {
10892 48 : switch (ref->type)
10893 : {
10894 24 : case REF_COMPONENT:
10895 24 : ts = &ref->u.c.component->ts;
10896 24 : internal_ref
10897 24 : = target->ref == ref && ref->next
10898 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10899 : break;
10900 24 : case REF_ARRAY:
10901 24 : if (ts->type == BT_CLASS)
10902 0 : ts = &ts->u.derived->components->ts;
10903 24 : if (internal_ref && ref->u.ar.codimen > 0)
10904 0 : for (int i = ref->u.ar.dimen;
10905 : internal_ref
10906 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
10907 : ++i)
10908 0 : internal_ref
10909 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
10910 : break;
10911 : default:
10912 : break;
10913 : }
10914 : }
10915 : /* Only rewrite the type of this symbol, when the refs are not the
10916 : internal ones for class and co-array this-image. */
10917 24 : if (!internal_ref)
10918 : {
10919 : /* Create a scalar instance of the current class type. Because
10920 : the rank of a class array goes into its name, the type has to
10921 : be rebuilt. The alternative of (re-)setting just the
10922 : attributes and as in the current type, destroys the type also
10923 : in other places. */
10924 0 : as = NULL;
10925 0 : sym->ts = *ts;
10926 0 : sym->ts.type = BT_CLASS;
10927 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10928 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
10929 0 : sym->as = NULL;
10930 : }
10931 : }
10932 : }
10933 :
10934 : /* Mark this as an associate variable. */
10935 7787 : sym->attr.associate_var = 1;
10936 :
10937 : /* Fix up the type-spec for CHARACTER types. */
10938 7787 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
10939 : {
10940 527 : gfc_ref *ref;
10941 812 : for (ref = target->ref; ref; ref = ref->next)
10942 311 : if (ref->type == REF_SUBSTRING
10943 74 : && (ref->u.ss.start == NULL
10944 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
10945 74 : || ref->u.ss.end == NULL
10946 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
10947 : break;
10948 :
10949 527 : if (!sym->ts.u.cl)
10950 182 : sym->ts.u.cl = target->ts.u.cl;
10951 :
10952 527 : if (sym->ts.deferred
10953 195 : && sym->ts.u.cl == target->ts.u.cl)
10954 : {
10955 116 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10956 116 : sym->ts.deferred = 1;
10957 : }
10958 :
10959 527 : if (!sym->ts.u.cl->length
10960 333 : && !sym->ts.deferred
10961 138 : && target->expr_type == EXPR_CONSTANT)
10962 : {
10963 30 : sym->ts.u.cl->length =
10964 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
10965 30 : target->value.character.length);
10966 : }
10967 497 : else if (((!sym->ts.u.cl->length
10968 194 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10969 309 : && target->expr_type != EXPR_VARIABLE)
10970 368 : || ref)
10971 : {
10972 155 : if (!sym->ts.deferred)
10973 : {
10974 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10975 45 : sym->ts.deferred = 1;
10976 : }
10977 :
10978 : /* This is reset in trans-stmt.cc after the assignment
10979 : of the target expression to the associate name. */
10980 155 : if (ref && sym->as)
10981 26 : sym->attr.pointer = 1;
10982 : else
10983 129 : sym->attr.allocatable = 1;
10984 : }
10985 : }
10986 :
10987 7787 : if (sym->ts.type == BT_CLASS
10988 1466 : && IS_INFERRED_TYPE (target)
10989 13 : && target->ts.type == BT_DERIVED
10990 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
10991 0 : && target->ref && target->ref->next && !target->ref->next->next
10992 0 : && target->ref->next->type == REF_ARRAY)
10993 0 : target->ts = target->symtree->n.sym->ts;
10994 :
10995 : /* If the target is a good class object, so is the associate variable. */
10996 7787 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
10997 731 : sym->attr.class_ok = 1;
10998 :
10999 : /* If the target is a contiguous pointer, so is the associate variable. */
11000 7787 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
11001 3 : sym->attr.contiguous = 1;
11002 : }
11003 :
11004 :
11005 : /* Ensure that SELECT TYPE expressions have the correct rank and a full
11006 : array reference, where necessary. The symbols are artificial and so
11007 : the dimension attribute and arrayspec can also be set. In addition,
11008 : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
11009 : This is corrected here as well.*/
11010 :
11011 : static void
11012 1719 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
11013 : gfc_ref *ref)
11014 : {
11015 1719 : gfc_ref *nref = (*expr1)->ref;
11016 1719 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
11017 1719 : gfc_symbol *sym2;
11018 1719 : gfc_expr *selector = gfc_copy_expr (expr2);
11019 :
11020 1719 : (*expr1)->rank = rank;
11021 1719 : (*expr1)->corank = corank;
11022 1719 : if (selector)
11023 : {
11024 324 : gfc_resolve_expr (selector);
11025 324 : if (selector->expr_type == EXPR_OP
11026 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
11027 2 : sym2 = selector->value.op.op1->symtree->n.sym;
11028 322 : else if (selector->expr_type == EXPR_VARIABLE
11029 7 : || selector->expr_type == EXPR_FUNCTION)
11030 322 : sym2 = selector->symtree->n.sym;
11031 : else
11032 0 : gcc_unreachable ();
11033 : }
11034 : else
11035 : sym2 = NULL;
11036 :
11037 1719 : if (sym1->ts.type == BT_CLASS)
11038 : {
11039 1719 : if ((*expr1)->ts.type != BT_CLASS)
11040 13 : (*expr1)->ts = sym1->ts;
11041 :
11042 1719 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
11043 1719 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
11044 1719 : if (CLASS_DATA (sym1)->as == NULL && sym2)
11045 1 : CLASS_DATA (sym1)->as
11046 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
11047 : }
11048 : else
11049 : {
11050 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
11051 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
11052 0 : if (sym1->as == NULL && sym2)
11053 0 : sym1->as = gfc_copy_array_spec (sym2->as);
11054 : }
11055 :
11056 3108 : for (; nref; nref = nref->next)
11057 2784 : if (nref->next == NULL)
11058 : break;
11059 :
11060 1719 : if (ref && nref && nref->type != REF_ARRAY)
11061 6 : nref->next = gfc_copy_ref (ref);
11062 1713 : else if (ref && !nref)
11063 315 : (*expr1)->ref = gfc_copy_ref (ref);
11064 1398 : else if (ref && nref->u.ar.codimen != corank)
11065 : {
11066 976 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
11067 915 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
11068 61 : nref->u.ar.codimen = corank;
11069 : }
11070 1719 : }
11071 :
11072 :
11073 : static gfc_expr *
11074 6856 : build_loc_call (gfc_expr *sym_expr)
11075 : {
11076 6856 : gfc_expr *loc_call;
11077 6856 : loc_call = gfc_get_expr ();
11078 6856 : loc_call->expr_type = EXPR_FUNCTION;
11079 6856 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
11080 6856 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
11081 6856 : loc_call->symtree->n.sym->attr.intrinsic = 1;
11082 6856 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
11083 6856 : gfc_commit_symbol (loc_call->symtree->n.sym);
11084 6856 : loc_call->ts.type = BT_INTEGER;
11085 6856 : loc_call->ts.kind = gfc_index_integer_kind;
11086 6856 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
11087 6856 : loc_call->value.function.actual = gfc_get_actual_arglist ();
11088 6856 : loc_call->value.function.actual->expr = sym_expr;
11089 6856 : loc_call->where = sym_expr->where;
11090 6856 : return loc_call;
11091 : }
11092 :
11093 : /* Resolve a SELECT TYPE statement. */
11094 :
11095 : static void
11096 3081 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
11097 : {
11098 3081 : gfc_symbol *selector_type;
11099 3081 : gfc_code *body, *new_st, *if_st, *tail;
11100 3081 : gfc_code *class_is = NULL, *default_case = NULL;
11101 3081 : gfc_case *c;
11102 3081 : gfc_symtree *st;
11103 3081 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
11104 3081 : gfc_namespace *ns;
11105 3081 : int error = 0;
11106 3081 : int rank = 0, corank = 0;
11107 3081 : gfc_ref* ref = NULL;
11108 3081 : gfc_expr *selector_expr = NULL;
11109 3081 : gfc_code *old_code = code;
11110 :
11111 3081 : ns = code->ext.block.ns;
11112 3081 : if (code->expr2)
11113 : {
11114 : /* Set this, or coarray checks in resolve will fail. */
11115 670 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
11116 : }
11117 3081 : gfc_resolve (ns);
11118 :
11119 : /* Check for F03:C813. */
11120 3081 : if (code->expr1->ts.type != BT_CLASS
11121 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
11122 : {
11123 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
11124 : "at %L", &code->loc);
11125 42 : return;
11126 : }
11127 :
11128 : /* Prevent segfault, when class type is not initialized due to previous
11129 : error. */
11130 3068 : if (!code->expr1->symtree->n.sym->attr.class_ok
11131 3066 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
11132 : return;
11133 :
11134 3061 : if (code->expr2)
11135 : {
11136 661 : gfc_ref *ref2 = NULL;
11137 1532 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
11138 871 : if (ref->type == REF_COMPONENT
11139 447 : && ref->u.c.component->ts.type == BT_CLASS)
11140 871 : ref2 = ref;
11141 :
11142 661 : if (ref2)
11143 : {
11144 353 : if (code->expr1->symtree->n.sym->attr.untyped)
11145 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
11146 353 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
11147 : }
11148 : else
11149 : {
11150 308 : if (code->expr1->symtree->n.sym->attr.untyped)
11151 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
11152 : /* Sometimes the selector expression is given the typespec of the
11153 : '_data' field, which is logical enough but inappropriate here. */
11154 308 : if (code->expr2->ts.type == BT_DERIVED
11155 73 : && code->expr2->symtree
11156 73 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
11157 73 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
11158 308 : selector_type = CLASS_DATA (code->expr2)
11159 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
11160 : }
11161 :
11162 661 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
11163 : {
11164 310 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
11165 310 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
11166 310 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
11167 : }
11168 :
11169 : /* F2008: C803 The selector expression must not be coindexed. */
11170 661 : if (gfc_is_coindexed (code->expr2))
11171 : {
11172 4 : gfc_error ("Selector at %L must not be coindexed",
11173 4 : &code->expr2->where);
11174 4 : return;
11175 : }
11176 :
11177 : }
11178 : else
11179 : {
11180 2400 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
11181 :
11182 2400 : if (gfc_is_coindexed (code->expr1))
11183 : {
11184 0 : gfc_error ("Selector at %L must not be coindexed",
11185 0 : &code->expr1->where);
11186 0 : return;
11187 : }
11188 : }
11189 :
11190 : /* Loop over TYPE IS / CLASS IS cases. */
11191 8513 : for (body = code->block; body; body = body->block)
11192 : {
11193 5457 : c = body->ext.block.case_list;
11194 :
11195 5457 : if (!error)
11196 : {
11197 : /* Check for repeated cases. */
11198 8452 : for (tail = code->block; tail; tail = tail->block)
11199 : {
11200 8452 : gfc_case *d = tail->ext.block.case_list;
11201 8452 : if (tail == body)
11202 : break;
11203 :
11204 3004 : if (c->ts.type == d->ts.type
11205 516 : && ((c->ts.type == BT_DERIVED
11206 418 : && c->ts.u.derived && d->ts.u.derived
11207 418 : && !strcmp (c->ts.u.derived->name,
11208 : d->ts.u.derived->name))
11209 515 : || c->ts.type == BT_UNKNOWN
11210 515 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11211 55 : && c->ts.kind == d->ts.kind)))
11212 : {
11213 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11214 : &c->where, &d->where);
11215 1 : return;
11216 : }
11217 : }
11218 : }
11219 :
11220 : /* Check F03:C815. */
11221 3448 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11222 2358 : && selector_type
11223 2358 : && !selector_type->attr.unlimited_polymorphic
11224 7491 : && !gfc_type_is_extensible (c->ts.u.derived))
11225 : {
11226 1 : gfc_error ("Derived type %qs at %L must be extensible",
11227 1 : c->ts.u.derived->name, &c->where);
11228 1 : error++;
11229 1 : continue;
11230 : }
11231 :
11232 : /* Check F03:C816. */
11233 5461 : if (c->ts.type != BT_UNKNOWN
11234 3815 : && selector_type && !selector_type->attr.unlimited_polymorphic
11235 7493 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11236 2034 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11237 : {
11238 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11239 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11240 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11241 : else
11242 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11243 : gfc_basic_typename (c->ts.type), &c->where);
11244 6 : error++;
11245 6 : continue;
11246 : }
11247 :
11248 : /* Check F03:C814. */
11249 5449 : if (c->ts.type == BT_CHARACTER
11250 742 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11251 : {
11252 0 : gfc_error ("The type-spec at %L shall specify that each length "
11253 : "type parameter is assumed", &c->where);
11254 0 : error++;
11255 0 : continue;
11256 : }
11257 :
11258 : /* Intercept the DEFAULT case. */
11259 5449 : if (c->ts.type == BT_UNKNOWN)
11260 : {
11261 : /* Check F03:C818. */
11262 1640 : if (default_case)
11263 : {
11264 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11265 : "by a second DEFAULT CASE at %L",
11266 1 : &default_case->ext.block.case_list->where, &c->where);
11267 1 : error++;
11268 1 : continue;
11269 : }
11270 :
11271 : default_case = body;
11272 : }
11273 : }
11274 :
11275 3056 : if (error > 0)
11276 : return;
11277 :
11278 : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11279 : target if present. If there are any EXIT statements referring to the
11280 : SELECT TYPE construct, this is no problem because the gfc_code
11281 : reference stays the same and EXIT is equally possible from the BLOCK
11282 : it is changed to. */
11283 3053 : code->op = EXEC_BLOCK;
11284 3053 : if (code->expr2)
11285 : {
11286 657 : gfc_association_list* assoc;
11287 :
11288 657 : assoc = gfc_get_association_list ();
11289 657 : assoc->st = code->expr1->symtree;
11290 657 : assoc->target = gfc_copy_expr (code->expr2);
11291 657 : assoc->target->where = code->expr2->where;
11292 : /* assoc->variable will be set by resolve_assoc_var. */
11293 :
11294 657 : code->ext.block.assoc = assoc;
11295 657 : code->expr1->symtree->n.sym->assoc = assoc;
11296 :
11297 657 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11298 : }
11299 : else
11300 2396 : code->ext.block.assoc = NULL;
11301 :
11302 : /* Ensure that the selector rank and arrayspec are available to
11303 : correct expressions in which they might be missing. */
11304 3053 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11305 : {
11306 324 : rank = code->expr2->rank;
11307 324 : corank = code->expr2->corank;
11308 608 : for (ref = code->expr2->ref; ref; ref = ref->next)
11309 599 : if (ref->next == NULL)
11310 : break;
11311 324 : if (ref && ref->type == REF_ARRAY)
11312 315 : ref = gfc_copy_ref (ref);
11313 :
11314 : /* Fixup expr1 if necessary. */
11315 324 : if (rank || corank)
11316 324 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11317 : }
11318 2729 : else if (code->expr1->rank || code->expr1->corank)
11319 : {
11320 892 : rank = code->expr1->rank;
11321 892 : corank = code->expr1->corank;
11322 892 : for (ref = code->expr1->ref; ref; ref = ref->next)
11323 892 : if (ref->next == NULL)
11324 : break;
11325 892 : if (ref && ref->type == REF_ARRAY)
11326 892 : ref = gfc_copy_ref (ref);
11327 : }
11328 :
11329 3053 : gfc_expr *orig_expr1 = code->expr1;
11330 :
11331 : /* Add EXEC_SELECT to switch on type. */
11332 3053 : new_st = gfc_get_code (code->op);
11333 3053 : new_st->expr1 = code->expr1;
11334 3053 : new_st->expr2 = code->expr2;
11335 3053 : new_st->block = code->block;
11336 3053 : code->expr1 = code->expr2 = NULL;
11337 3053 : code->block = NULL;
11338 3053 : if (!ns->code)
11339 3053 : ns->code = new_st;
11340 : else
11341 0 : ns->code->next = new_st;
11342 3053 : code = new_st;
11343 3053 : code->op = EXEC_SELECT_TYPE;
11344 :
11345 : /* Use the intrinsic LOC function to generate an integer expression
11346 : for the vtable of the selector. Note that the rank of the selector
11347 : expression has to be set to zero. */
11348 3053 : gfc_add_vptr_component (code->expr1);
11349 3053 : code->expr1->rank = 0;
11350 3053 : code->expr1->corank = 0;
11351 3053 : code->expr1 = build_loc_call (code->expr1);
11352 3053 : selector_expr = code->expr1->value.function.actual->expr;
11353 :
11354 : /* Loop over TYPE IS / CLASS IS cases. */
11355 8494 : for (body = code->block; body; body = body->block)
11356 : {
11357 5441 : gfc_symbol *vtab;
11358 5441 : c = body->ext.block.case_list;
11359 :
11360 : /* Generate an index integer expression for address of the
11361 : TYPE/CLASS vtable and store it in c->low. The hash expression
11362 : is stored in c->high and is used to resolve intrinsic cases. */
11363 5441 : if (c->ts.type != BT_UNKNOWN)
11364 : {
11365 3803 : gfc_expr *e;
11366 3803 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11367 : {
11368 2349 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11369 2349 : gcc_assert (vtab);
11370 2349 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11371 2349 : c->ts.u.derived->hash_value);
11372 : }
11373 : else
11374 : {
11375 1454 : vtab = gfc_find_vtab (&c->ts);
11376 1454 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11377 1454 : e = CLASS_DATA (vtab)->initializer;
11378 1454 : c->high = gfc_copy_expr (e);
11379 1454 : if (c->high->ts.kind != gfc_integer_4_kind)
11380 : {
11381 1 : gfc_typespec ts;
11382 1 : ts.kind = gfc_integer_4_kind;
11383 1 : ts.type = BT_INTEGER;
11384 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11385 : }
11386 : }
11387 :
11388 3803 : e = gfc_lval_expr_from_sym (vtab);
11389 3803 : c->low = build_loc_call (e);
11390 : }
11391 : else
11392 1638 : continue;
11393 :
11394 : /* Associate temporary to selector. This should only be done
11395 : when this case is actually true, so build a new ASSOCIATE
11396 : that does precisely this here (instead of using the
11397 : 'global' one). */
11398 :
11399 : /* First check the derived type import status. */
11400 3803 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11401 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11402 : {
11403 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11404 6 : c->ts.u.derived->name);
11405 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11406 : gfc_current_ns))
11407 6 : error++;
11408 : }
11409 :
11410 3803 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11411 3803 : if (c->ts.type == BT_CLASS)
11412 348 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11413 348 : c->ts.u.derived->name, var_name);
11414 3455 : else if (c->ts.type == BT_DERIVED)
11415 2001 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11416 2001 : c->ts.u.derived->name, var_name);
11417 1454 : else if (c->ts.type == BT_CHARACTER)
11418 : {
11419 742 : HOST_WIDE_INT charlen = 0;
11420 742 : if (c->ts.u.cl && c->ts.u.cl->length
11421 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11422 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11423 742 : snprintf (name, sizeof (name),
11424 : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11425 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11426 : var_name);
11427 : }
11428 : else
11429 712 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11430 : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11431 :
11432 3803 : st = gfc_find_symtree (ns->sym_root, name);
11433 3803 : gcc_assert (st->n.sym->assoc);
11434 3803 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11435 3803 : st->n.sym->assoc->target->where = selector_expr->where;
11436 3803 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11437 : {
11438 3455 : gfc_add_data_component (st->n.sym->assoc->target);
11439 : /* Fixup the target expression if necessary. */
11440 3455 : if (rank || corank)
11441 1395 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11442 : ref);
11443 : }
11444 :
11445 3803 : new_st = gfc_get_code (EXEC_BLOCK);
11446 3803 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11447 3803 : new_st->ext.block.ns->code = body->next;
11448 3803 : body->next = new_st;
11449 :
11450 : /* Chain in the new list only if it is marked as dangling. Otherwise
11451 : there is a CASE label overlap and this is already used. Just ignore,
11452 : the error is diagnosed elsewhere. */
11453 3803 : if (st->n.sym->assoc->dangling)
11454 : {
11455 3802 : new_st->ext.block.assoc = st->n.sym->assoc;
11456 3802 : st->n.sym->assoc->dangling = 0;
11457 : }
11458 :
11459 3803 : resolve_assoc_var (st->n.sym, false);
11460 : }
11461 :
11462 : /* Take out CLASS IS cases for separate treatment. */
11463 : body = code;
11464 8494 : while (body && body->block)
11465 : {
11466 5441 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11467 : {
11468 : /* Add to class_is list. */
11469 348 : if (class_is == NULL)
11470 : {
11471 317 : class_is = body->block;
11472 317 : tail = class_is;
11473 : }
11474 : else
11475 : {
11476 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11477 31 : tail->block = body->block;
11478 31 : tail = tail->block;
11479 : }
11480 : /* Remove from EXEC_SELECT list. */
11481 348 : body->block = body->block->block;
11482 348 : tail->block = NULL;
11483 : }
11484 : else
11485 : body = body->block;
11486 : }
11487 :
11488 3053 : if (class_is)
11489 : {
11490 317 : gfc_symbol *vtab;
11491 :
11492 317 : if (!default_case)
11493 : {
11494 : /* Add a default case to hold the CLASS IS cases. */
11495 315 : for (tail = code; tail->block; tail = tail->block) ;
11496 207 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11497 207 : tail = tail->block;
11498 207 : tail->ext.block.case_list = gfc_get_case ();
11499 207 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11500 207 : tail->next = NULL;
11501 207 : default_case = tail;
11502 : }
11503 :
11504 : /* More than one CLASS IS block? */
11505 317 : if (class_is->block)
11506 : {
11507 37 : gfc_code **c1,*c2;
11508 37 : bool swapped;
11509 : /* Sort CLASS IS blocks by extension level. */
11510 36 : do
11511 : {
11512 37 : swapped = false;
11513 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11514 : {
11515 61 : c2 = (*c1)->block;
11516 : /* F03:C817 (check for doubles). */
11517 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11518 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11519 : {
11520 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11521 : "statement at %L",
11522 : &c2->ext.block.case_list->where);
11523 1 : return;
11524 : }
11525 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11526 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11527 : {
11528 : /* Swap. */
11529 24 : (*c1)->block = c2->block;
11530 24 : c2->block = *c1;
11531 24 : *c1 = c2;
11532 24 : swapped = true;
11533 : }
11534 : }
11535 : }
11536 : while (swapped);
11537 : }
11538 :
11539 : /* Generate IF chain. */
11540 316 : if_st = gfc_get_code (EXEC_IF);
11541 316 : new_st = if_st;
11542 662 : for (body = class_is; body; body = body->block)
11543 : {
11544 346 : new_st->block = gfc_get_code (EXEC_IF);
11545 346 : new_st = new_st->block;
11546 : /* Set up IF condition: Call _gfortran_is_extension_of. */
11547 346 : new_st->expr1 = gfc_get_expr ();
11548 346 : new_st->expr1->expr_type = EXPR_FUNCTION;
11549 346 : new_st->expr1->ts.type = BT_LOGICAL;
11550 346 : new_st->expr1->ts.kind = 4;
11551 346 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11552 346 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11553 346 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11554 : /* Set up arguments. */
11555 346 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11556 346 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11557 346 : new_st->expr1->value.function.actual->expr->where = code->loc;
11558 346 : new_st->expr1->where = code->loc;
11559 346 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11560 346 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11561 346 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11562 346 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11563 346 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11564 346 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11565 : /* Set up types in formal arg list. */
11566 346 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11567 346 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11568 346 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11569 346 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11570 :
11571 346 : new_st->next = body->next;
11572 : }
11573 316 : if (default_case->next)
11574 : {
11575 110 : new_st->block = gfc_get_code (EXEC_IF);
11576 110 : new_st = new_st->block;
11577 110 : new_st->next = default_case->next;
11578 : }
11579 :
11580 : /* Replace CLASS DEFAULT code by the IF chain. */
11581 316 : default_case->next = if_st;
11582 : }
11583 :
11584 : /* Resolve the internal code. This cannot be done earlier because
11585 : it requires that the sym->assoc of selectors is set already. */
11586 3052 : gfc_current_ns = ns;
11587 3052 : gfc_resolve_blocks (code->block, gfc_current_ns);
11588 3052 : gfc_current_ns = old_ns;
11589 :
11590 3052 : free (ref);
11591 : }
11592 :
11593 :
11594 : /* Resolve a SELECT RANK statement. */
11595 :
11596 : static void
11597 1036 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11598 : {
11599 1036 : gfc_namespace *ns;
11600 1036 : gfc_code *body, *new_st, *tail;
11601 1036 : gfc_case *c;
11602 1036 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11603 1036 : char name[2 * GFC_MAX_SYMBOL_LEN];
11604 1036 : gfc_symtree *st;
11605 1036 : gfc_expr *selector_expr = NULL;
11606 1036 : int case_value;
11607 1036 : HOST_WIDE_INT charlen = 0;
11608 :
11609 1036 : ns = code->ext.block.ns;
11610 1036 : gfc_resolve (ns);
11611 :
11612 1036 : code->op = EXEC_BLOCK;
11613 1036 : if (code->expr2)
11614 : {
11615 42 : gfc_association_list* assoc;
11616 :
11617 42 : assoc = gfc_get_association_list ();
11618 42 : assoc->st = code->expr1->symtree;
11619 42 : assoc->target = gfc_copy_expr (code->expr2);
11620 42 : assoc->target->where = code->expr2->where;
11621 : /* assoc->variable will be set by resolve_assoc_var. */
11622 :
11623 42 : code->ext.block.assoc = assoc;
11624 42 : code->expr1->symtree->n.sym->assoc = assoc;
11625 :
11626 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11627 : }
11628 : else
11629 994 : code->ext.block.assoc = NULL;
11630 :
11631 : /* Loop over RANK cases. Note that returning on the errors causes a
11632 : cascade of further errors because the case blocks do not compile
11633 : correctly. */
11634 3380 : for (body = code->block; body; body = body->block)
11635 : {
11636 2344 : c = body->ext.block.case_list;
11637 2344 : if (c->low)
11638 1413 : case_value = (int) mpz_get_si (c->low->value.integer);
11639 : else
11640 : case_value = -2;
11641 :
11642 : /* Check for repeated cases. */
11643 5914 : for (tail = code->block; tail; tail = tail->block)
11644 : {
11645 5914 : gfc_case *d = tail->ext.block.case_list;
11646 5914 : int case_value2;
11647 :
11648 5914 : if (tail == body)
11649 : break;
11650 :
11651 : /* Check F2018: C1153. */
11652 3570 : if (!c->low && !d->low)
11653 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11654 : &c->where, &d->where);
11655 :
11656 3570 : if (!c->low || !d->low)
11657 1277 : continue;
11658 :
11659 : /* Check F2018: C1153. */
11660 2293 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11661 2293 : if ((case_value == case_value2) && case_value == -1)
11662 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11663 : &c->where, &d->where);
11664 2292 : else if (case_value == case_value2)
11665 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11666 : case_value, &c->where, &d->where);
11667 : }
11668 :
11669 2344 : if (!c->low)
11670 931 : continue;
11671 :
11672 : /* Check F2018: C1155. */
11673 1413 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11674 1411 : || gfc_expr_attr (code->expr1).pointer))
11675 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11676 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11677 : }
11678 :
11679 : /* Add EXEC_SELECT to switch on rank. */
11680 1036 : new_st = gfc_get_code (code->op);
11681 1036 : new_st->expr1 = code->expr1;
11682 1036 : new_st->expr2 = code->expr2;
11683 1036 : new_st->block = code->block;
11684 1036 : code->expr1 = code->expr2 = NULL;
11685 1036 : code->block = NULL;
11686 1036 : if (!ns->code)
11687 1036 : ns->code = new_st;
11688 : else
11689 0 : ns->code->next = new_st;
11690 1036 : code = new_st;
11691 1036 : code->op = EXEC_SELECT_RANK;
11692 :
11693 1036 : selector_expr = code->expr1;
11694 :
11695 : /* Loop over SELECT RANK cases. */
11696 3380 : for (body = code->block; body; body = body->block)
11697 : {
11698 2344 : c = body->ext.block.case_list;
11699 2344 : int case_value;
11700 :
11701 : /* Pass on the default case. */
11702 2344 : if (c->low == NULL)
11703 931 : continue;
11704 :
11705 : /* Associate temporary to selector. This should only be done
11706 : when this case is actually true, so build a new ASSOCIATE
11707 : that does precisely this here (instead of using the
11708 : 'global' one). */
11709 1413 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11710 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11711 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11712 :
11713 1413 : if (c->ts.type == BT_CLASS)
11714 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11715 1268 : else if (c->ts.type == BT_DERIVED)
11716 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11717 1158 : else if (c->ts.type != BT_CHARACTER)
11718 599 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11719 : else
11720 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11721 : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11722 :
11723 1413 : case_value = (int) mpz_get_si (c->low->value.integer);
11724 1413 : if (case_value >= 0)
11725 1380 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11726 : else
11727 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11728 :
11729 1413 : st = gfc_find_symtree (ns->sym_root, name);
11730 1413 : gcc_assert (st->n.sym->assoc);
11731 :
11732 1413 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11733 1413 : st->n.sym->assoc->target->where = selector_expr->where;
11734 :
11735 1413 : new_st = gfc_get_code (EXEC_BLOCK);
11736 1413 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11737 1413 : new_st->ext.block.ns->code = body->next;
11738 1413 : body->next = new_st;
11739 :
11740 : /* Chain in the new list only if it is marked as dangling. Otherwise
11741 : there is a CASE label overlap and this is already used. Just ignore,
11742 : the error is diagnosed elsewhere. */
11743 1413 : if (st->n.sym->assoc->dangling)
11744 : {
11745 1411 : new_st->ext.block.assoc = st->n.sym->assoc;
11746 1411 : st->n.sym->assoc->dangling = 0;
11747 : }
11748 :
11749 1413 : resolve_assoc_var (st->n.sym, false);
11750 : }
11751 :
11752 1036 : gfc_current_ns = ns;
11753 1036 : gfc_resolve_blocks (code->block, gfc_current_ns);
11754 1036 : gfc_current_ns = old_ns;
11755 1036 : }
11756 :
11757 :
11758 : /* Resolve a transfer statement. This is making sure that:
11759 : -- a derived type being transferred has only non-pointer components
11760 : -- a derived type being transferred doesn't have private components, unless
11761 : it's being transferred from the module where the type was defined
11762 : -- we're not trying to transfer a whole assumed size array. */
11763 :
11764 : static void
11765 47611 : resolve_transfer (gfc_code *code)
11766 : {
11767 47611 : gfc_symbol *sym, *derived;
11768 47611 : gfc_ref *ref;
11769 47611 : gfc_expr *exp;
11770 47611 : bool write = false;
11771 47611 : bool formatted = false;
11772 47611 : gfc_dt *dt = code->ext.dt;
11773 47611 : gfc_symbol *dtio_sub = NULL;
11774 :
11775 47611 : exp = code->expr1;
11776 :
11777 95228 : while (exp != NULL && exp->expr_type == EXPR_OP
11778 48545 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11779 6 : exp = exp->value.op.op1;
11780 :
11781 47611 : if (exp && exp->expr_type == EXPR_NULL
11782 2 : && code->ext.dt)
11783 : {
11784 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11785 : &exp->where);
11786 2 : return;
11787 : }
11788 :
11789 47609 : if (dt && (dt->dt_io_kind->value.iokind == M_WRITE
11790 47457 : || dt->dt_io_kind->value.iokind == M_PRINT))
11791 39851 : gfc_value_used_expr (exp, VALUE_USED);
11792 :
11793 47609 : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11794 : && exp->expr_type != EXPR_FUNCTION
11795 : && exp->expr_type != EXPR_ARRAY
11796 : && exp->expr_type != EXPR_STRUCTURE))
11797 : return;
11798 :
11799 26421 : if (dt && dt->dt_io_kind->value.iokind == M_READ)
11800 : {
11801 : /* If we are reading, the variable will be changed. Note that
11802 : code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE
11803 : statement -- but in this case, we are not reading, either. */
11804 7606 : if (!gfc_check_vardef_context (exp, false, false, false,
11805 7606 : _("item in READ")))
11806 : return;
11807 :
11808 7602 : gfc_expr_set_at (exp, &exp->where, VALUE_READ);
11809 : }
11810 :
11811 26417 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11812 26417 : || exp->expr_type == EXPR_FUNCTION
11813 22020 : || exp->expr_type == EXPR_ARRAY
11814 48437 : ? &exp->ts : &exp->symtree->n.sym->ts;
11815 :
11816 : /* Go to actual component transferred. */
11817 34242 : for (ref = exp->ref; ref; ref = ref->next)
11818 7825 : if (ref->type == REF_COMPONENT)
11819 2210 : ts = &ref->u.c.component->ts;
11820 :
11821 26417 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11822 26269 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11823 : {
11824 720 : derived = ts->u.derived;
11825 :
11826 : /* Determine when to use the formatted DTIO procedure. */
11827 720 : if (dt && (dt->format_expr || dt->format_label))
11828 645 : formatted = true;
11829 :
11830 720 : write = dt->dt_io_kind->value.iokind == M_WRITE
11831 720 : || dt->dt_io_kind->value.iokind == M_PRINT;
11832 720 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11833 :
11834 720 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11835 : {
11836 450 : dt->udtio = exp;
11837 450 : sym = exp->symtree->n.sym->ns->proc_name;
11838 : /* Check to see if this is a nested DTIO call, with the
11839 : dummy as the io-list object. */
11840 450 : if (sym && sym == dtio_sub && sym->formal
11841 30 : && sym->formal->sym == exp->symtree->n.sym
11842 30 : && exp->ref == NULL)
11843 : {
11844 0 : if (!sym->attr.recursive)
11845 : {
11846 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11847 : sym->name, &sym->declared_at);
11848 0 : return;
11849 : }
11850 : }
11851 : }
11852 : }
11853 :
11854 26417 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11855 : {
11856 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11857 : "it is processed by a defined input/output procedure",
11858 : &code->loc);
11859 3 : return;
11860 : }
11861 :
11862 26414 : if (ts->type == BT_DERIVED)
11863 : {
11864 : /* Check that transferred derived type doesn't contain POINTER
11865 : components unless it is processed by a defined input/output
11866 : procedure". */
11867 688 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11868 : {
11869 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11870 : "components unless it is processed by a defined "
11871 : "input/output procedure", &code->loc);
11872 2 : return;
11873 : }
11874 :
11875 : /* F08:C935. */
11876 686 : if (ts->u.derived->attr.proc_pointer_comp)
11877 : {
11878 2 : gfc_error ("Data transfer element at %L cannot have "
11879 : "procedure pointer components", &code->loc);
11880 2 : return;
11881 : }
11882 :
11883 684 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11884 : {
11885 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11886 : "components unless it is processed by a defined "
11887 : "input/output procedure", &code->loc);
11888 6 : return;
11889 : }
11890 :
11891 : /* C_PTR and C_FUNPTR have private components which means they cannot
11892 : be printed. However, if -std=gnu and not -pedantic, allow
11893 : the component to be printed to help debugging. */
11894 678 : if (ts->u.derived->ts.f90_type == BT_VOID)
11895 : {
11896 4 : gfc_error ("Data transfer element at %L "
11897 : "cannot have PRIVATE components", &code->loc);
11898 4 : return;
11899 : }
11900 674 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11901 : {
11902 4 : gfc_error ("Data transfer element at %L cannot have "
11903 : "PRIVATE components unless it is processed by "
11904 : "a defined input/output procedure", &code->loc);
11905 4 : return;
11906 : }
11907 : }
11908 :
11909 26396 : if (exp->expr_type == EXPR_STRUCTURE)
11910 : return;
11911 :
11912 26351 : if (exp->expr_type == EXPR_ARRAY)
11913 : return;
11914 :
11915 25969 : sym = exp->symtree->n.sym;
11916 :
11917 25969 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
11918 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
11919 : {
11920 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
11921 : "an assumed-size array", &code->loc);
11922 1 : return;
11923 : }
11924 :
11925 : }
11926 :
11927 :
11928 : /*********** Toplevel code resolution subroutines ***********/
11929 :
11930 : /* Find the set of labels that are reachable from this block. We also
11931 : record the last statement in each block. */
11932 :
11933 : static void
11934 696781 : find_reachable_labels (gfc_code *block)
11935 : {
11936 696781 : gfc_code *c;
11937 :
11938 696781 : if (!block)
11939 : return;
11940 :
11941 429667 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
11942 :
11943 : /* Collect labels in this block. We don't keep those corresponding
11944 : to END {IF|SELECT}, these are checked in resolve_branch by going
11945 : up through the code_stack. */
11946 1575607 : for (c = block; c; c = c->next)
11947 : {
11948 1145940 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
11949 3662 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
11950 : }
11951 :
11952 : /* Merge with labels from parent block. */
11953 429667 : if (cs_base->prev)
11954 : {
11955 352595 : gcc_assert (cs_base->prev->reachable_labels);
11956 352595 : bitmap_ior_into (cs_base->reachable_labels,
11957 : cs_base->prev->reachable_labels);
11958 : }
11959 : }
11960 :
11961 : static void
11962 197 : resolve_lock_unlock_event (gfc_code *code)
11963 : {
11964 197 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
11965 197 : && (code->expr1->ts.type != BT_DERIVED
11966 137 : || code->expr1->expr_type != EXPR_VARIABLE
11967 137 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11968 136 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
11969 136 : || code->expr1->rank != 0
11970 181 : || (!gfc_is_coarray (code->expr1) &&
11971 46 : !gfc_is_coindexed (code->expr1))))
11972 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
11973 4 : &code->expr1->where);
11974 193 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
11975 58 : && (code->expr1->ts.type != BT_DERIVED
11976 58 : || code->expr1->expr_type != EXPR_VARIABLE
11977 58 : || code->expr1->ts.u.derived->from_intmod
11978 : != INTMOD_ISO_FORTRAN_ENV
11979 58 : || code->expr1->ts.u.derived->intmod_sym_id
11980 : != ISOFORTRAN_EVENT_TYPE
11981 58 : || code->expr1->rank != 0))
11982 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
11983 : &code->expr1->where);
11984 34 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
11985 209 : && !gfc_is_coindexed (code->expr1))
11986 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
11987 0 : &code->expr1->where);
11988 193 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
11989 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
11990 0 : "coindexed", &code->expr1->where);
11991 :
11992 : /* Check STAT. */
11993 197 : if (code->expr2
11994 54 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
11995 54 : || code->expr2->expr_type != EXPR_VARIABLE))
11996 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11997 : &code->expr2->where);
11998 :
11999 197 : if (code->expr2
12000 251 : && !gfc_check_vardef_context (code->expr2, false, false, false,
12001 54 : _("STAT variable")))
12002 : return;
12003 :
12004 : /* Check ERRMSG. */
12005 197 : if (code->expr3
12006 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
12007 2 : || code->expr3->expr_type != EXPR_VARIABLE))
12008 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12009 : &code->expr3->where);
12010 :
12011 197 : if (code->expr3
12012 199 : && !gfc_check_vardef_context (code->expr3, false, false, false,
12013 2 : _("ERRMSG variable")))
12014 : return;
12015 :
12016 : /* Check for LOCK the ACQUIRED_LOCK. */
12017 197 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12018 22 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
12019 22 : || code->expr4->expr_type != EXPR_VARIABLE))
12020 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
12021 : "variable", &code->expr4->where);
12022 :
12023 173 : if (code->op != EXEC_EVENT_WAIT && code->expr4
12024 219 : && !gfc_check_vardef_context (code->expr4, false, false, false,
12025 22 : _("ACQUIRED_LOCK variable")))
12026 : return;
12027 :
12028 : /* Check for EVENT WAIT the UNTIL_COUNT. */
12029 197 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
12030 : {
12031 36 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
12032 36 : || code->expr4->rank != 0)
12033 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
12034 0 : "expression", &code->expr4->where);
12035 : }
12036 : }
12037 :
12038 : static void
12039 294 : resolve_team_argument (gfc_expr *team)
12040 : {
12041 294 : gfc_resolve_expr (team);
12042 294 : if (team->rank != 0 || team->ts.type != BT_DERIVED
12043 287 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12044 287 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
12045 : {
12046 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
12047 : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
12048 : &team->where);
12049 : }
12050 294 : }
12051 :
12052 : static void
12053 1502 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
12054 : gfc_expr *e)
12055 : {
12056 1502 : gfc_resolve_expr (e);
12057 1502 : if (e
12058 139 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
12059 124 : || e->expr_type != EXPR_VARIABLE))
12060 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
12061 : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
12062 : exp_kind);
12063 1502 : }
12064 :
12065 : void
12066 751 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
12067 : {
12068 751 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
12069 751 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
12070 : gfc_default_character_kind,
12071 : sync_stat->errmsg);
12072 751 : }
12073 :
12074 : static void
12075 308 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
12076 : gfc_expr *e)
12077 : {
12078 308 : gfc_resolve_expr (e);
12079 308 : if (e
12080 185 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
12081 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
12082 : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
12083 308 : }
12084 :
12085 : static void
12086 154 : resolve_form_team (gfc_code *code)
12087 : {
12088 154 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
12089 : code->expr1);
12090 154 : resolve_team_argument (code->expr2);
12091 154 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
12092 : code->expr3);
12093 154 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12094 154 : }
12095 :
12096 : static void resolve_block_construct (gfc_code *);
12097 :
12098 : static void
12099 97 : resolve_change_team (gfc_code *code)
12100 : {
12101 97 : resolve_team_argument (code->expr1);
12102 97 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
12103 194 : resolve_block_construct (code);
12104 : /* Map the coarray bounds as selected. */
12105 100 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
12106 3 : if (a->ar)
12107 : {
12108 3 : gfc_array_spec *src = a->ar->as, *dst;
12109 3 : if (a->st->n.sym->ts.type == BT_CLASS)
12110 0 : dst = CLASS_DATA (a->st->n.sym)->as;
12111 : else
12112 3 : dst = a->st->n.sym->as;
12113 3 : dst->corank = src->corank;
12114 3 : dst->cotype = src->cotype;
12115 6 : for (int i = 0; i < src->corank; ++i)
12116 : {
12117 3 : dst->lower[dst->rank + i] = src->lower[i];
12118 3 : dst->upper[dst->rank + i] = src->upper[i];
12119 3 : src->lower[i] = src->upper[i] = nullptr;
12120 : }
12121 3 : gfc_free_array_spec (src);
12122 3 : free (a->ar);
12123 3 : a->ar = nullptr;
12124 3 : dst->resolved = false;
12125 3 : gfc_resolve_array_spec (dst, 0);
12126 : }
12127 97 : }
12128 :
12129 : static void
12130 43 : resolve_sync_team (gfc_code *code)
12131 : {
12132 43 : resolve_team_argument (code->expr1);
12133 43 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12134 43 : }
12135 :
12136 : static void
12137 95 : resolve_end_team (gfc_code *code)
12138 : {
12139 95 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12140 95 : }
12141 :
12142 : static void
12143 54 : resolve_critical (gfc_code *code)
12144 : {
12145 54 : gfc_symtree *symtree;
12146 54 : gfc_symbol *lock_type;
12147 54 : char name[GFC_MAX_SYMBOL_LEN];
12148 54 : static int serial = 0;
12149 :
12150 54 : gfc_resolve_sync_stat (&code->ext.sync_stat);
12151 :
12152 54 : if (flag_coarray != GFC_FCOARRAY_LIB)
12153 30 : return;
12154 :
12155 24 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12156 : GFC_PREFIX ("lock_type"));
12157 24 : if (symtree)
12158 12 : lock_type = symtree->n.sym;
12159 : else
12160 : {
12161 12 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
12162 : false) != 0)
12163 0 : gcc_unreachable ();
12164 12 : lock_type = symtree->n.sym;
12165 12 : lock_type->attr.flavor = FL_DERIVED;
12166 12 : lock_type->attr.zero_comp = 1;
12167 12 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
12168 12 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
12169 : }
12170 :
12171 24 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
12172 24 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
12173 0 : gcc_unreachable ();
12174 :
12175 24 : code->resolved_sym = symtree->n.sym;
12176 24 : symtree->n.sym->attr.flavor = FL_VARIABLE;
12177 24 : symtree->n.sym->attr.referenced = 1;
12178 24 : symtree->n.sym->attr.artificial = 1;
12179 24 : symtree->n.sym->attr.codimension = 1;
12180 24 : symtree->n.sym->ts.type = BT_DERIVED;
12181 24 : symtree->n.sym->ts.u.derived = lock_type;
12182 24 : symtree->n.sym->as = gfc_get_array_spec ();
12183 24 : symtree->n.sym->as->corank = 1;
12184 24 : symtree->n.sym->as->type = AS_EXPLICIT;
12185 24 : symtree->n.sym->as->cotype = AS_EXPLICIT;
12186 24 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
12187 : NULL, 1);
12188 24 : gfc_commit_symbols();
12189 : }
12190 :
12191 :
12192 : static void
12193 1317 : resolve_sync (gfc_code *code)
12194 : {
12195 : /* Check imageset. The * case matches expr1 == NULL. */
12196 1317 : if (code->expr1)
12197 : {
12198 71 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
12199 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
12200 : "INTEGER expression", &code->expr1->where);
12201 71 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
12202 27 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
12203 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
12204 : &code->expr1->where);
12205 70 : else if (code->expr1->expr_type == EXPR_ARRAY
12206 70 : && gfc_simplify_expr (code->expr1, 0))
12207 : {
12208 20 : gfc_constructor *cons;
12209 20 : cons = gfc_constructor_first (code->expr1->value.constructor);
12210 60 : for (; cons; cons = gfc_constructor_next (cons))
12211 20 : if (cons->expr->expr_type == EXPR_CONSTANT
12212 20 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
12213 0 : gfc_error ("Imageset argument at %L must between 1 and "
12214 : "num_images()", &cons->expr->where);
12215 : }
12216 : }
12217 :
12218 : /* Check STAT. */
12219 1317 : gfc_resolve_expr (code->expr2);
12220 1317 : if (code->expr2)
12221 : {
12222 108 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12223 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12224 : &code->expr2->where);
12225 : else
12226 107 : gfc_check_vardef_context (code->expr2, false, false, false,
12227 107 : _("STAT variable"));
12228 : }
12229 :
12230 : /* Check ERRMSG. */
12231 1317 : gfc_resolve_expr (code->expr3);
12232 1317 : if (code->expr3)
12233 : {
12234 90 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12235 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12236 : &code->expr3->where);
12237 : else
12238 86 : gfc_check_vardef_context (code->expr3, false, false, false,
12239 86 : _("ERRMSG variable"));
12240 : }
12241 1317 : }
12242 :
12243 :
12244 : /* Given a branch to a label, see if the branch is conforming.
12245 : The code node describes where the branch is located. */
12246 :
12247 : static void
12248 112045 : resolve_branch (gfc_st_label *label, gfc_code *code)
12249 : {
12250 112045 : code_stack *stack;
12251 :
12252 112045 : if (label == NULL)
12253 : return;
12254 :
12255 : /* Step one: is this a valid branching target? */
12256 :
12257 2460 : if (label->defined == ST_LABEL_UNKNOWN)
12258 : {
12259 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12260 : &code->loc);
12261 4 : return;
12262 : }
12263 :
12264 2456 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12265 : {
12266 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12267 : "for the branch statement at %L", &label->where, &code->loc);
12268 4 : return;
12269 : }
12270 :
12271 : /* Step two: make sure this branch is not a branch to itself ;-) */
12272 :
12273 2452 : if (code->here == label)
12274 : {
12275 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12276 : &code->loc);
12277 0 : return;
12278 : }
12279 :
12280 : /* Step three: See if the label is in the same block as the
12281 : branching statement. The hard work has been done by setting up
12282 : the bitmap reachable_labels. */
12283 :
12284 2452 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12285 : {
12286 : /* Check now whether there is a CRITICAL construct; if so, check
12287 : whether the label is still visible outside of the CRITICAL block,
12288 : which is invalid. */
12289 6267 : for (stack = cs_base; stack; stack = stack->prev)
12290 : {
12291 3883 : if (stack->current->op == EXEC_CRITICAL
12292 3883 : && bitmap_bit_p (stack->reachable_labels, label->value))
12293 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12294 : "label at %L", &code->loc, &label->where);
12295 3881 : else if (stack->current->op == EXEC_DO_CONCURRENT
12296 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12297 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12298 : "for label at %L", &code->loc, &label->where);
12299 3881 : else if (stack->current->op == EXEC_CHANGE_TEAM
12300 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12301 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12302 : "for label at %L", &code->loc, &label->where);
12303 : }
12304 :
12305 : return;
12306 : }
12307 :
12308 : /* Step four: If we haven't found the label in the bitmap, it may
12309 : still be the label of the END of the enclosing block, in which
12310 : case we find it by going up the code_stack. */
12311 :
12312 167 : for (stack = cs_base; stack; stack = stack->prev)
12313 : {
12314 131 : if (stack->current->next && stack->current->next->here == label)
12315 : break;
12316 101 : if (stack->current->op == EXEC_CRITICAL)
12317 : {
12318 : /* Note: A label at END CRITICAL does not leave the CRITICAL
12319 : construct as END CRITICAL is still part of it. */
12320 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12321 : " at %L", &code->loc, &label->where);
12322 2 : return;
12323 : }
12324 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12325 : {
12326 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12327 : "label at %L", &code->loc, &label->where);
12328 0 : return;
12329 : }
12330 : }
12331 :
12332 66 : if (stack)
12333 : {
12334 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12335 : return;
12336 : }
12337 :
12338 : /* The label is not in an enclosing block, so illegal. This was
12339 : allowed in Fortran 66, so we allow it as extension. No
12340 : further checks are necessary in this case. */
12341 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12342 : "as the GOTO statement at %L", &label->where,
12343 : &code->loc);
12344 36 : return;
12345 : }
12346 :
12347 :
12348 : /* Check whether EXPR1 has the same shape as EXPR2. */
12349 :
12350 : static bool
12351 1467 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12352 : {
12353 1467 : mpz_t shape[GFC_MAX_DIMENSIONS];
12354 1467 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12355 1467 : bool result = false;
12356 1467 : int i;
12357 :
12358 : /* Compare the rank. */
12359 1467 : if (expr1->rank != expr2->rank)
12360 : return result;
12361 :
12362 : /* Compare the size of each dimension. */
12363 2811 : for (i=0; i<expr1->rank; i++)
12364 : {
12365 1495 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12366 151 : goto ignore;
12367 :
12368 1344 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12369 0 : goto ignore;
12370 :
12371 1344 : if (mpz_cmp (shape[i], shape2[i]))
12372 0 : goto over;
12373 : }
12374 :
12375 : /* When either of the two expression is an assumed size array, we
12376 : ignore the comparison of dimension sizes. */
12377 1316 : ignore:
12378 : result = true;
12379 :
12380 1467 : over:
12381 1467 : gfc_clear_shape (shape, i);
12382 1467 : gfc_clear_shape (shape2, i);
12383 1467 : return result;
12384 : }
12385 :
12386 :
12387 : /* Check whether a WHERE assignment target or a WHERE mask expression
12388 : has the same shape as the outermost WHERE mask expression. */
12389 :
12390 : static void
12391 509 : resolve_where (gfc_code *code, gfc_expr *mask)
12392 : {
12393 509 : gfc_code *cblock;
12394 509 : gfc_code *cnext;
12395 509 : gfc_expr *e = NULL;
12396 :
12397 509 : cblock = code->block;
12398 :
12399 : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12400 : In case of nested WHERE, only the outermost one is stored. */
12401 509 : if (mask == NULL) /* outermost WHERE */
12402 453 : e = cblock->expr1;
12403 : else /* inner WHERE */
12404 509 : e = mask;
12405 :
12406 1387 : while (cblock)
12407 : {
12408 878 : if (cblock->expr1)
12409 : {
12410 : /* Check if the mask-expr has a consistent shape with the
12411 : outermost WHERE mask-expr. */
12412 714 : if (!resolve_where_shape (cblock->expr1, e))
12413 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12414 0 : &cblock->expr1->where);
12415 : }
12416 :
12417 : /* the assignment statement of a WHERE statement, or the first
12418 : statement in where-body-construct of a WHERE construct */
12419 878 : cnext = cblock->next;
12420 1733 : while (cnext)
12421 : {
12422 855 : switch (cnext->op)
12423 : {
12424 : /* WHERE assignment statement */
12425 753 : case EXEC_ASSIGN:
12426 :
12427 : /* Check shape consistent for WHERE assignment target. */
12428 753 : if (e && !resolve_where_shape (cnext->expr1, e))
12429 0 : gfc_error ("WHERE assignment target at %L has "
12430 0 : "inconsistent shape", &cnext->expr1->where);
12431 :
12432 753 : if (cnext->op == EXEC_ASSIGN
12433 753 : && gfc_may_be_finalized (cnext->expr1->ts))
12434 0 : cnext->expr1->must_finalize = 1;
12435 :
12436 : break;
12437 :
12438 :
12439 46 : case EXEC_ASSIGN_CALL:
12440 46 : resolve_call (cnext);
12441 46 : if (!cnext->resolved_sym->attr.elemental)
12442 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12443 2 : &cnext->ext.actual->expr->where);
12444 : break;
12445 :
12446 : /* WHERE or WHERE construct is part of a where-body-construct */
12447 56 : case EXEC_WHERE:
12448 56 : resolve_where (cnext, e);
12449 56 : break;
12450 :
12451 0 : default:
12452 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12453 : &cnext->loc);
12454 : }
12455 : /* the next statement within the same where-body-construct */
12456 855 : cnext = cnext->next;
12457 : }
12458 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12459 878 : cblock = cblock->block;
12460 : }
12461 509 : }
12462 :
12463 :
12464 : /* Resolve assignment in FORALL construct.
12465 : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12466 : FORALL index variables. */
12467 :
12468 : static void
12469 2376 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12470 : {
12471 2376 : int n;
12472 2376 : gfc_symbol *forall_index;
12473 :
12474 6774 : for (n = 0; n < nvar; n++)
12475 : {
12476 4398 : forall_index = var_expr[n]->symtree->n.sym;
12477 :
12478 : /* Check whether the assignment target is one of the FORALL index
12479 : variable. */
12480 4398 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12481 4398 : && (code->expr1->symtree->n.sym == forall_index))
12482 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12483 : &code->expr1->where);
12484 : else
12485 : {
12486 : /* If one of the FORALL index variables doesn't appear in the
12487 : assignment variable, then there could be a many-to-one
12488 : assignment. Emit a warning rather than an error because the
12489 : mask could be resolving this problem.
12490 : DO NOT emit this warning for DO CONCURRENT - reduction-like
12491 : many-to-one assignments are semantically valid (formalized with
12492 : the REDUCE locality-spec in Fortran 2023). */
12493 4398 : if (!find_forall_index (code->expr1, forall_index, 0)
12494 4398 : && !gfc_do_concurrent_flag)
12495 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12496 : "left side of the assignment at %L and so might "
12497 : "cause multiple assignment to this object",
12498 0 : var_expr[n]->symtree->name, &code->expr1->where);
12499 : }
12500 : }
12501 2376 : }
12502 :
12503 :
12504 : /* Resolve WHERE statement in FORALL construct. */
12505 :
12506 : static void
12507 47 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12508 : gfc_expr **var_expr)
12509 : {
12510 47 : gfc_code *cblock;
12511 47 : gfc_code *cnext;
12512 :
12513 47 : cblock = code->block;
12514 113 : while (cblock)
12515 : {
12516 : /* the assignment statement of a WHERE statement, or the first
12517 : statement in where-body-construct of a WHERE construct */
12518 66 : cnext = cblock->next;
12519 132 : while (cnext)
12520 : {
12521 66 : switch (cnext->op)
12522 : {
12523 : /* WHERE assignment statement */
12524 66 : case EXEC_ASSIGN:
12525 66 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12526 :
12527 66 : if (cnext->op == EXEC_ASSIGN
12528 66 : && gfc_may_be_finalized (cnext->expr1->ts))
12529 0 : cnext->expr1->must_finalize = 1;
12530 :
12531 : break;
12532 :
12533 : /* WHERE operator assignment statement */
12534 0 : case EXEC_ASSIGN_CALL:
12535 0 : resolve_call (cnext);
12536 0 : if (!cnext->resolved_sym->attr.elemental)
12537 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12538 0 : &cnext->ext.actual->expr->where);
12539 : break;
12540 :
12541 : /* WHERE or WHERE construct is part of a where-body-construct */
12542 0 : case EXEC_WHERE:
12543 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12544 0 : break;
12545 :
12546 0 : default:
12547 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12548 : &cnext->loc);
12549 : }
12550 : /* the next statement within the same where-body-construct */
12551 66 : cnext = cnext->next;
12552 : }
12553 : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12554 66 : cblock = cblock->block;
12555 : }
12556 47 : }
12557 :
12558 :
12559 : /* Traverse the FORALL body to check whether the following errors exist:
12560 : 1. For assignment, check if a many-to-one assignment happens.
12561 : 2. For WHERE statement, check the WHERE body to see if there is any
12562 : many-to-one assignment. */
12563 :
12564 : static void
12565 2217 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12566 : {
12567 2217 : gfc_code *c;
12568 :
12569 2217 : c = code->block->next;
12570 4856 : while (c)
12571 : {
12572 2639 : switch (c->op)
12573 : {
12574 2310 : case EXEC_ASSIGN:
12575 2310 : case EXEC_POINTER_ASSIGN:
12576 2310 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12577 :
12578 2310 : if (c->op == EXEC_ASSIGN
12579 2310 : && gfc_may_be_finalized (c->expr1->ts))
12580 0 : c->expr1->must_finalize = 1;
12581 :
12582 : break;
12583 :
12584 0 : case EXEC_ASSIGN_CALL:
12585 0 : resolve_call (c);
12586 0 : break;
12587 :
12588 : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12589 : there is no need to handle it here. */
12590 : case EXEC_FORALL:
12591 : break;
12592 47 : case EXEC_WHERE:
12593 47 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12594 47 : break;
12595 : default:
12596 : break;
12597 : }
12598 : /* The next statement in the FORALL body. */
12599 2639 : c = c->next;
12600 : }
12601 2217 : }
12602 :
12603 :
12604 : /* Counts the number of iterators needed inside a forall construct, including
12605 : nested forall constructs. This is used to allocate the needed memory
12606 : in gfc_resolve_forall. */
12607 :
12608 : static int gfc_count_forall_iterators (gfc_code *code);
12609 :
12610 : /* Return the deepest nested FORALL/DO CONCURRENT iterator count in CODE's
12611 : next-chain, descending into block arms such as IF/ELSE branches. */
12612 :
12613 : static int
12614 2415 : gfc_max_forall_iterators_in_chain (gfc_code *code)
12615 : {
12616 2415 : int max_iters = 0;
12617 :
12618 5281 : for (gfc_code *c = code; c; c = c->next)
12619 : {
12620 2866 : int sub_iters = 0;
12621 :
12622 2866 : if (c->op == EXEC_FORALL || c->op == EXEC_DO_CONCURRENT)
12623 94 : sub_iters = gfc_count_forall_iterators (c);
12624 2772 : else if (c->op == EXEC_BLOCK)
12625 : {
12626 : /* BLOCK/ASSOCIATE bodies live in the block namespace code chain,
12627 : not in the generic c->block arm list used by IF/SELECT. */
12628 34 : if (c->ext.block.ns && c->ext.block.ns->code)
12629 34 : sub_iters = gfc_max_forall_iterators_in_chain (c->ext.block.ns->code);
12630 : }
12631 2738 : else if (c->block)
12632 307 : for (gfc_code *b = c->block; b; b = b->block)
12633 : {
12634 164 : int arm_iters = gfc_max_forall_iterators_in_chain (b->next);
12635 164 : if (arm_iters > sub_iters)
12636 : sub_iters = arm_iters;
12637 : }
12638 :
12639 2866 : if (sub_iters > max_iters)
12640 : max_iters = sub_iters;
12641 : }
12642 :
12643 2415 : return max_iters;
12644 : }
12645 :
12646 :
12647 : static int
12648 2217 : gfc_count_forall_iterators (gfc_code *code)
12649 : {
12650 2217 : int current_iters = 0;
12651 2217 : gfc_forall_iterator *fa;
12652 :
12653 2217 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12654 :
12655 6352 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12656 4135 : current_iters++;
12657 :
12658 2217 : return current_iters + gfc_max_forall_iterators_in_chain (code->block->next);
12659 : }
12660 :
12661 :
12662 : /* Given a FORALL construct.
12663 : 1) Resolve the FORALL iterator.
12664 : 2) Check for shadow index-name(s) and update code block.
12665 : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12666 :
12667 : /* Custom recursive expression walker that replaces symbols.
12668 : Visits all expressions including array subscripts. Also called from
12669 : replace_in_code_recursive to handle ASSOCIATE selector expressions. */
12670 :
12671 : static void
12672 192 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st)
12673 : {
12674 228 : if (!expr)
12675 : return;
12676 :
12677 : /* Check if this is a variable reference to replace */
12678 144 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12679 : {
12680 30 : expr->symtree = new_st;
12681 30 : expr->ts = new_st->n.sym->ts;
12682 : }
12683 :
12684 : /* Walk through reference chain (array subscripts, substrings, etc.) */
12685 150 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
12686 : {
12687 6 : if (ref->type == REF_ARRAY)
12688 : {
12689 : gfc_array_ref *ar = &ref->u.ar;
12690 12 : for (int i = 0; i < ar->dimen; i++)
12691 : {
12692 6 : replace_in_expr_recursive (ar->start[i], old_sym, new_st);
12693 6 : replace_in_expr_recursive (ar->end[i], old_sym, new_st);
12694 6 : replace_in_expr_recursive (ar->stride[i], old_sym, new_st);
12695 : }
12696 : }
12697 0 : else if (ref->type == REF_SUBSTRING)
12698 : {
12699 0 : replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st);
12700 0 : replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st);
12701 : }
12702 : }
12703 :
12704 : /* Walk through sub-expressions based on expression type */
12705 144 : switch (expr->expr_type)
12706 : {
12707 36 : case EXPR_OP:
12708 36 : replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st);
12709 36 : replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st);
12710 36 : break;
12711 :
12712 6 : case EXPR_FUNCTION:
12713 18 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
12714 12 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12715 : break;
12716 :
12717 0 : case EXPR_ARRAY:
12718 0 : case EXPR_STRUCTURE:
12719 0 : for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
12720 0 : c; c = gfc_constructor_next (c))
12721 : {
12722 0 : replace_in_expr_recursive (c->expr, old_sym, new_st);
12723 0 : if (c->iterator)
12724 : {
12725 0 : replace_in_expr_recursive (c->iterator->start, old_sym, new_st);
12726 0 : replace_in_expr_recursive (c->iterator->end, old_sym, new_st);
12727 0 : replace_in_expr_recursive (c->iterator->step, old_sym, new_st);
12728 : }
12729 : }
12730 : break;
12731 :
12732 : default:
12733 : break;
12734 : }
12735 : }
12736 :
12737 :
12738 : /* Walk code tree and replace all variable references */
12739 :
12740 : static void
12741 30 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12742 : {
12743 30 : if (!code)
12744 : return;
12745 :
12746 60 : for (gfc_code *c = code; c; c = c->next)
12747 : {
12748 : /* Replace in expressions associated with this code node */
12749 30 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12750 30 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12751 30 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12752 30 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12753 :
12754 : /* Handle special code types with additional expressions */
12755 30 : switch (c->op)
12756 : {
12757 0 : case EXEC_DO:
12758 0 : if (c->ext.iterator)
12759 : {
12760 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12761 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12762 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12763 : }
12764 : break;
12765 :
12766 0 : case EXEC_CALL:
12767 0 : case EXEC_ASSIGN_CALL:
12768 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12769 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12770 : break;
12771 :
12772 0 : case EXEC_SELECT:
12773 0 : for (gfc_code *b = c->block; b; b = b->block)
12774 : {
12775 0 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12776 : {
12777 0 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12778 0 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12779 : }
12780 0 : replace_in_code_recursive (b->next, old_sym, new_st);
12781 : }
12782 : break;
12783 :
12784 0 : case EXEC_FORALL:
12785 0 : case EXEC_DO_CONCURRENT:
12786 0 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12787 : {
12788 0 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12789 0 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12790 0 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12791 : }
12792 : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12793 : they'll be handled separately */
12794 : break;
12795 :
12796 6 : case EXEC_BLOCK:
12797 : /* Replace in ASSOCIATE selector expressions and the body.
12798 : The body of an EXEC_BLOCK lives in c->ext.block.ns->code, not
12799 : c->block->next, so without this case both selectors and body
12800 : are silently skipped, leaving shadow iterator references unreplaced
12801 : and producing wrong values at runtime. */
12802 6 : for (gfc_association_list *alist = c->ext.block.assoc;
12803 12 : alist; alist = alist->next)
12804 6 : replace_in_expr_recursive (alist->target, old_sym, new_st);
12805 6 : if (c->ext.block.ns)
12806 6 : replace_in_code_recursive (c->ext.block.ns->code, old_sym, new_st);
12807 : break;
12808 :
12809 : default:
12810 : break;
12811 : }
12812 :
12813 : /* Recurse into blocks */
12814 30 : if (c->block)
12815 0 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12816 : }
12817 : }
12818 :
12819 :
12820 : /* Replace all references to outer_sym with shadow_st in the given code. */
12821 :
12822 : static void
12823 24 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12824 : gfc_symtree *shadow_st)
12825 : {
12826 : /* Use custom recursive walker to ensure we visit ALL expressions */
12827 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12828 24 : }
12829 :
12830 :
12831 : static void
12832 2217 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12833 : {
12834 2217 : static gfc_expr **var_expr;
12835 2217 : static int total_var = 0;
12836 2217 : static int nvar = 0;
12837 2217 : int i, old_nvar, tmp;
12838 2217 : gfc_forall_iterator *fa;
12839 2217 : bool shadow = false;
12840 :
12841 2217 : old_nvar = nvar;
12842 :
12843 : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12844 2217 : if (code->op == EXEC_FORALL
12845 2217 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12846 : return;
12847 :
12848 : /* Start to resolve a FORALL construct */
12849 : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12850 : forall_save==0 means we're not nested in a FORALL in the current scope,
12851 : but nvar==0 ensures we're not nested in a parent scope either (prevents
12852 : double allocation when FORALL is nested inside DO CONCURRENT). */
12853 2217 : if (forall_save == 0 && nvar == 0)
12854 : {
12855 : /* Count the total number of FORALL indices in the nested FORALL
12856 : construct in order to allocate the VAR_EXPR with proper size. */
12857 2123 : total_var = gfc_count_forall_iterators (code);
12858 :
12859 : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12860 2123 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12861 : }
12862 :
12863 : /* The information about FORALL iterator, including FORALL indices start,
12864 : end and stride. An outer FORALL indice cannot appear in start, end or
12865 : stride. Check for a shadow index-name. */
12866 6352 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12867 : {
12868 : /* Fortran 2008: C738 (R753). */
12869 4135 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12870 : {
12871 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12872 : "of type integer", &fa->var->where);
12873 2 : continue;
12874 : }
12875 :
12876 : /* Check if any outer FORALL index name is the same as the current
12877 : one. Skip this check if the iterator is a shadow variable (from
12878 : DO CONCURRENT type spec) which may not have a symtree yet. */
12879 7144 : for (i = 0; i < nvar; i++)
12880 : {
12881 3011 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12882 3011 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12883 0 : gfc_error ("An outer FORALL construct already has an index "
12884 : "with this name %L", &fa->var->where);
12885 : }
12886 :
12887 4133 : if (fa->shadow)
12888 24 : shadow = true;
12889 :
12890 : /* Record the current FORALL index. */
12891 4133 : var_expr[nvar] = gfc_copy_expr (fa->var);
12892 :
12893 4133 : nvar++;
12894 :
12895 : /* No memory leak. */
12896 4133 : gcc_assert (nvar <= total_var);
12897 : }
12898 :
12899 : /* Need to walk the code and replace references to the index-name with
12900 : references to the shadow index-name. This must be done BEFORE resolving
12901 : the body so that resolution uses the correct shadow variables. */
12902 2217 : if (shadow)
12903 : {
12904 : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
12905 54 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12906 : {
12907 30 : if (fa->shadow)
12908 : {
12909 24 : gfc_symtree *shadow_st;
12910 24 : const char *shadow_name_str;
12911 24 : char *outer_name;
12912 :
12913 : /* fa->var now points to the shadow variable "_name". */
12914 24 : shadow_name_str = fa->var->symtree->name;
12915 24 : shadow_st = fa->var->symtree;
12916 :
12917 24 : if (shadow_name_str[0] != '_')
12918 0 : gfc_internal_error ("Expected shadow variable name to start with _");
12919 :
12920 24 : outer_name = (char *) alloca (strlen (shadow_name_str));
12921 24 : strcpy (outer_name, shadow_name_str + 1);
12922 :
12923 : /* Find the ITERATOR symbol in the current namespace.
12924 : This is the local DO CONCURRENT variable that body expressions reference. */
12925 24 : gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name);
12926 :
12927 24 : if (!iter_st)
12928 : /* No iterator variable found - this shouldn't happen */
12929 0 : continue;
12930 :
12931 24 : gfc_symbol *iter_sym = iter_st->n.sym;
12932 :
12933 : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
12934 24 : if (code->block && code->block->next)
12935 24 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
12936 : }
12937 : }
12938 : }
12939 :
12940 : /* Resolve the FORALL body. */
12941 2217 : gfc_resolve_forall_body (code, nvar, var_expr);
12942 :
12943 : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
12944 2217 : gfc_resolve_blocks (code->block, ns);
12945 :
12946 2217 : tmp = nvar;
12947 2217 : nvar = old_nvar;
12948 : /* Free only the VAR_EXPRs allocated in this frame. */
12949 6350 : for (i = nvar; i < tmp; i++)
12950 4133 : gfc_free_expr (var_expr[i]);
12951 :
12952 2217 : if (nvar == 0)
12953 : {
12954 : /* We are in the outermost FORALL construct. */
12955 2123 : gcc_assert (forall_save == 0);
12956 :
12957 : /* VAR_EXPR is not needed any more. */
12958 2123 : free (var_expr);
12959 2123 : total_var = 0;
12960 : }
12961 : }
12962 :
12963 :
12964 : /* Resolve a BLOCK construct statement. */
12965 :
12966 : static void
12967 8332 : resolve_block_construct (gfc_code* code)
12968 : {
12969 8332 : gfc_namespace *ns = code->ext.block.ns;
12970 :
12971 : /* For an ASSOCIATE block, the associations (and their targets) will be
12972 : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
12973 : namespace. */
12974 8332 : gfc_resolve (ns);
12975 0 : }
12976 :
12977 :
12978 : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
12979 : DO code nodes. */
12980 :
12981 : void
12982 334934 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
12983 : {
12984 334934 : bool t;
12985 :
12986 681404 : for (; b; b = b->block)
12987 : {
12988 346470 : t = gfc_resolve_expr (b->expr1);
12989 346470 : if (!gfc_resolve_expr (b->expr2))
12990 0 : t = false;
12991 :
12992 346470 : switch (b->op)
12993 : {
12994 239002 : case EXEC_IF:
12995 239002 : if (t && b->expr1 != NULL
12996 234679 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
12997 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12998 : &b->expr1->where);
12999 : break;
13000 :
13001 764 : case EXEC_WHERE:
13002 764 : if (t
13003 764 : && b->expr1 != NULL
13004 631 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
13005 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
13006 : &b->expr1->where);
13007 : break;
13008 :
13009 76 : case EXEC_GOTO:
13010 76 : resolve_branch (b->label1, b);
13011 76 : break;
13012 :
13013 0 : case EXEC_BLOCK:
13014 0 : resolve_block_construct (b);
13015 0 : break;
13016 :
13017 : case EXEC_SELECT:
13018 : case EXEC_SELECT_TYPE:
13019 : case EXEC_SELECT_RANK:
13020 : case EXEC_FORALL:
13021 : case EXEC_DO:
13022 : case EXEC_DO_WHILE:
13023 : case EXEC_DO_CONCURRENT:
13024 : case EXEC_CRITICAL:
13025 : case EXEC_READ:
13026 : case EXEC_WRITE:
13027 : case EXEC_IOLENGTH:
13028 : case EXEC_WAIT:
13029 : break;
13030 :
13031 2697 : case EXEC_OMP_ATOMIC:
13032 2697 : case EXEC_OACC_ATOMIC:
13033 2697 : {
13034 : /* Verify this before calling gfc_resolve_code, which might
13035 : change it. */
13036 2697 : gcc_assert (b->op == EXEC_OMP_ATOMIC
13037 : || (b->next && b->next->op == EXEC_ASSIGN));
13038 : }
13039 : break;
13040 :
13041 : case EXEC_OACC_PARALLEL_LOOP:
13042 : case EXEC_OACC_PARALLEL:
13043 : case EXEC_OACC_KERNELS_LOOP:
13044 : case EXEC_OACC_KERNELS:
13045 : case EXEC_OACC_SERIAL_LOOP:
13046 : case EXEC_OACC_SERIAL:
13047 : case EXEC_OACC_DATA:
13048 : case EXEC_OACC_HOST_DATA:
13049 : case EXEC_OACC_LOOP:
13050 : case EXEC_OACC_UPDATE:
13051 : case EXEC_OACC_WAIT:
13052 : case EXEC_OACC_CACHE:
13053 : case EXEC_OACC_ENTER_DATA:
13054 : case EXEC_OACC_EXIT_DATA:
13055 : case EXEC_OACC_ROUTINE:
13056 : case EXEC_OACC_INIT:
13057 : case EXEC_OACC_SHUTDOWN:
13058 : case EXEC_OACC_SET:
13059 : case EXEC_OMP_ALLOCATE:
13060 : case EXEC_OMP_ALLOCATORS:
13061 : case EXEC_OMP_ASSUME:
13062 : case EXEC_OMP_CRITICAL:
13063 : case EXEC_OMP_DISPATCH:
13064 : case EXEC_OMP_DISTRIBUTE:
13065 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13066 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13067 : case EXEC_OMP_DISTRIBUTE_SIMD:
13068 : case EXEC_OMP_DO:
13069 : case EXEC_OMP_DO_SIMD:
13070 : case EXEC_OMP_ERROR:
13071 : case EXEC_OMP_LOOP:
13072 : case EXEC_OMP_MASKED:
13073 : case EXEC_OMP_MASKED_TASKLOOP:
13074 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13075 : case EXEC_OMP_MASTER:
13076 : case EXEC_OMP_MASTER_TASKLOOP:
13077 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13078 : case EXEC_OMP_ORDERED:
13079 : case EXEC_OMP_PARALLEL:
13080 : case EXEC_OMP_PARALLEL_DO:
13081 : case EXEC_OMP_PARALLEL_DO_SIMD:
13082 : case EXEC_OMP_PARALLEL_LOOP:
13083 : case EXEC_OMP_PARALLEL_MASKED:
13084 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13085 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13086 : case EXEC_OMP_PARALLEL_MASTER:
13087 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13088 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13089 : case EXEC_OMP_PARALLEL_SECTIONS:
13090 : case EXEC_OMP_PARALLEL_WORKSHARE:
13091 : case EXEC_OMP_SECTIONS:
13092 : case EXEC_OMP_SIMD:
13093 : case EXEC_OMP_SCOPE:
13094 : case EXEC_OMP_SINGLE:
13095 : case EXEC_OMP_TARGET:
13096 : case EXEC_OMP_TARGET_DATA:
13097 : case EXEC_OMP_TARGET_ENTER_DATA:
13098 : case EXEC_OMP_TARGET_EXIT_DATA:
13099 : case EXEC_OMP_TARGET_PARALLEL:
13100 : case EXEC_OMP_TARGET_PARALLEL_DO:
13101 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13102 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13103 : case EXEC_OMP_TARGET_SIMD:
13104 : case EXEC_OMP_TARGET_TEAMS:
13105 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13106 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13107 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13108 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13109 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13110 : case EXEC_OMP_TARGET_UPDATE:
13111 : case EXEC_OMP_TASK:
13112 : case EXEC_OMP_TASKGROUP:
13113 : case EXEC_OMP_TASKLOOP:
13114 : case EXEC_OMP_TASKLOOP_SIMD:
13115 : case EXEC_OMP_TASKWAIT:
13116 : case EXEC_OMP_TASKYIELD:
13117 : case EXEC_OMP_TEAMS:
13118 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13119 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13120 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13121 : case EXEC_OMP_TEAMS_LOOP:
13122 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13123 : case EXEC_OMP_TILE:
13124 : case EXEC_OMP_UNROLL:
13125 : case EXEC_OMP_WORKSHARE:
13126 : break;
13127 :
13128 0 : default:
13129 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
13130 : }
13131 346470 : gfc_value_used_expr (b->expr1, VALUE_USED);
13132 346470 : gfc_value_used_expr (b->expr2, VALUE_USED);
13133 346470 : gfc_resolve_code (b->next, ns);
13134 : }
13135 334934 : }
13136 :
13137 : bool
13138 0 : caf_possible_reallocate (gfc_expr *e)
13139 : {
13140 0 : symbol_attribute caf_attr;
13141 0 : gfc_ref *last_arr_ref = nullptr;
13142 :
13143 0 : caf_attr = gfc_caf_attr (e);
13144 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
13145 : return false;
13146 :
13147 : /* Only full array refs can indicate a needed reallocation. */
13148 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
13149 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
13150 0 : last_arr_ref = ref;
13151 :
13152 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
13153 : }
13154 :
13155 : /* Does everything to resolve an ordinary assignment. Returns true
13156 : if this is an interface assignment. */
13157 : static bool
13158 287703 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
13159 : {
13160 287703 : bool rval = false;
13161 287703 : gfc_expr *lhs;
13162 287703 : gfc_expr *rhs;
13163 287703 : int n;
13164 287703 : gfc_ref *ref;
13165 287703 : symbol_attribute attr;
13166 :
13167 287703 : if (gfc_extend_assign (code, ns))
13168 : {
13169 918 : gfc_expr** rhsptr;
13170 :
13171 918 : if (code->op == EXEC_ASSIGN_CALL)
13172 : {
13173 469 : lhs = code->ext.actual->expr;
13174 469 : rhsptr = &code->ext.actual->next->expr;
13175 : }
13176 : else
13177 : {
13178 449 : gfc_actual_arglist* args;
13179 449 : gfc_typebound_proc* tbp;
13180 :
13181 449 : gcc_assert (code->op == EXEC_COMPCALL);
13182 :
13183 449 : args = code->expr1->value.compcall.actual;
13184 449 : lhs = args->expr;
13185 449 : rhsptr = &args->next->expr;
13186 :
13187 449 : tbp = code->expr1->value.compcall.tbp;
13188 449 : gcc_assert (!tbp->is_generic);
13189 : }
13190 :
13191 : /* Make a temporary rhs when there is a default initializer
13192 : and rhs is the same symbol as the lhs. */
13193 918 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
13194 507 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
13195 436 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
13196 1206 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
13197 60 : *rhsptr = gfc_get_parentheses (*rhsptr);
13198 :
13199 918 : return true;
13200 : }
13201 :
13202 286785 : lhs = code->expr1;
13203 286785 : rhs = code->expr2;
13204 :
13205 286785 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
13206 266453 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
13207 22962 : && !lhs->symtree->n.sym->attr.proc_pointer
13208 309747 : && gfc_expr_attr (lhs).proc_pointer)
13209 : {
13210 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
13211 : "pointer component",
13212 : &lhs->where);
13213 1 : return false;
13214 : }
13215 :
13216 338117 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
13217 250957 : && rhs->ts.type == BT_CHARACTER
13218 287177 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
13219 : {
13220 : /* Use of -fdec-char-conversions allows assignment of character data
13221 : to non-character variables. This not permitted for nonconstant
13222 : strings. */
13223 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
13224 : gfc_typename (lhs), &rhs->where);
13225 29 : return false;
13226 : }
13227 :
13228 286755 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
13229 : {
13230 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
13231 : gfc_typename (lhs), &rhs->where);
13232 0 : return false;
13233 : }
13234 :
13235 : /* Handle the case of a BOZ literal on the RHS. */
13236 286755 : if (rhs->ts.type == BT_BOZ)
13237 : {
13238 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
13239 : "statement value nor an actual argument of "
13240 : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
13241 : &rhs->where))
13242 : return false;
13243 :
13244 1 : switch (lhs->ts.type)
13245 : {
13246 0 : case BT_INTEGER:
13247 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
13248 : return false;
13249 : break;
13250 1 : case BT_REAL:
13251 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
13252 : return false;
13253 : break;
13254 0 : default:
13255 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13256 0 : return false;
13257 : }
13258 : }
13259 :
13260 286753 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13261 : {
13262 67 : HOST_WIDE_INT llen = 0, rlen = 0;
13263 67 : if (lhs->ts.u.cl != NULL
13264 67 : && lhs->ts.u.cl->length != NULL
13265 56 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13266 56 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13267 :
13268 67 : if (rhs->expr_type == EXPR_CONSTANT)
13269 29 : rlen = rhs->value.character.length;
13270 :
13271 38 : else if (rhs->ts.u.cl != NULL
13272 38 : && rhs->ts.u.cl->length != NULL
13273 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13274 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13275 :
13276 67 : if (rlen && llen && rlen > llen)
13277 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13278 : "CHARACTER expression will be truncated "
13279 : "in assignment (%wd/%wd) at %L",
13280 : llen, rlen, &code->loc);
13281 : }
13282 :
13283 : /* Ensure that a vector index expression for the lvalue is evaluated
13284 : to a temporary if the lvalue symbol is referenced in it. */
13285 286753 : if (lhs->rank)
13286 : {
13287 113487 : for (ref = lhs->ref; ref; ref= ref->next)
13288 60643 : if (ref->type == REF_ARRAY)
13289 : {
13290 133636 : for (n = 0; n < ref->u.ar.dimen; n++)
13291 78984 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13292 79214 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13293 230 : ref->u.ar.start[n]))
13294 14 : ref->u.ar.start[n]
13295 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13296 : }
13297 : }
13298 :
13299 286753 : if (gfc_pure (NULL))
13300 : {
13301 3549 : if (lhs->ts.type == BT_DERIVED
13302 136 : && lhs->expr_type == EXPR_VARIABLE
13303 136 : && lhs->ts.u.derived->attr.pointer_comp
13304 4 : && rhs->expr_type == EXPR_VARIABLE
13305 3552 : && (gfc_impure_variable (rhs->symtree->n.sym)
13306 2 : || gfc_is_coindexed (rhs)))
13307 : {
13308 : /* F2008, C1283. */
13309 2 : if (gfc_is_coindexed (rhs))
13310 1 : gfc_error ("Coindexed expression at %L is assigned to "
13311 : "a derived type variable with a POINTER "
13312 : "component in a PURE procedure",
13313 : &rhs->where);
13314 : else
13315 : /* F2008, C1283 (4). */
13316 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13317 : "shall not be used as the expr at %L of an intrinsic "
13318 : "assignment statement in which the variable is of a "
13319 : "derived type if the derived type has a pointer "
13320 : "component at any level of component selection.",
13321 : &rhs->where);
13322 2 : return rval;
13323 : }
13324 :
13325 : /* Fortran 2008, C1283. */
13326 3547 : if (gfc_is_coindexed (lhs))
13327 : {
13328 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13329 : "procedure", &rhs->where);
13330 1 : return rval;
13331 : }
13332 : }
13333 :
13334 286750 : if (gfc_implicit_pure (NULL))
13335 : {
13336 7365 : if (lhs->expr_type == EXPR_VARIABLE
13337 7365 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13338 5250 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13339 256 : gfc_unset_implicit_pure (NULL);
13340 :
13341 7365 : if (lhs->ts.type == BT_DERIVED
13342 353 : && lhs->expr_type == EXPR_VARIABLE
13343 353 : && lhs->ts.u.derived->attr.pointer_comp
13344 7 : && rhs->expr_type == EXPR_VARIABLE
13345 7372 : && (gfc_impure_variable (rhs->symtree->n.sym)
13346 7 : || gfc_is_coindexed (rhs)))
13347 0 : gfc_unset_implicit_pure (NULL);
13348 :
13349 : /* Fortran 2008, C1283. */
13350 7365 : if (gfc_is_coindexed (lhs))
13351 0 : gfc_unset_implicit_pure (NULL);
13352 : }
13353 :
13354 : /* F2008, 7.2.1.2. */
13355 286750 : attr = gfc_expr_attr (lhs);
13356 286750 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13357 : {
13358 987 : if (attr.codimension)
13359 : {
13360 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13361 : "permitted", &lhs->where);
13362 1 : return false;
13363 : }
13364 986 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13365 : "polymorphic variable at %L", &lhs->where))
13366 : return false;
13367 985 : if (!flag_realloc_lhs)
13368 : {
13369 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13370 : "requires %<-frealloc-lhs%>", &lhs->where);
13371 1 : return false;
13372 : }
13373 : }
13374 285763 : else if (lhs->ts.type == BT_CLASS)
13375 : {
13376 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13377 : "assignment at %L - check that there is a matching specific "
13378 : "subroutine for %<=%> operator", &lhs->where);
13379 9 : return false;
13380 : }
13381 :
13382 286738 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13383 :
13384 : /* F2008, Section 7.2.1.2. */
13385 286738 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13386 : {
13387 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13388 : "component in assignment at %L", &lhs->where);
13389 1 : return false;
13390 : }
13391 :
13392 : /* Assign the 'data' of a class object to a derived type. */
13393 286737 : if (lhs->ts.type == BT_DERIVED
13394 7345 : && rhs->ts.type == BT_CLASS
13395 168 : && (rhs->expr_type != EXPR_ARRAY
13396 162 : && rhs->expr_type != EXPR_OP))
13397 156 : gfc_add_data_component (rhs);
13398 :
13399 : /* Make sure there is a vtable and, in particular, a _copy for the
13400 : rhs type. */
13401 286737 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13402 615 : gfc_find_vtab (&rhs->ts);
13403 :
13404 286737 : gfc_check_assign (lhs, rhs, 1);
13405 :
13406 286737 : return false;
13407 : }
13408 :
13409 :
13410 : /* Add a component reference onto an expression. */
13411 :
13412 : static void
13413 665 : add_comp_ref (gfc_expr *e, gfc_component *c)
13414 : {
13415 665 : gfc_ref **ref;
13416 665 : ref = &(e->ref);
13417 889 : while (*ref)
13418 224 : ref = &((*ref)->next);
13419 665 : *ref = gfc_get_ref ();
13420 665 : (*ref)->type = REF_COMPONENT;
13421 665 : (*ref)->u.c.sym = e->ts.u.derived;
13422 665 : (*ref)->u.c.component = c;
13423 665 : e->ts = c->ts;
13424 :
13425 : /* Add a full array ref, as necessary. */
13426 665 : if (c->as)
13427 : {
13428 84 : gfc_add_full_array_ref (e, c->as);
13429 84 : e->rank = c->as->rank;
13430 84 : e->corank = c->as->corank;
13431 : }
13432 665 : }
13433 :
13434 :
13435 : /* Build an assignment. Keep the argument 'op' for future use, so that
13436 : pointer assignments can be made. */
13437 :
13438 : static gfc_code *
13439 988 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13440 : gfc_component *comp1, gfc_component *comp2, locus loc)
13441 : {
13442 988 : gfc_code *this_code;
13443 :
13444 988 : this_code = gfc_get_code (op);
13445 988 : this_code->next = NULL;
13446 988 : this_code->expr1 = gfc_copy_expr (expr1);
13447 988 : this_code->expr2 = gfc_copy_expr (expr2);
13448 988 : this_code->loc = loc;
13449 988 : if (comp1 && comp2)
13450 : {
13451 288 : add_comp_ref (this_code->expr1, comp1);
13452 288 : add_comp_ref (this_code->expr2, comp2);
13453 : }
13454 :
13455 988 : return this_code;
13456 : }
13457 :
13458 :
13459 : /* Makes a temporary variable expression based on the characteristics of
13460 : a given variable expression. If allocatable is set, the temporary is
13461 : unconditionally allocatable*/
13462 :
13463 : static gfc_expr*
13464 482 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
13465 : bool allocatable = false)
13466 : {
13467 482 : static int serial = 0;
13468 482 : char name[GFC_MAX_SYMBOL_LEN];
13469 482 : gfc_symtree *tmp;
13470 482 : gfc_array_spec *as;
13471 482 : gfc_array_ref *aref;
13472 482 : gfc_ref *ref;
13473 :
13474 482 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13475 482 : gfc_get_sym_tree (name, ns, &tmp, false);
13476 482 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13477 :
13478 482 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13479 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13480 : NULL,
13481 0 : e->value.character.length);
13482 :
13483 482 : as = NULL;
13484 482 : ref = NULL;
13485 482 : aref = NULL;
13486 :
13487 : /* Obtain the arrayspec for the temporary. */
13488 482 : if (e->rank && e->expr_type != EXPR_ARRAY
13489 : && e->expr_type != EXPR_FUNCTION
13490 : && e->expr_type != EXPR_OP)
13491 : {
13492 52 : aref = gfc_find_array_ref (e);
13493 52 : if (e->expr_type == EXPR_VARIABLE
13494 52 : && e->symtree->n.sym->as == aref->as)
13495 : as = aref->as;
13496 : else
13497 : {
13498 0 : for (ref = e->ref; ref; ref = ref->next)
13499 0 : if (ref->type == REF_COMPONENT
13500 0 : && ref->u.c.component->as == aref->as)
13501 : {
13502 : as = aref->as;
13503 : break;
13504 : }
13505 : }
13506 : }
13507 :
13508 : /* Add the attributes and the arrayspec to the temporary. */
13509 482 : tmp->n.sym->attr = gfc_expr_attr (e);
13510 482 : tmp->n.sym->attr.function = 0;
13511 482 : tmp->n.sym->attr.proc_pointer = 0;
13512 482 : tmp->n.sym->attr.result = 0;
13513 482 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13514 482 : tmp->n.sym->attr.dummy = 0;
13515 482 : tmp->n.sym->attr.use_assoc = 0;
13516 482 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13517 :
13518 :
13519 482 : if (as && !allocatable)
13520 : {
13521 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13522 52 : if (!ref)
13523 52 : ref = e->ref;
13524 52 : if (as->type == AS_DEFERRED)
13525 46 : tmp->n.sym->attr.allocatable = 1;
13526 : }
13527 430 : else if ((e->rank || e->corank)
13528 130 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13529 24 : || e->expr_type == EXPR_OP || allocatable))
13530 : {
13531 130 : tmp->n.sym->as = gfc_get_array_spec ();
13532 130 : tmp->n.sym->as->type = AS_DEFERRED;
13533 130 : tmp->n.sym->as->rank = e->rank;
13534 130 : tmp->n.sym->as->corank = e->corank;
13535 130 : tmp->n.sym->attr.allocatable = 1;
13536 130 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13537 260 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13538 : }
13539 : else
13540 300 : tmp->n.sym->attr.dimension = 0;
13541 :
13542 482 : gfc_set_sym_referenced (tmp->n.sym);
13543 482 : gfc_commit_symbol (tmp->n.sym);
13544 482 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13545 :
13546 : /* Should the lhs be a section, use its array ref for the
13547 : temporary expression. */
13548 482 : if (aref && aref->type != AR_FULL && !allocatable)
13549 : {
13550 6 : gfc_free_ref_list (e->ref);
13551 6 : e->ref = gfc_copy_ref (ref);
13552 : }
13553 482 : return e;
13554 : }
13555 :
13556 :
13557 : /* Helper function to take an argument in a subroutine call with a dependency
13558 : on another argument, copy it to an allocatable temporary and use the
13559 : temporary in the call expression. The new code is embedded in a block to
13560 : ensure local, automatic deallocation. */
13561 :
13562 : static void
13563 36 : add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,
13564 : gfc_expr **rhsptr)
13565 : {
13566 36 : gfc_namespace *block_ns;
13567 36 : gfc_expr *tmp_var;
13568 :
13569 : /* Wrap the new code in a block so that the temporary is deallocated. */
13570 36 : block_ns = gfc_build_block_ns (ns);
13571 :
13572 : /* As it stands, the block_ns does not not stand up to resolution because the
13573 : the assignment would be converted to a call and, in any case, the modified
13574 : call fails in gfc_check_conformance. */
13575 36 : block_ns->resolved = 1;
13576 :
13577 : /* Assign the original expression to the temporary. */
13578 36 : tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);
13579 72 : block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,
13580 36 : NULL, NULL, (*rhsptr)->where);
13581 :
13582 : /* Transfer the call to the block and terminate block code. */
13583 36 : *rhsptr = gfc_copy_expr (tmp_var);
13584 36 : block_ns->code->next = gfc_get_code (EXEC_NOP);
13585 36 : *(block_ns->code->next) = *code;
13586 36 : block_ns->code->next->next = NULL;
13587 :
13588 : /* Convert the original code to execute the block. */
13589 36 : code->op = EXEC_BLOCK;
13590 36 : code->ext.block.ns = block_ns;
13591 36 : code->ext.block.assoc = NULL;
13592 36 : code->expr1 = code->expr2 = NULL;
13593 36 : }
13594 :
13595 :
13596 : /* Add one line of code to the code chain, making sure that 'head' and
13597 : 'tail' are appropriately updated. */
13598 :
13599 : static void
13600 656 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13601 : {
13602 656 : gcc_assert (this_code);
13603 656 : if (*head == NULL)
13604 308 : *head = *tail = *this_code;
13605 : else
13606 348 : *tail = gfc_append_code (*tail, *this_code);
13607 656 : *this_code = NULL;
13608 656 : }
13609 :
13610 :
13611 : /* Generate a final call from a variable expression */
13612 :
13613 : static void
13614 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13615 : {
13616 81 : gfc_code *this_code;
13617 81 : gfc_expr *final_expr = NULL;
13618 81 : gfc_expr *size_expr;
13619 81 : gfc_expr *fini_coarray;
13620 :
13621 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13622 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13623 75 : return;
13624 :
13625 : /* Now generate the finalizer call. */
13626 6 : this_code = gfc_get_code (EXEC_CALL);
13627 6 : this_code->symtree = final_expr->symtree;
13628 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13629 :
13630 : //* Expression to be finalized */
13631 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13632 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13633 :
13634 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13635 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13636 6 : size_expr = gfc_get_expr ();
13637 6 : size_expr->where = gfc_current_locus;
13638 6 : size_expr->expr_type = EXPR_OP;
13639 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13640 6 : size_expr->value.op.op1
13641 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13642 : "storage_size", gfc_current_locus, 2,
13643 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13644 : gfc_get_int_expr (gfc_index_integer_kind,
13645 : NULL, 0));
13646 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13647 : gfc_character_storage_size);
13648 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13649 6 : size_expr->ts = size_expr->value.op.op1->ts;
13650 6 : this_code->ext.actual->next->expr = size_expr;
13651 :
13652 : /* fini_coarray */
13653 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13654 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13655 : &tmp_expr->where);
13656 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13657 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13658 :
13659 6 : add_code_to_chain (&this_code, head, tail);
13660 :
13661 : }
13662 :
13663 : /* Counts the potential number of part array references that would
13664 : result from resolution of typebound defined assignments. */
13665 :
13666 :
13667 : static int
13668 243 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13669 : {
13670 243 : gfc_component *c;
13671 243 : int c_depth = 0, t_depth;
13672 :
13673 584 : for (c= derived->components; c; c = c->next)
13674 : {
13675 341 : if ((!gfc_bt_struct (c->ts.type)
13676 261 : || c->attr.pointer
13677 261 : || c->attr.allocatable
13678 260 : || c->attr.proc_pointer_comp
13679 260 : || c->attr.class_pointer
13680 260 : || c->attr.proc_pointer)
13681 81 : && !c->attr.defined_assign_comp)
13682 81 : continue;
13683 :
13684 260 : if (c->as && c_depth == 0)
13685 260 : c_depth = 1;
13686 :
13687 260 : if (c->ts.u.derived->attr.defined_assign_comp)
13688 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13689 : c->as ? 1 : 0);
13690 : else
13691 : t_depth = 0;
13692 :
13693 260 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13694 : }
13695 243 : return depth + c_depth;
13696 : }
13697 :
13698 :
13699 : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13700 : "An intrinsic assignment where the variable is of derived type is performed
13701 : as if each component of the variable were assigned from the corresponding
13702 : component of expr using pointer assignment (10.2.2) for each pointer
13703 : component, defined assignment for each nonpointer nonallocatable component
13704 : of a type that has a type-bound defined assignment consistent with the
13705 : component, intrinsic assignment for each other nonpointer nonallocatable
13706 : component, and intrinsic assignment for each allocated coarray component.
13707 : For unallocated coarray components, the corresponding component of the
13708 : variable shall be unallocated. For a noncoarray allocatable component the
13709 : following sequence of operations is applied.
13710 : (1) If the component of the variable is allocated, it is deallocated.
13711 : (2) If the component of the value of expr is allocated, the
13712 : corresponding component of the variable is allocated with the same
13713 : dynamic type and type parameters as the component of the value of
13714 : expr. If it is an array, it is allocated with the same bounds. The
13715 : value of the component of the value of expr is then assigned to the
13716 : corresponding component of the variable using defined assignment if
13717 : the declared type of the component has a type-bound defined
13718 : assignment consistent with the component, and intrinsic assignment
13719 : for the dynamic type of that component otherwise."
13720 :
13721 : The pointer assignments are taken care of by the intrinsic assignment of the
13722 : structure itself. This function recursively adds defined assignments where
13723 : required. The recursion is accomplished by calling gfc_resolve_code.
13724 :
13725 : When the lhs in a defined assignment has intent INOUT or is intent OUT
13726 : and the component of 'var' is finalizable, we need a temporary for the
13727 : lhs. In pseudo-code for an assignment var = expr:
13728 :
13729 : ! Confine finalization of temporaries, as far as possible.
13730 : Enclose the code for the assignment in a block
13731 : ! Only call function 'expr' once.
13732 : #if ('expr is not a constant or an variable)
13733 : temp_expr = expr
13734 : expr = temp_x
13735 : ! Do the intrinsic assignment
13736 : #if typeof ('var') has a typebound final subroutine
13737 : finalize (var)
13738 : var = expr
13739 : ! Now do the component assignments
13740 : #do over derived type components [%cmp]
13741 : #if (cmp is a pointer of any kind)
13742 : continue
13743 : build the assignment
13744 : resolve the code
13745 : #if the code is a typebound assignment
13746 : #if (arg1 is INOUT or finalizable OUT && !t1)
13747 : t1 = var
13748 : arg1 = t1
13749 : deal with allocatation or not of var and this component
13750 : #elseif the code is an assignment by itself
13751 : #if this component does not need finalization
13752 : delete code and continue
13753 : #else
13754 : remove the leading assignment
13755 : #endif
13756 : commit the code
13757 : #if (t1 and (arg1 is INOUT or finalizable OUT))
13758 : var%cmp = t1%cmp
13759 : #enddo
13760 : put all code chunks involving t1 to the top of the generated code
13761 : insert the generated block in place of the original code
13762 : */
13763 :
13764 : static bool
13765 381 : is_finalizable_type (gfc_typespec ts)
13766 : {
13767 381 : gfc_component *c;
13768 :
13769 381 : if (ts.type != BT_DERIVED)
13770 : return false;
13771 :
13772 : /* (1) Check for FINAL subroutines. */
13773 381 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13774 : return true;
13775 :
13776 : /* (2) Check for components of finalizable type. */
13777 809 : for (c = ts.u.derived->components; c; c = c->next)
13778 470 : if (c->ts.type == BT_DERIVED
13779 243 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13780 242 : && c->ts.u.derived->f2k_derived
13781 242 : && c->ts.u.derived->f2k_derived->finalizers)
13782 : return true;
13783 :
13784 : return false;
13785 : }
13786 :
13787 : /* The temporary assignments have to be put on top of the additional
13788 : code to avoid the result being changed by the intrinsic assignment.
13789 : */
13790 : static int component_assignment_level = 0;
13791 : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13792 : static bool finalizable_comp;
13793 :
13794 : static void
13795 188 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13796 : {
13797 188 : gfc_component *comp1, *comp2;
13798 188 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13799 188 : gfc_code *tmp_code = NULL;
13800 188 : gfc_expr *t1 = NULL;
13801 188 : gfc_expr *tmp_expr = NULL;
13802 188 : int error_count, depth;
13803 188 : bool finalizable_lhs;
13804 :
13805 188 : gfc_get_errors (NULL, &error_count);
13806 :
13807 : /* Filter out continuing processing after an error. */
13808 188 : if (error_count
13809 188 : || (*code)->expr1->ts.type != BT_DERIVED
13810 188 : || (*code)->expr2->ts.type != BT_DERIVED)
13811 140 : return;
13812 :
13813 : /* TODO: Handle more than one part array reference in assignments. */
13814 188 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13815 188 : (*code)->expr1->rank ? 1 : 0);
13816 188 : if (depth > 1)
13817 : {
13818 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13819 : "done because multiple part array references would "
13820 : "occur in intermediate expressions.", &(*code)->loc);
13821 6 : return;
13822 : }
13823 :
13824 182 : if (!component_assignment_level)
13825 134 : finalizable_comp = true;
13826 :
13827 : /* Build a block so that function result temporaries are finalized
13828 : locally on exiting the rather than enclosing scope. */
13829 182 : if (!component_assignment_level)
13830 : {
13831 134 : ns = gfc_build_block_ns (ns);
13832 134 : tmp_code = gfc_get_code (EXEC_NOP);
13833 134 : *tmp_code = **code;
13834 134 : tmp_code->next = NULL;
13835 134 : (*code)->op = EXEC_BLOCK;
13836 134 : (*code)->ext.block.ns = ns;
13837 134 : (*code)->ext.block.assoc = NULL;
13838 134 : (*code)->expr1 = (*code)->expr2 = NULL;
13839 134 : ns->code = tmp_code;
13840 134 : code = &ns->code;
13841 : }
13842 :
13843 182 : component_assignment_level++;
13844 :
13845 182 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13846 :
13847 : /* Create a temporary so that functions get called only once. */
13848 182 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13849 182 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13850 : {
13851 : /* Assign the rhs to the temporary. */
13852 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13853 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13854 : {
13855 : /* Use allocate on assignment for the sake of simplicity. The
13856 : temporary must not take on the optional attribute. Assume
13857 : that the assignment is guarded by a PRESENT condition if the
13858 : lhs is optional. */
13859 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13860 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
13861 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13862 : }
13863 162 : this_code = build_assignment (EXEC_ASSIGN,
13864 : tmp_expr, (*code)->expr2,
13865 81 : NULL, NULL, (*code)->loc);
13866 81 : this_code->expr2->must_finalize = 1;
13867 : /* Add the code and substitute the rhs expression. */
13868 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13869 81 : gfc_free_expr ((*code)->expr2);
13870 81 : (*code)->expr2 = tmp_expr;
13871 : }
13872 :
13873 : /* Do the intrinsic assignment. This is not needed if the lhs is one
13874 : of the temporaries generated here, since the intrinsic assignment
13875 : to the final result already does this. */
13876 182 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
13877 : {
13878 182 : if (finalizable_lhs)
13879 18 : (*code)->expr1->must_finalize = 1;
13880 182 : this_code = build_assignment (EXEC_ASSIGN,
13881 : (*code)->expr1, (*code)->expr2,
13882 : NULL, NULL, (*code)->loc);
13883 182 : add_code_to_chain (&this_code, &head, &tail);
13884 : }
13885 :
13886 182 : comp1 = (*code)->expr1->ts.u.derived->components;
13887 182 : comp2 = (*code)->expr2->ts.u.derived->components;
13888 :
13889 449 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
13890 : {
13891 267 : bool inout = false;
13892 267 : bool finalizable_out = false;
13893 :
13894 : /* The intrinsic assignment does the right thing for pointers
13895 : of all kinds and allocatable components. */
13896 267 : if (!gfc_bt_struct (comp1->ts.type)
13897 200 : || comp1->attr.pointer
13898 200 : || comp1->attr.allocatable
13899 199 : || comp1->attr.proc_pointer_comp
13900 199 : || comp1->attr.class_pointer
13901 199 : || comp1->attr.proc_pointer)
13902 68 : continue;
13903 :
13904 398 : finalizable_comp = is_finalizable_type (comp1->ts)
13905 199 : && !finalizable_lhs;
13906 :
13907 : /* Make an assignment for this component. */
13908 398 : this_code = build_assignment (EXEC_ASSIGN,
13909 : (*code)->expr1, (*code)->expr2,
13910 199 : comp1, comp2, (*code)->loc);
13911 :
13912 : /* Convert the assignment if there is a defined assignment for
13913 : this type. Otherwise, using the call from gfc_resolve_code,
13914 : recurse into its components. */
13915 199 : gfc_resolve_code (this_code, ns);
13916 :
13917 199 : if (this_code->op == EXEC_ASSIGN_CALL)
13918 : {
13919 144 : gfc_formal_arglist *dummy_args;
13920 144 : gfc_symbol *rsym;
13921 : /* Check that there is a typebound defined assignment. If not,
13922 : then this must be a module defined assignment. We cannot
13923 : use the defined_assign_comp attribute here because it must
13924 : be this derived type that has the defined assignment and not
13925 : a parent type. */
13926 144 : if (!(comp1->ts.u.derived->f2k_derived
13927 : && comp1->ts.u.derived->f2k_derived
13928 144 : ->tb_op[INTRINSIC_ASSIGN]))
13929 : {
13930 1 : gfc_free_statements (this_code);
13931 1 : this_code = NULL;
13932 1 : continue;
13933 : }
13934 :
13935 : /* If the first argument of the subroutine has intent INOUT
13936 : a temporary must be generated and used instead. */
13937 143 : rsym = this_code->resolved_sym;
13938 143 : dummy_args = gfc_sym_get_dummy_args (rsym);
13939 268 : finalizable_out = gfc_may_be_finalized (comp1->ts)
13940 18 : && dummy_args
13941 161 : && dummy_args->sym->attr.intent == INTENT_OUT;
13942 286 : inout = dummy_args
13943 268 : && dummy_args->sym->attr.intent == INTENT_INOUT;
13944 72 : if ((inout || finalizable_out)
13945 89 : && !comp1->attr.allocatable)
13946 : {
13947 89 : gfc_code *temp_code;
13948 89 : inout = true;
13949 :
13950 : /* Build the temporary required for the assignment and put
13951 : it at the head of the generated code. */
13952 89 : if (!t1)
13953 : {
13954 89 : gfc_namespace *tmp_ns = ns;
13955 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
13956 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
13957 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
13958 89 : t1->symtree->n.sym->attr.artificial = 1;
13959 178 : temp_code = build_assignment (EXEC_ASSIGN,
13960 : t1, (*code)->expr1,
13961 89 : NULL, NULL, (*code)->loc);
13962 :
13963 : /* For allocatable LHS, check whether it is allocated. Note
13964 : that allocatable components with defined assignment are
13965 : not yet support. See PR 57696. */
13966 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
13967 : {
13968 24 : gfc_code *block;
13969 24 : gfc_expr *e =
13970 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13971 24 : block = gfc_get_code (EXEC_IF);
13972 24 : block->block = gfc_get_code (EXEC_IF);
13973 24 : block->block->expr1
13974 48 : = gfc_build_intrinsic_call (ns,
13975 : GFC_ISYM_ALLOCATED, "allocated",
13976 24 : (*code)->loc, 1, e);
13977 24 : block->block->next = temp_code;
13978 24 : temp_code = block;
13979 : }
13980 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
13981 : }
13982 :
13983 : /* Replace the first actual arg with the component of the
13984 : temporary. */
13985 89 : gfc_free_expr (this_code->ext.actual->expr);
13986 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
13987 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
13988 :
13989 : /* If the LHS variable is allocatable and wasn't allocated and
13990 : the temporary is allocatable, pointer assign the address of
13991 : the freshly allocated LHS to the temporary. */
13992 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
13993 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
13994 : {
13995 18 : gfc_code *block;
13996 18 : gfc_expr *cond;
13997 :
13998 18 : cond = gfc_get_expr ();
13999 18 : cond->ts.type = BT_LOGICAL;
14000 18 : cond->ts.kind = gfc_default_logical_kind;
14001 18 : cond->expr_type = EXPR_OP;
14002 18 : cond->where = (*code)->loc;
14003 18 : cond->value.op.op = INTRINSIC_NOT;
14004 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
14005 : GFC_ISYM_ALLOCATED, "allocated",
14006 18 : (*code)->loc, 1, gfc_copy_expr (t1));
14007 18 : block = gfc_get_code (EXEC_IF);
14008 18 : block->block = gfc_get_code (EXEC_IF);
14009 18 : block->block->expr1 = cond;
14010 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14011 : t1, (*code)->expr1,
14012 18 : NULL, NULL, (*code)->loc);
14013 18 : add_code_to_chain (&block, &head, &tail);
14014 : }
14015 : }
14016 : }
14017 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
14018 : {
14019 : /* Don't add intrinsic assignments since they are already
14020 : effected by the intrinsic assignment of the structure, unless
14021 : finalization is required. */
14022 7 : if (finalizable_comp)
14023 0 : this_code->expr1->must_finalize = 1;
14024 : else
14025 : {
14026 7 : gfc_free_statements (this_code);
14027 7 : this_code = NULL;
14028 7 : continue;
14029 : }
14030 : }
14031 : else
14032 : {
14033 : /* Resolution has expanded an assignment of a derived type with
14034 : defined assigned components. Remove the redundant, leading
14035 : assignment. */
14036 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
14037 48 : gfc_code *tmp = this_code;
14038 48 : this_code = this_code->next;
14039 48 : tmp->next = NULL;
14040 48 : gfc_free_statements (tmp);
14041 : }
14042 :
14043 191 : add_code_to_chain (&this_code, &head, &tail);
14044 :
14045 191 : if (t1 && (inout || finalizable_out))
14046 : {
14047 : /* Transfer the value to the final result. */
14048 178 : this_code = build_assignment (EXEC_ASSIGN,
14049 : (*code)->expr1, t1,
14050 89 : comp1, comp2, (*code)->loc);
14051 89 : this_code->expr1->must_finalize = 0;
14052 89 : add_code_to_chain (&this_code, &head, &tail);
14053 : }
14054 : }
14055 :
14056 : /* Put the temporary assignments at the top of the generated code. */
14057 182 : if (tmp_head && component_assignment_level == 1)
14058 : {
14059 126 : gfc_append_code (tmp_head, head);
14060 126 : head = tmp_head;
14061 126 : tmp_head = tmp_tail = NULL;
14062 : }
14063 :
14064 : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
14065 : not accidentally deallocated. Hence, nullify t1. */
14066 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
14067 271 : && gfc_expr_attr ((*code)->expr1).allocatable)
14068 : {
14069 18 : gfc_code *block;
14070 18 : gfc_expr *cond;
14071 18 : gfc_expr *e;
14072 :
14073 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
14074 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
14075 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
14076 18 : block = gfc_get_code (EXEC_IF);
14077 18 : block->block = gfc_get_code (EXEC_IF);
14078 18 : block->block->expr1 = cond;
14079 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
14080 : t1, gfc_get_null_expr (&(*code)->loc),
14081 18 : NULL, NULL, (*code)->loc);
14082 18 : gfc_append_code (tail, block);
14083 18 : tail = block;
14084 : }
14085 :
14086 182 : component_assignment_level--;
14087 :
14088 : /* Make an explicit final call for the function result. */
14089 182 : if (tmp_expr)
14090 81 : generate_final_call (tmp_expr, &head, &tail);
14091 :
14092 182 : if (tmp_code)
14093 : {
14094 134 : ns->code = head;
14095 134 : return;
14096 : }
14097 :
14098 : /* Now attach the remaining code chain to the input code. Step on
14099 : to the end of the new code since resolution is complete. */
14100 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
14101 48 : tail->next = (*code)->next;
14102 : /* Overwrite 'code' because this would place the intrinsic assignment
14103 : before the temporary for the lhs is created. */
14104 48 : gfc_free_expr ((*code)->expr1);
14105 48 : gfc_free_expr ((*code)->expr2);
14106 48 : **code = *head;
14107 48 : if (head != tail)
14108 48 : free (head);
14109 48 : *code = tail;
14110 : }
14111 :
14112 :
14113 : /* F2008: Pointer function assignments are of the form:
14114 : ptr_fcn (args) = expr
14115 : This function breaks these assignments into two statements:
14116 : temporary_pointer => ptr_fcn(args)
14117 : temporary_pointer = expr */
14118 :
14119 : static bool
14120 287947 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
14121 : {
14122 287947 : gfc_expr *tmp_ptr_expr;
14123 287947 : gfc_code *this_code;
14124 287947 : gfc_component *comp;
14125 287947 : gfc_symbol *s;
14126 :
14127 287947 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
14128 : return false;
14129 :
14130 : /* Even if standard does not support this feature, continue to build
14131 : the two statements to avoid upsetting frontend_passes.c. */
14132 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
14133 : "%L", &(*code)->loc);
14134 :
14135 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
14136 :
14137 205 : if (comp)
14138 6 : s = comp->ts.interface;
14139 : else
14140 199 : s = (*code)->expr1->symtree->n.sym;
14141 :
14142 205 : if (s == NULL || !s->result->attr.pointer)
14143 : {
14144 5 : gfc_error ("The function result on the lhs of the assignment at "
14145 : "%L must have the pointer attribute.",
14146 5 : &(*code)->expr1->where);
14147 5 : (*code)->op = EXEC_NOP;
14148 5 : return false;
14149 : }
14150 :
14151 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
14152 :
14153 : /* get_temp_from_expression is set up for ordinary assignments. To that
14154 : end, where array bounds are not known, arrays are made allocatable.
14155 : Change the temporary to a pointer here. */
14156 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
14157 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
14158 200 : tmp_ptr_expr->where = (*code)->loc;
14159 :
14160 : /* A new charlen is required to ensure that the variable string length
14161 : is different to that of the original lhs for deferred results. */
14162 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
14163 : {
14164 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
14165 60 : tmp_ptr_expr->ts.deferred = 1;
14166 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
14167 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
14168 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
14169 : }
14170 :
14171 400 : this_code = build_assignment (EXEC_ASSIGN,
14172 : tmp_ptr_expr, (*code)->expr2,
14173 200 : NULL, NULL, (*code)->loc);
14174 200 : this_code->next = (*code)->next;
14175 200 : (*code)->next = this_code;
14176 200 : (*code)->op = EXEC_POINTER_ASSIGN;
14177 200 : (*code)->expr2 = (*code)->expr1;
14178 200 : (*code)->expr1 = tmp_ptr_expr;
14179 :
14180 200 : return true;
14181 : }
14182 :
14183 :
14184 : /* Deferred character length assignments from an operator expression
14185 : require a temporary because the character length of the lhs can
14186 : change in the course of the assignment. */
14187 :
14188 : static bool
14189 286785 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
14190 : {
14191 286785 : gfc_expr *tmp_expr;
14192 286785 : gfc_code *this_code;
14193 :
14194 286785 : if (!((*code)->expr1->ts.type == BT_CHARACTER
14195 27484 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
14196 836 : && (*code)->expr2->ts.type == BT_CHARACTER
14197 835 : && (*code)->expr2->expr_type == EXPR_OP))
14198 : return false;
14199 :
14200 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
14201 : return false;
14202 :
14203 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
14204 : return false;
14205 :
14206 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
14207 22 : tmp_expr->where = (*code)->loc;
14208 :
14209 : /* A new charlen is required to ensure that the variable string
14210 : length is different to that of the original lhs. */
14211 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
14212 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
14213 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
14214 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
14215 :
14216 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
14217 :
14218 22 : this_code = build_assignment (EXEC_ASSIGN,
14219 22 : (*code)->expr1,
14220 : gfc_copy_expr (tmp_expr),
14221 : NULL, NULL, (*code)->loc);
14222 :
14223 22 : (*code)->expr1 = tmp_expr;
14224 :
14225 22 : this_code->next = (*code)->next;
14226 22 : (*code)->next = this_code;
14227 :
14228 22 : return true;
14229 : }
14230 :
14231 : static void mark_lhs_assignments_set (gfc_code *code);
14232 :
14233 : /* Given a block of code, recursively resolve everything pointed to by this
14234 : code block. */
14235 :
14236 : void
14237 696781 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
14238 : {
14239 696781 : int omp_workshare_save;
14240 696781 : int forall_save, do_concurrent_save;
14241 696781 : code_stack frame;
14242 696781 : bool t;
14243 696781 : gfc_code *orig_code = code;
14244 :
14245 696781 : frame.prev = cs_base;
14246 696781 : frame.head = code;
14247 696781 : cs_base = &frame;
14248 :
14249 696781 : find_reachable_labels (code);
14250 :
14251 1842995 : for (; code; code = code->next)
14252 : {
14253 1146215 : frame.current = code;
14254 1146215 : forall_save = forall_flag;
14255 1146215 : do_concurrent_save = gfc_do_concurrent_flag;
14256 :
14257 1146215 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
14258 : {
14259 2217 : if (code->op == EXEC_FORALL)
14260 1993 : forall_flag = 1;
14261 224 : else if (code->op == EXEC_DO_CONCURRENT)
14262 224 : gfc_do_concurrent_flag = 1;
14263 2217 : gfc_resolve_forall (code, ns, forall_save);
14264 2217 : if (code->op == EXEC_FORALL)
14265 1993 : forall_flag = 2;
14266 224 : else if (code->op == EXEC_DO_CONCURRENT)
14267 224 : gfc_do_concurrent_flag = 2;
14268 : }
14269 1143998 : else if (code->op == EXEC_OMP_METADIRECTIVE)
14270 138 : for (gfc_omp_variant *variant
14271 : = code->ext.omp_variants;
14272 448 : variant; variant = variant->next)
14273 310 : gfc_resolve_code (variant->code, ns);
14274 1143860 : else if (code->block)
14275 : {
14276 332720 : omp_workshare_save = -1;
14277 332720 : switch (code->op)
14278 : {
14279 10119 : case EXEC_OACC_PARALLEL_LOOP:
14280 10119 : case EXEC_OACC_PARALLEL:
14281 10119 : case EXEC_OACC_KERNELS_LOOP:
14282 10119 : case EXEC_OACC_KERNELS:
14283 10119 : case EXEC_OACC_SERIAL_LOOP:
14284 10119 : case EXEC_OACC_SERIAL:
14285 10119 : case EXEC_OACC_DATA:
14286 10119 : case EXEC_OACC_HOST_DATA:
14287 10119 : case EXEC_OACC_LOOP:
14288 10119 : gfc_resolve_oacc_blocks (code, ns);
14289 10119 : break;
14290 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
14291 54 : omp_workshare_save = omp_workshare_flag;
14292 54 : omp_workshare_flag = 1;
14293 54 : gfc_resolve_omp_parallel_blocks (code, ns);
14294 54 : break;
14295 6049 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14296 6049 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14297 6049 : case EXEC_OMP_MASKED_TASKLOOP:
14298 6049 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14299 6049 : case EXEC_OMP_MASTER_TASKLOOP:
14300 6049 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14301 6049 : case EXEC_OMP_PARALLEL:
14302 6049 : case EXEC_OMP_PARALLEL_DO:
14303 6049 : case EXEC_OMP_PARALLEL_DO_SIMD:
14304 6049 : case EXEC_OMP_PARALLEL_LOOP:
14305 6049 : case EXEC_OMP_PARALLEL_MASKED:
14306 6049 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14307 6049 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14308 6049 : case EXEC_OMP_PARALLEL_MASTER:
14309 6049 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14310 6049 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14311 6049 : case EXEC_OMP_PARALLEL_SECTIONS:
14312 6049 : case EXEC_OMP_TARGET_PARALLEL:
14313 6049 : case EXEC_OMP_TARGET_PARALLEL_DO:
14314 6049 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14315 6049 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14316 6049 : case EXEC_OMP_TARGET_TEAMS:
14317 6049 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14318 6049 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14319 6049 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14320 6049 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14321 6049 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14322 6049 : case EXEC_OMP_TASK:
14323 6049 : case EXEC_OMP_TASKLOOP:
14324 6049 : case EXEC_OMP_TASKLOOP_SIMD:
14325 6049 : case EXEC_OMP_TEAMS:
14326 6049 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14327 6049 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14328 6049 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14329 6049 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14330 6049 : case EXEC_OMP_TEAMS_LOOP:
14331 6049 : omp_workshare_save = omp_workshare_flag;
14332 6049 : omp_workshare_flag = 0;
14333 6049 : gfc_resolve_omp_parallel_blocks (code, ns);
14334 6049 : break;
14335 3064 : case EXEC_OMP_DISTRIBUTE:
14336 3064 : case EXEC_OMP_DISTRIBUTE_SIMD:
14337 3064 : case EXEC_OMP_DO:
14338 3064 : case EXEC_OMP_DO_SIMD:
14339 3064 : case EXEC_OMP_LOOP:
14340 3064 : case EXEC_OMP_SIMD:
14341 3064 : case EXEC_OMP_TARGET_SIMD:
14342 3064 : case EXEC_OMP_TILE:
14343 3064 : case EXEC_OMP_UNROLL:
14344 3064 : gfc_resolve_omp_do_blocks (code, ns);
14345 3064 : break;
14346 : case EXEC_SELECT_TYPE:
14347 : case EXEC_SELECT_RANK:
14348 : /* Blocks are handled in resolve_select_type/rank because we
14349 : have to transform the SELECT TYPE into ASSOCIATE first. */
14350 : break;
14351 : case EXEC_DO_CONCURRENT:
14352 : gfc_do_concurrent_flag = 1;
14353 : gfc_resolve_blocks (code->block, ns);
14354 : gfc_do_concurrent_flag = 2;
14355 : break;
14356 39 : case EXEC_OMP_WORKSHARE:
14357 39 : omp_workshare_save = omp_workshare_flag;
14358 39 : omp_workshare_flag = 1;
14359 : /* FALL THROUGH */
14360 309343 : default:
14361 309343 : gfc_resolve_blocks (code->block, ns);
14362 309343 : break;
14363 : }
14364 :
14365 328629 : if (omp_workshare_save != -1)
14366 6142 : omp_workshare_flag = omp_workshare_save;
14367 : }
14368 811140 : start:
14369 1146420 : t = true;
14370 1146420 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14371 1144989 : t = gfc_resolve_expr (code->expr1);
14372 :
14373 1146420 : forall_flag = forall_save;
14374 1146420 : gfc_do_concurrent_flag = do_concurrent_save;
14375 :
14376 1146420 : if (!gfc_resolve_expr (code->expr2))
14377 638 : t = false;
14378 :
14379 1146420 : if (code->op == EXEC_ALLOCATE
14380 1146420 : && !gfc_resolve_expr (code->expr3))
14381 : t = false;
14382 :
14383 1146420 : switch (code->op)
14384 : {
14385 : case EXEC_NOP:
14386 : case EXEC_END_BLOCK:
14387 : case EXEC_END_NESTED_BLOCK:
14388 : case EXEC_CYCLE:
14389 : break;
14390 :
14391 219192 : case EXEC_STOP:
14392 219192 : case EXEC_ERROR_STOP:
14393 219192 : if (code->expr1 != NULL && t)
14394 : {
14395 198739 : if (!(code->expr1->ts.type == BT_CHARACTER
14396 : || code->expr1->ts.type == BT_INTEGER))
14397 1 : gfc_error ("STOP code at %L must be either INTEGER or CHARACTER "
14398 : "type", &code->expr1->where);
14399 198738 : else if (code->expr1->rank != 0)
14400 0 : gfc_error ("STOP code at %L must be scalar",
14401 : &code->expr1->where);
14402 198738 : else if (code->expr1->ts.type == BT_CHARACTER
14403 478 : && code->expr1->ts.kind != gfc_default_character_kind)
14404 0 : gfc_error ("STOP code at %L must be default character KIND=%d",
14405 : &code->expr1->where, (int) gfc_default_character_kind);
14406 198738 : else if (code->expr1->ts.type == BT_INTEGER
14407 198260 : && code->expr1->ts.kind != gfc_default_integer_kind)
14408 8 : gfc_notify_std (GFC_STD_F2018, "STOP code at %L must be default "
14409 : "integer KIND=%d", &code->expr1->where,
14410 : (int) gfc_default_integer_kind);
14411 : }
14412 219192 : if (code->expr2 != NULL
14413 37 : && (code->expr2->ts.type != BT_LOGICAL
14414 37 : || code->expr2->rank != 0))
14415 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14416 : &code->expr2->where);
14417 :
14418 : /* Fall through. */
14419 219222 : case EXEC_PAUSE:
14420 219222 : gfc_value_used_expr (code->expr1, VALUE_USED);
14421 219222 : break;
14422 :
14423 : case EXEC_EXIT:
14424 : case EXEC_CONTINUE:
14425 : case EXEC_DT_END:
14426 : case EXEC_ASSIGN_CALL:
14427 : break;
14428 :
14429 54 : case EXEC_CRITICAL:
14430 54 : resolve_critical (code);
14431 54 : break;
14432 :
14433 1317 : case EXEC_SYNC_ALL:
14434 1317 : case EXEC_SYNC_IMAGES:
14435 1317 : case EXEC_SYNC_MEMORY:
14436 1317 : resolve_sync (code);
14437 1317 : break;
14438 :
14439 197 : case EXEC_LOCK:
14440 197 : case EXEC_UNLOCK:
14441 197 : case EXEC_EVENT_POST:
14442 197 : case EXEC_EVENT_WAIT:
14443 197 : resolve_lock_unlock_event (code);
14444 197 : break;
14445 :
14446 : case EXEC_FAIL_IMAGE:
14447 : break;
14448 :
14449 154 : case EXEC_FORM_TEAM:
14450 154 : resolve_form_team (code);
14451 154 : break;
14452 :
14453 97 : case EXEC_CHANGE_TEAM:
14454 97 : resolve_change_team (code);
14455 97 : break;
14456 :
14457 95 : case EXEC_END_TEAM:
14458 95 : resolve_end_team (code);
14459 95 : break;
14460 :
14461 43 : case EXEC_SYNC_TEAM:
14462 43 : resolve_sync_team (code);
14463 43 : break;
14464 :
14465 1491 : case EXEC_ENTRY:
14466 : /* Keep track of which entry we are up to. */
14467 1491 : current_entry_id = code->ext.entry->id;
14468 1491 : break;
14469 :
14470 453 : case EXEC_WHERE:
14471 453 : resolve_where (code, NULL);
14472 453 : break;
14473 :
14474 1250 : case EXEC_GOTO:
14475 1250 : if (code->expr1 != NULL)
14476 : {
14477 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14478 76 : || code->expr1->ts.type != BT_INTEGER
14479 76 : || (code->expr1->ref
14480 1 : && code->expr1->ref->type == REF_ARRAY)
14481 75 : || code->expr1->symtree == NULL
14482 75 : || (code->expr1->symtree->n.sym
14483 75 : && (code->expr1->symtree->n.sym->attr.flavor
14484 75 : == FL_PARAMETER)))
14485 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14486 : "scalar INTEGER variable", &code->expr1->where);
14487 74 : else if (code->expr1->symtree->n.sym
14488 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14489 1 : gfc_error ("Variable %qs has not been assigned a target "
14490 : "label at %L", code->expr1->symtree->n.sym->name,
14491 : &code->expr1->where);
14492 : }
14493 : else
14494 1172 : resolve_branch (code->label1, code);
14495 : break;
14496 :
14497 3224 : case EXEC_RETURN:
14498 3224 : if (code->expr1 != NULL
14499 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14500 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14501 : "INTEGER return specifier", &code->expr1->where);
14502 : break;
14503 :
14504 : case EXEC_INIT_ASSIGN:
14505 : case EXEC_END_PROCEDURE:
14506 : break;
14507 :
14508 289123 : case EXEC_ASSIGN:
14509 289123 : if (!t)
14510 : break;
14511 :
14512 288447 : if (flag_coarray == GFC_FCOARRAY_LIB
14513 288447 : && gfc_is_coindexed (code->expr1))
14514 : {
14515 : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14516 : coindexed variable. */
14517 500 : code->op = EXEC_CALL;
14518 500 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14519 : true);
14520 500 : code->resolved_sym = code->symtree->n.sym;
14521 500 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14522 500 : code->resolved_sym->attr.intrinsic = 1;
14523 500 : code->resolved_sym->attr.subroutine = 1;
14524 500 : code->resolved_isym
14525 500 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14526 500 : gfc_commit_symbol (code->resolved_sym);
14527 500 : code->ext.actual = gfc_get_actual_arglist ();
14528 500 : code->ext.actual->expr = code->expr1;
14529 500 : code->ext.actual->next = gfc_get_actual_arglist ();
14530 500 : if (code->expr2->expr_type != EXPR_VARIABLE
14531 500 : && code->expr2->expr_type != EXPR_CONSTANT)
14532 : {
14533 : /* Convert assignments of expr1[...] = expr2 into
14534 : tvar = expr2
14535 : expr1[...] = tvar
14536 : when expr2 is not trivial. */
14537 54 : gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
14538 54 : gfc_code next_code = *code;
14539 54 : gfc_code *rhs_code
14540 108 : = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
14541 54 : NULL, code->expr2->where);
14542 54 : *code = *rhs_code;
14543 54 : code->next = rhs_code;
14544 54 : *rhs_code = next_code;
14545 :
14546 54 : rhs_code->ext.actual->next->expr = tvar;
14547 54 : rhs_code->expr1 = NULL;
14548 54 : rhs_code->expr2 = NULL;
14549 : }
14550 : else
14551 : {
14552 446 : code->ext.actual->next->expr = code->expr2;
14553 :
14554 446 : code->expr1 = NULL;
14555 446 : code->expr2 = NULL;
14556 : }
14557 : break;
14558 : }
14559 :
14560 287947 : if (code->expr1->ts.type == BT_CLASS)
14561 1114 : gfc_find_vtab (&code->expr2->ts);
14562 :
14563 : /* If this is a pointer function in an lvalue variable context,
14564 : the new code will have to be resolved afresh. This is also the
14565 : case with an error, where the code is transformed into NOP to
14566 : prevent ICEs downstream. */
14567 287947 : if (resolve_ptr_fcn_assign (&code, ns)
14568 287947 : || code->op == EXEC_NOP)
14569 205 : goto start;
14570 :
14571 287742 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14572 287742 : _("assignment")))
14573 : break;
14574 :
14575 287703 : if (resolve_ordinary_assign (code, ns))
14576 : {
14577 918 : if (omp_workshare_flag)
14578 : {
14579 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14580 1 : "at %L", &code->loc);
14581 1 : break;
14582 : }
14583 917 : if (code->op == EXEC_COMPCALL)
14584 449 : goto compcall;
14585 : else
14586 468 : goto call;
14587 : }
14588 :
14589 : /* Check for dependencies in deferred character length array
14590 : assignments and generate a temporary, if necessary. */
14591 286785 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14592 : break;
14593 :
14594 : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14595 286763 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14596 7348 : && code->expr1->ts.u.derived
14597 7348 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14598 188 : generate_component_assignments (&code, ns);
14599 286575 : else if (code->op == EXEC_ASSIGN)
14600 : {
14601 286575 : if (gfc_may_be_finalized (code->expr1->ts))
14602 1295 : code->expr1->must_finalize = 1;
14603 286575 : if (code->expr2->expr_type == EXPR_ARRAY
14604 286575 : && gfc_may_be_finalized (code->expr2->ts))
14605 73 : code->expr2->must_finalize = 1;
14606 : }
14607 :
14608 : break;
14609 :
14610 126 : case EXEC_LABEL_ASSIGN:
14611 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14612 0 : gfc_error ("Label %d referenced at %L is never defined",
14613 : code->label1->value, &code->label1->where);
14614 126 : if (t
14615 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14616 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14617 126 : || code->expr1->symtree->n.sym->ts.kind
14618 126 : != gfc_default_integer_kind
14619 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14620 125 : || code->expr1->symtree->n.sym->as != NULL))
14621 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14622 : "default INTEGER variable", &code->expr1->where);
14623 : break;
14624 :
14625 10478 : case EXEC_POINTER_ASSIGN:
14626 10478 : {
14627 10478 : gfc_expr* e;
14628 :
14629 10478 : if (!t)
14630 : break;
14631 :
14632 : /* This is both a variable definition and pointer assignment
14633 : context, so check both of them. For rank remapping, a final
14634 : array ref may be present on the LHS and fool gfc_expr_attr
14635 : used in gfc_check_vardef_context. Remove it. */
14636 10473 : e = remove_last_array_ref (code->expr1);
14637 20946 : t = gfc_check_vardef_context (e, true, false, false,
14638 10473 : _("pointer assignment"));
14639 10473 : if (t)
14640 10444 : t = gfc_check_vardef_context (e, false, false, false,
14641 10444 : _("pointer assignment"));
14642 10473 : gfc_free_expr (e);
14643 :
14644 10473 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14645 :
14646 10331 : if (!t)
14647 : break;
14648 :
14649 : /* Assigning a class object always is a regular assign. */
14650 10331 : if (code->expr2->ts.type == BT_CLASS
14651 582 : && code->expr1->ts.type == BT_CLASS
14652 491 : && CLASS_DATA (code->expr2)
14653 490 : && !CLASS_DATA (code->expr2)->attr.dimension
14654 10968 : && !(gfc_expr_attr (code->expr1).proc_pointer
14655 55 : && code->expr2->expr_type == EXPR_VARIABLE
14656 43 : && code->expr2->symtree->n.sym->attr.flavor
14657 43 : == FL_PROCEDURE))
14658 340 : code->op = EXEC_ASSIGN;
14659 : break;
14660 : }
14661 :
14662 72 : case EXEC_ARITHMETIC_IF:
14663 72 : {
14664 72 : gfc_expr *e = code->expr1;
14665 :
14666 72 : gfc_resolve_expr (e);
14667 72 : if (e->expr_type == EXPR_NULL)
14668 1 : gfc_error ("Invalid NULL at %L", &e->where);
14669 :
14670 72 : if (t && (e->rank > 0
14671 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14672 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14673 : "REAL or INTEGER expression", &e->where);
14674 :
14675 72 : resolve_branch (code->label1, code);
14676 72 : resolve_branch (code->label2, code);
14677 72 : resolve_branch (code->label3, code);
14678 : }
14679 72 : break;
14680 :
14681 232801 : case EXEC_IF:
14682 232801 : if (t && code->expr1 != NULL
14683 0 : && (code->expr1->ts.type != BT_LOGICAL
14684 0 : || code->expr1->rank != 0))
14685 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14686 : &code->expr1->where);
14687 : break;
14688 :
14689 80303 : case EXEC_CALL:
14690 80303 : call:
14691 80303 : resolve_call (code);
14692 80303 : break;
14693 :
14694 1756 : case EXEC_COMPCALL:
14695 1756 : compcall:
14696 1756 : resolve_typebound_subroutine (code);
14697 1756 : break;
14698 :
14699 124 : case EXEC_CALL_PPC:
14700 124 : resolve_ppc_call (code);
14701 124 : break;
14702 :
14703 688 : case EXEC_SELECT:
14704 : /* Select is complicated. Also, a SELECT construct could be
14705 : a transformed computed GOTO. */
14706 688 : resolve_select (code, false);
14707 688 : break;
14708 :
14709 3081 : case EXEC_SELECT_TYPE:
14710 3081 : resolve_select_type (code, ns);
14711 3081 : break;
14712 :
14713 1036 : case EXEC_SELECT_RANK:
14714 1036 : resolve_select_rank (code, ns);
14715 1036 : break;
14716 :
14717 8235 : case EXEC_BLOCK:
14718 8235 : resolve_block_construct (code);
14719 8235 : break;
14720 :
14721 33112 : case EXEC_DO:
14722 33112 : if (code->ext.iterator != NULL)
14723 : {
14724 33112 : gfc_iterator *iter = code->ext.iterator;
14725 33112 : if (gfc_resolve_iterator (iter, true, false))
14726 33098 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14727 : true);
14728 : }
14729 : break;
14730 :
14731 531 : case EXEC_DO_WHILE:
14732 531 : if (code->expr1 == NULL)
14733 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14734 : "DO WHILE");
14735 531 : if (t
14736 531 : && (code->expr1->rank != 0
14737 531 : || code->expr1->ts.type != BT_LOGICAL))
14738 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14739 : "a scalar LOGICAL expression", &code->expr1->where);
14740 : break;
14741 :
14742 14469 : case EXEC_ALLOCATE:
14743 14469 : if (t)
14744 14467 : resolve_allocate_deallocate (code, "ALLOCATE");
14745 :
14746 : break;
14747 :
14748 6163 : case EXEC_DEALLOCATE:
14749 6163 : if (t)
14750 6163 : resolve_allocate_deallocate (code, "DEALLOCATE");
14751 :
14752 : break;
14753 :
14754 3955 : case EXEC_OPEN:
14755 3955 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14756 : break;
14757 :
14758 3728 : resolve_branch (code->ext.open->err, code);
14759 3728 : break;
14760 :
14761 3148 : case EXEC_CLOSE:
14762 3148 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14763 : break;
14764 :
14765 3114 : resolve_branch (code->ext.close->err, code);
14766 3114 : break;
14767 :
14768 2851 : case EXEC_BACKSPACE:
14769 2851 : case EXEC_ENDFILE:
14770 2851 : case EXEC_REWIND:
14771 2851 : case EXEC_FLUSH:
14772 2851 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14773 : break;
14774 :
14775 2785 : resolve_branch (code->ext.filepos->err, code);
14776 2785 : break;
14777 :
14778 838 : case EXEC_INQUIRE:
14779 838 : if (!gfc_resolve_inquire (code->ext.inquire))
14780 : break;
14781 :
14782 790 : resolve_branch (code->ext.inquire->err, code);
14783 790 : break;
14784 :
14785 92 : case EXEC_IOLENGTH:
14786 92 : gcc_assert (code->ext.inquire != NULL);
14787 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14788 : break;
14789 :
14790 90 : resolve_branch (code->ext.inquire->err, code);
14791 90 : break;
14792 :
14793 89 : case EXEC_WAIT:
14794 89 : if (!gfc_resolve_wait (code->ext.wait))
14795 : break;
14796 :
14797 74 : resolve_branch (code->ext.wait->err, code);
14798 74 : resolve_branch (code->ext.wait->end, code);
14799 74 : resolve_branch (code->ext.wait->eor, code);
14800 74 : break;
14801 :
14802 33592 : case EXEC_READ:
14803 33592 : case EXEC_WRITE:
14804 33592 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14805 : break;
14806 :
14807 33284 : resolve_branch (code->ext.dt->err, code);
14808 33284 : resolve_branch (code->ext.dt->end, code);
14809 33284 : resolve_branch (code->ext.dt->eor, code);
14810 33284 : break;
14811 :
14812 47611 : case EXEC_TRANSFER:
14813 47611 : resolve_transfer (code);
14814 47611 : break;
14815 :
14816 2217 : case EXEC_DO_CONCURRENT:
14817 2217 : case EXEC_FORALL:
14818 2217 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14819 :
14820 2217 : if (code->expr1 != NULL
14821 732 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14822 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14823 : "expression", &code->expr1->where);
14824 :
14825 2217 : if (code->op == EXEC_DO_CONCURRENT)
14826 224 : resolve_locality_spec (code, ns);
14827 : break;
14828 :
14829 13538 : case EXEC_OACC_PARALLEL_LOOP:
14830 13538 : case EXEC_OACC_PARALLEL:
14831 13538 : case EXEC_OACC_KERNELS_LOOP:
14832 13538 : case EXEC_OACC_KERNELS:
14833 13538 : case EXEC_OACC_SERIAL_LOOP:
14834 13538 : case EXEC_OACC_SERIAL:
14835 13538 : case EXEC_OACC_DATA:
14836 13538 : case EXEC_OACC_HOST_DATA:
14837 13538 : case EXEC_OACC_LOOP:
14838 13538 : case EXEC_OACC_UPDATE:
14839 13538 : case EXEC_OACC_WAIT:
14840 13538 : case EXEC_OACC_CACHE:
14841 13538 : case EXEC_OACC_ENTER_DATA:
14842 13538 : case EXEC_OACC_EXIT_DATA:
14843 13538 : case EXEC_OACC_ATOMIC:
14844 13538 : case EXEC_OACC_DECLARE:
14845 13538 : case EXEC_OACC_INIT:
14846 13538 : case EXEC_OACC_SHUTDOWN:
14847 13538 : case EXEC_OACC_SET:
14848 13538 : gfc_resolve_oacc_directive (code, ns);
14849 13538 : break;
14850 :
14851 17319 : case EXEC_OMP_ALLOCATE:
14852 17319 : case EXEC_OMP_ALLOCATORS:
14853 17319 : case EXEC_OMP_ASSUME:
14854 17319 : case EXEC_OMP_ATOMIC:
14855 17319 : case EXEC_OMP_BARRIER:
14856 17319 : case EXEC_OMP_CANCEL:
14857 17319 : case EXEC_OMP_CANCELLATION_POINT:
14858 17319 : case EXEC_OMP_CRITICAL:
14859 17319 : case EXEC_OMP_FLUSH:
14860 17319 : case EXEC_OMP_DEPOBJ:
14861 17319 : case EXEC_OMP_DISPATCH:
14862 17319 : case EXEC_OMP_DISTRIBUTE:
14863 17319 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14864 17319 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14865 17319 : case EXEC_OMP_DISTRIBUTE_SIMD:
14866 17319 : case EXEC_OMP_DO:
14867 17319 : case EXEC_OMP_DO_SIMD:
14868 17319 : case EXEC_OMP_ERROR:
14869 17319 : case EXEC_OMP_INTEROP:
14870 17319 : case EXEC_OMP_LOOP:
14871 17319 : case EXEC_OMP_MASTER:
14872 17319 : case EXEC_OMP_MASTER_TASKLOOP:
14873 17319 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14874 17319 : case EXEC_OMP_MASKED:
14875 17319 : case EXEC_OMP_MASKED_TASKLOOP:
14876 17319 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14877 17319 : case EXEC_OMP_METADIRECTIVE:
14878 17319 : case EXEC_OMP_ORDERED:
14879 17319 : case EXEC_OMP_SCAN:
14880 17319 : case EXEC_OMP_SCOPE:
14881 17319 : case EXEC_OMP_SECTIONS:
14882 17319 : case EXEC_OMP_SIMD:
14883 17319 : case EXEC_OMP_SINGLE:
14884 17319 : case EXEC_OMP_TARGET:
14885 17319 : case EXEC_OMP_TARGET_DATA:
14886 17319 : case EXEC_OMP_TARGET_ENTER_DATA:
14887 17319 : case EXEC_OMP_TARGET_EXIT_DATA:
14888 17319 : case EXEC_OMP_TARGET_PARALLEL:
14889 17319 : case EXEC_OMP_TARGET_PARALLEL_DO:
14890 17319 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14891 17319 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14892 17319 : case EXEC_OMP_TARGET_SIMD:
14893 17319 : case EXEC_OMP_TARGET_TEAMS:
14894 17319 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14895 17319 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14896 17319 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14897 17319 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14898 17319 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14899 17319 : case EXEC_OMP_TARGET_UPDATE:
14900 17319 : case EXEC_OMP_TASK:
14901 17319 : case EXEC_OMP_TASKGROUP:
14902 17319 : case EXEC_OMP_TASKLOOP:
14903 17319 : case EXEC_OMP_TASKLOOP_SIMD:
14904 17319 : case EXEC_OMP_TASKWAIT:
14905 17319 : case EXEC_OMP_TASKYIELD:
14906 17319 : case EXEC_OMP_TEAMS:
14907 17319 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14908 17319 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14909 17319 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14910 17319 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14911 17319 : case EXEC_OMP_TEAMS_LOOP:
14912 17319 : case EXEC_OMP_TILE:
14913 17319 : case EXEC_OMP_UNROLL:
14914 17319 : case EXEC_OMP_WORKSHARE:
14915 17319 : gfc_resolve_omp_directive (code, ns);
14916 17319 : break;
14917 :
14918 3927 : case EXEC_OMP_PARALLEL:
14919 3927 : case EXEC_OMP_PARALLEL_DO:
14920 3927 : case EXEC_OMP_PARALLEL_DO_SIMD:
14921 3927 : case EXEC_OMP_PARALLEL_LOOP:
14922 3927 : case EXEC_OMP_PARALLEL_MASKED:
14923 3927 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14924 3927 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14925 3927 : case EXEC_OMP_PARALLEL_MASTER:
14926 3927 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14927 3927 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14928 3927 : case EXEC_OMP_PARALLEL_SECTIONS:
14929 3927 : case EXEC_OMP_PARALLEL_WORKSHARE:
14930 3927 : omp_workshare_save = omp_workshare_flag;
14931 3927 : omp_workshare_flag = 0;
14932 3927 : gfc_resolve_omp_directive (code, ns);
14933 3927 : omp_workshare_flag = omp_workshare_save;
14934 3927 : break;
14935 :
14936 0 : default:
14937 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
14938 : }
14939 1146214 : gfc_value_used_expr (code->expr2, VALUE_USED);
14940 1146214 : gfc_value_used_expr (code->expr3, VALUE_USED);
14941 1146214 : gfc_value_used_expr (code->expr4, VALUE_USED);
14942 : }
14943 :
14944 696780 : mark_lhs_assignments_set (orig_code);
14945 :
14946 696780 : cs_base = frame.prev;
14947 696780 : }
14948 :
14949 :
14950 : /* Resolve initial values and make sure they are compatible with
14951 : the variable. */
14952 :
14953 : static void
14954 1939251 : resolve_values (gfc_symbol *sym)
14955 : {
14956 1939251 : bool t;
14957 :
14958 1939251 : if (sym->value == NULL)
14959 : return;
14960 :
14961 445997 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
14962 14 : gfc_warning (OPT_Wdeprecated_declarations,
14963 : "Using parameter %qs declared at %L is deprecated",
14964 : sym->name, &sym->declared_at);
14965 :
14966 445997 : if (sym->value->expr_type == EXPR_STRUCTURE)
14967 40452 : t= resolve_structure_cons (sym->value, 1);
14968 : else
14969 405545 : t = gfc_resolve_expr (sym->value);
14970 :
14971 445997 : if (!t)
14972 : return;
14973 :
14974 445995 : gfc_check_assign_symbol (sym, NULL, sym->value);
14975 : }
14976 :
14977 :
14978 : /* Verify any BIND(C) derived types in the namespace so we can report errors
14979 : for them once, rather than for each variable declared of that type. */
14980 :
14981 : static void
14982 1909211 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
14983 : {
14984 1909211 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
14985 85313 : && derived_sym->attr.is_bind_c == 1)
14986 27883 : verify_bind_c_derived_type (derived_sym);
14987 :
14988 1909211 : return;
14989 : }
14990 :
14991 :
14992 : /* Check the interfaces of DTIO procedures associated with derived
14993 : type 'sym'. These procedures can either have typebound bindings or
14994 : can appear in DTIO generic interfaces. */
14995 :
14996 : static void
14997 1940221 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
14998 : {
14999 1940221 : if (!sym || sym->attr.flavor != FL_DERIVED)
15000 : return;
15001 :
15002 94832 : gfc_check_dtio_interfaces (sym);
15003 :
15004 94832 : return;
15005 : }
15006 :
15007 : /* Auxiliary function, checks if an argument decays to a pointer. */
15008 :
15009 : static bool
15010 70414 : decays_to_pointer (gfc_symbol *sym)
15011 : {
15012 70414 : if (!sym->as)
15013 : return true;
15014 :
15015 19599 : if (sym->as->type == AS_ASSUMED_SHAPE)
15016 : return false;
15017 :
15018 15844 : if (sym->as->type == AS_ASSUMED_RANK)
15019 : return false;
15020 :
15021 10746 : if (sym->as->type == AS_DEFERRED && sym->attr.dummy)
15022 968 : return false;
15023 :
15024 : return true;
15025 : }
15026 :
15027 : /* Helper function, returns true if the types conform according to the C
15028 : standard, when they are not equal on the Fortran side. If we decide to
15029 : include or exclude any types from this, this is the place to change. */
15030 :
15031 : static bool
15032 390 : c_types_conform (gfc_typespec *ts1, gfc_typespec *ts2)
15033 : {
15034 390 : if (ts1->type == BT_ASSUMED || ts2->type == BT_ASSUMED)
15035 : return true;
15036 :
15037 384 : if (ts1->kind == ts2->kind
15038 : && (ts1->type == BT_CHARACTER || ts1->type == BT_INTEGER
15039 : || ts1->type == BT_UNSIGNED)
15040 : && (ts2->type == BT_CHARACTER || ts2->type == BT_INTEGER
15041 : || ts2->type == BT_UNSIGNED))
15042 384 : return true;
15043 :
15044 : return false;
15045 :
15046 : }
15047 :
15048 : /* Check argument lists of BIND(C) procedures against each other, return
15049 : false if they do not. */
15050 :
15051 : static bool
15052 12872 : compare_c_binding_arglists (gfc_symbol *osym, gfc_symbol *nsym)
15053 : {
15054 12872 : gfc_formal_arglist *oarg, *narg;
15055 12872 : bool ret = true;
15056 12872 : locus *oloc, *nloc;
15057 :
15058 12872 : oarg = osym->formal;
15059 12872 : narg = nsym->formal;
15060 12872 : oloc = &osym->declared_at;
15061 12872 : nloc = &nsym->declared_at;
15062 48089 : for ( ; oarg && narg ; oarg = oarg->next, narg = narg->next)
15063 : {
15064 35217 : oloc = &oarg->sym->declared_at;
15065 35217 : nloc = &narg->sym->declared_at;
15066 :
15067 35217 : if (!gfc_compare_types (&oarg->sym->ts, &narg->sym->ts)
15068 35217 : && (pedantic || !c_types_conform (&oarg->sym->ts, &narg->sym->ts)))
15069 : {
15070 24 : gfc_error ("Type mismatch in argument %qs at %L (%s/%s) "
15071 8 : "originally declared at %L", narg->sym->name,
15072 8 : nloc, gfc_typename (&narg->sym->ts),
15073 8 : gfc_typename (&oarg->sym->ts), oloc);
15074 8 : ret = false;
15075 8 : continue;
15076 : }
15077 35209 : if (oarg->sym->attr.value != narg->sym->attr.value)
15078 : {
15079 1 : gfc_error ("VALUE attribute mismatch in argument %qs at %L "
15080 : "originally declared at %L",narg->sym->name,
15081 : nloc, oloc);
15082 1 : ret = false;
15083 1 : continue;
15084 : }
15085 :
15086 : /* According to the Fortran standard, ranks have to match for arguments.
15087 : In this case, this makes little sense because both decay to C
15088 : pointers. Only issue an error if -pedantic or if the argument does
15089 : not decay to a pointer. Same thing for CFI_desc arrays, which include
15090 : assumed rank. */
15091 :
15092 35208 : int orank = gfc_symbol_rank (oarg->sym);
15093 35208 : int nrank = gfc_symbol_rank (narg->sym);
15094 35208 : if (orank != nrank && pedantic)
15095 : {
15096 1 : gfc_error ("Rank mismatch in argument %qs (%d/%d) at %L originally "
15097 1 : "declared at %L", narg->sym->name, nrank, orank, nloc,
15098 : oloc);
15099 1 : ret = false;
15100 1 : continue;
15101 : }
15102 :
15103 : /* Confusion between CFI_desc and "normal" arrays. */
15104 :
15105 35207 : if (decays_to_pointer (oarg->sym) != decays_to_pointer (narg->sym))
15106 : {
15107 1 : gfc_error ("Array specification mismatch in argument %qs at %L "
15108 : "originally declared at %L", narg->sym->name,
15109 : nloc, oloc);
15110 1 : ret = false;
15111 1 : continue;
15112 : }
15113 : }
15114 :
15115 12872 : if (oarg && !narg)
15116 : {
15117 0 : gfc_error ("Not enough arguments for procedure %qs with binding label "
15118 : "%qs after %L, originally declared at %L", nsym->name,
15119 0 : nsym->binding_label, nloc, &oarg->sym->declared_at);
15120 0 : ret = false;
15121 : }
15122 :
15123 12872 : if (!oarg && narg)
15124 : {
15125 2 : gfc_error ("Too many arguments for procedure %qs with binding label "
15126 : "%qs at %L, originally declared at %L", nsym->name,
15127 2 : nsym->binding_label, &narg->sym->declared_at, oloc);
15128 2 : ret = false;
15129 : }
15130 :
15131 12872 : return ret;
15132 : }
15133 :
15134 :
15135 : /* Verify that any binding labels used in a given namespace do not collide
15136 : with the names or binding labels of any global symbols. Multiple INTERFACE
15137 : for the same procedure are permitted. Abstract interfaces and dummy
15138 : arguments are not checked. */
15139 :
15140 : static void
15141 1940221 : gfc_verify_binding_labels (gfc_symbol *sym)
15142 : {
15143 1940221 : gfc_gsymbol *gsym;
15144 1940221 : const char *module;
15145 :
15146 1940221 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
15147 70661 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
15148 41837 : || sym->attr.abstract || sym->attr.dummy)
15149 : return;
15150 :
15151 : /* Avoid double error reporting. */
15152 41701 : if (sym->error)
15153 : return;
15154 :
15155 : /* TODO: Check the names of reserved external C identifiers here, see
15156 : PR 125251. */
15157 :
15158 : /* According to the Fortran standard, global identifiers are case
15159 : insensitive, which also holds for C identifiers. This was probably done
15160 : for systems which had case-insensitive linkers. Such systems could not
15161 : accommodate the C standards referenced, so this restriction makes little
15162 : sense for modern systems. Therefore, check case-sensitive labels unless
15163 : -pedantic is in force. */
15164 :
15165 41701 : if (pedantic)
15166 4654 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
15167 : else
15168 37047 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
15169 :
15170 41701 : if (sym->module)
15171 : module = sym->module;
15172 13124 : else if (sym->ns && sym->ns->proc_name
15173 13124 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
15174 4582 : module = sym->ns->proc_name->name;
15175 8542 : else if (sym->ns && sym->ns->parent
15176 358 : && sym->ns && sym->ns->parent->proc_name
15177 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15178 272 : module = sym->ns->parent->proc_name->name;
15179 : else
15180 : module = NULL;
15181 :
15182 41701 : if (gsym)
15183 : {
15184 12916 : if (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)
15185 : {
15186 12875 : gfc_symbol *global_sym;
15187 12875 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &global_sym);
15188 :
15189 : /* For when the symtree does not match the symbol name, which can happen
15190 : in modules with PRIVATE. */
15191 :
15192 12875 : if (global_sym == NULL)
15193 1 : gfc_find_symbol_by_name (gsym->sym_name, gsym->ns, &global_sym);
15194 :
15195 12875 : gcc_assert (global_sym);
15196 :
15197 : /* If subroutines and functions are conflated, there is little point
15198 : in continuing checks. */
15199 12875 : if ((sym->attr.function && gsym->type == GSYM_SUBROUTINE)
15200 12875 : || (sym->attr.subroutine && gsym->type == GSYM_FUNCTION))
15201 : {
15202 1 : gfc_global_used (gsym, &sym->declared_at);
15203 1 : sym->binding_label = NULL;
15204 1 : sym->error = 1;
15205 13 : return;
15206 : }
15207 :
15208 7242 : if (gsym->type == GSYM_FUNCTION && sym->attr.function
15209 20116 : && !gfc_compare_types (&sym->ts, &global_sym->ts))
15210 : {
15211 2 : gfc_error ("Return type mismatch of function %qs with binding "
15212 : "label %qs at %L (%s/%s), originally declared at %L",
15213 : sym->name, sym->binding_label,
15214 : &sym->declared_at,
15215 : gfc_typename (&sym->ts),
15216 2 : gfc_typename (&global_sym->ts),
15217 : &gsym->where);
15218 2 : sym->binding_label = NULL;
15219 2 : sym->error = 1;
15220 2 : return;
15221 : }
15222 12872 : if (!compare_c_binding_arglists (global_sym, sym))
15223 : {
15224 10 : sym->binding_label = NULL;
15225 10 : sym->error = 1;
15226 10 : return;
15227 : }
15228 : }
15229 : }
15230 :
15231 12862 : if (!gsym
15232 12903 : || (!gsym->defined
15233 9955 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
15234 : {
15235 28785 : if (!gsym)
15236 28785 : gsym = gfc_get_gsymbol (sym->binding_label, true);
15237 38740 : gsym->where = sym->declared_at;
15238 38740 : gsym->sym_name = sym->name;
15239 38740 : gsym->binding_label = sym->binding_label;
15240 38740 : gsym->ns = sym->ns;
15241 38740 : gsym->mod_name = module;
15242 38740 : if (sym->attr.function)
15243 26322 : gsym->type = GSYM_FUNCTION;
15244 12418 : else if (sym->attr.subroutine)
15245 12279 : gsym->type = GSYM_SUBROUTINE;
15246 : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
15247 38740 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
15248 38740 : return;
15249 : }
15250 :
15251 2948 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
15252 : {
15253 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
15254 : "identifier as entity at %L", sym->name,
15255 : sym->binding_label, &sym->declared_at, &gsym->where);
15256 : /* Clear the binding label to prevent checking multiple times. */
15257 1 : sym->binding_label = NULL;
15258 1 : return;
15259 : }
15260 :
15261 2947 : if (sym->attr.flavor == FL_VARIABLE && module
15262 37 : && (strcmp (module, gsym->mod_name) != 0
15263 35 : || strcmp (sym->name, gsym->sym_name) != 0))
15264 : {
15265 : /* This can only happen if the variable is defined in a module - if it
15266 : isn't the same module, reject it. */
15267 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
15268 : "uses the same global identifier as entity at %L from module %qs",
15269 : sym->name, module, sym->binding_label,
15270 : &sym->declared_at, &gsym->where, gsym->mod_name);
15271 3 : sym->binding_label = NULL;
15272 3 : return;
15273 : }
15274 :
15275 2944 : if ((sym->attr.function || sym->attr.subroutine)
15276 2908 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
15277 2906 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
15278 2523 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
15279 2091 : && (module != gsym->mod_name
15280 2087 : || strcmp (gsym->sym_name, sym->name) != 0
15281 2087 : || (module && strcmp (module, gsym->mod_name) != 0)))
15282 : {
15283 : /* Print an error if the procedure is defined multiple times; we have to
15284 : exclude references to the same procedure via module association or
15285 : multiple checks for the same procedure. */
15286 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
15287 : "global identifier as entity at %L", sym->name,
15288 : sym->binding_label, &sym->declared_at, &gsym->where);
15289 4 : sym->binding_label = NULL;
15290 4 : return;
15291 : }
15292 : }
15293 :
15294 :
15295 : /* Resolve an index expression. */
15296 :
15297 : static bool
15298 267770 : resolve_index_expr (gfc_expr *e)
15299 : {
15300 267770 : if (!gfc_resolve_expr (e))
15301 : return false;
15302 :
15303 267760 : if (!gfc_simplify_expr (e, 0))
15304 : return false;
15305 :
15306 267758 : if (!gfc_specification_expr (e))
15307 : return false;
15308 :
15309 : return true;
15310 : }
15311 :
15312 :
15313 : /* Resolve a charlen structure. */
15314 :
15315 : static bool
15316 104760 : resolve_charlen (gfc_charlen *cl)
15317 : {
15318 104760 : int k;
15319 104760 : bool saved_specification_expr;
15320 :
15321 104760 : if (cl->resolved)
15322 : return true;
15323 :
15324 96234 : cl->resolved = 1;
15325 96234 : saved_specification_expr = specification_expr;
15326 96234 : specification_expr = true;
15327 :
15328 96234 : if (cl->length_from_typespec)
15329 : {
15330 2138 : if (!gfc_resolve_expr (cl->length))
15331 : {
15332 1 : specification_expr = saved_specification_expr;
15333 1 : return false;
15334 : }
15335 :
15336 2137 : if (!gfc_simplify_expr (cl->length, 0))
15337 : {
15338 0 : specification_expr = saved_specification_expr;
15339 0 : return false;
15340 : }
15341 :
15342 : /* cl->length has been resolved. It should have an integer type. */
15343 2137 : if (cl->length
15344 2136 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
15345 : {
15346 4 : gfc_error ("Scalar INTEGER expression expected at %L",
15347 : &cl->length->where);
15348 4 : return false;
15349 : }
15350 : }
15351 : else
15352 : {
15353 94096 : if (!resolve_index_expr (cl->length))
15354 : {
15355 19 : specification_expr = saved_specification_expr;
15356 19 : return false;
15357 : }
15358 : }
15359 :
15360 : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
15361 : a negative value, the length of character entities declared is zero. */
15362 96210 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15363 57732 : && mpz_sgn (cl->length->value.integer) < 0)
15364 0 : gfc_replace_expr (cl->length,
15365 : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
15366 :
15367 : /* Check that the character length is not too large. */
15368 96210 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
15369 96210 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
15370 57732 : && cl->length->ts.type == BT_INTEGER
15371 57732 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
15372 : {
15373 4 : gfc_error ("String length at %L is too large", &cl->length->where);
15374 4 : specification_expr = saved_specification_expr;
15375 4 : return false;
15376 : }
15377 :
15378 96206 : specification_expr = saved_specification_expr;
15379 96206 : return true;
15380 : }
15381 :
15382 :
15383 : /* Test for non-constant shape arrays. */
15384 :
15385 : static bool
15386 118826 : is_non_constant_shape_array (gfc_symbol *sym)
15387 : {
15388 118826 : gfc_expr *e;
15389 118826 : int i;
15390 118826 : bool not_constant;
15391 :
15392 118826 : not_constant = false;
15393 118826 : if (sym->as != NULL)
15394 : {
15395 : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
15396 : has not been simplified; parameter array references. Do the
15397 : simplification now. */
15398 156445 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
15399 : {
15400 90290 : if (i == GFC_MAX_DIMENSIONS)
15401 : break;
15402 :
15403 90288 : e = sym->as->lower[i];
15404 90288 : if (e && (!resolve_index_expr(e)
15405 87434 : || !gfc_is_constant_expr (e)))
15406 : not_constant = true;
15407 90288 : e = sym->as->upper[i];
15408 90288 : if (e && (!resolve_index_expr(e)
15409 86212 : || !gfc_is_constant_expr (e)))
15410 : not_constant = true;
15411 : }
15412 : }
15413 118826 : return not_constant;
15414 : }
15415 :
15416 : /* Given a symbol and an initialization expression, add code to initialize
15417 : the symbol to the function entry. */
15418 : static void
15419 2144 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
15420 : {
15421 2144 : gfc_expr *lval;
15422 2144 : gfc_code *init_st;
15423 2144 : gfc_namespace *ns = sym->ns;
15424 :
15425 2144 : if (sym->attr.function && sym->result == sym && IS_PDT (sym))
15426 : {
15427 46 : gfc_free_expr (init);
15428 46 : return;
15429 : }
15430 :
15431 : /* Search for the function namespace if this is a contained
15432 : function without an explicit result. */
15433 2098 : if (sym->attr.function && sym == sym->result
15434 299 : && sym->name != sym->ns->proc_name->name)
15435 : {
15436 298 : ns = ns->contained;
15437 1376 : for (;ns; ns = ns->sibling)
15438 1315 : if (strcmp (ns->proc_name->name, sym->name) == 0)
15439 : break;
15440 : }
15441 :
15442 2098 : if (ns == NULL)
15443 : {
15444 61 : gfc_free_expr (init);
15445 61 : return;
15446 : }
15447 :
15448 : /* Build an l-value expression for the result. */
15449 2037 : lval = gfc_lval_expr_from_sym (sym);
15450 :
15451 : /* Add the code at scope entry. */
15452 2037 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
15453 2037 : init_st->next = ns->code;
15454 2037 : ns->code = init_st;
15455 :
15456 : /* Assign the default initializer to the l-value. */
15457 2037 : init_st->loc = sym->declared_at;
15458 2037 : init_st->expr1 = lval;
15459 2037 : init_st->expr2 = init;
15460 : }
15461 :
15462 :
15463 : /* Whether or not we can generate a default initializer for a symbol. */
15464 :
15465 : static bool
15466 30651 : can_generate_init (gfc_symbol *sym)
15467 : {
15468 30651 : symbol_attribute *a;
15469 30651 : if (!sym)
15470 : return false;
15471 30651 : a = &sym->attr;
15472 :
15473 : /* These symbols should never have a default initialization. */
15474 50448 : return !(
15475 30651 : a->allocatable
15476 30651 : || a->external
15477 29472 : || a->pointer
15478 29472 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
15479 5783 : && (CLASS_DATA (sym)->attr.class_pointer
15480 3789 : || CLASS_DATA (sym)->attr.proc_pointer))
15481 27478 : || a->in_equivalence
15482 27357 : || a->in_common
15483 27310 : || a->data
15484 27132 : || sym->module
15485 23297 : || a->cray_pointee
15486 23235 : || a->cray_pointer
15487 23235 : || sym->assoc
15488 20478 : || (!a->referenced && !a->result)
15489 19797 : || (a->dummy && (a->intent != INTENT_OUT
15490 1081 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
15491 19797 : || (a->function && sym != sym->result)
15492 : );
15493 : }
15494 :
15495 :
15496 : /* Assign the default initializer to a derived type variable or result. */
15497 :
15498 : static void
15499 11717 : apply_default_init (gfc_symbol *sym)
15500 : {
15501 11717 : gfc_expr *init = NULL;
15502 :
15503 11717 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15504 : return;
15505 :
15506 11472 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
15507 10619 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15508 :
15509 11472 : if (init == NULL && sym->ts.type != BT_CLASS)
15510 : return;
15511 :
15512 1762 : build_init_assign (sym, init);
15513 1762 : sym->attr.referenced = 1;
15514 : }
15515 :
15516 :
15517 : /* Build an initializer for a local. Returns null if the symbol should not have
15518 : a default initialization. */
15519 :
15520 : static gfc_expr *
15521 207061 : build_default_init_expr (gfc_symbol *sym)
15522 : {
15523 : /* These symbols should never have a default initialization. */
15524 207061 : if (sym->attr.allocatable
15525 193195 : || sym->attr.external
15526 193195 : || sym->attr.dummy
15527 126816 : || sym->attr.pointer
15528 118611 : || sym->attr.in_equivalence
15529 116235 : || sym->attr.in_common
15530 113133 : || sym->attr.data
15531 110835 : || sym->module
15532 108275 : || sym->attr.cray_pointee
15533 107974 : || sym->attr.cray_pointer
15534 107672 : || sym->assoc)
15535 : return NULL;
15536 :
15537 : /* Get the appropriate init expression. */
15538 102817 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
15539 : }
15540 :
15541 : /* Add an initialization expression to a local variable. */
15542 : static void
15543 207061 : apply_default_init_local (gfc_symbol *sym)
15544 : {
15545 207061 : gfc_expr *init = NULL;
15546 :
15547 : /* The symbol should be a variable or a function return value. */
15548 207061 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15549 207061 : || (sym->attr.function && sym->result != sym))
15550 : return;
15551 :
15552 : /* Try to build the initializer expression. If we can't initialize
15553 : this symbol, then init will be NULL. */
15554 207061 : init = build_default_init_expr (sym);
15555 207061 : if (init == NULL)
15556 : return;
15557 :
15558 : /* For saved variables, we don't want to add an initializer at function
15559 : entry, so we just add a static initializer. Note that automatic variables
15560 : are stack allocated even with -fno-automatic; we have also to exclude
15561 : result variable, which are also nonstatic. */
15562 419 : if (!sym->attr.automatic
15563 419 : && (sym->attr.save || sym->ns->save_all
15564 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15565 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15566 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15567 : {
15568 : /* Don't clobber an existing initializer! */
15569 37 : gcc_assert (sym->value == NULL);
15570 37 : sym->value = init;
15571 37 : return;
15572 : }
15573 :
15574 382 : build_init_assign (sym, init);
15575 : }
15576 :
15577 :
15578 : /* Resolution of common features of flavors variable and procedure. */
15579 :
15580 : static bool
15581 1007512 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15582 : {
15583 1007512 : gfc_array_spec *as;
15584 :
15585 1007512 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15586 19688 : && sym->ts.u.derived && CLASS_DATA (sym))
15587 19682 : as = CLASS_DATA (sym)->as;
15588 : else
15589 987830 : as = sym->as;
15590 :
15591 : /* Constraints on deferred shape variable. */
15592 1007512 : if (as == NULL || as->type != AS_DEFERRED)
15593 : {
15594 982914 : bool pointer, allocatable, dimension;
15595 :
15596 982914 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15597 16447 : && sym->ts.u.derived && CLASS_DATA (sym))
15598 : {
15599 16441 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15600 16441 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15601 16441 : dimension = CLASS_DATA (sym)->attr.dimension;
15602 : }
15603 : else
15604 : {
15605 966473 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15606 966473 : allocatable = sym->attr.allocatable;
15607 966473 : dimension = sym->attr.dimension;
15608 : }
15609 :
15610 982914 : if (allocatable)
15611 : {
15612 8135 : if (dimension
15613 8135 : && as
15614 524 : && as->type != AS_ASSUMED_RANK
15615 5 : && !sym->attr.select_rank_temporary)
15616 : {
15617 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15618 : "shape or assumed rank", sym->name, &sym->declared_at);
15619 3 : return false;
15620 : }
15621 8132 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15622 : "%qs at %L may not be ALLOCATABLE",
15623 : sym->name, &sym->declared_at))
15624 : return false;
15625 : }
15626 :
15627 982910 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15628 : {
15629 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15630 : "assumed rank", sym->name, &sym->declared_at);
15631 4 : sym->error = 1;
15632 4 : return false;
15633 : }
15634 : }
15635 : else
15636 : {
15637 24598 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15638 4731 : && sym->ts.type != BT_CLASS && !sym->assoc)
15639 : {
15640 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15641 : sym->name, &sym->declared_at);
15642 3 : return false;
15643 : }
15644 : }
15645 :
15646 : /* Constraints on polymorphic variables. */
15647 1007501 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15648 : {
15649 : /* F03:C502. */
15650 19021 : if (sym->attr.class_ok
15651 18965 : && sym->ts.u.derived
15652 18960 : && !sym->attr.select_type_temporary
15653 17826 : && !UNLIMITED_POLY (sym)
15654 15277 : && CLASS_DATA (sym)
15655 15276 : && CLASS_DATA (sym)->ts.u.derived
15656 34296 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15657 : {
15658 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15659 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15660 : &sym->declared_at);
15661 5 : return false;
15662 : }
15663 :
15664 : /* F03:C509. */
15665 : /* Assume that use associated symbols were checked in the module ns.
15666 : Class-variables that are associate-names are also something special
15667 : and excepted from the test. */
15668 19016 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15669 54 : && !sym->attr.select_type_temporary
15670 54 : && !sym->attr.select_rank_temporary)
15671 : {
15672 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15673 : "or pointer", sym->name, &sym->declared_at);
15674 54 : return false;
15675 : }
15676 : }
15677 :
15678 : return true;
15679 : }
15680 :
15681 :
15682 : /* Additional checks for symbols with flavor variable and derived
15683 : type. To be called from resolve_fl_variable. */
15684 :
15685 : static bool
15686 83870 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15687 : {
15688 83870 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15689 :
15690 : /* Check to see if a derived type is blocked from being host
15691 : associated by the presence of another class I symbol in the same
15692 : namespace. 14.6.1.3 of the standard and the discussion on
15693 : comp.lang.fortran. */
15694 83870 : if (sym->ts.u.derived
15695 83865 : && sym->ns != sym->ts.u.derived->ns
15696 47955 : && !sym->ts.u.derived->attr.use_assoc
15697 17819 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15698 : {
15699 16830 : gfc_symbol *s;
15700 16830 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15701 16830 : if (s && s->attr.generic)
15702 2 : s = gfc_find_dt_in_generic (s);
15703 16830 : if (s && !gfc_fl_struct (s->attr.flavor))
15704 : {
15705 2 : gfc_error ("The type %qs cannot be host associated at %L "
15706 : "because it is blocked by an incompatible object "
15707 : "of the same name declared at %L",
15708 2 : sym->ts.u.derived->name, &sym->declared_at,
15709 : &s->declared_at);
15710 2 : return false;
15711 : }
15712 : }
15713 :
15714 : /* 4th constraint in section 11.3: "If an object of a type for which
15715 : component-initialization is specified (R429) appears in the
15716 : specification-part of a module and does not have the ALLOCATABLE
15717 : or POINTER attribute, the object shall have the SAVE attribute."
15718 :
15719 : The check for initializers is performed with
15720 : gfc_has_default_initializer because gfc_default_initializer generates
15721 : a hidden default for allocatable components. */
15722 83191 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15723 18819 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15724 423 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15725 21 : && !sym->attr.pointer && !sym->attr.allocatable
15726 21 : && gfc_has_default_initializer (sym->ts.u.derived)
15727 83877 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15728 : "%qs at %L, needed due to the default "
15729 : "initialization", sym->name, &sym->declared_at))
15730 : return false;
15731 :
15732 : /* Assign default initializer. */
15733 83866 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15734 77545 : && (!no_init_flag
15735 60564 : || (sym->attr.intent == INTENT_OUT
15736 3225 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15737 20032 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15738 :
15739 : return true;
15740 : }
15741 :
15742 :
15743 : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15744 : except in the declaration of an entity or component that has the POINTER
15745 : or ALLOCATABLE attribute. */
15746 :
15747 : static bool
15748 1585900 : deferred_requirements (gfc_symbol *sym)
15749 : {
15750 1585900 : if (sym->ts.deferred
15751 8086 : && !(sym->attr.pointer
15752 2424 : || sym->attr.allocatable
15753 92 : || sym->attr.associate_var
15754 7 : || sym->attr.omp_udr_artificial_var))
15755 : {
15756 : /* If a function has a result variable, only check the variable. */
15757 7 : if (sym->result && sym->name != sym->result->name)
15758 : return true;
15759 :
15760 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15761 : "requires either the POINTER or ALLOCATABLE attribute",
15762 : sym->name, &sym->declared_at);
15763 6 : return false;
15764 : }
15765 : return true;
15766 : }
15767 :
15768 :
15769 : /* Resolve symbols with flavor variable. */
15770 :
15771 : static bool
15772 676206 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15773 : {
15774 676206 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15775 : "SAVE attribute");
15776 :
15777 676206 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15778 : return false;
15779 :
15780 : /* Set this flag to check that variables are parameters of all entries.
15781 : This check is effected by the call to gfc_resolve_expr through
15782 : is_non_constant_shape_array. */
15783 676146 : bool saved_specification_expr = specification_expr;
15784 676146 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
15785 676146 : specification_expr = true;
15786 676146 : specification_expr_symbol = sym;
15787 :
15788 676146 : if (sym->ns->proc_name
15789 676051 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15790 670989 : || sym->ns->proc_name->attr.is_main_program)
15791 83527 : && !sym->attr.use_assoc
15792 80327 : && !sym->attr.allocatable
15793 74494 : && !sym->attr.pointer
15794 746972 : && is_non_constant_shape_array (sym))
15795 : {
15796 : /* F08:C541. The shape of an array defined in a main program or module
15797 : * needs to be constant. */
15798 3 : gfc_error ("The module or main program array %qs at %L must "
15799 : "have constant shape", sym->name, &sym->declared_at);
15800 3 : specification_expr = saved_specification_expr;
15801 3 : specification_expr_symbol = saved_specification_expr_symbol;
15802 3 : return false;
15803 : }
15804 :
15805 : /* Constraints on deferred type parameter. */
15806 676143 : if (!deferred_requirements (sym))
15807 : return false;
15808 :
15809 676139 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15810 : {
15811 : /* Make sure that character string variables with assumed length are
15812 : dummy arguments. */
15813 36388 : gfc_expr *e = NULL;
15814 :
15815 36388 : if (sym->ts.u.cl)
15816 36388 : e = sym->ts.u.cl->length;
15817 : else
15818 : return false;
15819 :
15820 36388 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15821 2646 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15822 2 : && !sym->attr.omp_udr_artificial_var)
15823 : {
15824 2 : gfc_error ("Entity with assumed character length at %L must be a "
15825 : "dummy argument or a PARAMETER", &sym->declared_at);
15826 2 : specification_expr = saved_specification_expr;
15827 2 : specification_expr_symbol = saved_specification_expr_symbol;
15828 2 : return false;
15829 : }
15830 :
15831 21048 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15832 : {
15833 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15834 1 : specification_expr = saved_specification_expr;
15835 1 : specification_expr_symbol = saved_specification_expr_symbol;
15836 1 : return false;
15837 : }
15838 :
15839 36385 : if (!gfc_is_constant_expr (e)
15840 36385 : && !(e->expr_type == EXPR_VARIABLE
15841 1388 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
15842 : {
15843 2184 : if (!sym->attr.use_assoc && sym->ns->proc_name
15844 1680 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15845 1679 : || sym->ns->proc_name->attr.is_main_program))
15846 : {
15847 3 : gfc_error ("%qs at %L must have constant character length "
15848 : "in this context", sym->name, &sym->declared_at);
15849 3 : specification_expr = saved_specification_expr;
15850 3 : specification_expr_symbol = saved_specification_expr_symbol;
15851 3 : return false;
15852 : }
15853 2181 : if (sym->attr.in_common)
15854 : {
15855 1 : gfc_error ("COMMON variable %qs at %L must have constant "
15856 : "character length", sym->name, &sym->declared_at);
15857 1 : specification_expr = saved_specification_expr;
15858 1 : specification_expr_symbol = saved_specification_expr_symbol;
15859 1 : return false;
15860 : }
15861 : }
15862 : }
15863 :
15864 676132 : if (sym->value == NULL && sym->attr.referenced
15865 208995 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
15866 207061 : apply_default_init_local (sym); /* Try to apply a default initialization. */
15867 :
15868 : /* Determine if the symbol may not have an initializer. */
15869 676132 : int no_init_flag = 0, automatic_flag = 0;
15870 676132 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
15871 172422 : || sym->attr.intrinsic || sym->attr.result)
15872 : no_init_flag = 1;
15873 139964 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
15874 174905 : && is_non_constant_shape_array (sym))
15875 : {
15876 1351 : no_init_flag = automatic_flag = 1;
15877 :
15878 : /* Also, they must not have the SAVE attribute.
15879 : SAVE_IMPLICIT is checked below. */
15880 1351 : if (sym->as && sym->attr.codimension)
15881 : {
15882 7 : int corank = sym->as->corank;
15883 7 : sym->as->corank = 0;
15884 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
15885 7 : sym->as->corank = corank;
15886 : }
15887 1351 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
15888 : {
15889 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15890 2 : specification_expr = saved_specification_expr;
15891 2 : specification_expr_symbol = saved_specification_expr_symbol;
15892 2 : return false;
15893 : }
15894 : }
15895 :
15896 : /* Ensure that any initializer is simplified. */
15897 676130 : if (sym->value)
15898 8252 : gfc_simplify_expr (sym->value, 1);
15899 :
15900 : /* Reject illegal initializers. */
15901 676130 : if (!sym->mark && sym->value)
15902 : {
15903 8252 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
15904 67 : && CLASS_DATA (sym)->attr.allocatable))
15905 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
15906 : sym->name, &sym->declared_at);
15907 8251 : else if (sym->attr.external)
15908 0 : gfc_error ("External %qs at %L cannot have an initializer",
15909 : sym->name, &sym->declared_at);
15910 8251 : else if (sym->attr.dummy)
15911 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
15912 : sym->name, &sym->declared_at);
15913 8248 : else if (sym->attr.intrinsic)
15914 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
15915 : sym->name, &sym->declared_at);
15916 8248 : else if (sym->attr.result)
15917 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
15918 : sym->name, &sym->declared_at);
15919 8247 : else if (automatic_flag)
15920 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
15921 : sym->name, &sym->declared_at);
15922 : else
15923 8242 : goto no_init_error;
15924 10 : specification_expr = saved_specification_expr;
15925 10 : specification_expr_symbol = saved_specification_expr_symbol;
15926 10 : return false;
15927 : }
15928 :
15929 667878 : no_init_error:
15930 676120 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
15931 : {
15932 83870 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
15933 83870 : specification_expr = saved_specification_expr;
15934 83870 : specification_expr_symbol = saved_specification_expr_symbol;
15935 83870 : return res;
15936 : }
15937 :
15938 592250 : specification_expr = saved_specification_expr;
15939 592250 : specification_expr_symbol = saved_specification_expr_symbol;
15940 592250 : return true;
15941 : }
15942 :
15943 :
15944 : /* Compare the dummy characteristics of a module procedure interface
15945 : declaration with the corresponding declaration in a submodule. */
15946 : static gfc_formal_arglist *new_formal;
15947 : static char errmsg[200];
15948 :
15949 : static void
15950 1352 : compare_fsyms (gfc_symbol *sym)
15951 : {
15952 1352 : gfc_symbol *fsym;
15953 :
15954 1352 : if (sym == NULL || new_formal == NULL)
15955 : return;
15956 :
15957 1352 : fsym = new_formal->sym;
15958 :
15959 1352 : if (sym == fsym)
15960 : return;
15961 :
15962 1328 : if (strcmp (sym->name, fsym->name) == 0)
15963 : {
15964 523 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
15965 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
15966 : }
15967 : }
15968 :
15969 :
15970 : /* Resolve a procedure. */
15971 :
15972 : static bool
15973 498683 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
15974 : {
15975 498683 : gfc_formal_arglist *arg;
15976 498683 : bool allocatable_or_pointer = false;
15977 :
15978 498683 : if (sym->attr.function
15979 498683 : && !resolve_fl_var_and_proc (sym, mp_flag))
15980 : return false;
15981 :
15982 : /* Constraints on deferred type parameter. */
15983 498673 : if (!deferred_requirements (sym))
15984 : return false;
15985 :
15986 498672 : if (sym->ts.type == BT_CHARACTER)
15987 : {
15988 11945 : gfc_charlen *cl = sym->ts.u.cl;
15989 :
15990 7722 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
15991 13252 : && !resolve_charlen (cl))
15992 : return false;
15993 :
15994 11944 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
15995 10638 : && sym->attr.proc == PROC_ST_FUNCTION)
15996 : {
15997 0 : gfc_error ("Character-valued statement function %qs at %L must "
15998 : "have constant length", sym->name, &sym->declared_at);
15999 0 : return false;
16000 : }
16001 : }
16002 :
16003 : /* Ensure that derived type for are not of a private type. Internal
16004 : module procedures are excluded by 2.2.3.3 - i.e., they are not
16005 : externally accessible and can access all the objects accessible in
16006 : the host. */
16007 114777 : if (!(sym->ns->parent && sym->ns->parent->proc_name
16008 114777 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
16009 587300 : && gfc_check_symbol_access (sym))
16010 : {
16011 465243 : gfc_interface *iface;
16012 :
16013 992319 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
16014 : {
16015 527077 : if (arg->sym
16016 526937 : && arg->sym->ts.type == BT_DERIVED
16017 43572 : && arg->sym->ts.u.derived
16018 43572 : && !arg->sym->ts.u.derived->attr.use_assoc
16019 4254 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16020 527086 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
16021 : "and cannot be a dummy argument"
16022 : " of %qs, which is PUBLIC at %L",
16023 9 : arg->sym->name, sym->name,
16024 : &sym->declared_at))
16025 : {
16026 : /* Stop this message from recurring. */
16027 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16028 1 : return false;
16029 : }
16030 : }
16031 :
16032 : /* PUBLIC interfaces may expose PRIVATE procedures that take types
16033 : PRIVATE to the containing module. */
16034 661694 : for (iface = sym->generic; iface; iface = iface->next)
16035 : {
16036 462442 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
16037 : {
16038 265990 : if (arg->sym
16039 265958 : && arg->sym->ts.type == BT_DERIVED
16040 8033 : && !arg->sym->ts.u.derived->attr.use_assoc
16041 232 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
16042 265994 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
16043 : "PUBLIC interface %qs at %L "
16044 : "takes dummy arguments of %qs which "
16045 : "is PRIVATE", iface->sym->name,
16046 4 : sym->name, &iface->sym->declared_at,
16047 4 : gfc_typename(&arg->sym->ts)))
16048 : {
16049 : /* Stop this message from recurring. */
16050 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
16051 1 : return false;
16052 : }
16053 : }
16054 : }
16055 : }
16056 :
16057 498669 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
16058 86 : && !sym->attr.proc_pointer)
16059 : {
16060 2 : gfc_error ("Function %qs at %L cannot have an initializer",
16061 : sym->name, &sym->declared_at);
16062 :
16063 : /* Make sure no second error is issued for this. */
16064 2 : sym->value->error = 1;
16065 2 : return false;
16066 : }
16067 :
16068 : /* An external symbol may not have an initializer because it is taken to be
16069 : a procedure. Exception: Procedure Pointers. */
16070 498667 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
16071 : {
16072 0 : gfc_error ("External object %qs at %L may not have an initializer",
16073 : sym->name, &sym->declared_at);
16074 0 : return false;
16075 : }
16076 :
16077 : /* An elemental function is required to return a scalar 12.7.1 */
16078 498667 : if (sym->attr.elemental && sym->attr.function
16079 86530 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16080 2 : && CLASS_DATA (sym)->as)))
16081 : {
16082 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
16083 : "result", sym->name, &sym->declared_at);
16084 : /* Reset so that the error only occurs once. */
16085 3 : sym->attr.elemental = 0;
16086 3 : return false;
16087 : }
16088 :
16089 498664 : if (sym->attr.proc == PROC_ST_FUNCTION
16090 223 : && (sym->attr.allocatable || sym->attr.pointer))
16091 : {
16092 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
16093 : "allocatable attribute", sym->name, &sym->declared_at);
16094 2 : return false;
16095 : }
16096 :
16097 : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
16098 : char-len-param shall not be array-valued, pointer-valued, recursive
16099 : or pure. ....snip... A character value of * may only be used in the
16100 : following ways: (i) Dummy arg of procedure - dummy associates with
16101 : actual length; (ii) To declare a named constant; or (iii) External
16102 : function - but length must be declared in calling scoping unit. */
16103 498662 : if (sym->attr.function
16104 331287 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
16105 6828 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
16106 : {
16107 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
16108 178 : || (sym->attr.recursive) || (sym->attr.pure))
16109 : {
16110 4 : if (sym->as && sym->as->rank)
16111 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16112 : "array-valued", sym->name, &sym->declared_at);
16113 :
16114 4 : if (sym->attr.pointer)
16115 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16116 : "pointer-valued", sym->name, &sym->declared_at);
16117 :
16118 4 : if (sym->attr.pure)
16119 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16120 : "pure", sym->name, &sym->declared_at);
16121 :
16122 4 : if (sym->attr.recursive)
16123 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
16124 : "recursive", sym->name, &sym->declared_at);
16125 :
16126 4 : return false;
16127 : }
16128 :
16129 : /* Appendix B.2 of the standard. Contained functions give an
16130 : error anyway. Deferred character length is an F2003 feature.
16131 : Don't warn on intrinsic conversion functions, which start
16132 : with two underscores. */
16133 176 : if (!sym->attr.contained && !sym->ts.deferred
16134 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
16135 172 : gfc_notify_std (GFC_STD_F95_OBS,
16136 : "CHARACTER(*) function %qs at %L",
16137 : sym->name, &sym->declared_at);
16138 : }
16139 :
16140 : /* F2008, C1218. */
16141 498658 : if (sym->attr.elemental)
16142 : {
16143 89832 : if (sym->attr.proc_pointer)
16144 : {
16145 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
16146 : : sym->name);
16147 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
16148 : name, &sym->declared_at);
16149 7 : return false;
16150 : }
16151 89825 : if (sym->attr.dummy)
16152 : {
16153 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
16154 : sym->name, &sym->declared_at);
16155 3 : return false;
16156 : }
16157 : }
16158 :
16159 : /* F2018, C15100: "The result of an elemental function shall be scalar,
16160 : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
16161 : pointer is tested and caught elsewhere. */
16162 498648 : if (sym->result)
16163 278915 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
16164 278915 : && CLASS_DATA (sym->result) ?
16165 1669 : (CLASS_DATA (sym->result)->attr.allocatable
16166 1669 : || CLASS_DATA (sym->result)->attr.pointer) :
16167 277246 : (sym->result->attr.allocatable
16168 277246 : || sym->result->attr.pointer);
16169 :
16170 498648 : if (sym->attr.elemental && sym->result
16171 86147 : && allocatable_or_pointer)
16172 : {
16173 4 : gfc_error ("Function result variable %qs at %L of elemental "
16174 : "function %qs shall not have an ALLOCATABLE or POINTER "
16175 : "attribute", sym->result->name,
16176 : &sym->result->declared_at, sym->name);
16177 4 : return false;
16178 : }
16179 :
16180 : /* F2018:C1585: "The function result of a pure function shall not be both
16181 : polymorphic and allocatable, or have a polymorphic allocatable ultimate
16182 : component." */
16183 498644 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
16184 : {
16185 2520 : if (sym->ts.type == BT_CLASS
16186 5 : && sym->attr.class_ok
16187 4 : && CLASS_DATA (sym->result)
16188 4 : && CLASS_DATA (sym->result)->attr.allocatable)
16189 : {
16190 4 : gfc_error ("Result variable %qs of pure function at %L is "
16191 : "polymorphic allocatable",
16192 : sym->result->name, &sym->result->declared_at);
16193 4 : return false;
16194 : }
16195 :
16196 2516 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
16197 : {
16198 : gfc_component *c = sym->ts.u.derived->components;
16199 4613 : for (; c; c = c->next)
16200 2406 : if (c->ts.type == BT_CLASS
16201 2 : && CLASS_DATA (c)
16202 2 : && CLASS_DATA (c)->attr.allocatable)
16203 : {
16204 2 : gfc_error ("Result variable %qs of pure function at %L has "
16205 : "polymorphic allocatable component %qs",
16206 : sym->result->name, &sym->result->declared_at,
16207 : c->name);
16208 2 : return false;
16209 : }
16210 : }
16211 : }
16212 :
16213 498638 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
16214 : {
16215 7234 : gfc_formal_arglist *curr_arg;
16216 7234 : int has_non_interop_arg = 0;
16217 :
16218 7234 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
16219 7234 : sym->common_block))
16220 : {
16221 : /* Clear these to prevent looking at them again if there was an
16222 : error. */
16223 2 : sym->attr.is_bind_c = 0;
16224 2 : sym->attr.is_c_interop = 0;
16225 2 : sym->ts.is_c_interop = 0;
16226 : }
16227 : else
16228 : {
16229 : /* So far, no errors have been found. */
16230 7232 : sym->attr.is_c_interop = 1;
16231 7232 : sym->ts.is_c_interop = 1;
16232 : }
16233 :
16234 7234 : curr_arg = gfc_sym_get_dummy_args (sym);
16235 31841 : while (curr_arg != NULL)
16236 : {
16237 : /* Skip implicitly typed dummy args here. */
16238 17373 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
16239 17316 : if (!gfc_verify_c_interop_param (curr_arg->sym))
16240 : /* If something is found to fail, record the fact so we
16241 : can mark the symbol for the procedure as not being
16242 : BIND(C) to try and prevent multiple errors being
16243 : reported. */
16244 17373 : has_non_interop_arg = 1;
16245 :
16246 17373 : curr_arg = curr_arg->next;
16247 : }
16248 :
16249 : /* See if any of the arguments were not interoperable and if so, clear
16250 : the procedure symbol to prevent duplicate error messages. */
16251 7234 : if (has_non_interop_arg != 0)
16252 : {
16253 128 : sym->attr.is_c_interop = 0;
16254 128 : sym->ts.is_c_interop = 0;
16255 128 : sym->attr.is_bind_c = 0;
16256 : }
16257 : }
16258 :
16259 498638 : if (!sym->attr.proc_pointer)
16260 : {
16261 497532 : if (sym->attr.save == SAVE_EXPLICIT)
16262 : {
16263 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
16264 : "in %qs at %L", sym->name, &sym->declared_at);
16265 5 : return false;
16266 : }
16267 497527 : if (sym->attr.intent)
16268 : {
16269 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
16270 : "in %qs at %L", sym->name, &sym->declared_at);
16271 1 : return false;
16272 : }
16273 497526 : if (sym->attr.subroutine && sym->attr.result)
16274 : {
16275 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
16276 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
16277 2 : return false;
16278 : }
16279 497524 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
16280 144992 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
16281 144989 : || sym->attr.contained))
16282 : {
16283 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
16284 : "in %qs at %L", sym->name, &sym->declared_at);
16285 3 : return false;
16286 : }
16287 497521 : if (strcmp ("ppr@", sym->name) == 0)
16288 : {
16289 0 : gfc_error ("Procedure pointer result %qs at %L "
16290 : "is missing the pointer attribute",
16291 0 : sym->ns->proc_name->name, &sym->declared_at);
16292 0 : return false;
16293 : }
16294 : }
16295 :
16296 : /* Assume that a procedure whose body is not known has references
16297 : to external arrays. */
16298 498627 : if (sym->attr.if_source != IFSRC_DECL)
16299 344315 : sym->attr.array_outer_dependency = 1;
16300 :
16301 : /* Compare the characteristics of a module procedure with the
16302 : interface declaration. Ideally this would be done with
16303 : gfc_compare_interfaces but, at present, the formal interface
16304 : cannot be copied to the ts.interface. */
16305 498627 : if (sym->attr.module_procedure
16306 1615 : && sym->attr.if_source == IFSRC_DECL)
16307 : {
16308 659 : gfc_symbol *iface;
16309 659 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
16310 659 : char *module_name;
16311 659 : char *submodule_name;
16312 659 : strcpy (name, sym->ns->proc_name->name);
16313 659 : module_name = strtok (name, ".");
16314 659 : submodule_name = strtok (NULL, ".");
16315 :
16316 659 : iface = sym->tlink;
16317 659 : sym->tlink = NULL;
16318 :
16319 : /* Make sure that the result uses the correct charlen for deferred
16320 : length results. */
16321 659 : if (iface && sym->result
16322 192 : && iface->ts.type == BT_CHARACTER
16323 19 : && iface->ts.deferred)
16324 6 : sym->result->ts.u.cl = iface->ts.u.cl;
16325 :
16326 6 : if (iface == NULL)
16327 196 : goto check_formal;
16328 :
16329 : /* Check the procedure characteristics. */
16330 463 : if (sym->attr.elemental != iface->attr.elemental)
16331 : {
16332 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
16333 : "PROCEDURE at %L and its interface in %s",
16334 : &sym->declared_at, module_name);
16335 10 : return false;
16336 : }
16337 :
16338 462 : if (sym->attr.pure != iface->attr.pure)
16339 : {
16340 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
16341 : "PROCEDURE at %L and its interface in %s",
16342 : &sym->declared_at, module_name);
16343 2 : return false;
16344 : }
16345 :
16346 460 : if (sym->attr.recursive != iface->attr.recursive)
16347 : {
16348 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
16349 : "PROCEDURE at %L and its interface in %s",
16350 : &sym->declared_at, module_name);
16351 2 : return false;
16352 : }
16353 :
16354 : /* Check the result characteristics. */
16355 458 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
16356 : {
16357 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
16358 : "in MODULE %qs and the declaration at %L in "
16359 : "(SUB)MODULE %qs",
16360 : errmsg, module_name, &sym->declared_at,
16361 : submodule_name ? submodule_name : module_name);
16362 5 : return false;
16363 : }
16364 :
16365 453 : check_formal:
16366 : /* Check the characteristics of the formal arguments. */
16367 649 : if (sym->formal && sym->formal_ns)
16368 : {
16369 1260 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
16370 : {
16371 722 : new_formal = arg;
16372 722 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
16373 : }
16374 : }
16375 : }
16376 :
16377 : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
16378 : BIND(C) attribute. */
16379 498617 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
16380 : {
16381 1 : gfc_error ("Interface of %qs at %L must be explicit",
16382 : sym->name, &sym->declared_at);
16383 1 : return false;
16384 : }
16385 :
16386 : return true;
16387 : }
16388 :
16389 :
16390 : /* Resolve a list of finalizer procedures. That is, after they have hopefully
16391 : been defined and we now know their defined arguments, check that they fulfill
16392 : the requirements of the standard for procedures used as finalizers. */
16393 :
16394 : static bool
16395 114367 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
16396 : {
16397 114367 : gfc_finalizer *list, *pdt_finalizers = NULL;
16398 114367 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
16399 114367 : bool result = true;
16400 114367 : bool seen_scalar = false;
16401 114367 : gfc_symbol *vtab;
16402 114367 : gfc_component *c;
16403 114367 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
16404 :
16405 114367 : if (parent)
16406 15822 : gfc_resolve_finalizers (parent, finalizable);
16407 :
16408 : /* Ensure that derived-type components have a their finalizers resolved. */
16409 114367 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
16410 359498 : for (c = derived->components; c; c = c->next)
16411 245131 : if (c->ts.type == BT_DERIVED
16412 68801 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
16413 : {
16414 8394 : bool has_final2 = false;
16415 8394 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
16416 0 : return false; /* Error. */
16417 8394 : has_final = has_final || has_final2;
16418 : }
16419 : /* Return early if not finalizable. */
16420 114367 : if (!has_final)
16421 : {
16422 111670 : if (finalizable)
16423 8284 : *finalizable = false;
16424 111670 : return true;
16425 : }
16426 :
16427 : /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of
16428 : the template. If the finalizers field has the same value, it needs to be
16429 : supplied with finalizers of the same pdt_type. */
16430 2697 : if (derived->attr.pdt_type
16431 54 : && derived->template_sym
16432 24 : && derived->template_sym->f2k_derived
16433 24 : && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers)
16434 2721 : && derived->f2k_derived->finalizers == pdt_finalizers)
16435 : {
16436 24 : gfc_finalizer *tmp = NULL;
16437 24 : derived->f2k_derived->finalizers = NULL;
16438 24 : prev_link = &derived->f2k_derived->finalizers;
16439 84 : for (list = pdt_finalizers; list; list = list->next)
16440 : {
16441 60 : gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym);
16442 60 : if (args->sym
16443 60 : && args->sym->ts.type == BT_DERIVED
16444 60 : && args->sym->ts.u.derived
16445 60 : && !strcmp (args->sym->ts.u.derived->name, derived->name))
16446 : {
16447 36 : tmp = gfc_get_finalizer ();
16448 36 : *tmp = *list;
16449 36 : tmp->next = NULL;
16450 36 : *prev_link = tmp;
16451 36 : prev_link = &(tmp->next);
16452 36 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16453 : }
16454 : }
16455 : }
16456 :
16457 : /* Walk over the list of finalizer-procedures, check them, and if any one
16458 : does not fit in with the standard's definition, print an error and remove
16459 : it from the list. */
16460 2697 : prev_link = &derived->f2k_derived->finalizers;
16461 5554 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
16462 : {
16463 2857 : gfc_formal_arglist *dummy_args;
16464 2857 : gfc_symbol* arg;
16465 2857 : gfc_finalizer* i;
16466 2857 : int my_rank;
16467 :
16468 : /* Skip this finalizer if we already resolved it. */
16469 2857 : if (list->proc_tree)
16470 : {
16471 2294 : if (list->proc_tree->n.sym->formal->sym->as == NULL
16472 602 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
16473 1692 : seen_scalar = true;
16474 2294 : prev_link = &(list->next);
16475 2294 : continue;
16476 : }
16477 :
16478 : /* Check this exists and is a SUBROUTINE. */
16479 563 : if (!list->proc_sym->attr.subroutine)
16480 : {
16481 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
16482 : list->proc_sym->name, &list->where);
16483 3 : goto error;
16484 : }
16485 :
16486 : /* We should have exactly one argument. */
16487 560 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
16488 560 : if (!dummy_args || dummy_args->next)
16489 : {
16490 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
16491 : &list->where);
16492 2 : goto error;
16493 : }
16494 558 : arg = dummy_args->sym;
16495 :
16496 558 : if (!arg)
16497 : {
16498 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16499 1 : &list->proc_sym->declared_at, derived->name);
16500 1 : goto error;
16501 : }
16502 :
16503 557 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
16504 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
16505 : {
16506 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
16507 : "be the only finalizer with the same kind/type "
16508 : "(F2018: C790)", &list->where);
16509 0 : goto error;
16510 : }
16511 :
16512 : /* This argument must be of our type. */
16513 557 : if (!derived->attr.pdt_template
16514 545 : && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived))
16515 : {
16516 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
16517 : &arg->declared_at, derived->name);
16518 2 : goto error;
16519 : }
16520 :
16521 : /* It must neither be a pointer nor allocatable nor optional. */
16522 555 : if (arg->attr.pointer)
16523 : {
16524 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
16525 : &arg->declared_at);
16526 1 : goto error;
16527 : }
16528 554 : if (arg->attr.allocatable)
16529 : {
16530 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16531 : " ALLOCATABLE", &arg->declared_at);
16532 1 : goto error;
16533 : }
16534 553 : if (arg->attr.optional)
16535 : {
16536 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
16537 : &arg->declared_at);
16538 1 : goto error;
16539 : }
16540 :
16541 : /* It must not be INTENT(OUT). */
16542 552 : if (arg->attr.intent == INTENT_OUT)
16543 : {
16544 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
16545 : " INTENT(OUT)", &arg->declared_at);
16546 1 : goto error;
16547 : }
16548 :
16549 : /* Warn if the procedure is non-scalar and not assumed shape. */
16550 551 : if (warn_surprising && arg->as && arg->as->rank != 0
16551 3 : && arg->as->type != AS_ASSUMED_SHAPE)
16552 2 : gfc_warning (OPT_Wsurprising,
16553 : "Non-scalar FINAL procedure at %L should have assumed"
16554 : " shape argument", &arg->declared_at);
16555 :
16556 : /* Check that it does not match in kind and rank with a FINAL procedure
16557 : defined earlier. To really loop over the *earlier* declarations,
16558 : we need to walk the tail of the list as new ones were pushed at the
16559 : front. */
16560 : /* TODO: Handle kind parameters once they are implemented. */
16561 551 : my_rank = (arg->as ? arg->as->rank : 0);
16562 658 : for (i = list->next; i; i = i->next)
16563 : {
16564 109 : gfc_formal_arglist *dummy_args;
16565 :
16566 : /* Argument list might be empty; that is an error signalled earlier,
16567 : but we nevertheless continued resolving. */
16568 109 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
16569 109 : if (dummy_args && !derived->attr.pdt_template)
16570 : {
16571 107 : gfc_symbol* i_arg = dummy_args->sym;
16572 107 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
16573 107 : if (i_rank == my_rank)
16574 : {
16575 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
16576 : " rank (%d) as %qs",
16577 2 : list->proc_sym->name, &list->where, my_rank,
16578 2 : i->proc_sym->name);
16579 2 : goto error;
16580 : }
16581 : }
16582 : }
16583 :
16584 : /* Is this the/a scalar finalizer procedure? */
16585 549 : if (my_rank == 0)
16586 417 : seen_scalar = true;
16587 :
16588 : /* Find the symtree for this procedure. */
16589 549 : gcc_assert (!list->proc_tree);
16590 549 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16591 :
16592 549 : prev_link = &list->next;
16593 549 : continue;
16594 :
16595 : /* Remove wrong nodes immediately from the list so we don't risk any
16596 : troubles in the future when they might fail later expectations. */
16597 14 : error:
16598 14 : i = list;
16599 14 : *prev_link = list->next;
16600 14 : gfc_free_finalizer (i);
16601 14 : result = false;
16602 549 : }
16603 :
16604 2697 : if (result == false)
16605 : return false;
16606 :
16607 : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16608 : were nodes in the list, must have been for arrays. It is surely a good
16609 : idea to have a scalar version there if there's something to finalize. */
16610 2693 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16611 1 : gfc_warning (OPT_Wsurprising,
16612 : "Only array FINAL procedures declared for derived type %qs"
16613 : " defined at %L, suggest also scalar one unless an assumed"
16614 : " rank finalizer has been declared",
16615 : derived->name, &derived->declared_at);
16616 :
16617 2693 : if (!derived->attr.pdt_template)
16618 : {
16619 2645 : vtab = gfc_find_derived_vtab (derived);
16620 2645 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16621 2645 : if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym)
16622 2645 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16623 : }
16624 :
16625 2693 : if (finalizable)
16626 664 : *finalizable = true;
16627 :
16628 : return true;
16629 : }
16630 :
16631 :
16632 : static gfc_symbol * containing_dt;
16633 :
16634 : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16635 : arguments whose declared types are PDT instances only transmit the PASS arg
16636 : if they match the enclosing derived type. */
16637 :
16638 : static bool
16639 1496 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16640 : {
16641 1496 : gfc_formal_arglist *dummy_args;
16642 1496 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16643 : {
16644 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16645 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16646 126 : dummy_args = dummy_args->next;
16647 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16648 532 : if (dummy_args->sym->ts.type == BT_CLASS
16649 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16650 : containing_dt->name))
16651 : return true;
16652 : }
16653 : return false;
16654 : }
16655 :
16656 :
16657 : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16658 :
16659 : static bool
16660 750 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16661 : const char* generic_name, locus where)
16662 : {
16663 750 : gfc_symbol *sym1, *sym2;
16664 750 : const char *pass1, *pass2;
16665 750 : gfc_formal_arglist *dummy_args;
16666 :
16667 750 : gcc_assert (t1->specific && t2->specific);
16668 750 : gcc_assert (!t1->specific->is_generic);
16669 750 : gcc_assert (!t2->specific->is_generic);
16670 750 : gcc_assert (t1->is_operator == t2->is_operator);
16671 :
16672 750 : sym1 = t1->specific->u.specific->n.sym;
16673 750 : sym2 = t2->specific->u.specific->n.sym;
16674 :
16675 750 : if (sym1 == sym2)
16676 : return true;
16677 :
16678 : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16679 750 : if (sym1->attr.subroutine != sym2->attr.subroutine
16680 748 : || sym1->attr.function != sym2->attr.function)
16681 : {
16682 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16683 : " GENERIC %qs at %L",
16684 : sym1->name, sym2->name, generic_name, &where);
16685 2 : return false;
16686 : }
16687 :
16688 : /* Determine PASS arguments. */
16689 748 : if (t1->specific->nopass)
16690 : pass1 = NULL;
16691 697 : else if (t1->specific->pass_arg)
16692 : pass1 = t1->specific->pass_arg;
16693 : else
16694 : {
16695 438 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16696 438 : if (dummy_args)
16697 437 : pass1 = dummy_args->sym->name;
16698 : else
16699 : pass1 = NULL;
16700 : }
16701 748 : if (t2->specific->nopass)
16702 : pass2 = NULL;
16703 696 : else if (t2->specific->pass_arg)
16704 : pass2 = t2->specific->pass_arg;
16705 : else
16706 : {
16707 559 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16708 559 : if (dummy_args)
16709 558 : pass2 = dummy_args->sym->name;
16710 : else
16711 : pass2 = NULL;
16712 : }
16713 :
16714 : /* Care must be taken with pdt types and templates because the declared type
16715 : of the argument that is not 'no_pass' need not be the same as the
16716 : containing derived type. If this is the case, subject the argument to
16717 : the full interface check, even though it cannot be used in the type
16718 : bound context. */
16719 748 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16720 748 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16721 :
16722 748 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16723 748 : pass1 = pass2 = NULL;
16724 :
16725 : /* Compare the interfaces. */
16726 748 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16727 : NULL, 0, pass1, pass2))
16728 : {
16729 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16730 : sym1->name, sym2->name, generic_name, &where);
16731 8 : return false;
16732 : }
16733 :
16734 : return true;
16735 : }
16736 :
16737 :
16738 : /* Worker function for resolving a generic procedure binding; this is used to
16739 : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16740 :
16741 : The difference between those cases is finding possible inherited bindings
16742 : that are overridden, as one has to look for them in tb_sym_root,
16743 : tb_uop_root or tb_op, respectively. Thus the caller must already find
16744 : the super-type and set p->overridden correctly. */
16745 :
16746 : static bool
16747 2409 : resolve_tb_generic_targets (gfc_symbol* super_type,
16748 : gfc_typebound_proc* p, const char* name)
16749 : {
16750 2409 : gfc_tbp_generic* target;
16751 2409 : gfc_symtree* first_target;
16752 2409 : gfc_symtree* inherited;
16753 :
16754 2409 : gcc_assert (p && p->is_generic);
16755 :
16756 : /* Try to find the specific bindings for the symtrees in our target-list. */
16757 2409 : gcc_assert (p->u.generic);
16758 5422 : for (target = p->u.generic; target; target = target->next)
16759 3030 : if (!target->specific)
16760 : {
16761 2615 : gfc_typebound_proc* overridden_tbp;
16762 2615 : gfc_tbp_generic* g;
16763 2615 : const char* target_name;
16764 :
16765 2615 : target_name = target->specific_st->name;
16766 :
16767 : /* Defined for this type directly. */
16768 2615 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16769 : {
16770 2606 : target->specific = target->specific_st->n.tb;
16771 2606 : goto specific_found;
16772 : }
16773 :
16774 : /* Look for an inherited specific binding. */
16775 9 : if (super_type)
16776 : {
16777 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16778 : true, NULL);
16779 :
16780 5 : if (inherited)
16781 : {
16782 5 : gcc_assert (inherited->n.tb);
16783 5 : target->specific = inherited->n.tb;
16784 5 : goto specific_found;
16785 : }
16786 : }
16787 :
16788 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16789 : " at %L", target_name, name, &p->where);
16790 4 : return false;
16791 :
16792 : /* Once we've found the specific binding, check it is not ambiguous with
16793 : other specifics already found or inherited for the same GENERIC. */
16794 2611 : specific_found:
16795 2611 : gcc_assert (target->specific);
16796 :
16797 : /* This must really be a specific binding! */
16798 2611 : if (target->specific->is_generic)
16799 : {
16800 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16801 : " %qs is GENERIC, too", name, &p->where, target_name);
16802 3 : return false;
16803 : }
16804 :
16805 : /* Check those already resolved on this type directly. */
16806 6666 : for (g = p->u.generic; g; g = g->next)
16807 1464 : if (g != target && g->specific
16808 4797 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16809 : return false;
16810 :
16811 : /* Check for ambiguity with inherited specific targets. */
16812 2617 : for (overridden_tbp = p->overridden; overridden_tbp;
16813 16 : overridden_tbp = overridden_tbp->overridden)
16814 19 : if (overridden_tbp->is_generic)
16815 : {
16816 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16817 : {
16818 18 : gcc_assert (g->specific);
16819 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16820 : return false;
16821 : }
16822 : }
16823 : }
16824 :
16825 : /* If we attempt to "overwrite" a specific binding, this is an error. */
16826 2392 : if (p->overridden && !p->overridden->is_generic)
16827 : {
16828 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16829 : " the same name", name, &p->where);
16830 1 : return false;
16831 : }
16832 :
16833 : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16834 : all must have the same attributes here. */
16835 2391 : first_target = p->u.generic->specific->u.specific;
16836 2391 : gcc_assert (first_target);
16837 2391 : p->subroutine = first_target->n.sym->attr.subroutine;
16838 2391 : p->function = first_target->n.sym->attr.function;
16839 :
16840 2391 : return true;
16841 : }
16842 :
16843 :
16844 : /* Resolve a GENERIC procedure binding for a derived type. */
16845 :
16846 : static bool
16847 1249 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
16848 : {
16849 1249 : gfc_symbol* super_type;
16850 :
16851 : /* Find the overridden binding if any. */
16852 1249 : st->n.tb->overridden = NULL;
16853 1249 : super_type = gfc_get_derived_super_type (derived);
16854 1249 : if (super_type)
16855 : {
16856 40 : gfc_symtree* overridden;
16857 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
16858 : true, NULL);
16859 :
16860 40 : if (overridden && overridden->n.tb)
16861 21 : st->n.tb->overridden = overridden->n.tb;
16862 : }
16863 :
16864 : /* Resolve using worker function. */
16865 1249 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
16866 : }
16867 :
16868 :
16869 : /* Retrieve the target-procedure of an operator binding and do some checks in
16870 : common for intrinsic and user-defined type-bound operators. */
16871 :
16872 : static gfc_symbol*
16873 1232 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
16874 : {
16875 1232 : gfc_symbol* target_proc;
16876 :
16877 1232 : gcc_assert (target->specific && !target->specific->is_generic);
16878 1232 : target_proc = target->specific->u.specific->n.sym;
16879 1232 : gcc_assert (target_proc);
16880 :
16881 : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
16882 1232 : if (target->specific->nopass)
16883 : {
16884 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
16885 2 : return NULL;
16886 : }
16887 :
16888 : return target_proc;
16889 : }
16890 :
16891 :
16892 : /* Resolve a type-bound intrinsic operator. */
16893 :
16894 : static bool
16895 1047 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
16896 : gfc_typebound_proc* p)
16897 : {
16898 1047 : gfc_symbol* super_type;
16899 1047 : gfc_tbp_generic* target;
16900 :
16901 : /* If there's already an error here, do nothing (but don't fail again). */
16902 1047 : if (p->error)
16903 : return true;
16904 :
16905 : /* Operators should always be GENERIC bindings. */
16906 1047 : gcc_assert (p->is_generic);
16907 :
16908 : /* Look for an overridden binding. */
16909 1047 : super_type = gfc_get_derived_super_type (derived);
16910 1047 : if (super_type && super_type->f2k_derived)
16911 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
16912 : op, true, NULL);
16913 : else
16914 1046 : p->overridden = NULL;
16915 :
16916 : /* Resolve general GENERIC properties using worker function. */
16917 1047 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
16918 1 : goto error;
16919 :
16920 : /* Check the targets to be procedures of correct interface. */
16921 2139 : for (target = p->u.generic; target; target = target->next)
16922 : {
16923 1118 : gfc_symbol* target_proc;
16924 :
16925 1118 : target_proc = get_checked_tb_operator_target (target, p->where);
16926 1118 : if (!target_proc)
16927 1 : goto error;
16928 :
16929 1117 : if (!gfc_check_operator_interface (target_proc, op, p->where))
16930 3 : goto error;
16931 :
16932 : /* Add target to non-typebound operator list. */
16933 1114 : if (!target->specific->deferred && !derived->attr.use_assoc
16934 391 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
16935 : {
16936 389 : gfc_interface *head, *intr;
16937 :
16938 : /* Preempt 'gfc_check_new_interface' for submodules, where the
16939 : mechanism for handling module procedures winds up resolving
16940 : operator interfaces twice and would otherwise cause an error.
16941 : Likewise, new instances of PDTs can cause the operator inter-
16942 : faces to be resolved multiple times. */
16943 461 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
16944 91 : if (intr->sym == target_proc
16945 21 : && (target_proc->attr.used_in_submodule
16946 4 : || derived->attr.pdt_type
16947 2 : || derived->attr.pdt_template))
16948 : return true;
16949 :
16950 370 : if (!gfc_check_new_interface (derived->ns->op[op],
16951 : target_proc, p->where))
16952 : return false;
16953 368 : head = derived->ns->op[op];
16954 368 : intr = gfc_get_interface ();
16955 368 : intr->sym = target_proc;
16956 368 : intr->where = p->where;
16957 368 : intr->next = head;
16958 368 : derived->ns->op[op] = intr;
16959 : }
16960 : }
16961 :
16962 : return true;
16963 :
16964 5 : error:
16965 5 : p->error = 1;
16966 5 : return false;
16967 : }
16968 :
16969 :
16970 : /* Resolve a type-bound user operator (tree-walker callback). */
16971 :
16972 : static gfc_symbol* resolve_bindings_derived;
16973 : static bool resolve_bindings_result;
16974 :
16975 : static bool check_uop_procedure (gfc_symbol* sym, locus where);
16976 :
16977 : static void
16978 113 : resolve_typebound_user_op (gfc_symtree* stree)
16979 : {
16980 113 : gfc_symbol* super_type;
16981 113 : gfc_tbp_generic* target;
16982 :
16983 113 : gcc_assert (stree && stree->n.tb);
16984 :
16985 113 : if (stree->n.tb->error)
16986 : return;
16987 :
16988 : /* Operators should always be GENERIC bindings. */
16989 113 : gcc_assert (stree->n.tb->is_generic);
16990 :
16991 : /* Find overridden procedure, if any. */
16992 113 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16993 113 : if (super_type && super_type->f2k_derived)
16994 : {
16995 18 : gfc_symtree* overridden;
16996 18 : overridden = gfc_find_typebound_user_op (super_type, NULL,
16997 : stree->name, true, NULL);
16998 :
16999 18 : if (overridden && overridden->n.tb)
17000 0 : stree->n.tb->overridden = overridden->n.tb;
17001 : }
17002 : else
17003 95 : stree->n.tb->overridden = NULL;
17004 :
17005 : /* Resolve basically using worker function. */
17006 113 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
17007 0 : goto error;
17008 :
17009 : /* Check the targets to be functions of correct interface. */
17010 224 : for (target = stree->n.tb->u.generic; target; target = target->next)
17011 : {
17012 114 : gfc_symbol* target_proc;
17013 :
17014 114 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
17015 114 : if (!target_proc)
17016 1 : goto error;
17017 :
17018 113 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
17019 2 : goto error;
17020 : }
17021 :
17022 : return;
17023 :
17024 3 : error:
17025 3 : resolve_bindings_result = false;
17026 3 : stree->n.tb->error = 1;
17027 : }
17028 :
17029 :
17030 : /* Resolve the type-bound procedures for a derived type. */
17031 :
17032 : static void
17033 10183 : resolve_typebound_procedure (gfc_symtree* stree)
17034 : {
17035 10183 : gfc_symbol* proc;
17036 10183 : locus where;
17037 10183 : gfc_symbol* me_arg;
17038 10183 : gfc_symbol* super_type;
17039 10183 : gfc_component* comp;
17040 :
17041 10183 : gcc_assert (stree);
17042 :
17043 : /* Undefined specific symbol from GENERIC target definition. */
17044 10183 : if (!stree->n.tb)
17045 10101 : return;
17046 :
17047 10177 : if (stree->n.tb->error)
17048 : return;
17049 :
17050 : /* If this is a GENERIC binding, use that routine. */
17051 10161 : if (stree->n.tb->is_generic)
17052 : {
17053 1249 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
17054 17 : goto error;
17055 : return;
17056 : }
17057 :
17058 : /* Get the target-procedure to check it. */
17059 8912 : gcc_assert (!stree->n.tb->is_generic);
17060 8912 : gcc_assert (stree->n.tb->u.specific);
17061 8912 : proc = stree->n.tb->u.specific->n.sym;
17062 8912 : where = stree->n.tb->where;
17063 :
17064 : /* Default access should already be resolved from the parser. */
17065 8912 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
17066 :
17067 8912 : if (stree->n.tb->deferred)
17068 : {
17069 676 : if (!check_proc_interface (proc, &where))
17070 5 : goto error;
17071 : }
17072 : else
17073 : {
17074 : /* If proc has not been resolved at this point, proc->name may
17075 : actually be a USE associated entity. See PR fortran/89647. */
17076 8236 : if (!proc->resolve_symbol_called
17077 5698 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
17078 : {
17079 11 : gfc_symbol *tmp;
17080 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
17081 11 : if (tmp && tmp->attr.use_assoc)
17082 : {
17083 1 : proc->module = tmp->module;
17084 1 : proc->attr.proc = tmp->attr.proc;
17085 1 : proc->attr.function = tmp->attr.function;
17086 1 : proc->attr.subroutine = tmp->attr.subroutine;
17087 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
17088 1 : proc->ts = tmp->ts;
17089 1 : proc->result = tmp->result;
17090 : }
17091 : }
17092 :
17093 : /* Check for F08:C465. */
17094 8236 : if ((!proc->attr.subroutine && !proc->attr.function)
17095 8226 : || (proc->attr.proc != PROC_MODULE
17096 70 : && proc->attr.if_source != IFSRC_IFBODY
17097 7 : && !proc->attr.module_procedure)
17098 8225 : || proc->attr.abstract)
17099 : {
17100 12 : gfc_error ("%qs must be a module procedure or an external "
17101 : "procedure with an explicit interface at %L",
17102 : proc->name, &where);
17103 12 : goto error;
17104 : }
17105 : }
17106 :
17107 8895 : stree->n.tb->subroutine = proc->attr.subroutine;
17108 8895 : stree->n.tb->function = proc->attr.function;
17109 :
17110 : /* Find the super-type of the current derived type. We could do this once and
17111 : store in a global if speed is needed, but as long as not I believe this is
17112 : more readable and clearer. */
17113 8895 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
17114 :
17115 : /* If PASS, resolve and check arguments if not already resolved / loaded
17116 : from a .mod file. */
17117 8895 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
17118 : {
17119 2838 : gfc_formal_arglist *dummy_args;
17120 :
17121 2838 : dummy_args = gfc_sym_get_dummy_args (proc);
17122 2838 : if (stree->n.tb->pass_arg)
17123 : {
17124 468 : gfc_formal_arglist *i;
17125 :
17126 : /* If an explicit passing argument name is given, walk the arg-list
17127 : and look for it. */
17128 :
17129 468 : me_arg = NULL;
17130 468 : stree->n.tb->pass_arg_num = 1;
17131 601 : for (i = dummy_args; i; i = i->next)
17132 : {
17133 599 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
17134 : {
17135 : me_arg = i->sym;
17136 : break;
17137 : }
17138 133 : ++stree->n.tb->pass_arg_num;
17139 : }
17140 :
17141 468 : if (!me_arg)
17142 : {
17143 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
17144 : " argument %qs",
17145 : proc->name, stree->n.tb->pass_arg, &where,
17146 : stree->n.tb->pass_arg);
17147 2 : goto error;
17148 : }
17149 : }
17150 : else
17151 : {
17152 : /* Otherwise, take the first one; there should in fact be at least
17153 : one. */
17154 2370 : stree->n.tb->pass_arg_num = 1;
17155 2370 : if (!dummy_args)
17156 : {
17157 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
17158 : " least one argument", proc->name, &where);
17159 2 : goto error;
17160 : }
17161 2368 : me_arg = dummy_args->sym;
17162 : }
17163 :
17164 : /* Now check that the argument-type matches and the passed-object
17165 : dummy argument is generally fine. */
17166 :
17167 2368 : gcc_assert (me_arg);
17168 :
17169 2834 : if (me_arg->ts.type != BT_CLASS)
17170 : {
17171 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17172 : " at %L", proc->name, &where);
17173 5 : goto error;
17174 : }
17175 :
17176 : /* The derived type is not a PDT template or type. Resolve as usual. */
17177 2829 : if (!resolve_bindings_derived->attr.pdt_template
17178 2820 : && !(containing_dt && containing_dt->attr.pdt_type
17179 60 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
17180 2800 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
17181 : {
17182 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17183 : "the derived-type %qs", me_arg->name, proc->name,
17184 : me_arg->name, &where, resolve_bindings_derived->name);
17185 0 : goto error;
17186 : }
17187 :
17188 2829 : if (resolve_bindings_derived->attr.pdt_template
17189 2838 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
17190 9 : CLASS_DATA (me_arg)->ts.u.derived))
17191 : {
17192 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
17193 : "the parametric derived-type %qs", me_arg->name,
17194 : proc->name, me_arg->name, &where,
17195 : resolve_bindings_derived->name);
17196 0 : goto error;
17197 : }
17198 :
17199 2829 : if (((resolve_bindings_derived->attr.pdt_template
17200 9 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
17201 9 : CLASS_DATA (me_arg)->ts.u.derived))
17202 2820 : || resolve_bindings_derived->attr.pdt_type)
17203 69 : && (me_arg->param_list != NULL)
17204 2898 : && (gfc_spec_list_type (me_arg->param_list,
17205 69 : CLASS_DATA(me_arg)->ts.u.derived)
17206 : != SPEC_ASSUMED))
17207 : {
17208 :
17209 : /* Add a check to verify if there are any LEN parameters in the
17210 : first place. If there are LEN parameters, throw this error.
17211 : If there are only KIND parameters, then don't trigger
17212 : this error. */
17213 6 : gfc_component *c;
17214 6 : bool seen_len_param = false;
17215 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
17216 :
17217 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
17218 : {
17219 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
17220 : me_arg_param->name, true, true, NULL);
17221 :
17222 6 : gcc_assert (c != NULL);
17223 :
17224 6 : if (c->attr.pdt_kind)
17225 0 : continue;
17226 :
17227 : /* Getting here implies that there is a pdt_len parameter
17228 : in the list. */
17229 : seen_len_param = true;
17230 : break;
17231 : }
17232 :
17233 6 : if (seen_len_param)
17234 : {
17235 6 : gfc_error ("All LEN type parameters of the passed dummy "
17236 : "argument %qs of %qs at %L must be ASSUMED.",
17237 : me_arg->name, proc->name, &where);
17238 6 : goto error;
17239 : }
17240 : }
17241 :
17242 2823 : gcc_assert (me_arg->ts.type == BT_CLASS);
17243 2823 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
17244 : {
17245 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
17246 : " scalar", proc->name, &where);
17247 1 : goto error;
17248 : }
17249 2822 : if (CLASS_DATA (me_arg)->attr.allocatable)
17250 : {
17251 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17252 : " be ALLOCATABLE", proc->name, &where);
17253 2 : goto error;
17254 : }
17255 2820 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17256 : {
17257 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
17258 : " be POINTER", proc->name, &where);
17259 2 : goto error;
17260 : }
17261 : }
17262 :
17263 : /* If we are extending some type, check that we don't override a procedure
17264 : flagged NON_OVERRIDABLE. */
17265 8875 : stree->n.tb->overridden = NULL;
17266 8875 : if (super_type)
17267 : {
17268 1513 : gfc_symtree* overridden;
17269 1513 : overridden = gfc_find_typebound_proc (super_type, NULL,
17270 : stree->name, true, NULL);
17271 :
17272 1513 : if (overridden)
17273 : {
17274 1218 : if (overridden->n.tb)
17275 1218 : stree->n.tb->overridden = overridden->n.tb;
17276 :
17277 1218 : if (!gfc_check_typebound_override (stree, overridden))
17278 26 : goto error;
17279 : }
17280 : }
17281 :
17282 : /* See if there's a name collision with a component directly in this type. */
17283 21237 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
17284 12389 : if (!strcmp (comp->name, stree->name))
17285 : {
17286 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
17287 : " %qs",
17288 : stree->name, &where, resolve_bindings_derived->name);
17289 1 : goto error;
17290 : }
17291 :
17292 : /* Try to find a name collision with an inherited component. */
17293 8848 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
17294 : NULL))
17295 : {
17296 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
17297 : " component of %qs",
17298 : stree->name, &where, resolve_bindings_derived->name);
17299 1 : goto error;
17300 : }
17301 :
17302 8847 : stree->n.tb->error = 0;
17303 8847 : return;
17304 :
17305 82 : error:
17306 82 : resolve_bindings_result = false;
17307 82 : stree->n.tb->error = 1;
17308 : }
17309 :
17310 :
17311 : static bool
17312 88004 : resolve_typebound_procedures (gfc_symbol* derived)
17313 : {
17314 88004 : int op;
17315 88004 : gfc_symbol* super_type;
17316 :
17317 : /* Resolve the super-type first so that inherited bindings (including
17318 : user operators) are fully resolved before we look them up via
17319 : gfc_find_typebound_user_op. This must happen even when 'derived'
17320 : has no direct type-bound bindings of its own. */
17321 88004 : super_type = gfc_get_derived_super_type (derived);
17322 88004 : if (super_type)
17323 13472 : resolve_symbol (super_type);
17324 :
17325 88004 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
17326 : return true;
17327 :
17328 4870 : resolve_bindings_derived = derived;
17329 4870 : resolve_bindings_result = true;
17330 :
17331 4870 : containing_dt = derived; /* Needed for checks of PDTs. */
17332 4870 : if (derived->f2k_derived->tb_sym_root)
17333 4870 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
17334 : &resolve_typebound_procedure);
17335 :
17336 4870 : if (derived->f2k_derived->tb_uop_root)
17337 91 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
17338 : &resolve_typebound_user_op);
17339 4870 : containing_dt = NULL;
17340 :
17341 141230 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
17342 : {
17343 136360 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
17344 136360 : if (p && !resolve_typebound_intrinsic_op (derived,
17345 : (gfc_intrinsic_op)op, p))
17346 7 : resolve_bindings_result = false;
17347 : }
17348 :
17349 4870 : return resolve_bindings_result;
17350 : }
17351 :
17352 :
17353 : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
17354 : to give all identical derived types the same backend_decl. */
17355 : static void
17356 179850 : add_dt_to_dt_list (gfc_symbol *derived)
17357 : {
17358 179850 : if (!derived->dt_next)
17359 : {
17360 84150 : if (gfc_derived_types)
17361 : {
17362 68929 : derived->dt_next = gfc_derived_types->dt_next;
17363 68929 : gfc_derived_types->dt_next = derived;
17364 : }
17365 : else
17366 : {
17367 15221 : derived->dt_next = derived;
17368 : }
17369 84150 : gfc_derived_types = derived;
17370 : }
17371 179850 : }
17372 :
17373 :
17374 : /* Ensure that a derived-type is really not abstract, meaning that every
17375 : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
17376 :
17377 : static bool
17378 7092 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
17379 : {
17380 7092 : if (!st)
17381 : return true;
17382 :
17383 2772 : if (!ensure_not_abstract_walker (sub, st->left))
17384 : return false;
17385 2772 : if (!ensure_not_abstract_walker (sub, st->right))
17386 : return false;
17387 :
17388 2771 : if (st->n.tb && st->n.tb->deferred)
17389 : {
17390 2019 : gfc_symtree* overriding;
17391 2019 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
17392 2019 : if (!overriding)
17393 : return false;
17394 2018 : gcc_assert (overriding->n.tb);
17395 2018 : if (overriding->n.tb->deferred)
17396 : {
17397 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
17398 : " %qs is DEFERRED and not overridden",
17399 : sub->name, &sub->declared_at, st->name);
17400 5 : return false;
17401 : }
17402 : }
17403 :
17404 : return true;
17405 : }
17406 :
17407 : static bool
17408 1400 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
17409 : {
17410 : /* The algorithm used here is to recursively travel up the ancestry of sub
17411 : and for each ancestor-type, check all bindings. If any of them is
17412 : DEFERRED, look it up starting from sub and see if the found (overriding)
17413 : binding is not DEFERRED.
17414 : This is not the most efficient way to do this, but it should be ok and is
17415 : clearer than something sophisticated. */
17416 :
17417 1549 : gcc_assert (ancestor && !sub->attr.abstract);
17418 :
17419 1549 : if (!ancestor->attr.abstract)
17420 : return true;
17421 :
17422 : /* Walk bindings of this ancestor. */
17423 1548 : if (ancestor->f2k_derived)
17424 : {
17425 1548 : bool t;
17426 1548 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
17427 1548 : if (!t)
17428 : return false;
17429 : }
17430 :
17431 : /* Find next ancestor type and recurse on it. */
17432 1542 : ancestor = gfc_get_derived_super_type (ancestor);
17433 1542 : if (ancestor)
17434 : return ensure_not_abstract (sub, ancestor);
17435 :
17436 : return true;
17437 : }
17438 :
17439 :
17440 : /* This check for typebound defined assignments is done recursively
17441 : since the order in which derived types are resolved is not always in
17442 : order of the declarations. */
17443 :
17444 : static void
17445 184407 : check_defined_assignments (gfc_symbol *derived)
17446 : {
17447 184407 : gfc_component *c;
17448 :
17449 618069 : for (c = derived->components; c; c = c->next)
17450 : {
17451 435439 : if (!gfc_bt_struct (c->ts.type)
17452 105232 : || c->attr.pointer
17453 20806 : || c->attr.proc_pointer_comp
17454 20806 : || c->attr.class_pointer
17455 20800 : || c->attr.proc_pointer)
17456 415173 : continue;
17457 :
17458 20266 : if (c->ts.u.derived->attr.defined_assign_comp
17459 20031 : || (c->ts.u.derived->f2k_derived
17460 19449 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
17461 : {
17462 1753 : derived->attr.defined_assign_comp = 1;
17463 1753 : return;
17464 : }
17465 :
17466 18513 : if (c->attr.allocatable)
17467 6751 : continue;
17468 :
17469 11762 : check_defined_assignments (c->ts.u.derived);
17470 11762 : if (c->ts.u.derived->attr.defined_assign_comp)
17471 : {
17472 24 : derived->attr.defined_assign_comp = 1;
17473 24 : return;
17474 : }
17475 : }
17476 : }
17477 :
17478 :
17479 : /* Resolve a single component of a derived type or structure. */
17480 :
17481 : static bool
17482 415312 : resolve_component (gfc_component *c, gfc_symbol *sym)
17483 : {
17484 415312 : gfc_symbol *super_type;
17485 415312 : symbol_attribute *attr;
17486 :
17487 415312 : if (c->attr.artificial)
17488 : return true;
17489 :
17490 : /* Do not allow vtype components to be resolved in nameless namespaces
17491 : such as block data because the procedure pointers will cause ICEs
17492 : and vtables are not needed in these contexts. */
17493 283371 : if (sym->attr.vtype && sym->attr.use_assoc
17494 49409 : && sym->ns->proc_name == NULL)
17495 : return true;
17496 :
17497 : /* F2008, C442. */
17498 283362 : if ((!sym->attr.is_class || c != sym->components)
17499 283362 : && c->attr.codimension
17500 230 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
17501 : {
17502 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
17503 : "deferred shape", c->name, &c->loc);
17504 4 : return false;
17505 : }
17506 :
17507 : /* F2008, C443. */
17508 283358 : if (c->attr.codimension && c->ts.type == BT_DERIVED
17509 85 : && c->ts.u.derived->ts.is_iso_c)
17510 : {
17511 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17512 : "shall not be a coarray", c->name, &c->loc);
17513 1 : return false;
17514 : }
17515 :
17516 : /* F2008, C444. */
17517 283357 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
17518 28 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
17519 26 : || c->attr.allocatable))
17520 : {
17521 3 : gfc_error ("Component %qs at %L with coarray component "
17522 : "shall be a nonpointer, nonallocatable scalar",
17523 : c->name, &c->loc);
17524 3 : return false;
17525 : }
17526 :
17527 : /* F2008, C448. */
17528 283354 : if (c->ts.type == BT_CLASS)
17529 : {
17530 6992 : if (c->attr.class_ok && CLASS_DATA (c))
17531 : {
17532 6984 : attr = &(CLASS_DATA (c)->attr);
17533 :
17534 : /* Fix up contiguous attribute. */
17535 6984 : if (c->attr.contiguous)
17536 11 : attr->contiguous = 1;
17537 : }
17538 : else
17539 : attr = NULL;
17540 : }
17541 : else
17542 276362 : attr = &c->attr;
17543 :
17544 283357 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
17545 : {
17546 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
17547 : "is not an array pointer", c->name, &c->loc);
17548 5 : return false;
17549 : }
17550 :
17551 : /* F2003, 15.2.1 - length has to be one. */
17552 41714 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
17553 283368 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
17554 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
17555 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
17556 : {
17557 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
17558 : c->name, &c->loc);
17559 1 : return false;
17560 : }
17561 :
17562 52666 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
17563 313 : && !sym->attr.pdt_type && !sym->attr.pdt_template
17564 283356 : && !(gfc_get_derived_super_type (sym)
17565 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
17566 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
17567 : {
17568 8 : gfc_actual_arglist *type_spec_list;
17569 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
17570 : &type_spec_list)
17571 : != MATCH_YES)
17572 0 : return false;
17573 8 : gfc_free_actual_arglist (c->param_list);
17574 8 : c->param_list = type_spec_list;
17575 8 : if (!sym->attr.pdt_type)
17576 8 : sym->attr.pdt_comp = 1;
17577 : }
17578 283340 : else if (IS_PDT (c) && !sym->attr.pdt_type)
17579 54 : sym->attr.pdt_comp = 1;
17580 :
17581 283348 : if (c->attr.proc_pointer && c->ts.interface)
17582 : {
17583 14894 : gfc_symbol *ifc = c->ts.interface;
17584 :
17585 14894 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
17586 : {
17587 6 : c->tb->error = 1;
17588 6 : return false;
17589 : }
17590 :
17591 14888 : if (ifc->attr.if_source || ifc->attr.intrinsic)
17592 : {
17593 : /* Resolve interface and copy attributes. */
17594 14839 : if (ifc->formal && !ifc->formal_ns)
17595 2605 : resolve_symbol (ifc);
17596 14839 : if (ifc->attr.intrinsic)
17597 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17598 :
17599 14839 : if (ifc->result)
17600 : {
17601 7747 : c->ts = ifc->result->ts;
17602 7747 : c->attr.allocatable = ifc->result->attr.allocatable;
17603 7747 : c->attr.pointer = ifc->result->attr.pointer;
17604 7747 : c->attr.dimension = ifc->result->attr.dimension;
17605 7747 : c->as = gfc_copy_array_spec (ifc->result->as);
17606 7747 : c->attr.class_ok = ifc->result->attr.class_ok;
17607 : }
17608 : else
17609 : {
17610 7092 : c->ts = ifc->ts;
17611 7092 : c->attr.allocatable = ifc->attr.allocatable;
17612 7092 : c->attr.pointer = ifc->attr.pointer;
17613 7092 : c->attr.dimension = ifc->attr.dimension;
17614 7092 : c->as = gfc_copy_array_spec (ifc->as);
17615 7092 : c->attr.class_ok = ifc->attr.class_ok;
17616 : }
17617 14839 : c->ts.interface = ifc;
17618 14839 : c->attr.function = ifc->attr.function;
17619 14839 : c->attr.subroutine = ifc->attr.subroutine;
17620 :
17621 14839 : c->attr.pure = ifc->attr.pure;
17622 14839 : c->attr.elemental = ifc->attr.elemental;
17623 14839 : c->attr.recursive = ifc->attr.recursive;
17624 14839 : c->attr.always_explicit = ifc->attr.always_explicit;
17625 14839 : c->attr.ext_attr |= ifc->attr.ext_attr;
17626 : /* Copy char length. */
17627 14839 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17628 : {
17629 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17630 454 : if (cl->length && !cl->resolved
17631 601 : && !gfc_resolve_expr (cl->length))
17632 : {
17633 0 : c->tb->error = 1;
17634 0 : return false;
17635 : }
17636 491 : c->ts.u.cl = cl;
17637 : }
17638 : }
17639 : }
17640 268454 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17641 : {
17642 : /* Since PPCs are not implicitly typed, a PPC without an explicit
17643 : interface must be a subroutine. */
17644 116 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17645 : }
17646 :
17647 : /* Procedure pointer components: Check PASS arg. */
17648 283342 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17649 560 : && !sym->attr.vtype)
17650 : {
17651 95 : gfc_symbol* me_arg;
17652 :
17653 95 : if (c->tb->pass_arg)
17654 : {
17655 20 : gfc_formal_arglist* i;
17656 :
17657 : /* If an explicit passing argument name is given, walk the arg-list
17658 : and look for it. */
17659 :
17660 20 : me_arg = NULL;
17661 20 : c->tb->pass_arg_num = 1;
17662 34 : for (i = c->ts.interface->formal; i; i = i->next)
17663 : {
17664 33 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17665 : {
17666 : me_arg = i->sym;
17667 : break;
17668 : }
17669 14 : c->tb->pass_arg_num++;
17670 : }
17671 :
17672 20 : if (!me_arg)
17673 : {
17674 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17675 : "at %L has no argument %qs", c->name,
17676 : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17677 1 : c->tb->error = 1;
17678 1 : return false;
17679 : }
17680 : }
17681 : else
17682 : {
17683 : /* Otherwise, take the first one; there should in fact be at least
17684 : one. */
17685 75 : c->tb->pass_arg_num = 1;
17686 75 : if (!c->ts.interface->formal)
17687 : {
17688 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17689 : "must have at least one argument",
17690 : c->name, &c->loc);
17691 3 : c->tb->error = 1;
17692 3 : return false;
17693 : }
17694 72 : me_arg = c->ts.interface->formal->sym;
17695 : }
17696 :
17697 : /* Now check that the argument-type matches. */
17698 72 : gcc_assert (me_arg);
17699 91 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17700 90 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17701 90 : || (me_arg->ts.type == BT_CLASS
17702 82 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17703 : {
17704 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17705 : " the derived type %qs", me_arg->name, c->name,
17706 : me_arg->name, &c->loc, sym->name);
17707 1 : c->tb->error = 1;
17708 1 : return false;
17709 : }
17710 :
17711 : /* Check for F03:C453. */
17712 90 : if (CLASS_DATA (me_arg)->attr.dimension)
17713 : {
17714 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17715 : "must be scalar", me_arg->name, c->name, me_arg->name,
17716 : &c->loc);
17717 1 : c->tb->error = 1;
17718 1 : return false;
17719 : }
17720 :
17721 89 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17722 : {
17723 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17724 : "may not have the POINTER attribute", me_arg->name,
17725 : c->name, me_arg->name, &c->loc);
17726 1 : c->tb->error = 1;
17727 1 : return false;
17728 : }
17729 :
17730 88 : if (CLASS_DATA (me_arg)->attr.allocatable)
17731 : {
17732 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17733 : "may not be ALLOCATABLE", me_arg->name, c->name,
17734 : me_arg->name, &c->loc);
17735 1 : c->tb->error = 1;
17736 1 : return false;
17737 : }
17738 :
17739 87 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17740 : {
17741 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17742 : " at %L", c->name, &c->loc);
17743 2 : return false;
17744 : }
17745 :
17746 : }
17747 :
17748 : /* Check type-spec if this is not the parent-type component. */
17749 283332 : if (((sym->attr.is_class
17750 12551 : && (!sym->components->ts.u.derived->attr.extension
17751 2400 : || c != CLASS_DATA (sym->components)))
17752 272132 : || (!sym->attr.is_class
17753 270781 : && (!sym->attr.extension || c != sym->components)))
17754 275154 : && !sym->attr.vtype
17755 448333 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17756 : return false;
17757 :
17758 283331 : super_type = gfc_get_derived_super_type (sym);
17759 :
17760 : /* If this type is an extension, set the accessibility of the parent
17761 : component. */
17762 283331 : if (super_type
17763 25806 : && ((sym->attr.is_class
17764 12551 : && c == CLASS_DATA (sym->components))
17765 17023 : || (!sym->attr.is_class && c == sym->components))
17766 15610 : && strcmp (super_type->name, c->name) == 0)
17767 6641 : c->attr.access = super_type->attr.access;
17768 :
17769 : /* If this type is an extension, see if this component has the same name
17770 : as an inherited type-bound procedure. */
17771 25806 : if (super_type && !sym->attr.is_class
17772 13255 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17773 : {
17774 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17775 : " inherited type-bound procedure",
17776 : c->name, sym->name, &c->loc);
17777 1 : return false;
17778 : }
17779 :
17780 283330 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17781 9471 : && !c->ts.deferred)
17782 : {
17783 7212 : if (sym->attr.pdt_template || c->attr.pdt_string)
17784 258 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17785 :
17786 7212 : if (c->ts.u.cl->length == NULL
17787 7206 : || !resolve_charlen(c->ts.u.cl)
17788 14417 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17789 : {
17790 9 : gfc_error ("Character length of component %qs needs to "
17791 : "be a constant specification expression at %L",
17792 : c->name,
17793 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17794 9 : return false;
17795 : }
17796 :
17797 7203 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17798 : {
17799 2 : if (!c->ts.u.cl->length->error)
17800 : {
17801 1 : gfc_error ("Character length expression of component %qs at %L "
17802 : "must be of INTEGER type, found %s",
17803 1 : c->name, &c->ts.u.cl->length->where,
17804 : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17805 1 : c->ts.u.cl->length->error = 1;
17806 : }
17807 2 : return false;
17808 : }
17809 : }
17810 :
17811 283319 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17812 2295 : && !c->attr.pointer && !c->attr.allocatable)
17813 : {
17814 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17815 : "length must be a POINTER or ALLOCATABLE",
17816 : c->name, sym->name, &c->loc);
17817 1 : return false;
17818 : }
17819 :
17820 : /* Add the hidden deferred length field. */
17821 283318 : if (c->ts.type == BT_CHARACTER
17822 9971 : && (c->ts.deferred || c->attr.pdt_string)
17823 2469 : && !c->attr.function
17824 2433 : && !sym->attr.is_class)
17825 : {
17826 2286 : char name[GFC_MAX_SYMBOL_LEN+9];
17827 2286 : gfc_component *strlen;
17828 2286 : sprintf (name, "_%s_length", c->name);
17829 2286 : strlen = gfc_find_component (sym, name, true, true, NULL);
17830 2286 : if (strlen == NULL)
17831 : {
17832 484 : if (!gfc_add_component (sym, name, &strlen))
17833 0 : return false;
17834 484 : strlen->ts.type = BT_INTEGER;
17835 484 : strlen->ts.kind = gfc_charlen_int_kind;
17836 484 : strlen->attr.access = ACCESS_PRIVATE;
17837 484 : strlen->attr.artificial = 1;
17838 : }
17839 : }
17840 :
17841 283318 : if (c->ts.type == BT_DERIVED
17842 52876 : && sym->component_access != ACCESS_PRIVATE
17843 51856 : && gfc_check_symbol_access (sym)
17844 101676 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
17845 50779 : && !c->ts.u.derived->attr.use_assoc
17846 27289 : && !gfc_check_symbol_access (c->ts.u.derived)
17847 283515 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
17848 : "PRIVATE type and cannot be a component of "
17849 : "%qs, which is PUBLIC at %L", c->name,
17850 : sym->name, &sym->declared_at))
17851 : return false;
17852 :
17853 283317 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
17854 : {
17855 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
17856 : "type %s", c->name, &c->loc, sym->name);
17857 2 : return false;
17858 : }
17859 :
17860 283315 : if (sym->attr.sequence)
17861 : {
17862 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
17863 : {
17864 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
17865 : "not have the SEQUENCE attribute",
17866 : c->ts.u.derived->name, &sym->declared_at);
17867 0 : return false;
17868 : }
17869 : }
17870 :
17871 283315 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
17872 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
17873 283315 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
17874 7326 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
17875 0 : CLASS_DATA (c)->ts.u.derived
17876 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
17877 :
17878 : /* If an allocatable component derived type is of the same type as
17879 : the enclosing derived type, we need a vtable generating so that
17880 : the __deallocate procedure is created. */
17881 283315 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
17882 60212 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
17883 399 : gfc_find_vtab (&c->ts);
17884 :
17885 : /* Ensure that all the derived type components are put on the
17886 : derived type list; even in formal namespaces, where derived type
17887 : pointer components might not have been declared. */
17888 283315 : if (c->ts.type == BT_DERIVED
17889 52875 : && c->ts.u.derived
17890 52875 : && c->ts.u.derived->components
17891 49601 : && c->attr.pointer
17892 34008 : && sym != c->ts.u.derived)
17893 4289 : add_dt_to_dt_list (c->ts.u.derived);
17894 :
17895 283315 : if (c->as && c->as->type != AS_DEFERRED
17896 6488 : && (c->attr.pointer || c->attr.allocatable))
17897 : return false;
17898 :
17899 283301 : if (!gfc_resolve_array_spec (c->as,
17900 283301 : !(c->attr.pointer || c->attr.proc_pointer
17901 230564 : || c->attr.allocatable)))
17902 : return false;
17903 :
17904 107189 : if (c->initializer && !sym->attr.vtype
17905 32733 : && !c->attr.pdt_kind && !c->attr.pdt_len
17906 312860 : && !gfc_check_assign_symbol (sym, c, c->initializer))
17907 : return false;
17908 :
17909 : return true;
17910 : }
17911 :
17912 :
17913 : /* Be nice about the locus for a structure expression - show the locus of the
17914 : first non-null sub-expression if we can. */
17915 :
17916 : static locus *
17917 4 : cons_where (gfc_expr *struct_expr)
17918 : {
17919 4 : gfc_constructor *cons;
17920 :
17921 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
17922 :
17923 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
17924 12 : for (; cons; cons = gfc_constructor_next (cons))
17925 : {
17926 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
17927 4 : return &cons->expr->where;
17928 : }
17929 :
17930 0 : return &struct_expr->where;
17931 : }
17932 :
17933 : /* Resolve the components of a structure type. Much less work than derived
17934 : types. */
17935 :
17936 : static bool
17937 913 : resolve_fl_struct (gfc_symbol *sym)
17938 : {
17939 913 : gfc_component *c;
17940 913 : gfc_expr *init = NULL;
17941 913 : bool success;
17942 :
17943 : /* Make sure UNIONs do not have overlapping initializers. */
17944 913 : if (sym->attr.flavor == FL_UNION)
17945 : {
17946 498 : for (c = sym->components; c; c = c->next)
17947 : {
17948 331 : if (init && c->initializer)
17949 : {
17950 2 : gfc_error ("Conflicting initializers in union at %L and %L",
17951 : cons_where (init), cons_where (c->initializer));
17952 2 : gfc_free_expr (c->initializer);
17953 2 : c->initializer = NULL;
17954 : }
17955 291 : if (init == NULL)
17956 291 : init = c->initializer;
17957 : }
17958 : }
17959 :
17960 913 : success = true;
17961 2830 : for (c = sym->components; c; c = c->next)
17962 1917 : if (!resolve_component (c, sym))
17963 0 : success = false;
17964 :
17965 913 : if (!success)
17966 : return false;
17967 :
17968 913 : if (sym->components)
17969 862 : add_dt_to_dt_list (sym);
17970 :
17971 : return true;
17972 : }
17973 :
17974 : /* Figure if the derived type is using itself directly in one of its components
17975 : or through referencing other derived types. The information is required to
17976 : generate the __deallocate and __final type bound procedures to ensure
17977 : freeing larger hierarchies of derived types with allocatable objects. */
17978 :
17979 : static void
17980 140131 : resolve_cyclic_derived_type (gfc_symbol *derived)
17981 : {
17982 140131 : hash_set<gfc_symbol *> seen, to_examin;
17983 140131 : gfc_component *c;
17984 140131 : seen.add (derived);
17985 140131 : to_examin.add (derived);
17986 469694 : while (!to_examin.is_empty ())
17987 : {
17988 191624 : gfc_symbol *cand = *to_examin.begin ();
17989 191624 : to_examin.remove (cand);
17990 515923 : for (c = cand->components; c; c = c->next)
17991 326491 : if (c->ts.type == BT_DERIVED)
17992 : {
17993 71992 : if (c->ts.u.derived == derived)
17994 : {
17995 1168 : derived->attr.recursive = 1;
17996 2192 : return;
17997 : }
17998 70824 : else if (!seen.contains (c->ts.u.derived))
17999 : {
18000 46890 : seen.add (c->ts.u.derived);
18001 46890 : to_examin.add (c->ts.u.derived);
18002 : }
18003 : }
18004 254499 : else if (c->ts.type == BT_CLASS)
18005 : {
18006 9642 : if (!c->attr.class_ok)
18007 7 : continue;
18008 9635 : if (CLASS_DATA (c)->ts.u.derived == derived)
18009 : {
18010 1024 : derived->attr.recursive = 1;
18011 1024 : return;
18012 : }
18013 8611 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
18014 : {
18015 4826 : seen.add (CLASS_DATA (c)->ts.u.derived);
18016 4826 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
18017 : }
18018 : }
18019 : }
18020 140131 : }
18021 :
18022 : /* Resolve the components of a derived type. This does not have to wait until
18023 : resolution stage, but can be done as soon as the dt declaration has been
18024 : parsed. */
18025 :
18026 : static bool
18027 172741 : resolve_fl_derived0 (gfc_symbol *sym)
18028 : {
18029 172741 : gfc_symbol* super_type;
18030 172741 : gfc_component *c;
18031 172741 : gfc_formal_arglist *f;
18032 172741 : bool success;
18033 :
18034 172741 : if (sym->attr.unlimited_polymorphic)
18035 : return true;
18036 :
18037 172741 : super_type = gfc_get_derived_super_type (sym);
18038 :
18039 : /* F2008, C432. */
18040 172741 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
18041 : {
18042 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
18043 : "parent type %qs shall also have one", sym->name,
18044 : &sym->declared_at, super_type->name);
18045 2 : return false;
18046 : }
18047 :
18048 : /* Ensure the extended type gets resolved before we do. */
18049 17656 : if (super_type && !resolve_fl_derived0 (super_type))
18050 : return false;
18051 :
18052 : /* An ABSTRACT type must be extensible. */
18053 172733 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
18054 : {
18055 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
18056 : sym->name, &sym->declared_at);
18057 2 : return false;
18058 : }
18059 :
18060 : /* Resolving components below, may create vtabs for which the cyclic type
18061 : information needs to be present. */
18062 172731 : if (!sym->attr.vtype)
18063 140131 : resolve_cyclic_derived_type (sym);
18064 :
18065 172731 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
18066 : : sym->components;
18067 :
18068 : success = true;
18069 586126 : for ( ; c != NULL; c = c->next)
18070 413395 : if (!resolve_component (c, sym))
18071 96 : success = false;
18072 :
18073 172731 : if (!success)
18074 : return false;
18075 :
18076 : /* Now add the caf token field, where needed. */
18077 172645 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
18078 1012 : && !sym->attr.vtype)
18079 : {
18080 2260 : for (c = sym->components; c; c = c->next)
18081 1451 : if (!c->attr.dimension && !c->attr.codimension
18082 795 : && (c->attr.allocatable || c->attr.pointer))
18083 : {
18084 146 : char name[GFC_MAX_SYMBOL_LEN+9];
18085 146 : gfc_component *token;
18086 146 : sprintf (name, "_caf_%s", c->name);
18087 146 : token = gfc_find_component (sym, name, true, true, NULL);
18088 146 : if (token == NULL)
18089 : {
18090 82 : if (!gfc_add_component (sym, name, &token))
18091 0 : return false;
18092 82 : token->ts.type = BT_VOID;
18093 82 : token->ts.kind = gfc_default_integer_kind;
18094 82 : token->attr.access = ACCESS_PRIVATE;
18095 82 : token->attr.artificial = 1;
18096 82 : token->attr.caf_token = 1;
18097 : }
18098 146 : c->caf_token = token;
18099 : }
18100 : }
18101 :
18102 172645 : check_defined_assignments (sym);
18103 :
18104 172645 : if (!sym->attr.defined_assign_comp && super_type)
18105 16649 : sym->attr.defined_assign_comp
18106 16649 : = super_type->attr.defined_assign_comp;
18107 :
18108 : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
18109 : all DEFERRED bindings are overridden. */
18110 17649 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
18111 1403 : && !sym->attr.is_class
18112 3153 : && !ensure_not_abstract (sym, super_type))
18113 : return false;
18114 :
18115 : /* Check that there is a component for every PDT parameter. */
18116 172639 : if (sym->attr.pdt_template)
18117 : {
18118 2502 : for (f = sym->formal; f; f = f->next)
18119 : {
18120 1444 : if (!f->sym)
18121 1 : continue;
18122 1443 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
18123 1443 : if (c == NULL)
18124 : {
18125 9 : gfc_error ("Parameterized type %qs does not have a component "
18126 : "corresponding to parameter %qs at %L", sym->name,
18127 9 : f->sym->name, &sym->declared_at);
18128 9 : break;
18129 : }
18130 : }
18131 : }
18132 :
18133 : /* Add derived type to the derived type list. */
18134 172639 : add_dt_to_dt_list (sym);
18135 :
18136 172639 : return true;
18137 : }
18138 :
18139 : /* The following procedure does the full resolution of a derived type,
18140 : including resolution of all type-bound procedures (if present). In contrast
18141 : to 'resolve_fl_derived0' this can only be done after the module has been
18142 : parsed completely. */
18143 :
18144 : static bool
18145 90168 : resolve_fl_derived (gfc_symbol *sym)
18146 : {
18147 90168 : gfc_symbol *gen_dt = NULL;
18148 :
18149 90168 : if (sym->attr.unlimited_polymorphic)
18150 : return true;
18151 :
18152 90168 : if (!sym->attr.is_class)
18153 77280 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
18154 57596 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
18155 2291 : && (!gen_dt->generic->sym->attr.use_assoc
18156 2148 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
18157 90344 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
18158 : "%qs at %L being the same name as derived "
18159 : "type at %L", sym->name,
18160 : gen_dt->generic->sym == sym
18161 11 : ? gen_dt->generic->next->sym->name
18162 : : gen_dt->generic->sym->name,
18163 : gen_dt->generic->sym == sym
18164 11 : ? &gen_dt->generic->next->sym->declared_at
18165 : : &gen_dt->generic->sym->declared_at,
18166 : &sym->declared_at))
18167 : return false;
18168 :
18169 90164 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
18170 : {
18171 13 : gfc_error ("Derived type %qs at %L has not been declared",
18172 : sym->name, &sym->declared_at);
18173 13 : return false;
18174 : }
18175 :
18176 : /* Resolve the finalizer procedures. */
18177 90151 : if (!gfc_resolve_finalizers (sym, NULL))
18178 : return false;
18179 :
18180 90148 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
18181 : {
18182 : /* Fix up incomplete CLASS symbols. */
18183 12888 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
18184 12888 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18185 :
18186 12888 : if (data->ts.u.derived->attr.pdt_template)
18187 : {
18188 0 : match m;
18189 0 : m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
18190 : &data->param_list);
18191 0 : if (m != MATCH_YES
18192 0 : || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
18193 : {
18194 0 : gfc_error ("Failed to build PDT class component at %L",
18195 : &sym->declared_at);
18196 0 : return false;
18197 : }
18198 0 : data = gfc_find_component (sym, "_data", true, true, NULL);
18199 0 : vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
18200 : }
18201 :
18202 : /* Nothing more to do for unlimited polymorphic entities. */
18203 12888 : if (data->ts.u.derived->attr.unlimited_polymorphic)
18204 : {
18205 2060 : add_dt_to_dt_list (sym);
18206 2060 : return true;
18207 : }
18208 10828 : else if (vptr->ts.u.derived == NULL)
18209 : {
18210 6396 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
18211 6396 : gcc_assert (vtab);
18212 6396 : vptr->ts.u.derived = vtab->ts.u.derived;
18213 6396 : if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
18214 : return false;
18215 : }
18216 : }
18217 :
18218 88088 : if (!resolve_fl_derived0 (sym))
18219 : return false;
18220 :
18221 : /* Resolve the type-bound procedures. */
18222 88004 : if (!resolve_typebound_procedures (sym))
18223 : return false;
18224 :
18225 : /* Generate module vtables subject to their accessibility and their not
18226 : being vtables or pdt templates. If this is not done class declarations
18227 : in external procedures wind up with their own version and so SELECT TYPE
18228 : fails because the vptrs do not have the same address. */
18229 87963 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
18230 87902 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
18231 65929 : || (sym->attr.recursive && sym->attr.alloc_comp))
18232 22127 : && sym->attr.access != ACCESS_PRIVATE
18233 22094 : && !(sym->attr.vtype || sym->attr.pdt_template))
18234 : {
18235 19826 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
18236 19826 : gfc_set_sym_referenced (vtab);
18237 : }
18238 :
18239 : return true;
18240 : }
18241 :
18242 :
18243 : static bool
18244 869 : resolve_fl_namelist (gfc_symbol *sym)
18245 : {
18246 869 : gfc_namelist *nl;
18247 869 : gfc_symbol *nlsym;
18248 :
18249 3052 : for (nl = sym->namelist; nl; nl = nl->next)
18250 : {
18251 : /* Check again, the check in match only works if NAMELIST comes
18252 : after the decl. */
18253 2188 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
18254 : {
18255 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
18256 : "allowed", nl->sym->name, sym->name, &sym->declared_at);
18257 1 : return false;
18258 : }
18259 :
18260 678 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
18261 2195 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18262 : "with assumed shape in namelist %qs at %L",
18263 : nl->sym->name, sym->name, &sym->declared_at))
18264 : return false;
18265 :
18266 2186 : if (is_non_constant_shape_array (nl->sym)
18267 2236 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
18268 : "with nonconstant shape in namelist %qs at %L",
18269 50 : nl->sym->name, sym->name, &sym->declared_at))
18270 : return false;
18271 :
18272 2185 : if (nl->sym->ts.type == BT_CHARACTER
18273 593 : && (nl->sym->ts.u.cl->length == NULL
18274 554 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
18275 2267 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
18276 : "nonconstant character length in "
18277 82 : "namelist %qs at %L", nl->sym->name,
18278 : sym->name, &sym->declared_at))
18279 : return false;
18280 :
18281 : }
18282 :
18283 : /* Reject PRIVATE objects in a PUBLIC namelist. */
18284 864 : if (gfc_check_symbol_access (sym))
18285 : {
18286 3033 : for (nl = sym->namelist; nl; nl = nl->next)
18287 : {
18288 2182 : if (!nl->sym->attr.use_assoc
18289 4068 : && !is_sym_host_assoc (nl->sym, sym->ns)
18290 4194 : && !gfc_check_symbol_access (nl->sym))
18291 : {
18292 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
18293 : "cannot be member of PUBLIC namelist %qs at %L",
18294 2 : nl->sym->name, sym->name, &sym->declared_at);
18295 2 : return false;
18296 : }
18297 :
18298 2180 : if (nl->sym->ts.type == BT_DERIVED
18299 472 : && (nl->sym->ts.u.derived->attr.alloc_comp
18300 470 : || nl->sym->ts.u.derived->attr.pointer_comp))
18301 : {
18302 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
18303 : "namelist %qs at %L with ALLOCATABLE "
18304 : "or POINTER components", nl->sym->name,
18305 : sym->name, &sym->declared_at))
18306 : return false;
18307 : return true;
18308 : }
18309 :
18310 : /* Types with private components that came here by USE-association. */
18311 2175 : if (nl->sym->ts.type == BT_DERIVED
18312 2175 : && derived_inaccessible (nl->sym->ts.u.derived))
18313 : {
18314 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
18315 : "components and cannot be member of namelist %qs at %L",
18316 : nl->sym->name, sym->name, &sym->declared_at);
18317 6 : return false;
18318 : }
18319 :
18320 : /* Types with private components that are defined in the same module. */
18321 2169 : if (nl->sym->ts.type == BT_DERIVED
18322 922 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
18323 2453 : && nl->sym->ts.u.derived->attr.private_comp)
18324 : {
18325 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
18326 : "cannot be a member of PUBLIC namelist %qs at %L",
18327 : nl->sym->name, sym->name, &sym->declared_at);
18328 0 : return false;
18329 : }
18330 : }
18331 : }
18332 :
18333 :
18334 : /* 14.1.2 A module or internal procedure represent local entities
18335 : of the same type as a namelist member and so are not allowed. */
18336 3017 : for (nl = sym->namelist; nl; nl = nl->next)
18337 : {
18338 2169 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
18339 1604 : continue;
18340 :
18341 565 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
18342 7 : if ((nl->sym == sym->ns->proc_name)
18343 1 : ||
18344 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
18345 6 : continue;
18346 :
18347 559 : nlsym = NULL;
18348 559 : if (nl->sym->name)
18349 559 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
18350 559 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
18351 : {
18352 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
18353 : "attribute in %qs at %L", nlsym->name,
18354 : &sym->declared_at);
18355 3 : return false;
18356 : }
18357 : }
18358 :
18359 : return true;
18360 : }
18361 :
18362 :
18363 : static bool
18364 411101 : resolve_fl_parameter (gfc_symbol *sym)
18365 : {
18366 : /* A parameter array's shape needs to be constant. */
18367 411101 : if (sym->as != NULL
18368 411101 : && (sym->as->type == AS_DEFERRED
18369 6291 : || is_non_constant_shape_array (sym)))
18370 : {
18371 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
18372 : "or of deferred shape", sym->name, &sym->declared_at);
18373 17 : return false;
18374 : }
18375 :
18376 : /* Constraints on deferred type parameter. */
18377 411084 : if (!deferred_requirements (sym))
18378 : return false;
18379 :
18380 : /* Make sure a parameter that has been implicitly typed still
18381 : matches the implicit type, since PARAMETER statements can precede
18382 : IMPLICIT statements. */
18383 411083 : if (sym->attr.implicit_type
18384 411796 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
18385 713 : sym->ns)))
18386 : {
18387 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
18388 : "later IMPLICIT type", sym->name, &sym->declared_at);
18389 0 : return false;
18390 : }
18391 :
18392 : /* Make sure the types of derived parameters are consistent. This
18393 : type checking is deferred until resolution because the type may
18394 : refer to a derived type from the host. */
18395 411083 : if (sym->ts.type == BT_DERIVED
18396 411083 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
18397 : {
18398 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
18399 0 : &sym->value->where);
18400 0 : return false;
18401 : }
18402 :
18403 : /* F03:C509,C514. */
18404 411083 : if (sym->ts.type == BT_CLASS)
18405 : {
18406 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
18407 : sym->name, &sym->declared_at);
18408 0 : return false;
18409 : }
18410 :
18411 : /* Some programmers can have a typo when using an implied-do loop to
18412 : initialize an array constant. For example,
18413 : INTEGER I,J
18414 : INTEGER, PARAMETER :: A(3) = [(I, I = 1, 3)] ! OK
18415 : INTEGER, PARAMETER :: B(3) = [(A(J), I = 1, 3)] ! Not OK, J undefined
18416 : This check catches the typo. */
18417 411083 : if (sym->attr.dimension
18418 6284 : && sym->value && sym->value->expr_type == EXPR_ARRAY
18419 417361 : && !gfc_is_constant_expr (sym->value))
18420 : {
18421 : /* PR fortran/117070 argues a nonconstant proc pointer can appear in
18422 : the array constructor of a parameter. This seems inconsistent with
18423 : the concept of a parameter. TODO: Needs an interpretation. */
18424 20 : if (sym->value->ts.type == BT_DERIVED
18425 18 : && sym->value->ts.u.derived
18426 18 : && sym->value->ts.u.derived->attr.proc_pointer_comp)
18427 : return true;
18428 2 : gfc_error ("Expecting constant expression near %L", &sym->value->where);
18429 2 : return false;
18430 : }
18431 :
18432 : return true;
18433 : }
18434 :
18435 :
18436 : /* Called by resolve_symbol to check PDTs. */
18437 :
18438 : static void
18439 1462 : resolve_pdt (gfc_symbol* sym)
18440 : {
18441 1462 : gfc_symbol *derived = NULL;
18442 1462 : gfc_actual_arglist *param;
18443 1462 : gfc_component *c;
18444 1462 : bool const_len_exprs = true;
18445 1462 : bool assumed_len_exprs = false;
18446 1462 : symbol_attribute *attr;
18447 :
18448 1462 : if (sym->ts.type == BT_DERIVED)
18449 : {
18450 1223 : derived = sym->ts.u.derived;
18451 1223 : attr = &(sym->attr);
18452 : }
18453 239 : else if (sym->ts.type == BT_CLASS)
18454 : {
18455 239 : derived = CLASS_DATA (sym)->ts.u.derived;
18456 239 : attr = &(CLASS_DATA (sym)->attr);
18457 : }
18458 : else
18459 0 : gcc_unreachable ();
18460 :
18461 1462 : gcc_assert (derived->attr.pdt_type);
18462 :
18463 3447 : for (param = sym->param_list; param; param = param->next)
18464 : {
18465 1985 : c = gfc_find_component (derived, param->name, false, true, NULL);
18466 1985 : gcc_assert (c);
18467 1985 : if (c->attr.pdt_kind)
18468 1042 : continue;
18469 :
18470 662 : if (param->expr && !gfc_is_constant_expr (param->expr)
18471 1039 : && c->attr.pdt_len)
18472 : const_len_exprs = false;
18473 847 : else if (param->spec_type == SPEC_ASSUMED)
18474 303 : assumed_len_exprs = true;
18475 :
18476 943 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
18477 18 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
18478 16 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
18479 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
18480 : "parameter %qs and requires either the POINTER "
18481 : "or ALLOCATABLE attribute",
18482 : sym->name, &sym->declared_at,
18483 : param->name);
18484 :
18485 : }
18486 :
18487 1462 : if (!const_len_exprs
18488 96 : && (sym->ns->proc_name->attr.is_main_program
18489 95 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18490 94 : || sym->attr.save != SAVE_NONE))
18491 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
18492 : "SAVE attribute or be a variable declared in the "
18493 : "main program, a module or a submodule(F08/C513)",
18494 : sym->name, &sym->declared_at);
18495 :
18496 1462 : if (assumed_len_exprs && !(sym->attr.dummy
18497 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
18498 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
18499 : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
18500 : sym->name, &sym->declared_at);
18501 1462 : }
18502 :
18503 :
18504 : /* Resolve the symbol's array spec. */
18505 :
18506 : static bool
18507 1777503 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
18508 : {
18509 1777503 : gfc_namespace *orig_current_ns = gfc_current_ns;
18510 1777503 : gfc_current_ns = gfc_get_spec_ns (sym);
18511 :
18512 1777503 : bool saved_specification_expr = specification_expr;
18513 1777503 : gfc_symbol *saved_specification_expr_symbol = specification_expr_symbol;
18514 1777503 : specification_expr = true;
18515 1777503 : specification_expr_symbol = sym;
18516 :
18517 1777503 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
18518 :
18519 1777503 : specification_expr = saved_specification_expr;
18520 1777503 : specification_expr_symbol = saved_specification_expr_symbol;
18521 1777503 : gfc_current_ns = orig_current_ns;
18522 :
18523 1777503 : return result;
18524 : }
18525 :
18526 :
18527 : /* Do anything necessary to resolve a symbol. Right now, we just
18528 : assume that an otherwise unknown symbol is a variable. This sort
18529 : of thing commonly happens for symbols in module. */
18530 :
18531 : static void
18532 1936925 : resolve_symbol (gfc_symbol *sym)
18533 : {
18534 1936925 : int check_constant, mp_flag;
18535 1936925 : gfc_symtree *symtree;
18536 1936925 : gfc_symtree *this_symtree;
18537 1936925 : gfc_namespace *ns;
18538 1936925 : gfc_component *c;
18539 1936925 : symbol_attribute class_attr;
18540 1936925 : gfc_array_spec *as;
18541 1936925 : bool declared_has_coarray_comp = false;
18542 :
18543 1936925 : if (sym->resolve_symbol_called >= 1)
18544 190841 : return;
18545 1848358 : sym->resolve_symbol_called = 1;
18546 :
18547 : /* No symbol will ever have union type; only components can be unions.
18548 : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
18549 : (just like derived type declaration symbols have flavor FL_DERIVED). */
18550 1848358 : gcc_assert (sym->ts.type != BT_UNION);
18551 :
18552 : /* Coarrayed polymorphic objects with allocatable or pointer components are
18553 : yet unsupported for -fcoarray=lib. */
18554 1848358 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
18555 112 : && sym->ts.u.derived && CLASS_DATA (sym)
18556 112 : && CLASS_DATA (sym)->attr.codimension
18557 94 : && CLASS_DATA (sym)->ts.u.derived
18558 93 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
18559 90 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
18560 : {
18561 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
18562 : "type coarrays at %L are unsupported", &sym->declared_at);
18563 6 : return;
18564 : }
18565 :
18566 1848352 : if (sym->attr.artificial)
18567 : return;
18568 :
18569 1748814 : if (sym->attr.unlimited_polymorphic)
18570 : return;
18571 :
18572 1747324 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
18573 : {
18574 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
18575 : "the OpenMP DEPEND clause", &sym->declared_at);
18576 4 : return;
18577 : }
18578 :
18579 1747320 : if (sym->attr.flavor == FL_UNKNOWN
18580 1725952 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
18581 462205 : && !sym->attr.generic && !sym->attr.external
18582 182172 : && sym->attr.if_source == IFSRC_UNKNOWN
18583 82031 : && sym->ts.type == BT_UNKNOWN))
18584 : {
18585 : /* A symbol in a common block might not have been resolved yet properly.
18586 : Do not try to find an interface with the same name. */
18587 94857 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
18588 21364 : && !sym->attr.generic && !sym->attr.external
18589 21313 : && sym->attr.in_common)
18590 2594 : goto skip_interfaces;
18591 :
18592 : /* If we find that a flavorless symbol is an interface in one of the
18593 : parent namespaces, find its symtree in this namespace, free the
18594 : symbol and set the symtree to point to the interface symbol. */
18595 131909 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
18596 : {
18597 40353 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
18598 40353 : if (symtree && (symtree->n.sym->generic ||
18599 770 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
18600 674 : && sym->ns->construct_entities)))
18601 : {
18602 715 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
18603 : sym->name);
18604 715 : if (this_symtree->n.sym == sym)
18605 : {
18606 707 : symtree->n.sym->refs++;
18607 707 : gfc_release_symbol (sym);
18608 707 : this_symtree->n.sym = symtree->n.sym;
18609 707 : return;
18610 : }
18611 : }
18612 : }
18613 :
18614 91556 : skip_interfaces:
18615 : /* Otherwise give it a flavor according to such attributes as
18616 : it has. */
18617 94150 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
18618 21183 : && sym->attr.intrinsic == 0)
18619 21179 : sym->attr.flavor = FL_VARIABLE;
18620 72971 : else if (sym->attr.flavor == FL_UNKNOWN)
18621 : {
18622 55 : sym->attr.flavor = FL_PROCEDURE;
18623 55 : if (sym->attr.dimension)
18624 0 : sym->attr.function = 1;
18625 : }
18626 : }
18627 :
18628 1746613 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
18629 2384 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
18630 :
18631 1517 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
18632 1748130 : && !resolve_procedure_interface (sym))
18633 : return;
18634 :
18635 1746602 : if (sym->attr.is_protected && !sym->attr.proc_pointer
18636 130 : && (sym->attr.procedure || sym->attr.external))
18637 : {
18638 0 : if (sym->attr.external)
18639 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18640 : "at %L", &sym->declared_at);
18641 : else
18642 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18643 : "at %L", &sym->declared_at);
18644 :
18645 0 : return;
18646 : }
18647 :
18648 : /* Ensure that variables of derived or class type having a finalizer are
18649 : marked used even when the variable is not used anything else in the scope.
18650 : This fixes PR118730. */
18651 676324 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18652 468663 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18653 1797106 : && gfc_may_be_finalized (sym->ts))
18654 8722 : gfc_set_sym_referenced (sym);
18655 :
18656 1746602 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18657 : return;
18658 :
18659 1746457 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18660 1746457 : && !resolve_fl_struct (sym))
18661 : return;
18662 :
18663 : /* Symbols that are module procedures with results (functions) have
18664 : the types and array specification copied for type checking in
18665 : procedures that call them, as well as for saving to a module
18666 : file. These symbols can't stand the scrutiny that their results
18667 : can. */
18668 1746457 : mp_flag = (sym->result != NULL && sym->result != sym);
18669 :
18670 : /* Make sure that the intrinsic is consistent with its internal
18671 : representation. This needs to be done before assigning a default
18672 : type to avoid spurious warnings. */
18673 1711219 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18674 1783519 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18675 : return;
18676 :
18677 : /* Resolve associate names. */
18678 1746421 : if (sym->assoc)
18679 6919 : resolve_assoc_var (sym, true);
18680 :
18681 : /* Assign default type to symbols that need one and don't have one. */
18682 1746421 : if (sym->ts.type == BT_UNKNOWN)
18683 : {
18684 416476 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18685 : {
18686 11791 : gfc_set_default_type (sym, 1, NULL);
18687 : }
18688 :
18689 271282 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18690 65787 : && !sym->attr.function && !sym->attr.subroutine
18691 418149 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18692 622 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18693 :
18694 416476 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18695 : {
18696 : /* The specific case of an external procedure should emit an error
18697 : in the case that there is no implicit type. */
18698 103907 : if (!mp_flag)
18699 : {
18700 97776 : if (!sym->attr.mixed_entry_master)
18701 97668 : gfc_set_default_type (sym, sym->attr.external, NULL);
18702 : }
18703 : else
18704 : {
18705 : /* Result may be in another namespace. */
18706 6131 : resolve_symbol (sym->result);
18707 :
18708 6131 : if (!sym->result->attr.proc_pointer)
18709 : {
18710 5952 : sym->ts = sym->result->ts;
18711 5952 : sym->as = gfc_copy_array_spec (sym->result->as);
18712 5952 : sym->attr.dimension = sym->result->attr.dimension;
18713 5952 : sym->attr.codimension = sym->result->attr.codimension;
18714 5952 : sym->attr.pointer = sym->result->attr.pointer;
18715 5952 : sym->attr.allocatable = sym->result->attr.allocatable;
18716 5952 : sym->attr.contiguous = sym->result->attr.contiguous;
18717 : }
18718 : }
18719 : }
18720 : }
18721 1329945 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18722 31416 : resolve_symbol_array_spec (sym->result, false);
18723 :
18724 : /* For a CLASS-valued function with a result variable, affirm that it has
18725 : been resolved also when looking at the symbol 'sym'. */
18726 447892 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18727 720 : sym->attr.class_ok = sym->result->attr.class_ok;
18728 :
18729 1746421 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18730 19692 : && CLASS_DATA (sym))
18731 : {
18732 19691 : as = CLASS_DATA (sym)->as;
18733 19691 : class_attr = CLASS_DATA (sym)->attr;
18734 19691 : class_attr.pointer = class_attr.class_pointer;
18735 19691 : declared_has_coarray_comp = CLASS_DATA (sym)->ts.u.derived
18736 19691 : && CLASS_DATA (sym)->ts.u.derived->attr.coarray_comp;
18737 : }
18738 : else
18739 : {
18740 1726730 : class_attr = sym->attr;
18741 1726730 : as = sym->as;
18742 : }
18743 :
18744 : /* F2008, C530. */
18745 1746421 : if (sym->attr.contiguous
18746 8546 : && !sym->attr.associate_var
18747 8545 : && (!class_attr.dimension
18748 8542 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18749 140 : && !class_attr.pointer)))
18750 : {
18751 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18752 : "array pointer or an assumed-shape or assumed-rank array",
18753 : sym->name, &sym->declared_at);
18754 7 : return;
18755 : }
18756 :
18757 : /* Assumed size arrays and assumed shape arrays must be dummy
18758 : arguments. Array-spec's of implied-shape should have been resolved to
18759 : AS_EXPLICIT already. */
18760 :
18761 1738012 : if (as)
18762 : {
18763 : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18764 : specification expression. */
18765 151346 : if (as->type == AS_IMPLIED_SHAPE)
18766 : {
18767 : int i;
18768 1 : for (i=0; i<as->rank; i++)
18769 : {
18770 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18771 : {
18772 1 : gfc_error ("Bad specification for assumed size array at %L",
18773 : &as->lower[i]->where);
18774 1 : return;
18775 : }
18776 : }
18777 0 : gcc_unreachable();
18778 : }
18779 :
18780 151345 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18781 116228 : || as->type == AS_ASSUMED_SHAPE)
18782 46982 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18783 8 : && !sym->attr.associate_var)
18784 : {
18785 7 : if (as->type == AS_ASSUMED_SIZE)
18786 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18787 : &sym->declared_at);
18788 : else
18789 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18790 : &sym->declared_at);
18791 7 : return;
18792 : }
18793 : /* TS 29113, C535a. */
18794 151338 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18795 60 : && !sym->attr.select_type_temporary
18796 60 : && !(cs_base && cs_base->current
18797 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18798 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18799 0 : && cs_base->current->op == EXEC_BLOCK))))
18800 : {
18801 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18802 : &sym->declared_at);
18803 18 : return;
18804 : }
18805 151320 : if (as->type == AS_ASSUMED_RANK
18806 27355 : && (sym->attr.codimension || sym->attr.value))
18807 : {
18808 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18809 : "CODIMENSION attribute", &sym->declared_at);
18810 2 : return;
18811 : }
18812 : }
18813 :
18814 : /* Make sure symbols with known intent or optional are really dummy
18815 : variable. Because of ENTRY statement, this has to be deferred
18816 : until resolution time. */
18817 :
18818 1746386 : if (!sym->attr.dummy
18819 1253787 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
18820 : {
18821 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
18822 2 : return;
18823 : }
18824 :
18825 1746384 : if (sym->attr.value && !sym->attr.dummy)
18826 : {
18827 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
18828 : "it is not a dummy argument", sym->name, &sym->declared_at);
18829 2 : return;
18830 : }
18831 :
18832 1746382 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
18833 : {
18834 616 : gfc_charlen *cl = sym->ts.u.cl;
18835 616 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
18836 : {
18837 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
18838 : "attribute must have constant length",
18839 : sym->name, &sym->declared_at);
18840 2 : return;
18841 : }
18842 :
18843 614 : if (sym->ts.is_c_interop
18844 381 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
18845 : {
18846 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
18847 : "with VALUE attribute must have length one",
18848 : sym->name, &sym->declared_at);
18849 1 : return;
18850 : }
18851 : }
18852 :
18853 1746379 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18854 125908 : && sym->ts.u.derived->attr.generic)
18855 : {
18856 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
18857 20 : if (!sym->ts.u.derived)
18858 : {
18859 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
18860 : "which has not been defined", sym->name,
18861 : &sym->declared_at, sym->ts.u.derived->name);
18862 0 : sym->ts.type = BT_UNKNOWN;
18863 0 : return;
18864 : }
18865 : }
18866 :
18867 : /* Use the same constraints as TYPE(*), except for the type check
18868 : and that only scalars and assumed-size arrays are permitted. */
18869 1746379 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
18870 : {
18871 14556 : if (!sym->attr.dummy)
18872 : {
18873 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18874 : "a dummy argument", sym->name, &sym->declared_at);
18875 1 : return;
18876 : }
18877 :
18878 14555 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
18879 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
18880 0 : && sym->ts.type != BT_COMPLEX)
18881 : {
18882 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18883 : "of type TYPE(*) or of an numeric intrinsic type",
18884 : sym->name, &sym->declared_at);
18885 0 : return;
18886 : }
18887 :
18888 14555 : if (sym->attr.allocatable || sym->attr.codimension
18889 14553 : || sym->attr.pointer || sym->attr.value)
18890 : {
18891 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18892 : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
18893 : "attribute", sym->name, &sym->declared_at);
18894 4 : return;
18895 : }
18896 :
18897 14551 : if (sym->attr.intent == INTENT_OUT)
18898 : {
18899 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18900 : "have the INTENT(OUT) attribute",
18901 : sym->name, &sym->declared_at);
18902 0 : return;
18903 : }
18904 14551 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
18905 : {
18906 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
18907 : "either be a scalar or an assumed-size array",
18908 : sym->name, &sym->declared_at);
18909 1 : return;
18910 : }
18911 :
18912 : /* Set the type to TYPE(*) and add a dimension(*) to ensure
18913 : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
18914 : packing. */
18915 14550 : sym->ts.type = BT_ASSUMED;
18916 14550 : sym->as = gfc_get_array_spec ();
18917 14550 : sym->as->type = AS_ASSUMED_SIZE;
18918 14550 : sym->as->rank = 1;
18919 14550 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
18920 : }
18921 1731823 : else if (sym->ts.type == BT_ASSUMED)
18922 : {
18923 : /* TS 29113, C407a. */
18924 12350 : if (!sym->attr.dummy)
18925 : {
18926 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
18927 : "for dummy variables", sym->name, &sym->declared_at);
18928 7 : return;
18929 : }
18930 12343 : if (sym->attr.allocatable || sym->attr.codimension
18931 12339 : || sym->attr.pointer || sym->attr.value)
18932 : {
18933 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
18934 : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
18935 : sym->name, &sym->declared_at);
18936 8 : return;
18937 : }
18938 12335 : if (sym->attr.intent == INTENT_OUT)
18939 : {
18940 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
18941 : "INTENT(OUT) attribute",
18942 : sym->name, &sym->declared_at);
18943 2 : return;
18944 : }
18945 12333 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
18946 : {
18947 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
18948 : "explicit-shape array", sym->name, &sym->declared_at);
18949 3 : return;
18950 : }
18951 : }
18952 :
18953 : /* If the symbol is marked as bind(c), that it is declared at module level
18954 : scope and verify its type and kind. Do not do the latter for symbols
18955 : that are implicitly typed because that is handled in
18956 : gfc_set_default_type. Handle dummy arguments and procedure definitions
18957 : separately. Also, anything that is use associated is not handled here
18958 : but instead is handled in the module it is declared in. Finally, derived
18959 : type definitions are allowed to be BIND(C) since that only implies that
18960 : they're interoperable, and they are checked fully for interoperability
18961 : when a variable is declared of that type. */
18962 1746353 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
18963 7809 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
18964 567 : && sym->attr.flavor != FL_DERIVED)
18965 : {
18966 167 : bool t = true;
18967 :
18968 : /* First, make sure the variable is declared at the
18969 : module-level scope (J3/04-007, Section 15.3). */
18970 167 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
18971 7 : && !sym->attr.in_common)
18972 : {
18973 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
18974 : "is neither a COMMON block nor declared at the "
18975 : "module level scope", sym->name, &(sym->declared_at));
18976 6 : t = false;
18977 : }
18978 161 : else if (sym->ts.type == BT_CHARACTER
18979 161 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
18980 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
18981 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
18982 : {
18983 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
18984 1 : sym->name, &sym->declared_at);
18985 1 : t = false;
18986 : }
18987 160 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
18988 : {
18989 1 : t = verify_com_block_vars_c_interop (sym->common_head);
18990 : }
18991 159 : else if (sym->attr.implicit_type == 0)
18992 : {
18993 : /* If type() declaration, we need to verify that the components
18994 : of the given type are all C interoperable, etc. */
18995 157 : if (sym->ts.type == BT_DERIVED &&
18996 24 : sym->ts.u.derived->attr.is_c_interop != 1)
18997 : {
18998 : /* Make sure the user marked the derived type as BIND(C). If
18999 : not, call the verify routine. This could print an error
19000 : for the derived type more than once if multiple variables
19001 : of that type are declared. */
19002 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
19003 1 : verify_bind_c_derived_type (sym->ts.u.derived);
19004 157 : t = false;
19005 : }
19006 :
19007 : /* Verify the variable itself as C interoperable if it
19008 : is BIND(C). It is not possible for this to succeed if
19009 : the verify_bind_c_derived_type failed, so don't have to handle
19010 : any error returned by verify_bind_c_derived_type. */
19011 157 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
19012 157 : sym->common_block);
19013 : }
19014 :
19015 165 : if (!t)
19016 : {
19017 : /* clear the is_bind_c flag to prevent reporting errors more than
19018 : once if something failed. */
19019 10 : sym->attr.is_bind_c = 0;
19020 10 : return;
19021 : }
19022 : }
19023 :
19024 : /* If a derived type symbol has reached this point, without its
19025 : type being declared, we have an error. Notice that most
19026 : conditions that produce undefined derived types have already
19027 : been dealt with. However, the likes of:
19028 : implicit type(t) (t) ..... call foo (t) will get us here if
19029 : the type is not declared in the scope of the implicit
19030 : statement. Change the type to BT_UNKNOWN, both because it is so
19031 : and to prevent an ICE. */
19032 1746343 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
19033 125906 : && sym->ts.u.derived->components == NULL
19034 1151 : && !sym->ts.u.derived->attr.zero_comp)
19035 : {
19036 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
19037 : "which has not been defined", sym->name,
19038 : &sym->declared_at, sym->ts.u.derived->name);
19039 3 : sym->ts.type = BT_UNKNOWN;
19040 3 : return;
19041 : }
19042 :
19043 : /* Make sure that the derived type has been resolved and that the
19044 : derived type is visible in the symbol's namespace, if it is a
19045 : module function and is not PRIVATE. */
19046 1746340 : if (sym->ts.type == BT_DERIVED
19047 133057 : && sym->ts.u.derived->attr.use_assoc
19048 115318 : && sym->ns->proc_name
19049 115310 : && sym->ns->proc_name->attr.flavor == FL_MODULE
19050 1752289 : && !resolve_fl_derived (sym->ts.u.derived))
19051 : return;
19052 :
19053 : /* Unless the derived-type declaration is use associated, Fortran 95
19054 : does not allow public entries of private derived types.
19055 : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
19056 : 161 in 95-006r3. */
19057 1746340 : if (sym->ts.type == BT_DERIVED
19058 133057 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
19059 8093 : && !sym->ts.u.derived->attr.use_assoc
19060 2144 : && gfc_check_symbol_access (sym)
19061 1931 : && !gfc_check_symbol_access (sym->ts.u.derived)
19062 1746354 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
19063 : "derived type %qs",
19064 14 : (sym->attr.flavor == FL_PARAMETER)
19065 : ? "parameter" : "variable",
19066 : sym->name, &sym->declared_at,
19067 14 : sym->ts.u.derived->name))
19068 : return;
19069 :
19070 : /* F2008, C1302. */
19071 1746333 : if (sym->ts.type == BT_DERIVED
19072 133050 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19073 160 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
19074 133019 : || sym->ts.u.derived->attr.lock_comp)
19075 44 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19076 : {
19077 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
19078 : "type LOCK_TYPE must be a coarray", sym->name,
19079 : &sym->declared_at);
19080 4 : return;
19081 : }
19082 :
19083 : /* TS18508, C702/C703. */
19084 1746329 : if (sym->ts.type == BT_DERIVED
19085 133046 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
19086 159 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
19087 133029 : || sym->ts.u.derived->attr.event_comp)
19088 17 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
19089 : {
19090 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
19091 : "type EVENT_TYPE must be a coarray", sym->name,
19092 : &sym->declared_at);
19093 1 : return;
19094 : }
19095 :
19096 : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
19097 : default initialization is defined (5.1.2.4.4). */
19098 1746328 : if (sym->ts.type == BT_DERIVED
19099 133045 : && sym->attr.dummy
19100 45721 : && sym->attr.intent == INTENT_OUT
19101 2357 : && sym->as
19102 382 : && sym->as->type == AS_ASSUMED_SIZE)
19103 : {
19104 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
19105 : {
19106 1 : if (c->initializer)
19107 : {
19108 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
19109 : "ASSUMED SIZE and so cannot have a default initializer",
19110 : sym->name, &sym->declared_at);
19111 1 : return;
19112 : }
19113 : }
19114 : }
19115 :
19116 : /* F2008, C542. */
19117 1746327 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19118 45720 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
19119 : {
19120 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
19121 : "INTENT(OUT)", sym->name, &sym->declared_at);
19122 0 : return;
19123 : }
19124 :
19125 : /* TS18508. */
19126 1746327 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
19127 45720 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
19128 : {
19129 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
19130 : "INTENT(OUT)", sym->name, &sym->declared_at);
19131 0 : return;
19132 : }
19133 :
19134 : /* F2008, C525. */
19135 1746327 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19136 1746214 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19137 19695 : && sym->ts.u.derived && CLASS_DATA (sym)
19138 19689 : && CLASS_DATA (sym)->attr.coarray_comp))
19139 1746214 : || class_attr.codimension)
19140 1821 : && (sym->attr.result || sym->result == sym))
19141 : {
19142 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
19143 : "a coarray component", sym->name, &sym->declared_at);
19144 8 : return;
19145 : }
19146 :
19147 : /* F2008, C524. */
19148 1746319 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
19149 420 : && sym->ts.u.derived->ts.is_iso_c)
19150 : {
19151 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
19152 : "shall not be a coarray", sym->name, &sym->declared_at);
19153 3 : return;
19154 : }
19155 :
19156 : /* F2008, C525. */
19157 1746316 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19158 1746206 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19159 19694 : && sym->ts.u.derived && CLASS_DATA (sym)
19160 19688 : && CLASS_DATA (sym)->attr.coarray_comp))
19161 110 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
19162 106 : || class_attr.allocatable))
19163 : {
19164 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
19165 : "nonpointer, nonallocatable scalar, which is not a coarray",
19166 : sym->name, &sym->declared_at);
19167 4 : return;
19168 : }
19169 :
19170 : /* F2008, C526. The function-result case was handled above. */
19171 1746312 : if (class_attr.codimension
19172 1700 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
19173 350 : || sym->attr.select_type_temporary
19174 274 : || sym->attr.associate_var
19175 256 : || (sym->ns->save_all && !sym->attr.automatic)
19176 256 : || sym->ns->proc_name->attr.flavor == FL_MODULE
19177 256 : || sym->ns->proc_name->attr.is_main_program
19178 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
19179 : {
19180 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
19181 : "nor a dummy argument", sym->name, &sym->declared_at);
19182 4 : return;
19183 : }
19184 : /* F2008, C528. */
19185 1746308 : else if (class_attr.codimension && !sym->attr.select_type_temporary
19186 1620 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
19187 : {
19188 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
19189 : "deferred shape without allocatable", sym->name,
19190 : &sym->declared_at);
19191 6 : return;
19192 : }
19193 1746302 : else if (class_attr.codimension && class_attr.allocatable && as
19194 626 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
19195 : {
19196 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
19197 : "deferred shape", sym->name, &sym->declared_at);
19198 9 : return;
19199 : }
19200 :
19201 : /* F2008, C541. */
19202 1746293 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
19203 1746187 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
19204 19689 : && declared_has_coarray_comp))
19205 1746180 : || (class_attr.codimension && class_attr.allocatable))
19206 730 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
19207 : {
19208 4 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
19209 : "allocatable coarray or have coarray components",
19210 : sym->name, &sym->declared_at);
19211 4 : return;
19212 : }
19213 :
19214 1746289 : if (class_attr.codimension && sym->attr.dummy
19215 469 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
19216 : {
19217 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
19218 : "procedure %qs", sym->name, &sym->declared_at,
19219 : sym->ns->proc_name->name);
19220 2 : return;
19221 : }
19222 :
19223 1746287 : if (sym->ts.type == BT_LOGICAL
19224 114354 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
19225 114351 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
19226 32612 : && sym->ns->proc_name->attr.is_bind_c)))
19227 : {
19228 : int i;
19229 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
19230 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
19231 : break;
19232 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
19233 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
19234 : "%L with non-C_Bool kind in BIND(C) procedure "
19235 : "%qs", sym->name, &sym->declared_at,
19236 13 : sym->ns->proc_name->name))
19237 : return;
19238 167 : else if (!gfc_logical_kinds[i].c_bool
19239 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
19240 : "%qs at %L with non-C_Bool kind in "
19241 : "BIND(C) procedure %qs", sym->name,
19242 : &sym->declared_at,
19243 15 : sym->attr.function ? sym->name
19244 13 : : sym->ns->proc_name->name))
19245 : return;
19246 : }
19247 :
19248 1746284 : switch (sym->attr.flavor)
19249 : {
19250 676206 : case FL_VARIABLE:
19251 676206 : if (!resolve_fl_variable (sym, mp_flag))
19252 : return;
19253 : break;
19254 :
19255 498684 : case FL_PROCEDURE:
19256 498684 : if (sym->formal && !sym->formal_ns)
19257 : {
19258 : /* Check that none of the arguments are a namelist. */
19259 : gfc_formal_arglist *formal = sym->formal;
19260 :
19261 106535 : for (; formal; formal = formal->next)
19262 72227 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
19263 : {
19264 1 : gfc_error ("Namelist %qs cannot be an argument to "
19265 : "subroutine or function at %L",
19266 : formal->sym->name, &sym->declared_at);
19267 1 : return;
19268 : }
19269 : }
19270 :
19271 498683 : if (!resolve_fl_procedure (sym, mp_flag))
19272 : return;
19273 : break;
19274 :
19275 869 : case FL_NAMELIST:
19276 869 : if (!resolve_fl_namelist (sym))
19277 : return;
19278 : break;
19279 :
19280 411101 : case FL_PARAMETER:
19281 411101 : if (!resolve_fl_parameter (sym))
19282 : return;
19283 : break;
19284 :
19285 : default:
19286 : break;
19287 : }
19288 :
19289 : /* Resolve array specifier. Check as well some constraints
19290 : on COMMON blocks. */
19291 :
19292 1746087 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
19293 :
19294 1746087 : resolve_symbol_array_spec (sym, check_constant);
19295 :
19296 : /* Resolve formal namespaces. */
19297 1746087 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
19298 278881 : && !sym->attr.contained && !sym->attr.intrinsic)
19299 249315 : gfc_resolve (sym->formal_ns);
19300 :
19301 : /* Make sure the formal namespace is present. */
19302 1746087 : if (sym->formal && !sym->formal_ns)
19303 : {
19304 : gfc_formal_arglist *formal = sym->formal;
19305 34777 : while (formal && !formal->sym)
19306 11 : formal = formal->next;
19307 :
19308 34766 : if (formal)
19309 : {
19310 34755 : sym->formal_ns = formal->sym->ns;
19311 34755 : if (sym->formal_ns && sym->ns != formal->sym->ns)
19312 26300 : sym->formal_ns->refs++;
19313 : }
19314 : }
19315 :
19316 : /* Check threadprivate restrictions. */
19317 1746087 : if ((sym->attr.threadprivate || sym->attr.omp_groupprivate)
19318 384 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
19319 33 : && !(sym->ns->save_all && !sym->attr.automatic)
19320 32 : && sym->module == NULL
19321 17 : && (sym->ns->proc_name == NULL
19322 17 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19323 4 : && !sym->ns->proc_name->attr.is_main_program)))
19324 : {
19325 2 : if (sym->attr.threadprivate)
19326 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
19327 : else
19328 1 : gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE "
19329 : "attribute", sym->name, &sym->declared_at);
19330 : }
19331 :
19332 1746087 : if (sym->attr.omp_groupprivate && sym->value)
19333 2 : gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an "
19334 : "initializer", sym->name, &sym->declared_at);
19335 :
19336 : /* Check omp declare target restrictions. */
19337 1746087 : if ((sym->attr.omp_declare_target
19338 1744670 : || sym->attr.omp_declare_target_link
19339 1744622 : || sym->attr.omp_declare_target_local)
19340 1505 : && !sym->attr.omp_groupprivate /* already warned. */
19341 1458 : && sym->attr.flavor == FL_VARIABLE
19342 616 : && !sym->attr.save
19343 199 : && !(sym->ns->save_all && !sym->attr.automatic)
19344 199 : && (!sym->attr.in_common
19345 186 : && sym->module == NULL
19346 96 : && (sym->ns->proc_name == NULL
19347 96 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
19348 6 : && !sym->ns->proc_name->attr.is_main_program))))
19349 4 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
19350 : sym->name, &sym->declared_at);
19351 :
19352 : /* If we have come this far we can apply default-initializers, as
19353 : described in 14.7.5, to those variables that have not already
19354 : been assigned one. */
19355 1746087 : if (sym->ts.type == BT_DERIVED
19356 133015 : && !sym->value
19357 107811 : && !sym->attr.allocatable
19358 104792 : && !sym->attr.alloc_comp)
19359 : {
19360 104727 : symbol_attribute *a = &sym->attr;
19361 :
19362 104727 : if ((!a->save && !a->dummy && !a->pointer
19363 57649 : && !a->in_common && !a->use_assoc
19364 10615 : && a->referenced
19365 8326 : && !((a->function || a->result)
19366 1704 : && (!a->dimension
19367 160 : || sym->ts.u.derived->attr.alloc_comp
19368 95 : || sym->ts.u.derived->attr.pointer_comp))
19369 6703 : && !(a->function && sym != sym->result))
19370 98044 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
19371 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
19372 8112 : apply_default_init (sym);
19373 96615 : else if (a->function && !a->pointer && !a->allocatable
19374 21027 : && !a->use_assoc && !a->used_in_submodule && sym->result)
19375 : /* Default initialization for function results. */
19376 2752 : apply_default_init (sym->result);
19377 93863 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
19378 12021 : && (sym->ts.u.derived->attr.alloc_comp
19379 11456 : || sym->ts.u.derived->attr.pointer_comp))
19380 : /* Mark the result symbol to be referenced, when it has allocatable
19381 : components. */
19382 624 : sym->result->attr.referenced = 1;
19383 : }
19384 :
19385 1746087 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
19386 19189 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
19387 1226 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
19388 1151 : && !CLASS_DATA (sym)->attr.class_pointer
19389 1125 : && !CLASS_DATA (sym)->attr.allocatable)
19390 853 : apply_default_init (sym);
19391 :
19392 : /* If this symbol has a type-spec, check it. */
19393 1746087 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
19394 658890 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
19395 1418445 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
19396 : return;
19397 :
19398 1746084 : if (sym->param_list)
19399 1462 : resolve_pdt (sym);
19400 : }
19401 :
19402 :
19403 4125 : void gfc_resolve_symbol (gfc_symbol *sym)
19404 : {
19405 4125 : resolve_symbol (sym);
19406 4125 : return;
19407 : }
19408 :
19409 :
19410 : /************* Resolve DATA statements *************/
19411 :
19412 : static struct
19413 : {
19414 : gfc_data_value *vnode;
19415 : mpz_t left;
19416 : }
19417 : values;
19418 :
19419 :
19420 : /* Advance the values structure to point to the next value in the data list. */
19421 :
19422 : static bool
19423 10892 : next_data_value (void)
19424 : {
19425 16660 : while (mpz_cmp_ui (values.left, 0) == 0)
19426 : {
19427 :
19428 8198 : if (values.vnode->next == NULL)
19429 : return false;
19430 :
19431 5768 : values.vnode = values.vnode->next;
19432 5768 : mpz_set (values.left, values.vnode->repeat);
19433 : }
19434 :
19435 : return true;
19436 : }
19437 :
19438 :
19439 : static bool
19440 3557 : check_data_variable (gfc_data_variable *var, locus *where)
19441 : {
19442 3557 : gfc_expr *e;
19443 3557 : mpz_t size;
19444 3557 : mpz_t offset;
19445 3557 : bool t;
19446 3557 : ar_type mark = AR_UNKNOWN;
19447 3557 : int i;
19448 3557 : mpz_t section_index[GFC_MAX_DIMENSIONS];
19449 3557 : int vector_offset[GFC_MAX_DIMENSIONS];
19450 3557 : gfc_ref *ref;
19451 3557 : gfc_array_ref *ar;
19452 3557 : gfc_symbol *sym;
19453 3557 : int has_pointer;
19454 :
19455 3557 : if (!gfc_resolve_expr (var->expr))
19456 : return false;
19457 :
19458 3557 : ar = NULL;
19459 3557 : e = var->expr;
19460 :
19461 3557 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
19462 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
19463 0 : e = e->value.function.actual->expr;
19464 :
19465 3557 : if (e->expr_type != EXPR_VARIABLE)
19466 : {
19467 0 : gfc_error ("Expecting definable entity near %L", where);
19468 0 : return false;
19469 : }
19470 :
19471 3557 : sym = e->symtree->n.sym;
19472 :
19473 3557 : if (sym->ns->is_block_data && !sym->attr.in_common)
19474 : {
19475 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
19476 : sym->name, &sym->declared_at);
19477 2 : return false;
19478 : }
19479 :
19480 3555 : if (e->ref == NULL && sym->as)
19481 : {
19482 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
19483 : " declaration", sym->name, where);
19484 1 : return false;
19485 : }
19486 :
19487 3554 : if (gfc_is_coindexed (e))
19488 : {
19489 7 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
19490 : where);
19491 7 : return false;
19492 : }
19493 :
19494 3547 : has_pointer = sym->attr.pointer;
19495 :
19496 5988 : for (ref = e->ref; ref; ref = ref->next)
19497 : {
19498 2445 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
19499 : has_pointer = 1;
19500 :
19501 2419 : if (has_pointer)
19502 : {
19503 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
19504 : {
19505 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
19506 : "be a full array", sym->name, where);
19507 1 : return false;
19508 : }
19509 :
19510 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
19511 : {
19512 1 : gfc_error ("DATA object near %L has the pointer attribute "
19513 : "and the corresponding DATA value is not a valid "
19514 : "initial-data-target", where);
19515 1 : return false;
19516 : }
19517 : }
19518 :
19519 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
19520 : {
19521 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
19522 : "attribute", ref->u.c.component->name, &e->where);
19523 1 : return false;
19524 : }
19525 :
19526 : /* Reject substrings of strings of non-constant length. */
19527 2442 : if (ref->type == REF_SUBSTRING
19528 73 : && ref->u.ss.length
19529 73 : && ref->u.ss.length->length
19530 2515 : && !gfc_is_constant_expr (ref->u.ss.length->length))
19531 1 : goto bad_charlen;
19532 : }
19533 :
19534 : /* Reject strings with deferred length or non-constant length. */
19535 3543 : if (e->ts.type == BT_CHARACTER
19536 3543 : && (e->ts.deferred
19537 374 : || (e->ts.u.cl->length
19538 323 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
19539 5 : goto bad_charlen;
19540 :
19541 3538 : mpz_init_set_si (offset, 0);
19542 :
19543 3538 : if (e->rank == 0 || has_pointer)
19544 : {
19545 2691 : mpz_init_set_ui (size, 1);
19546 2691 : ref = NULL;
19547 : }
19548 : else
19549 : {
19550 847 : ref = e->ref;
19551 :
19552 : /* Find the array section reference. */
19553 1030 : for (ref = e->ref; ref; ref = ref->next)
19554 : {
19555 1030 : if (ref->type != REF_ARRAY)
19556 92 : continue;
19557 938 : if (ref->u.ar.type == AR_ELEMENT)
19558 91 : continue;
19559 : break;
19560 : }
19561 847 : gcc_assert (ref);
19562 :
19563 : /* Set marks according to the reference pattern. */
19564 847 : switch (ref->u.ar.type)
19565 : {
19566 : case AR_FULL:
19567 : mark = AR_FULL;
19568 : break;
19569 :
19570 151 : case AR_SECTION:
19571 151 : ar = &ref->u.ar;
19572 : /* Get the start position of array section. */
19573 151 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
19574 151 : mark = AR_SECTION;
19575 151 : break;
19576 :
19577 0 : default:
19578 0 : gcc_unreachable ();
19579 : }
19580 :
19581 847 : if (!gfc_array_size (e, &size))
19582 : {
19583 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
19584 : where);
19585 1 : mpz_clear (offset);
19586 1 : return false;
19587 : }
19588 : }
19589 :
19590 3537 : t = true;
19591 :
19592 11937 : while (mpz_cmp_ui (size, 0) > 0)
19593 : {
19594 8463 : if (!next_data_value ())
19595 : {
19596 1 : gfc_error ("DATA statement at %L has more variables than values",
19597 : where);
19598 1 : t = false;
19599 1 : break;
19600 : }
19601 :
19602 8462 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
19603 8462 : if (!t)
19604 : break;
19605 :
19606 : /* If we have more than one element left in the repeat count,
19607 : and we have more than one element left in the target variable,
19608 : then create a range assignment. */
19609 : /* FIXME: Only done for full arrays for now, since array sections
19610 : seem tricky. */
19611 8443 : if (mark == AR_FULL && ref && ref->next == NULL
19612 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
19613 : {
19614 137 : mpz_t range;
19615 :
19616 137 : if (mpz_cmp (size, values.left) >= 0)
19617 : {
19618 126 : mpz_init_set (range, values.left);
19619 126 : mpz_sub (size, size, values.left);
19620 126 : mpz_set_ui (values.left, 0);
19621 : }
19622 : else
19623 : {
19624 11 : mpz_init_set (range, size);
19625 11 : mpz_sub (values.left, values.left, size);
19626 11 : mpz_set_ui (size, 0);
19627 : }
19628 :
19629 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19630 : offset, &range);
19631 :
19632 137 : mpz_add (offset, offset, range);
19633 137 : mpz_clear (range);
19634 :
19635 137 : if (!t)
19636 : break;
19637 129 : }
19638 :
19639 : /* Assign initial value to symbol. */
19640 : else
19641 : {
19642 8306 : mpz_sub_ui (values.left, values.left, 1);
19643 8306 : mpz_sub_ui (size, size, 1);
19644 :
19645 8306 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
19646 : offset, NULL);
19647 8306 : if (!t)
19648 : break;
19649 :
19650 8271 : if (mark == AR_FULL)
19651 5259 : mpz_add_ui (offset, offset, 1);
19652 :
19653 : /* Modify the array section indexes and recalculate the offset
19654 : for next element. */
19655 3012 : else if (mark == AR_SECTION)
19656 366 : gfc_advance_section (section_index, ar, &offset, vector_offset);
19657 : }
19658 : }
19659 :
19660 3537 : if (mark == AR_SECTION)
19661 : {
19662 344 : for (i = 0; i < ar->dimen; i++)
19663 194 : mpz_clear (section_index[i]);
19664 : }
19665 :
19666 3537 : mpz_clear (size);
19667 3537 : mpz_clear (offset);
19668 :
19669 3537 : return t;
19670 :
19671 6 : bad_charlen:
19672 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19673 : &e->where);
19674 6 : return false;
19675 : }
19676 :
19677 :
19678 : static bool traverse_data_var (gfc_data_variable *, locus *);
19679 :
19680 : /* Iterate over a list of elements in a DATA statement. */
19681 :
19682 : static bool
19683 237 : traverse_data_list (gfc_data_variable *var, locus *where)
19684 : {
19685 237 : mpz_t trip;
19686 237 : iterator_stack frame;
19687 237 : gfc_expr *e, *start, *end, *step;
19688 237 : bool retval = true;
19689 :
19690 237 : mpz_init (frame.value);
19691 237 : mpz_init (trip);
19692 :
19693 237 : start = gfc_copy_expr (var->iter.start);
19694 237 : end = gfc_copy_expr (var->iter.end);
19695 237 : step = gfc_copy_expr (var->iter.step);
19696 :
19697 237 : if (!gfc_simplify_expr (start, 1)
19698 237 : || start->expr_type != EXPR_CONSTANT)
19699 : {
19700 0 : gfc_error ("start of implied-do loop at %L could not be "
19701 : "simplified to a constant value", &start->where);
19702 0 : retval = false;
19703 0 : goto cleanup;
19704 : }
19705 237 : if (!gfc_simplify_expr (end, 1)
19706 237 : || end->expr_type != EXPR_CONSTANT)
19707 : {
19708 0 : gfc_error ("end of implied-do loop at %L could not be "
19709 : "simplified to a constant value", &end->where);
19710 0 : retval = false;
19711 0 : goto cleanup;
19712 : }
19713 237 : if (!gfc_simplify_expr (step, 1)
19714 237 : || step->expr_type != EXPR_CONSTANT)
19715 : {
19716 0 : gfc_error ("step of implied-do loop at %L could not be "
19717 : "simplified to a constant value", &step->where);
19718 0 : retval = false;
19719 0 : goto cleanup;
19720 : }
19721 237 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19722 : {
19723 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19724 : &step->where);
19725 1 : retval = false;
19726 1 : goto cleanup;
19727 : }
19728 :
19729 236 : mpz_set (trip, end->value.integer);
19730 236 : mpz_sub (trip, trip, start->value.integer);
19731 236 : mpz_add (trip, trip, step->value.integer);
19732 :
19733 236 : mpz_div (trip, trip, step->value.integer);
19734 :
19735 236 : mpz_set (frame.value, start->value.integer);
19736 :
19737 236 : frame.prev = iter_stack;
19738 236 : frame.variable = var->iter.var->symtree;
19739 236 : iter_stack = &frame;
19740 :
19741 1127 : while (mpz_cmp_ui (trip, 0) > 0)
19742 : {
19743 905 : if (!traverse_data_var (var->list, where))
19744 : {
19745 14 : retval = false;
19746 14 : goto cleanup;
19747 : }
19748 :
19749 891 : e = gfc_copy_expr (var->expr);
19750 891 : if (!gfc_simplify_expr (e, 1))
19751 : {
19752 0 : gfc_free_expr (e);
19753 0 : retval = false;
19754 0 : goto cleanup;
19755 : }
19756 :
19757 891 : mpz_add (frame.value, frame.value, step->value.integer);
19758 :
19759 891 : mpz_sub_ui (trip, trip, 1);
19760 : }
19761 :
19762 222 : cleanup:
19763 237 : mpz_clear (frame.value);
19764 237 : mpz_clear (trip);
19765 :
19766 237 : gfc_free_expr (start);
19767 237 : gfc_free_expr (end);
19768 237 : gfc_free_expr (step);
19769 :
19770 237 : iter_stack = frame.prev;
19771 237 : return retval;
19772 : }
19773 :
19774 :
19775 : /* Type resolve variables in the variable list of a DATA statement. */
19776 :
19777 : static bool
19778 3418 : traverse_data_var (gfc_data_variable *var, locus *where)
19779 : {
19780 3418 : bool t;
19781 :
19782 7114 : for (; var; var = var->next)
19783 : {
19784 3794 : if (var->expr == NULL)
19785 237 : t = traverse_data_list (var, where);
19786 : else
19787 3557 : t = check_data_variable (var, where);
19788 :
19789 3794 : if (!t)
19790 : return false;
19791 : }
19792 :
19793 : return true;
19794 : }
19795 :
19796 :
19797 : /* Resolve the expressions and iterators associated with a data statement.
19798 : This is separate from the assignment checking because data lists should
19799 : only be resolved once. */
19800 :
19801 : static bool
19802 2668 : resolve_data_variables (gfc_data_variable *d)
19803 : {
19804 5707 : for (; d; d = d->next)
19805 : {
19806 3044 : if (d->list == NULL)
19807 : {
19808 2891 : if (!gfc_resolve_expr (d->expr))
19809 : return false;
19810 : }
19811 : else
19812 : {
19813 153 : if (!gfc_resolve_iterator (&d->iter, false, true))
19814 : return false;
19815 :
19816 150 : if (!resolve_data_variables (d->list))
19817 : return false;
19818 : }
19819 : }
19820 :
19821 : return true;
19822 : }
19823 :
19824 :
19825 : /* Resolve a single DATA statement. We implement this by storing a pointer to
19826 : the value list into static variables, and then recursively traversing the
19827 : variables list, expanding iterators and such. */
19828 :
19829 : static void
19830 2518 : resolve_data (gfc_data *d)
19831 : {
19832 :
19833 2518 : if (!resolve_data_variables (d->var))
19834 : return;
19835 :
19836 2513 : values.vnode = d->value;
19837 2513 : if (d->value == NULL)
19838 0 : mpz_set_ui (values.left, 0);
19839 : else
19840 2513 : mpz_set (values.left, d->value->repeat);
19841 :
19842 2513 : if (!traverse_data_var (d->var, &d->where))
19843 : return;
19844 :
19845 : /* At this point, we better not have any values left. */
19846 :
19847 2429 : if (next_data_value ())
19848 0 : gfc_error ("DATA statement at %L has more values than variables",
19849 : &d->where);
19850 : }
19851 :
19852 :
19853 : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
19854 : accessed by host or use association, is a dummy argument to a pure function,
19855 : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
19856 : is storage associated with any such variable, shall not be used in the
19857 : following contexts: (clients of this function). */
19858 :
19859 : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
19860 : procedure. Returns zero if assignment is OK, nonzero if there is a
19861 : problem. */
19862 : bool
19863 56440 : gfc_impure_variable (gfc_symbol *sym)
19864 : {
19865 56440 : gfc_symbol *proc;
19866 56440 : gfc_namespace *ns;
19867 :
19868 56440 : if (sym->attr.use_assoc || sym->attr.in_common)
19869 : return 1;
19870 :
19871 : /* The namespace of a module procedure interface holds the arguments and
19872 : symbols, and so the symbol namespace can be different to that of the
19873 : procedure. */
19874 55822 : if (sym->ns != gfc_current_ns
19875 6006 : && gfc_current_ns->proc_name->abr_modproc_decl
19876 48 : && sym->ns->proc_name->attr.function
19877 12 : && sym->attr.result
19878 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
19879 : return 0;
19880 :
19881 : /* Check if the symbol's ns is inside the pure procedure. */
19882 60567 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19883 : {
19884 60283 : if (ns == sym->ns)
19885 : break;
19886 6325 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
19887 5203 : && !(sym->attr.function || sym->attr.result))
19888 : return 1;
19889 : }
19890 :
19891 54242 : proc = sym->ns->proc_name;
19892 54242 : if (sym->attr.dummy
19893 6000 : && !sym->attr.value
19894 5878 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
19895 5675 : || proc->attr.function))
19896 697 : return 1;
19897 :
19898 : /* TODO: Sort out what can be storage associated, if anything, and include
19899 : it here. In principle equivalences should be scanned but it does not
19900 : seem to be possible to storage associate an impure variable this way. */
19901 : return 0;
19902 : }
19903 :
19904 :
19905 : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
19906 : current namespace is inside a pure procedure. */
19907 :
19908 : bool
19909 2378117 : gfc_pure (gfc_symbol *sym)
19910 : {
19911 2378117 : symbol_attribute attr;
19912 2378117 : gfc_namespace *ns;
19913 :
19914 2378117 : if (sym == NULL)
19915 : {
19916 : /* Check if the current namespace or one of its parents
19917 : belongs to a pure procedure. */
19918 3206219 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19919 : {
19920 1894461 : sym = ns->proc_name;
19921 1894461 : if (sym == NULL)
19922 : return 0;
19923 1893320 : attr = sym->attr;
19924 1893320 : if (attr.flavor == FL_PROCEDURE && attr.pure)
19925 : return 1;
19926 : }
19927 : return 0;
19928 : }
19929 :
19930 1057710 : attr = sym->attr;
19931 :
19932 1057710 : return attr.flavor == FL_PROCEDURE && attr.pure;
19933 : }
19934 :
19935 :
19936 : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
19937 : checks if the current namespace is implicitly pure. Note that this
19938 : function returns false for a PURE procedure. */
19939 :
19940 : bool
19941 730031 : gfc_implicit_pure (gfc_symbol *sym)
19942 : {
19943 730031 : gfc_namespace *ns;
19944 :
19945 730031 : if (sym == NULL)
19946 : {
19947 : /* Check if the current procedure is implicit_pure. Walk up
19948 : the procedure list until we find a procedure. */
19949 1005802 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19950 : {
19951 717871 : sym = ns->proc_name;
19952 717871 : if (sym == NULL)
19953 : return 0;
19954 :
19955 717798 : if (sym->attr.flavor == FL_PROCEDURE)
19956 : break;
19957 : }
19958 : }
19959 :
19960 442024 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
19961 757506 : && !sym->attr.pure;
19962 : }
19963 :
19964 :
19965 : void
19966 428467 : gfc_unset_implicit_pure (gfc_symbol *sym)
19967 : {
19968 428467 : gfc_namespace *ns;
19969 :
19970 428467 : if (sym == NULL)
19971 : {
19972 : /* Check if the current procedure is implicit_pure. Walk up
19973 : the procedure list until we find a procedure. */
19974 700384 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19975 : {
19976 433093 : sym = ns->proc_name;
19977 433093 : if (sym == NULL)
19978 : return;
19979 :
19980 432260 : if (sym->attr.flavor == FL_PROCEDURE)
19981 : break;
19982 : }
19983 : }
19984 :
19985 427634 : if (sym->attr.flavor == FL_PROCEDURE)
19986 151968 : sym->attr.implicit_pure = 0;
19987 : else
19988 275666 : sym->attr.pure = 0;
19989 : }
19990 :
19991 :
19992 : /* Test whether the current procedure is elemental or not. */
19993 :
19994 : bool
19995 1428217 : gfc_elemental (gfc_symbol *sym)
19996 : {
19997 1428217 : symbol_attribute attr;
19998 :
19999 1428217 : if (sym == NULL)
20000 0 : sym = gfc_current_ns->proc_name;
20001 0 : if (sym == NULL)
20002 : return 0;
20003 1428217 : attr = sym->attr;
20004 :
20005 1428217 : return attr.flavor == FL_PROCEDURE && attr.elemental;
20006 : }
20007 :
20008 :
20009 : /* Warn about unused labels. */
20010 :
20011 : static void
20012 4843 : warn_unused_fortran_label (gfc_st_label *label)
20013 : {
20014 4869 : if (label == NULL)
20015 : return;
20016 :
20017 27 : warn_unused_fortran_label (label->left);
20018 :
20019 27 : if (label->defined == ST_LABEL_UNKNOWN)
20020 : return;
20021 :
20022 26 : switch (label->referenced)
20023 : {
20024 2 : case ST_LABEL_UNKNOWN:
20025 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
20026 : label->value, &label->where);
20027 2 : break;
20028 :
20029 1 : case ST_LABEL_BAD_TARGET:
20030 1 : gfc_warning (OPT_Wunused_label,
20031 : "Label %d at %L defined but cannot be used",
20032 : label->value, &label->where);
20033 1 : break;
20034 :
20035 : default:
20036 : break;
20037 : }
20038 :
20039 26 : warn_unused_fortran_label (label->right);
20040 : }
20041 :
20042 :
20043 : /* Returns the sequence type of a symbol or sequence. */
20044 :
20045 : static seq_type
20046 1076 : sequence_type (gfc_typespec ts)
20047 : {
20048 1076 : seq_type result;
20049 1076 : gfc_component *c;
20050 :
20051 1076 : switch (ts.type)
20052 : {
20053 49 : case BT_DERIVED:
20054 :
20055 49 : if (ts.u.derived->components == NULL)
20056 : return SEQ_NONDEFAULT;
20057 :
20058 49 : result = sequence_type (ts.u.derived->components->ts);
20059 103 : for (c = ts.u.derived->components->next; c; c = c->next)
20060 67 : if (sequence_type (c->ts) != result)
20061 : return SEQ_MIXED;
20062 :
20063 : return result;
20064 :
20065 129 : case BT_CHARACTER:
20066 129 : if (ts.kind != gfc_default_character_kind)
20067 0 : return SEQ_NONDEFAULT;
20068 :
20069 : return SEQ_CHARACTER;
20070 :
20071 240 : case BT_INTEGER:
20072 240 : if (ts.kind != gfc_default_integer_kind)
20073 25 : return SEQ_NONDEFAULT;
20074 :
20075 : return SEQ_NUMERIC;
20076 :
20077 559 : case BT_REAL:
20078 559 : if (!(ts.kind == gfc_default_real_kind
20079 269 : || ts.kind == gfc_default_double_kind))
20080 0 : return SEQ_NONDEFAULT;
20081 :
20082 : return SEQ_NUMERIC;
20083 :
20084 81 : case BT_COMPLEX:
20085 81 : if (ts.kind != gfc_default_complex_kind)
20086 48 : return SEQ_NONDEFAULT;
20087 :
20088 : return SEQ_NUMERIC;
20089 :
20090 17 : case BT_LOGICAL:
20091 17 : if (ts.kind != gfc_default_logical_kind)
20092 0 : return SEQ_NONDEFAULT;
20093 :
20094 : return SEQ_NUMERIC;
20095 :
20096 : default:
20097 : return SEQ_NONDEFAULT;
20098 : }
20099 : }
20100 :
20101 :
20102 : /* Resolve derived type EQUIVALENCE object. */
20103 :
20104 : static bool
20105 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
20106 : {
20107 80 : gfc_component *c = derived->components;
20108 :
20109 80 : if (!derived)
20110 : return true;
20111 :
20112 : /* Shall not be an object of nonsequence derived type. */
20113 80 : if (!derived->attr.sequence)
20114 : {
20115 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
20116 : "attribute to be an EQUIVALENCE object", sym->name,
20117 : &e->where);
20118 0 : return false;
20119 : }
20120 :
20121 : /* Shall not have allocatable components. */
20122 80 : if (derived->attr.alloc_comp)
20123 : {
20124 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
20125 : "components to be an EQUIVALENCE object",sym->name,
20126 : &e->where);
20127 1 : return false;
20128 : }
20129 :
20130 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
20131 : {
20132 1 : gfc_error ("Derived type variable %qs at %L with default "
20133 : "initialization cannot be in EQUIVALENCE with a variable "
20134 : "in COMMON", sym->name, &e->where);
20135 1 : return false;
20136 : }
20137 :
20138 245 : for (; c ; c = c->next)
20139 : {
20140 167 : if (gfc_bt_struct (c->ts.type)
20141 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
20142 : return false;
20143 :
20144 : /* Shall not be an object of sequence derived type containing a pointer
20145 : in the structure. */
20146 167 : if (c->attr.pointer)
20147 : {
20148 0 : gfc_error ("Derived type variable %qs at %L with pointer "
20149 : "component(s) cannot be an EQUIVALENCE object",
20150 : sym->name, &e->where);
20151 0 : return false;
20152 : }
20153 : }
20154 : return true;
20155 : }
20156 :
20157 :
20158 : /* Resolve equivalence object.
20159 : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
20160 : an allocatable array, an object of nonsequence derived type, an object of
20161 : sequence derived type containing a pointer at any level of component
20162 : selection, an automatic object, a function name, an entry name, a result
20163 : name, a named constant, a structure component, or a subobject of any of
20164 : the preceding objects. A substring shall not have length zero. A
20165 : derived type shall not have components with default initialization nor
20166 : shall two objects of an equivalence group be initialized.
20167 : Either all or none of the objects shall have an protected attribute.
20168 : The simple constraints are done in symbol.cc(check_conflict) and the rest
20169 : are implemented here. */
20170 :
20171 : static void
20172 1565 : resolve_equivalence (gfc_equiv *eq)
20173 : {
20174 1565 : gfc_symbol *sym;
20175 1565 : gfc_symbol *first_sym;
20176 1565 : gfc_expr *e;
20177 1565 : gfc_ref *r;
20178 1565 : locus *last_where = NULL;
20179 1565 : seq_type eq_type, last_eq_type;
20180 1565 : gfc_typespec *last_ts;
20181 1565 : int object, cnt_protected;
20182 1565 : const char *msg;
20183 :
20184 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
20185 :
20186 1565 : first_sym = eq->expr->symtree->n.sym;
20187 :
20188 1565 : cnt_protected = 0;
20189 :
20190 4727 : for (object = 1; eq; eq = eq->eq, object++)
20191 : {
20192 3171 : e = eq->expr;
20193 :
20194 3171 : e->ts = e->symtree->n.sym->ts;
20195 : /* match_varspec might not know yet if it is seeing
20196 : array reference or substring reference, as it doesn't
20197 : know the types. */
20198 3171 : if (e->ref && e->ref->type == REF_ARRAY)
20199 : {
20200 2152 : gfc_ref *ref = e->ref;
20201 2152 : sym = e->symtree->n.sym;
20202 :
20203 2152 : if (sym->attr.dimension)
20204 : {
20205 1855 : ref->u.ar.as = sym->as;
20206 1855 : ref = ref->next;
20207 : }
20208 :
20209 : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
20210 2152 : if (e->ts.type == BT_CHARACTER
20211 592 : && ref
20212 371 : && ref->type == REF_ARRAY
20213 371 : && ref->u.ar.dimen == 1
20214 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
20215 371 : && ref->u.ar.stride[0] == NULL)
20216 : {
20217 370 : gfc_expr *start = ref->u.ar.start[0];
20218 370 : gfc_expr *end = ref->u.ar.end[0];
20219 370 : void *mem = NULL;
20220 :
20221 : /* Optimize away the (:) reference. */
20222 370 : if (start == NULL && end == NULL)
20223 : {
20224 9 : if (e->ref == ref)
20225 0 : e->ref = ref->next;
20226 : else
20227 9 : e->ref->next = ref->next;
20228 : mem = ref;
20229 : }
20230 : else
20231 : {
20232 361 : ref->type = REF_SUBSTRING;
20233 361 : if (start == NULL)
20234 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
20235 : NULL, 1);
20236 361 : ref->u.ss.start = start;
20237 361 : if (end == NULL && e->ts.u.cl)
20238 27 : end = gfc_copy_expr (e->ts.u.cl->length);
20239 361 : ref->u.ss.end = end;
20240 361 : ref->u.ss.length = e->ts.u.cl;
20241 361 : e->ts.u.cl = NULL;
20242 : }
20243 370 : ref = ref->next;
20244 370 : free (mem);
20245 : }
20246 :
20247 : /* Any further ref is an error. */
20248 1930 : if (ref)
20249 : {
20250 1 : gcc_assert (ref->type == REF_ARRAY);
20251 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
20252 : &ref->u.ar.where);
20253 1 : continue;
20254 : }
20255 : }
20256 :
20257 3170 : if (!gfc_resolve_expr (e))
20258 2 : continue;
20259 :
20260 3168 : sym = e->symtree->n.sym;
20261 :
20262 3168 : if (sym->attr.is_protected)
20263 2 : cnt_protected++;
20264 3168 : if (cnt_protected > 0 && cnt_protected != object)
20265 : {
20266 2 : gfc_error ("Either all or none of the objects in the "
20267 : "EQUIVALENCE set at %L shall have the "
20268 : "PROTECTED attribute",
20269 : &e->where);
20270 2 : break;
20271 : }
20272 :
20273 : /* Shall not equivalence common block variables in a PURE procedure. */
20274 3166 : if (sym->ns->proc_name
20275 3150 : && sym->ns->proc_name->attr.pure
20276 7 : && sym->attr.in_common)
20277 : {
20278 : /* Need to check for symbols that may have entered the pure
20279 : procedure via a USE statement. */
20280 7 : bool saw_sym = false;
20281 7 : if (sym->ns->use_stmts)
20282 : {
20283 6 : gfc_use_rename *r;
20284 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
20285 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
20286 : }
20287 : else
20288 : saw_sym = true;
20289 :
20290 6 : if (saw_sym)
20291 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
20292 : "EQUIVALENCE object in the pure procedure %qs",
20293 : sym->name, &e->where, sym->ns->proc_name->name);
20294 : break;
20295 : }
20296 :
20297 : /* Shall not be a named constant. */
20298 3159 : if (e->expr_type == EXPR_CONSTANT)
20299 : {
20300 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
20301 : "object", sym->name, &e->where);
20302 0 : continue;
20303 : }
20304 :
20305 3161 : if (e->ts.type == BT_DERIVED
20306 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
20307 2 : continue;
20308 :
20309 : /* Check that the types correspond correctly:
20310 : Note 5.28:
20311 : A numeric sequence structure may be equivalenced to another sequence
20312 : structure, an object of default integer type, default real type, double
20313 : precision real type, default logical type such that components of the
20314 : structure ultimately only become associated to objects of the same
20315 : kind. A character sequence structure may be equivalenced to an object
20316 : of default character kind or another character sequence structure.
20317 : Other objects may be equivalenced only to objects of the same type and
20318 : kind parameters. */
20319 :
20320 : /* Identical types are unconditionally OK. */
20321 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
20322 2677 : goto identical_types;
20323 :
20324 480 : last_eq_type = sequence_type (*last_ts);
20325 480 : eq_type = sequence_type (sym->ts);
20326 :
20327 : /* Since the pair of objects is not of the same type, mixed or
20328 : non-default sequences can be rejected. */
20329 :
20330 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
20331 : "statement at %L with different type objects");
20332 481 : if ((object ==2
20333 480 : && last_eq_type == SEQ_MIXED
20334 7 : && last_where
20335 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20336 486 : || (eq_type == SEQ_MIXED
20337 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20338 1 : continue;
20339 :
20340 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
20341 : "statement at %L with objects of different type");
20342 483 : if ((object ==2
20343 479 : && last_eq_type == SEQ_NONDEFAULT
20344 50 : && last_where
20345 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
20346 525 : || (eq_type == SEQ_NONDEFAULT
20347 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
20348 4 : continue;
20349 :
20350 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
20351 : "EQUIVALENCE statement at %L");
20352 479 : if (last_eq_type == SEQ_CHARACTER
20353 475 : && eq_type != SEQ_CHARACTER
20354 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20355 4 : continue;
20356 :
20357 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
20358 : "EQUIVALENCE statement at %L");
20359 473 : if (last_eq_type == SEQ_NUMERIC
20360 471 : && eq_type != SEQ_NUMERIC
20361 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
20362 2 : continue;
20363 :
20364 3146 : identical_types:
20365 :
20366 3146 : last_ts =&sym->ts;
20367 3146 : last_where = &e->where;
20368 :
20369 3146 : if (!e->ref)
20370 1003 : continue;
20371 :
20372 : /* Shall not be an automatic array. */
20373 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
20374 : {
20375 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
20376 : "an EQUIVALENCE object", sym->name, &e->where);
20377 3 : continue;
20378 : }
20379 :
20380 2140 : r = e->ref;
20381 4326 : while (r)
20382 : {
20383 : /* Shall not be a structure component. */
20384 2187 : if (r->type == REF_COMPONENT)
20385 : {
20386 0 : gfc_error ("Structure component %qs at %L cannot be an "
20387 : "EQUIVALENCE object",
20388 0 : r->u.c.component->name, &e->where);
20389 0 : break;
20390 : }
20391 :
20392 : /* A substring shall not have length zero. */
20393 2187 : if (r->type == REF_SUBSTRING)
20394 : {
20395 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
20396 : {
20397 1 : gfc_error ("Substring at %L has length zero",
20398 : &r->u.ss.start->where);
20399 1 : break;
20400 : }
20401 : }
20402 2186 : r = r->next;
20403 : }
20404 : }
20405 1565 : }
20406 :
20407 :
20408 : /* Function called by resolve_fntype to flag other symbols used in the
20409 : length type parameter specification of function results. */
20410 :
20411 : static bool
20412 4237 : flag_fn_result_spec (gfc_expr *expr,
20413 : gfc_symbol *sym,
20414 : int *f ATTRIBUTE_UNUSED)
20415 : {
20416 4237 : gfc_namespace *ns;
20417 4237 : gfc_symbol *s;
20418 :
20419 4237 : if (expr->expr_type == EXPR_VARIABLE)
20420 : {
20421 1384 : s = expr->symtree->n.sym;
20422 2171 : for (ns = s->ns; ns; ns = ns->parent)
20423 2171 : if (!ns->parent)
20424 : break;
20425 :
20426 1384 : if (sym == s)
20427 : {
20428 1 : gfc_error ("Self reference in character length expression "
20429 : "for %qs at %L", sym->name, &expr->where);
20430 1 : return true;
20431 : }
20432 :
20433 1383 : if (!s->fn_result_spec
20434 1383 : && s->attr.flavor == FL_PARAMETER)
20435 : {
20436 : /* Function contained in a module.... */
20437 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
20438 : {
20439 32 : gfc_symtree *st;
20440 32 : s->fn_result_spec = 1;
20441 : /* Make sure that this symbol is translated as a module
20442 : variable. */
20443 32 : st = gfc_get_unique_symtree (ns);
20444 32 : st->n.sym = s;
20445 32 : s->refs++;
20446 32 : }
20447 : /* ... which is use associated and called. */
20448 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
20449 0 : ||
20450 : /* External function matched with an interface. */
20451 0 : (s->ns->proc_name
20452 0 : && ((s->ns == ns
20453 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
20454 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
20455 0 : && s->ns->proc_name->attr.function))
20456 31 : s->fn_result_spec = 1;
20457 : }
20458 : }
20459 : return false;
20460 : }
20461 :
20462 :
20463 : /* Resolve function and ENTRY types, issue diagnostics if needed. */
20464 :
20465 : static void
20466 360463 : resolve_fntype (gfc_namespace *ns)
20467 : {
20468 360463 : gfc_entry_list *el;
20469 360463 : gfc_symbol *sym;
20470 :
20471 360463 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
20472 : return;
20473 :
20474 : /* If there are any entries, ns->proc_name is the entry master
20475 : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
20476 189292 : if (ns->entries)
20477 596 : sym = ns->entries->sym;
20478 : else
20479 : sym = ns->proc_name;
20480 189292 : if (sym->result == sym
20481 153840 : && sym->ts.type == BT_UNKNOWN
20482 6 : && !gfc_set_default_type (sym, 0, NULL)
20483 189296 : && !sym->attr.untyped)
20484 : {
20485 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
20486 : sym->name, &sym->declared_at);
20487 3 : sym->attr.untyped = 1;
20488 : }
20489 :
20490 14015 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
20491 1862 : && !sym->attr.contained
20492 299 : && !gfc_check_symbol_access (sym->ts.u.derived)
20493 189292 : && gfc_check_symbol_access (sym))
20494 : {
20495 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
20496 : "%L of PRIVATE type %qs", sym->name,
20497 0 : &sym->declared_at, sym->ts.u.derived->name);
20498 : }
20499 :
20500 189292 : if (ns->entries)
20501 1253 : for (el = ns->entries->next; el; el = el->next)
20502 : {
20503 657 : if (el->sym->result == el->sym
20504 445 : && el->sym->ts.type == BT_UNKNOWN
20505 2 : && !gfc_set_default_type (el->sym, 0, NULL)
20506 659 : && !el->sym->attr.untyped)
20507 : {
20508 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
20509 : el->sym->name, &el->sym->declared_at);
20510 2 : el->sym->attr.untyped = 1;
20511 : }
20512 : }
20513 :
20514 189292 : if (sym->ts.type == BT_CHARACTER
20515 7074 : && sym->ts.u.cl->length
20516 1883 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
20517 1878 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
20518 : }
20519 :
20520 :
20521 : /* 12.3.2.1.1 Defined operators. */
20522 :
20523 : static bool
20524 508 : check_uop_procedure (gfc_symbol *sym, locus where)
20525 : {
20526 508 : gfc_formal_arglist *formal;
20527 :
20528 508 : if (!sym->attr.function)
20529 : {
20530 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
20531 : sym->name, &where);
20532 4 : return false;
20533 : }
20534 :
20535 504 : if (sym->ts.type == BT_CHARACTER
20536 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
20537 2 : && !(sym->result && ((sym->result->ts.u.cl
20538 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
20539 : {
20540 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
20541 : "character length", sym->name, &where);
20542 2 : return false;
20543 : }
20544 :
20545 502 : formal = gfc_sym_get_dummy_args (sym);
20546 502 : if (!formal || !formal->sym)
20547 : {
20548 1 : gfc_error ("User operator procedure %qs at %L must have at least "
20549 : "one argument", sym->name, &where);
20550 1 : return false;
20551 : }
20552 :
20553 501 : if (formal->sym->attr.intent != INTENT_IN)
20554 : {
20555 0 : gfc_error ("First argument of operator interface at %L must be "
20556 : "INTENT(IN)", &where);
20557 0 : return false;
20558 : }
20559 :
20560 501 : if (formal->sym->attr.optional)
20561 : {
20562 0 : gfc_error ("First argument of operator interface at %L cannot be "
20563 : "optional", &where);
20564 0 : return false;
20565 : }
20566 :
20567 501 : formal = formal->next;
20568 501 : if (!formal || !formal->sym)
20569 : return true;
20570 :
20571 297 : if (formal->sym->attr.intent != INTENT_IN)
20572 : {
20573 0 : gfc_error ("Second argument of operator interface at %L must be "
20574 : "INTENT(IN)", &where);
20575 0 : return false;
20576 : }
20577 :
20578 297 : if (formal->sym->attr.optional)
20579 : {
20580 1 : gfc_error ("Second argument of operator interface at %L cannot be "
20581 : "optional", &where);
20582 1 : return false;
20583 : }
20584 :
20585 296 : if (formal->next)
20586 : {
20587 2 : gfc_error ("Operator interface at %L must have, at most, two "
20588 : "arguments", &where);
20589 2 : return false;
20590 : }
20591 :
20592 : return true;
20593 : }
20594 :
20595 : static void
20596 361269 : gfc_resolve_uops (gfc_symtree *symtree)
20597 : {
20598 361269 : gfc_interface *itr;
20599 :
20600 361269 : if (symtree == NULL)
20601 : return;
20602 :
20603 403 : gfc_resolve_uops (symtree->left);
20604 403 : gfc_resolve_uops (symtree->right);
20605 :
20606 798 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
20607 395 : check_uop_procedure (itr->sym, itr->sym->declared_at);
20608 : }
20609 :
20610 : /* Mark all lhs in assignment statement as used. It is better to put this into
20611 : its own function rather than into the different switch cases in
20612 : gfc_resolve_code. */
20613 :
20614 : static void
20615 696780 : mark_lhs_assignments_set (gfc_code *code)
20616 : {
20617 :
20618 1843066 : for (; code; code = code->next)
20619 : {
20620 1146286 : gfc_expr *lvalue = code->expr1, *rvalue = code->expr2;
20621 :
20622 1146286 : if (lvalue == NULL || lvalue->symtree == NULL || rvalue == NULL)
20623 846897 : continue;
20624 :
20625 299389 : switch (code->op)
20626 : {
20627 287781 : case EXEC_ASSIGN:
20628 287781 : if (gfc_is_reallocatable_lhs (lvalue) && lvalue->rank == rvalue->rank)
20629 8418 : gfc_lvalue_allocated_at (lvalue->symtree->n.sym, &lvalue->where);
20630 :
20631 297918 : gcc_fallthrough();
20632 297918 : case EXEC_POINTER_ASSIGN:
20633 297918 : gfc_expr_set_at (lvalue, &rvalue->where, VALUE_VARDEF);
20634 : default:
20635 : break;
20636 : }
20637 : }
20638 696780 : }
20639 :
20640 : /* Examine all of the expressions associated with a program unit,
20641 : assign types to all intermediate expressions, make sure that all
20642 : assignments are to compatible types and figure out which names
20643 : refer to which functions or subroutines. It doesn't check code
20644 : block, which is handled by gfc_resolve_code. */
20645 :
20646 : static void
20647 363013 : resolve_types (gfc_namespace *ns)
20648 : {
20649 363013 : gfc_namespace *n;
20650 363013 : gfc_charlen *cl;
20651 363013 : gfc_data *d;
20652 363013 : gfc_equiv *eq;
20653 363013 : gfc_namespace* old_ns = gfc_current_ns;
20654 363013 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
20655 :
20656 363013 : if (ns->types_resolved)
20657 : return;
20658 :
20659 : /* Check that all IMPLICIT types are ok. */
20660 360464 : if (!ns->seen_implicit_none)
20661 : {
20662 : unsigned letter;
20663 9083422 : for (letter = 0; letter != GFC_LETTERS; ++letter)
20664 8746999 : if (ns->set_flag[letter]
20665 8746999 : && !resolve_typespec_used (&ns->default_type[letter],
20666 : &ns->implicit_loc[letter], NULL))
20667 : return;
20668 : }
20669 :
20670 360463 : gfc_current_ns = ns;
20671 :
20672 360463 : resolve_entries (ns);
20673 :
20674 360463 : resolve_common_vars (&ns->blank_common, false);
20675 360463 : resolve_common_blocks (ns->common_root);
20676 :
20677 360463 : resolve_contained_functions (ns);
20678 :
20679 360463 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
20680 309516 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
20681 206361 : gfc_resolve_formal_arglist (ns->proc_name);
20682 :
20683 360463 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
20684 :
20685 456710 : for (cl = ns->cl_list; cl; cl = cl->next)
20686 96247 : resolve_charlen (cl);
20687 :
20688 360463 : gfc_traverse_ns (ns, resolve_symbol);
20689 :
20690 360463 : resolve_fntype (ns);
20691 :
20692 409308 : for (n = ns->contained; n; n = n->sibling)
20693 : {
20694 : /* Exclude final wrappers with the test for the artificial attribute. */
20695 48845 : if (gfc_pure (ns->proc_name)
20696 5 : && !gfc_pure (n->proc_name)
20697 48845 : && !n->proc_name->attr.artificial)
20698 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20699 : "also be PURE", n->proc_name->name,
20700 : &n->proc_name->declared_at);
20701 :
20702 48845 : resolve_types (n);
20703 : }
20704 :
20705 360463 : forall_flag = 0;
20706 360463 : gfc_do_concurrent_flag = 0;
20707 360463 : gfc_check_interfaces (ns);
20708 :
20709 360463 : gfc_traverse_ns (ns, resolve_values);
20710 :
20711 360463 : if (ns->save_all || (!flag_automatic && !recursive))
20712 315 : gfc_save_all (ns);
20713 :
20714 360463 : iter_stack = NULL;
20715 362981 : for (d = ns->data; d; d = d->next)
20716 2518 : resolve_data (d);
20717 :
20718 360463 : iter_stack = NULL;
20719 360463 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20720 :
20721 360463 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20722 :
20723 362028 : for (eq = ns->equiv; eq; eq = eq->next)
20724 1565 : resolve_equivalence (eq);
20725 :
20726 : /* Warn about unused labels. */
20727 360463 : if (warn_unused_label)
20728 4816 : warn_unused_fortran_label (ns->st_labels);
20729 :
20730 360463 : gfc_resolve_uops (ns->uop_root);
20731 :
20732 360463 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20733 :
20734 360463 : gfc_resolve_omp_declare (ns);
20735 :
20736 360463 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20737 :
20738 360463 : gfc_resolve_omp_udms (ns->omp_udm_root);
20739 :
20740 360463 : ns->types_resolved = 1;
20741 :
20742 360463 : gfc_current_ns = old_ns;
20743 : }
20744 :
20745 :
20746 : /* Call gfc_resolve_code recursively. */
20747 :
20748 : static void
20749 363069 : resolve_codes (gfc_namespace *ns)
20750 : {
20751 363069 : gfc_namespace *n;
20752 363069 : bitmap_obstack old_obstack;
20753 :
20754 363069 : if (ns->resolved == 1)
20755 14378 : return;
20756 :
20757 397592 : for (n = ns->contained; n; n = n->sibling)
20758 48901 : resolve_codes (n);
20759 :
20760 348691 : gfc_current_ns = ns;
20761 :
20762 : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20763 348691 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20764 336250 : cs_base = NULL;
20765 :
20766 : /* Set to an out of range value. */
20767 348691 : current_entry_id = -1;
20768 :
20769 348691 : old_obstack = labels_obstack;
20770 348691 : bitmap_obstack_initialize (&labels_obstack);
20771 :
20772 348691 : gfc_resolve_oacc_declare (ns);
20773 348691 : gfc_resolve_oacc_routines (ns);
20774 348691 : gfc_resolve_omp_local_vars (ns);
20775 348691 : if (ns->omp_allocate)
20776 62 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20777 348691 : gfc_resolve_code (ns->code, ns);
20778 :
20779 348690 : bitmap_obstack_release (&labels_obstack);
20780 348690 : labels_obstack = old_obstack;
20781 : }
20782 :
20783 : /* Return true if the value of a variable can be considered used, either
20784 : through the value_used flag or because it is a suitable dummy argument. */
20785 :
20786 : static bool
20787 453 : var_value_is_used (gfc_symbol *sym)
20788 : {
20789 453 : if (sym->attr.value_used != VALUE_UNUSED)
20790 : return true;
20791 :
20792 107 : if (!sym->attr.dummy)
20793 : return false;
20794 :
20795 90 : if (sym->attr.value)
20796 : return false;
20797 :
20798 90 : switch (sym->attr.intent)
20799 : {
20800 : case INTENT_UNKNOWN:
20801 : case INTENT_INOUT:
20802 : case INTENT_OUT:
20803 : return true;
20804 :
20805 : case INTENT_IN:
20806 : default:
20807 : return false;
20808 : }
20809 : }
20810 :
20811 : /* Similar, see if the variable could have gotten its value from somewhere. */
20812 :
20813 : static bool
20814 2379 : var_value_is_set (gfc_symbol *sym)
20815 : {
20816 2379 : if (sym->attr.value_set != VALUE_UNSET)
20817 : return true;
20818 :
20819 1683 : if (sym->value)
20820 : return true;
20821 :
20822 1668 : if (sym->ts.type == BT_DERIVED
20823 1668 : && gfc_has_default_initializer (sym->ts.u.derived))
20824 : return true;
20825 :
20826 1668 : if (!sym->attr.dummy)
20827 : return false;
20828 :
20829 1624 : if (sym->attr.value)
20830 : return true;
20831 :
20832 1591 : if (sym->attr.intent == INTENT_OUT)
20833 : return false;
20834 :
20835 : return true;
20836 : }
20837 :
20838 : /* Callback function to catch set but never used variables. */
20839 :
20840 : static void
20841 34273 : find_unused_vs_set (gfc_symbol *sym)
20842 : {
20843 34273 : symbol_attribute *attr = &sym->attr;
20844 :
20845 34273 : if (attr->flavor != FL_VARIABLE)
20846 : return;
20847 :
20848 : /* Do not warn about anything too far out of the ordinary. This might be
20849 : tightened later. */
20850 8603 : if (attr->in_common || attr->in_equivalence || attr->artificial
20851 8197 : || attr->cray_pointer || attr->cray_pointee || attr->associate_var
20852 8196 : || attr->target || attr->fe_temp || attr->omp_declare_target
20853 8193 : || attr->omp_declare_target_link || attr->omp_declare_target_local
20854 8184 : || attr->omp_declare_target_indirect || attr->oacc_declare_create
20855 8184 : || attr->oacc_declare_copyin || attr->oacc_declare_deviceptr
20856 8184 : || attr->oacc_declare_device_resident || attr->oacc_declare_link
20857 8184 : || attr->result || attr->warning_emitted || attr->use_assoc
20858 5643 : || attr->volatile_ || attr->asynchronous || !attr->referenced)
20859 : return;
20860 :
20861 2447 : if (attr->host_assoc && attr->access != ACCESS_PRIVATE)
20862 : return;
20863 :
20864 : /* There is no allocation in sight, but the variable is used anyway. This
20865 : might be hidden behind PRESENT, but issue a warning nonetheless. If
20866 : people complain, we might want to make this to an extra option to be
20867 : included with -Wextra. */
20868 :
20869 2381 : if (warn_undefined_vars && attr->allocatable && !attr->allocated
20870 2433 : && var_value_is_used (sym))
20871 : {
20872 3 : if (attr->dummy && attr->intent == INTENT_OUT)
20873 : {
20874 0 : gfc_warning (OPT_Wundefined_vars, "Unallocated INTENT(OUT) variable "
20875 : "%qs referenced at %L", sym->name, &sym->other_loc);
20876 0 : attr->warning_emitted = 1;
20877 0 : return;
20878 : }
20879 :
20880 3 : if (!attr->dummy)
20881 : {
20882 2 : gfc_warning (OPT_Wundefined_vars, "Unallocated variable %qs "
20883 : "referenced at %L", sym->name, &sym->other_loc);
20884 2 : attr->warning_emitted = 1;
20885 2 : return;
20886 : }
20887 : }
20888 :
20889 2422 : if (warn_undefined_vars && !var_value_is_set (sym))
20890 : {
20891 : /* Warn about variables which have been allocated and used, but never
20892 : set. */
20893 47 : if (attr->allocated && sym->attr.value_used > VALUE_MAYBE_USED)
20894 : {
20895 3 : switch (sym->attr.value_used)
20896 : {
20897 1 : case VALUE_INTENT_IN:
20898 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
20899 : "undefined to INTENT(IN) argument at %L", sym->name,
20900 : &sym->other_loc);
20901 1 : break;
20902 :
20903 1 : case VALUE_VALUE_ARG:
20904 1 : gfc_warning (OPT_Wundefined_vars, "Allocated variable %qs passed "
20905 : "undefined to VALUE argument at %L", sym->name,
20906 : &sym->other_loc);
20907 1 : break;
20908 1 : case VALUE_USED:
20909 1 : gfc_warning (OPT_Wundefined_vars, "Allocated undefined variable "
20910 : "%qs used at %L", sym->name, &sym->other_loc);
20911 1 : break;
20912 0 : default:
20913 0 : gfc_internal_error ("Wrong value_set");
20914 3 : break;
20915 : }
20916 3 : attr->warning_emitted = 1;
20917 3 : return;
20918 : }
20919 :
20920 : /* Similar, when undefined variables are passed to INTENT(IN), VALUE
20921 : arguments or are used in general. */
20922 :
20923 44 : if (attr->value_used == VALUE_INTENT_IN)
20924 : {
20925 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
20926 : "to INTENT(IN) argument at %L", sym->name, &sym->other_loc);
20927 1 : attr->warning_emitted = 1;
20928 1 : return;
20929 : }
20930 43 : else if (attr->value_used == VALUE_VALUE_ARG)
20931 : {
20932 1 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs passed "
20933 : "to VALUE argument at %L", sym->name, &sym->other_loc);
20934 1 : attr->warning_emitted = 1;
20935 1 : return;
20936 : }
20937 42 : else if (attr->value_used == VALUE_USED)
20938 : {
20939 8 : if (attr->dummy && attr->intent == INTENT_OUT)
20940 1 : gfc_warning (OPT_Wundefined_vars, "Undefined INTENT(OUT) variable %qs "
20941 : "used at %L", sym->name, &sym->other_loc);
20942 : else
20943 7 : gfc_warning (OPT_Wundefined_vars, "Undefined variable %qs used at "
20944 : "%L", sym->name, &sym->other_loc);
20945 :
20946 8 : attr->warning_emitted = 1;
20947 8 : return;
20948 : }
20949 :
20950 : /* PR 28004 - warn about INTENT(OUT) variables that are never set. If
20951 : the variable or a component are allocatable, do not warn since this is
20952 : a frequent shortcut for deallocation. */
20953 :
20954 34 : if (sym->attr.dummy && sym->attr.intent == INTENT_OUT
20955 2 : && !(attr->allocatable || attr->alloc_comp))
20956 : {
20957 0 : gfc_warning (OPT_Wundefined_vars, "INTENT(OUT) variable %qs "
20958 : "declared at %L is not assigned a value", sym->name,
20959 : &sym->declared_at);
20960 0 : attr->warning_emitted = 1;
20961 0 : return;
20962 : }
20963 : }
20964 :
20965 : /* Warn for unused but defined variables. */
20966 :
20967 2409 : if (warn_unused_but_set_variable)
20968 : {
20969 2302 : if (attr->value_set == VALUE_VARDEF && !var_value_is_used (sym))
20970 : {
20971 7 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs defined at "
20972 : "%L but never used", sym->name, &sym->other_loc);
20973 7 : attr->warning_emitted = 1;
20974 7 : return;
20975 : }
20976 2295 : if (attr->allocatable && !var_value_is_used (sym))
20977 : {
20978 2 : if (attr->allocated == ALLOCATED_ALLOCATE_STMT)
20979 : {
20980 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs "
20981 : "allocated at %L but never used", sym->name,
20982 : &sym->extra_loc);
20983 1 : attr->warning_emitted = 1;
20984 1 : return;
20985 : }
20986 1 : else if (attr->allocated == ALLOCATED_ARG)
20987 : {
20988 1 : gfc_warning (OPT_Wunused_but_set_variable_, "Variable %qs maybe "
20989 : "allocated as argument at %L but never used",
20990 : sym->name, &sym->extra_loc);
20991 1 : attr->warning_emitted = 1;
20992 1 : return;
20993 : }
20994 : }
20995 : }
20996 :
20997 : /* -Wunused-intent-out and -Wunused-read are enabled with -Wextra, so
20998 : check for these conditions at the end. If one of the warnings
20999 : with -Wall triggered, we do not want to issue a different warrning
21000 : for the same variable if the user supplies -Wall -Wextra instead
21001 : of only -Wall. */
21002 :
21003 39 : if (warn_unused_intent_out && attr->value_set == VALUE_INTENT_OUT
21004 2405 : && !var_value_is_used (sym))
21005 : {
21006 1 : gfc_warning (OPT_Wunused_intent_out, "Variable %qs passed to "
21007 : "INTENT(OUT) argument at %L but value never used",
21008 : sym->name, &sym->other_loc);
21009 1 : attr->warning_emitted = 1;
21010 1 : return;
21011 : }
21012 :
21013 2399 : if (warn_unused_read && attr->value_set == VALUE_READ && !var_value_is_used (sym))
21014 : {
21015 1 : gfc_warning (OPT_Wunused_read, "Variable %qs read at %L but never "
21016 : "used", sym->name, &sym->other_loc);
21017 1 : attr->warning_emitted = 1;
21018 1 : return;
21019 : }
21020 : }
21021 :
21022 : /* Run warn_unused_vs_set over a namespace recursively. */
21023 :
21024 : static void
21025 4842 : warn_unused_vs_set (gfc_namespace *ns)
21026 : {
21027 4842 : gfc_traverse_ns (ns, find_unused_vs_set);
21028 :
21029 5365 : for (gfc_namespace *n = ns->contained; n; n = n->sibling)
21030 523 : warn_unused_vs_set (n);
21031 4842 : }
21032 :
21033 : /* This function is called after a complete program unit has been compiled.
21034 : Its purpose is to examine all of the expressions associated with a program
21035 : unit, assign types to all intermediate expressions, make sure that all
21036 : assignments are to compatible types and figure out which names refer to
21037 : which functions or subroutines. */
21038 :
21039 : void
21040 319021 : gfc_resolve (gfc_namespace *ns)
21041 : {
21042 319021 : gfc_namespace *old_ns;
21043 319021 : code_stack *old_cs_base;
21044 319021 : struct gfc_omp_saved_state old_omp_state;
21045 :
21046 319021 : if (ns->resolved)
21047 4853 : return;
21048 :
21049 314168 : ns->resolved = -1;
21050 314168 : old_ns = gfc_current_ns;
21051 314168 : old_cs_base = cs_base;
21052 :
21053 : /* As gfc_resolve can be called during resolution of an OpenMP construct
21054 : body, we should clear any state associated to it, so that say NS's
21055 : DO loops are not interpreted as OpenMP loops. */
21056 314168 : if (!ns->construct_entities)
21057 301727 : gfc_omp_save_and_clear_state (&old_omp_state);
21058 :
21059 314168 : resolve_types (ns);
21060 314168 : component_assignment_level = 0;
21061 314168 : resolve_codes (ns);
21062 :
21063 314167 : if (warn_unused_but_set_variable || warn_unused_intent_out
21064 309903 : || warn_unused_read || warn_undefined_vars)
21065 : {
21066 4343 : int error_count;
21067 4343 : gfc_get_errors (NULL, &error_count);
21068 4343 : if (error_count == 0)
21069 4319 : warn_unused_vs_set (ns);
21070 : }
21071 :
21072 314167 : if (ns->omp_assumes)
21073 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
21074 :
21075 314167 : gfc_current_ns = old_ns;
21076 314167 : cs_base = old_cs_base;
21077 314167 : ns->resolved = 1;
21078 :
21079 314167 : gfc_run_passes (ns);
21080 :
21081 314167 : if (!ns->construct_entities)
21082 301726 : gfc_omp_restore_state (&old_omp_state);
21083 : }
|
