Branch data Line data Source code
1 : : /* Perform type resolution on the various structures.
2 : : Copyright (C) 2001-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "bitmap.h"
26 : : #include "gfortran.h"
27 : : #include "arith.h" /* For gfc_compare_expr(). */
28 : : #include "dependency.h"
29 : : #include "data.h"
30 : : #include "target-memory.h" /* for gfc_simplify_transfer */
31 : : #include "constructor.h"
32 : :
33 : : /* Types used in equivalence statements. */
34 : :
35 : : enum seq_type
36 : : {
37 : : SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 : : };
39 : :
40 : : /* Stack to keep track of the nesting of blocks as we move through the
41 : : code. See resolve_branch() and gfc_resolve_code(). */
42 : :
43 : : typedef struct code_stack
44 : : {
45 : : struct gfc_code *head, *current;
46 : : struct code_stack *prev;
47 : :
48 : : /* This bitmap keeps track of the targets valid for a branch from
49 : : inside this block except for END {IF|SELECT}s of enclosing
50 : : blocks. */
51 : : bitmap reachable_labels;
52 : : }
53 : : code_stack;
54 : :
55 : : static code_stack *cs_base = NULL;
56 : :
57 : : struct check_default_none_data
58 : : {
59 : : gfc_code *code;
60 : : hash_set<gfc_symbol *> *sym_hash;
61 : : gfc_namespace *ns;
62 : : bool default_none;
63 : : };
64 : :
65 : : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
66 : :
67 : : static int forall_flag;
68 : : int gfc_do_concurrent_flag;
69 : :
70 : : /* True when we are resolving an expression that is an actual argument to
71 : : a procedure. */
72 : : static bool actual_arg = false;
73 : : /* True when we are resolving an expression that is the first actual argument
74 : : to a procedure. */
75 : : static bool first_actual_arg = false;
76 : :
77 : :
78 : : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
79 : :
80 : : static int omp_workshare_flag;
81 : :
82 : :
83 : : /* True if we are resolving a specification expression. */
84 : : static bool specification_expr = false;
85 : :
86 : : /* The id of the last entry seen. */
87 : : static int current_entry_id;
88 : :
89 : : /* We use bitmaps to determine if a branch target is valid. */
90 : : static bitmap_obstack labels_obstack;
91 : :
92 : : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 : : static bool inquiry_argument = false;
94 : :
95 : :
96 : : /* Is the symbol host associated? */
97 : : static bool
98 : 49749 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
99 : : {
100 : 54160 : for (ns = ns->parent; ns; ns = ns->parent)
101 : : {
102 : 4662 : if (sym->ns == ns)
103 : : return true;
104 : : }
105 : :
106 : : return false;
107 : : }
108 : :
109 : : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
110 : : an ABSTRACT derived-type. If where is not NULL, an error message with that
111 : : locus is printed, optionally using name. */
112 : :
113 : : static bool
114 : 1486551 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
115 : : {
116 : 1486551 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
117 : : {
118 : 5 : if (where)
119 : : {
120 : 5 : if (name)
121 : 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
122 : : name, where, ts->u.derived->name);
123 : : else
124 : 1 : gfc_error ("ABSTRACT type %qs used at %L",
125 : : ts->u.derived->name, where);
126 : : }
127 : :
128 : 5 : return false;
129 : : }
130 : :
131 : : return true;
132 : : }
133 : :
134 : :
135 : : static bool
136 : 5301 : check_proc_interface (gfc_symbol *ifc, locus *where)
137 : : {
138 : : /* Several checks for F08:C1216. */
139 : 5301 : if (ifc->attr.procedure)
140 : : {
141 : 2 : gfc_error ("Interface %qs at %L is declared "
142 : : "in a later PROCEDURE statement", ifc->name, where);
143 : 2 : return false;
144 : : }
145 : 5299 : if (ifc->generic)
146 : : {
147 : : /* For generic interfaces, check if there is
148 : : a specific procedure with the same name. */
149 : : gfc_interface *gen = ifc->generic;
150 : 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
151 : 5 : gen = gen->next;
152 : 7 : if (!gen)
153 : : {
154 : 4 : gfc_error ("Interface %qs at %L may not be generic",
155 : : ifc->name, where);
156 : 4 : return false;
157 : : }
158 : : }
159 : 5295 : if (ifc->attr.proc == PROC_ST_FUNCTION)
160 : : {
161 : 4 : gfc_error ("Interface %qs at %L may not be a statement function",
162 : : ifc->name, where);
163 : 4 : return false;
164 : : }
165 : 5291 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
166 : 5291 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
167 : 17 : ifc->attr.intrinsic = 1;
168 : 5291 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
169 : : {
170 : 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
171 : : "PROCEDURE statement at %L", ifc->name, where);
172 : 3 : return false;
173 : : }
174 : 5288 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
175 : : {
176 : 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
177 : 7 : return false;
178 : : }
179 : : return true;
180 : : }
181 : :
182 : :
183 : : static void resolve_symbol (gfc_symbol *sym);
184 : :
185 : :
186 : : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
187 : :
188 : : static bool
189 : 1999 : resolve_procedure_interface (gfc_symbol *sym)
190 : : {
191 : 1999 : gfc_symbol *ifc = sym->ts.interface;
192 : :
193 : 1999 : if (!ifc)
194 : : return true;
195 : :
196 : 1843 : if (ifc == sym)
197 : : {
198 : 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
199 : : sym->name, &sym->declared_at);
200 : 2 : return false;
201 : : }
202 : 1841 : if (!check_proc_interface (ifc, &sym->declared_at))
203 : : return false;
204 : :
205 : 1832 : if (ifc->attr.if_source || ifc->attr.intrinsic)
206 : : {
207 : : /* Resolve interface and copy attributes. */
208 : 1553 : resolve_symbol (ifc);
209 : 1553 : if (ifc->attr.intrinsic)
210 : 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
211 : :
212 : 1553 : if (ifc->result)
213 : : {
214 : 678 : sym->ts = ifc->result->ts;
215 : 678 : sym->attr.allocatable = ifc->result->attr.allocatable;
216 : 678 : sym->attr.pointer = ifc->result->attr.pointer;
217 : 678 : sym->attr.dimension = ifc->result->attr.dimension;
218 : 678 : sym->attr.class_ok = ifc->result->attr.class_ok;
219 : 678 : sym->as = gfc_copy_array_spec (ifc->result->as);
220 : 678 : sym->result = sym;
221 : : }
222 : : else
223 : : {
224 : 875 : sym->ts = ifc->ts;
225 : 875 : sym->attr.allocatable = ifc->attr.allocatable;
226 : 875 : sym->attr.pointer = ifc->attr.pointer;
227 : 875 : sym->attr.dimension = ifc->attr.dimension;
228 : 875 : sym->attr.class_ok = ifc->attr.class_ok;
229 : 875 : sym->as = gfc_copy_array_spec (ifc->as);
230 : : }
231 : 1553 : sym->ts.interface = ifc;
232 : 1553 : sym->attr.function = ifc->attr.function;
233 : 1553 : sym->attr.subroutine = ifc->attr.subroutine;
234 : :
235 : 1553 : sym->attr.pure = ifc->attr.pure;
236 : 1553 : sym->attr.elemental = ifc->attr.elemental;
237 : 1553 : sym->attr.contiguous = ifc->attr.contiguous;
238 : 1553 : sym->attr.recursive = ifc->attr.recursive;
239 : 1553 : sym->attr.always_explicit = ifc->attr.always_explicit;
240 : 1553 : sym->attr.ext_attr |= ifc->attr.ext_attr;
241 : 1553 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
242 : : /* Copy char length. */
243 : 1553 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
244 : : {
245 : 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
246 : 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
247 : 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
248 : : return false;
249 : : }
250 : : }
251 : :
252 : : return true;
253 : : }
254 : :
255 : :
256 : : /* Resolve types of formal argument lists. These have to be done early so that
257 : : the formal argument lists of module procedures can be copied to the
258 : : containing module before the individual procedures are resolved
259 : : individually. We also resolve argument lists of procedures in interface
260 : : blocks because they are self-contained scoping units.
261 : :
262 : : Since a dummy argument cannot be a non-dummy procedure, the only
263 : : resort left for untyped names are the IMPLICIT types. */
264 : :
265 : : void
266 : 509263 : gfc_resolve_formal_arglist (gfc_symbol *proc)
267 : : {
268 : 509263 : gfc_formal_arglist *f;
269 : 509263 : gfc_symbol *sym;
270 : 509263 : bool saved_specification_expr;
271 : 509263 : int i;
272 : :
273 : 509263 : if (proc->result != NULL)
274 : 317785 : sym = proc->result;
275 : : else
276 : : sym = proc;
277 : :
278 : 509263 : if (gfc_elemental (proc)
279 : 347685 : || sym->attr.pointer || sym->attr.allocatable
280 : 845306 : || (sym->as && sym->as->rank != 0))
281 : : {
282 : 175507 : proc->attr.always_explicit = 1;
283 : 175507 : sym->attr.always_explicit = 1;
284 : : }
285 : :
286 : 509263 : gfc_namespace *orig_current_ns = gfc_current_ns;
287 : 509263 : gfc_current_ns = gfc_get_procedure_ns (proc);
288 : :
289 : 1319481 : for (f = proc->formal; f; f = f->next)
290 : : {
291 : 810220 : gfc_array_spec *as;
292 : :
293 : 810220 : sym = f->sym;
294 : :
295 : 810220 : if (sym == NULL)
296 : : {
297 : : /* Alternate return placeholder. */
298 : 171 : if (gfc_elemental (proc))
299 : 1 : gfc_error ("Alternate return specifier in elemental subroutine "
300 : : "%qs at %L is not allowed", proc->name,
301 : : &proc->declared_at);
302 : 171 : if (proc->attr.function)
303 : 1 : gfc_error ("Alternate return specifier in function "
304 : : "%qs at %L is not allowed", proc->name,
305 : : &proc->declared_at);
306 : 171 : continue;
307 : : }
308 : :
309 : 554 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310 : 810603 : && !resolve_procedure_interface (sym))
311 : : break;
312 : :
313 : 810049 : if (strcmp (proc->name, sym->name) == 0)
314 : : {
315 : 2 : gfc_error ("Self-referential argument "
316 : : "%qs at %L is not allowed", sym->name,
317 : : &proc->declared_at);
318 : 2 : break;
319 : : }
320 : :
321 : 810047 : if (sym->attr.if_source != IFSRC_UNKNOWN)
322 : 817 : gfc_resolve_formal_arglist (sym);
323 : :
324 : 810047 : if (sym->attr.subroutine || sym->attr.external)
325 : : {
326 : 821 : if (sym->attr.flavor == FL_UNKNOWN)
327 : 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328 : : }
329 : : else
330 : : {
331 : 809226 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 : 3661 : && (!sym->attr.function || sym->result == sym))
333 : 3623 : gfc_set_default_type (sym, 1, sym->ns);
334 : : }
335 : :
336 : 810047 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 : 823411 : ? CLASS_DATA (sym)->as : sym->as;
338 : :
339 : 810047 : saved_specification_expr = specification_expr;
340 : 810047 : specification_expr = true;
341 : 810047 : gfc_resolve_array_spec (as, 0);
342 : 810047 : specification_expr = saved_specification_expr;
343 : :
344 : : /* We can't tell if an array with dimension (:) is assumed or deferred
345 : : shape until we know if it has the pointer or allocatable attributes.
346 : : */
347 : 810047 : if (as && as->rank > 0 && as->type == AS_DEFERRED
348 : 12033 : && ((sym->ts.type != BT_CLASS
349 : 10958 : && !(sym->attr.pointer || sym->attr.allocatable))
350 : 5258 : || (sym->ts.type == BT_CLASS
351 : 1075 : && !(CLASS_DATA (sym)->attr.class_pointer
352 : 875 : || CLASS_DATA (sym)->attr.allocatable)))
353 : 7236 : && sym->attr.flavor != FL_PROCEDURE)
354 : : {
355 : 7235 : as->type = AS_ASSUMED_SHAPE;
356 : 16813 : for (i = 0; i < as->rank; i++)
357 : 9578 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
358 : : }
359 : :
360 : 126180 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361 : 112876 : || (as && as->type == AS_ASSUMED_RANK)
362 : 759645 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363 : 749589 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 : 11297 : && (CLASS_DATA (sym)->attr.class_pointer
365 : 10814 : || CLASS_DATA (sym)->attr.allocatable
366 : 9937 : || CLASS_DATA (sym)->attr.target))
367 : 748229 : || sym->attr.optional)
368 : : {
369 : 76644 : proc->attr.always_explicit = 1;
370 : 76644 : if (proc->result)
371 : 35420 : proc->result->attr.always_explicit = 1;
372 : : }
373 : :
374 : : /* If the flavor is unknown at this point, it has to be a variable.
375 : : A procedure specification would have already set the type. */
376 : :
377 : 810047 : if (sym->attr.flavor == FL_UNKNOWN)
378 : 50133 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379 : :
380 : 810047 : if (gfc_pure (proc))
381 : : {
382 : 326006 : if (sym->attr.flavor == FL_PROCEDURE)
383 : : {
384 : : /* F08:C1279. */
385 : 29 : if (!gfc_pure (sym))
386 : : {
387 : 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 : : "also be PURE", sym->name, &sym->declared_at);
389 : 1 : continue;
390 : : }
391 : : }
392 : 325977 : else if (!sym->attr.pointer)
393 : : {
394 : 325963 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 : : {
396 : 109 : if (sym->attr.value)
397 : 108 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398 : : " of pure function %qs at %L with VALUE "
399 : : "attribute but without INTENT(IN)",
400 : : sym->name, proc->name, &sym->declared_at);
401 : : else
402 : 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
403 : : "be INTENT(IN) or VALUE", sym->name, proc->name,
404 : : &sym->declared_at);
405 : : }
406 : :
407 : 325963 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 : : {
409 : 159 : if (sym->attr.value)
410 : 159 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411 : : " of pure subroutine %qs at %L with VALUE "
412 : : "attribute but without INTENT", sym->name,
413 : : proc->name, &sym->declared_at);
414 : : else
415 : 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 : : "must have its INTENT specified or have the "
417 : : "VALUE attribute", sym->name, proc->name,
418 : : &sym->declared_at);
419 : : }
420 : : }
421 : :
422 : : /* F08:C1278a. */
423 : 326005 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 : : {
425 : 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 : : " may not be polymorphic", sym->name, proc->name,
427 : : &sym->declared_at);
428 : 1 : continue;
429 : : }
430 : : }
431 : :
432 : 810045 : if (proc->attr.implicit_pure)
433 : : {
434 : 24291 : if (sym->attr.flavor == FL_PROCEDURE)
435 : : {
436 : 295 : if (!gfc_pure (sym))
437 : 275 : proc->attr.implicit_pure = 0;
438 : : }
439 : 23996 : else if (!sym->attr.pointer)
440 : : {
441 : 23214 : if (proc->attr.function && sym->attr.intent != INTENT_IN
442 : 2697 : && !sym->value)
443 : 2697 : proc->attr.implicit_pure = 0;
444 : :
445 : 23214 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 : 4129 : && !sym->value)
447 : 4129 : proc->attr.implicit_pure = 0;
448 : : }
449 : : }
450 : :
451 : 810045 : if (gfc_elemental (proc))
452 : : {
453 : : /* F08:C1289. */
454 : 300550 : if (sym->attr.codimension
455 : 300549 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456 : 898 : && CLASS_DATA (sym)->attr.codimension))
457 : : {
458 : 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 : : "procedure", sym->name, &sym->declared_at);
460 : 3 : continue;
461 : : }
462 : :
463 : 300547 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464 : 896 : && CLASS_DATA (sym)->as))
465 : : {
466 : 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
467 : : "be scalar", sym->name, &sym->declared_at);
468 : 2 : continue;
469 : : }
470 : :
471 : 300545 : if (sym->attr.allocatable
472 : 300544 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473 : 895 : && CLASS_DATA (sym)->attr.allocatable))
474 : : {
475 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 : : "have the ALLOCATABLE attribute", sym->name,
477 : : &sym->declared_at);
478 : 2 : continue;
479 : : }
480 : :
481 : 300543 : if (sym->attr.pointer
482 : 300542 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483 : 894 : && CLASS_DATA (sym)->attr.class_pointer))
484 : : {
485 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 : : "have the POINTER attribute", sym->name,
487 : : &sym->declared_at);
488 : 2 : continue;
489 : : }
490 : :
491 : 300541 : if (sym->attr.flavor == FL_PROCEDURE)
492 : : {
493 : 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
494 : : "procedure %qs at %L", sym->name, proc->name,
495 : : &sym->declared_at);
496 : 2 : continue;
497 : : }
498 : :
499 : : /* Fortran 2008 Corrigendum 1, C1290a. */
500 : 300539 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501 : : {
502 : 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 : : "have its INTENT specified or have the VALUE "
504 : : "attribute", sym->name, proc->name,
505 : : &sym->declared_at);
506 : 2 : continue;
507 : : }
508 : : }
509 : :
510 : : /* Each dummy shall be specified to be scalar. */
511 : 810032 : if (proc->attr.proc == PROC_ST_FUNCTION)
512 : : {
513 : 305 : if (sym->as != NULL)
514 : : {
515 : : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 : : shall be specified, explicitly or implicitly, to be scalar. */
517 : 1 : gfc_error ("Argument %qs of statement function %qs at %L "
518 : : "must be scalar", sym->name, proc->name,
519 : : &proc->declared_at);
520 : 1 : continue;
521 : : }
522 : :
523 : 304 : if (sym->ts.type == BT_CHARACTER)
524 : : {
525 : 48 : gfc_charlen *cl = sym->ts.u.cl;
526 : 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 : : {
528 : 0 : gfc_error ("Character-valued argument %qs of statement "
529 : : "function at %L must have constant length",
530 : : sym->name, &sym->declared_at);
531 : 0 : continue;
532 : : }
533 : : }
534 : : }
535 : : }
536 : 509263 : if (sym)
537 : 509171 : sym->formal_resolved = 1;
538 : 509263 : gfc_current_ns = orig_current_ns;
539 : 509263 : }
540 : :
541 : :
542 : : /* Work function called when searching for symbols that have argument lists
543 : : associated with them. */
544 : :
545 : : static void
546 : 1780258 : find_arglists (gfc_symbol *sym)
547 : : {
548 : 1780258 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
549 : 322202 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
550 : : return;
551 : :
552 : 320395 : gfc_resolve_formal_arglist (sym);
553 : : }
554 : :
555 : :
556 : : /* Given a namespace, resolve all formal argument lists within the namespace.
557 : : */
558 : :
559 : : static void
560 : 336401 : resolve_formal_arglists (gfc_namespace *ns)
561 : : {
562 : 0 : if (ns == NULL)
563 : : return;
564 : :
565 : 336401 : gfc_traverse_ns (ns, find_arglists);
566 : : }
567 : :
568 : :
569 : : static void
570 : 36230 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
571 : : {
572 : 36230 : bool t;
573 : :
574 : 36230 : if (sym && sym->attr.flavor == FL_PROCEDURE
575 : 36230 : && sym->ns->parent
576 : 1062 : && sym->ns->parent->proc_name
577 : 1062 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
578 : 1 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
579 : 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
580 : : "encompassing procedure", sym->name, &sym->declared_at);
581 : :
582 : : /* If this namespace is not a function or an entry master function,
583 : : ignore it. */
584 : 36230 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
585 : 10657 : || sym->attr.entry_master)
586 : 25761 : return;
587 : :
588 : 10469 : if (!sym->result)
589 : : return;
590 : :
591 : : /* Try to find out of what the return type is. */
592 : 10469 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
593 : : {
594 : 55 : t = gfc_set_default_type (sym->result, 0, ns);
595 : :
596 : 55 : if (!t && !sym->result->attr.untyped)
597 : : {
598 : 19 : if (sym->result == sym)
599 : 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
600 : : sym->name, &sym->declared_at);
601 : 18 : else if (!sym->result->attr.proc_pointer)
602 : 0 : gfc_error ("Result %qs of contained function %qs at %L has "
603 : : "no IMPLICIT type", sym->result->name, sym->name,
604 : : &sym->result->declared_at);
605 : 19 : sym->result->attr.untyped = 1;
606 : : }
607 : : }
608 : :
609 : : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
610 : : type, lists the only ways a character length value of * can be used:
611 : : dummy arguments of procedures, named constants, function results and
612 : : in allocate statements if the allocate_object is an assumed length dummy
613 : : in external functions. Internal function results and results of module
614 : : procedures are not on this list, ergo, not permitted. */
615 : :
616 : 10469 : if (sym->result->ts.type == BT_CHARACTER)
617 : : {
618 : 1176 : gfc_charlen *cl = sym->result->ts.u.cl;
619 : 1176 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
620 : : {
621 : : /* See if this is a module-procedure and adapt error message
622 : : accordingly. */
623 : 4 : bool module_proc;
624 : 4 : gcc_assert (ns->parent && ns->parent->proc_name);
625 : 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
626 : :
627 : 7 : gfc_error (module_proc
628 : : ? G_("Character-valued module procedure %qs at %L"
629 : : " must not be assumed length")
630 : : : G_("Character-valued internal function %qs at %L"
631 : : " must not be assumed length"),
632 : : sym->name, &sym->declared_at);
633 : : }
634 : : }
635 : : }
636 : :
637 : :
638 : : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
639 : : introduce duplicates. */
640 : :
641 : : static void
642 : 1420 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
643 : : {
644 : 1420 : gfc_formal_arglist *f, *new_arglist;
645 : 1420 : gfc_symbol *new_sym;
646 : :
647 : 2561 : for (; new_args != NULL; new_args = new_args->next)
648 : : {
649 : 1141 : new_sym = new_args->sym;
650 : : /* See if this arg is already in the formal argument list. */
651 : 2165 : for (f = proc->formal; f; f = f->next)
652 : : {
653 : 1470 : if (new_sym == f->sym)
654 : : break;
655 : : }
656 : :
657 : 1141 : if (f)
658 : 446 : continue;
659 : :
660 : : /* Add a new argument. Argument order is not important. */
661 : 695 : new_arglist = gfc_get_formal_arglist ();
662 : 695 : new_arglist->sym = new_sym;
663 : 695 : new_arglist->next = proc->formal;
664 : 695 : proc->formal = new_arglist;
665 : : }
666 : 1420 : }
667 : :
668 : :
669 : : /* Flag the arguments that are not present in all entries. */
670 : :
671 : : static void
672 : 1420 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
673 : : {
674 : 1420 : gfc_formal_arglist *f, *head;
675 : 1420 : head = new_args;
676 : :
677 : 2994 : for (f = proc->formal; f; f = f->next)
678 : : {
679 : 1574 : if (f->sym == NULL)
680 : 36 : continue;
681 : :
682 : 2704 : for (new_args = head; new_args; new_args = new_args->next)
683 : : {
684 : 2262 : if (new_args->sym == f->sym)
685 : : break;
686 : : }
687 : :
688 : 1538 : if (new_args)
689 : 1096 : continue;
690 : :
691 : 442 : f->sym->attr.not_always_present = 1;
692 : : }
693 : 1420 : }
694 : :
695 : :
696 : : /* Resolve alternate entry points. If a symbol has multiple entry points we
697 : : create a new master symbol for the main routine, and turn the existing
698 : : symbol into an entry point. */
699 : :
700 : : static void
701 : 372126 : resolve_entries (gfc_namespace *ns)
702 : : {
703 : 372126 : gfc_namespace *old_ns;
704 : 372126 : gfc_code *c;
705 : 372126 : gfc_symbol *proc;
706 : 372126 : gfc_entry_list *el;
707 : : /* Provide sufficient space to hold "master.%d.%s". */
708 : 372126 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
709 : 372126 : static int master_count = 0;
710 : :
711 : 372126 : if (ns->proc_name == NULL)
712 : 371458 : return;
713 : :
714 : : /* No need to do anything if this procedure doesn't have alternate entry
715 : : points. */
716 : 372078 : if (!ns->entries)
717 : : return;
718 : :
719 : : /* We may already have resolved alternate entry points. */
720 : 918 : if (ns->proc_name->attr.entry_master)
721 : : return;
722 : :
723 : : /* If this isn't a procedure something has gone horribly wrong. */
724 : 668 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
725 : :
726 : : /* Remember the current namespace. */
727 : 668 : old_ns = gfc_current_ns;
728 : :
729 : 668 : gfc_current_ns = ns;
730 : :
731 : : /* Add the main entry point to the list of entry points. */
732 : 668 : el = gfc_get_entry_list ();
733 : 668 : el->sym = ns->proc_name;
734 : 668 : el->id = 0;
735 : 668 : el->next = ns->entries;
736 : 668 : ns->entries = el;
737 : 668 : ns->proc_name->attr.entry = 1;
738 : :
739 : : /* If it is a module function, it needs to be in the right namespace
740 : : so that gfc_get_fake_result_decl can gather up the results. The
741 : : need for this arose in get_proc_name, where these beasts were
742 : : left in their own namespace, to keep prior references linked to
743 : : the entry declaration.*/
744 : 668 : if (ns->proc_name->attr.function
745 : 564 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
746 : 188 : el->sym->ns = ns;
747 : :
748 : : /* Do the same for entries where the master is not a module
749 : : procedure. These are retained in the module namespace because
750 : : of the module procedure declaration. */
751 : 1420 : for (el = el->next; el; el = el->next)
752 : 752 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
753 : 0 : && el->sym->attr.mod_proc)
754 : 0 : el->sym->ns = ns;
755 : 668 : el = ns->entries;
756 : :
757 : : /* Add an entry statement for it. */
758 : 668 : c = gfc_get_code (EXEC_ENTRY);
759 : 668 : c->ext.entry = el;
760 : 668 : c->next = ns->code;
761 : 668 : ns->code = c;
762 : :
763 : : /* Create a new symbol for the master function. */
764 : : /* Give the internal function a unique name (within this file).
765 : : Also include the function name so the user has some hope of figuring
766 : : out what is going on. */
767 : 668 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
768 : 668 : master_count++, ns->proc_name->name);
769 : 668 : gfc_get_ha_symbol (name, &proc);
770 : 668 : gcc_assert (proc != NULL);
771 : :
772 : 668 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
773 : 668 : if (ns->proc_name->attr.subroutine)
774 : 104 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
775 : : else
776 : : {
777 : 564 : gfc_symbol *sym;
778 : 564 : gfc_typespec *ts, *fts;
779 : 564 : gfc_array_spec *as, *fas;
780 : 564 : gfc_add_function (&proc->attr, proc->name, NULL);
781 : 564 : proc->result = proc;
782 : 564 : fas = ns->entries->sym->as;
783 : 564 : fas = fas ? fas : ns->entries->sym->result->as;
784 : 564 : fts = &ns->entries->sym->result->ts;
785 : 564 : if (fts->type == BT_UNKNOWN)
786 : 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
787 : 1058 : for (el = ns->entries->next; el; el = el->next)
788 : : {
789 : 603 : ts = &el->sym->result->ts;
790 : 603 : as = el->sym->as;
791 : 603 : as = as ? as : el->sym->result->as;
792 : 603 : if (ts->type == BT_UNKNOWN)
793 : 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
794 : :
795 : 603 : if (! gfc_compare_types (ts, fts)
796 : 497 : || (el->sym->result->attr.dimension
797 : 497 : != ns->entries->sym->result->attr.dimension)
798 : 603 : || (el->sym->result->attr.pointer
799 : 497 : != ns->entries->sym->result->attr.pointer))
800 : : break;
801 : 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
802 : 559 : && gfc_compare_array_spec (as, fas) == 0)
803 : 5 : gfc_error ("Function %s at %L has entries with mismatched "
804 : : "array specifications", ns->entries->sym->name,
805 : 5 : &ns->entries->sym->declared_at);
806 : : /* The characteristics need to match and thus both need to have
807 : : the same string length, i.e. both len=*, or both len=4.
808 : : Having both len=<variable> is also possible, but difficult to
809 : : check at compile time. */
810 : 492 : else if (ts->type == BT_CHARACTER
811 : 89 : && (el->sym->result->attr.allocatable
812 : 89 : != ns->entries->sym->result->attr.allocatable))
813 : : {
814 : 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
815 : : "characteristics", ns->entries->sym->name,
816 : : &ns->entries->sym->declared_at, el->sym->name);
817 : 3 : goto cleanup;
818 : : }
819 : 489 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
820 : 86 : && (((ts->u.cl->length && !fts->u.cl->length)
821 : 85 : ||(!ts->u.cl->length && fts->u.cl->length))
822 : 66 : || (ts->u.cl->length
823 : 29 : && ts->u.cl->length->expr_type
824 : 29 : != fts->u.cl->length->expr_type)
825 : 66 : || (ts->u.cl->length
826 : 29 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
827 : 28 : && mpz_cmp (ts->u.cl->length->value.integer,
828 : 28 : fts->u.cl->length->value.integer) != 0)))
829 : 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
830 : : "entries returning variables of different "
831 : : "string lengths", ns->entries->sym->name,
832 : 21 : &ns->entries->sym->declared_at);
833 : 468 : else if (el->sym->result->attr.allocatable
834 : 468 : != ns->entries->sym->result->attr.allocatable)
835 : : break;
836 : : }
837 : :
838 : 561 : if (el == NULL)
839 : : {
840 : 455 : sym = ns->entries->sym->result;
841 : : /* All result types the same. */
842 : 455 : proc->ts = *fts;
843 : 455 : if (sym->attr.dimension)
844 : 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
845 : 455 : if (sym->attr.pointer)
846 : 78 : gfc_add_pointer (&proc->attr, NULL);
847 : 455 : if (sym->attr.allocatable)
848 : 24 : gfc_add_allocatable (&proc->attr, NULL);
849 : : }
850 : : else
851 : : {
852 : : /* Otherwise the result will be passed through a union by
853 : : reference. */
854 : 106 : proc->attr.mixed_entry_master = 1;
855 : 340 : for (el = ns->entries; el; el = el->next)
856 : : {
857 : 234 : sym = el->sym->result;
858 : 234 : if (sym->attr.dimension)
859 : : {
860 : 1 : if (el == ns->entries)
861 : 0 : gfc_error ("FUNCTION result %s cannot be an array in "
862 : : "FUNCTION %s at %L", sym->name,
863 : 0 : ns->entries->sym->name, &sym->declared_at);
864 : : else
865 : 1 : gfc_error ("ENTRY result %s cannot be an array in "
866 : : "FUNCTION %s at %L", sym->name,
867 : 1 : ns->entries->sym->name, &sym->declared_at);
868 : : }
869 : 233 : else if (sym->attr.pointer)
870 : : {
871 : 1 : if (el == ns->entries)
872 : 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
873 : : "FUNCTION %s at %L", sym->name,
874 : 1 : ns->entries->sym->name, &sym->declared_at);
875 : : else
876 : 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
877 : : "FUNCTION %s at %L", sym->name,
878 : 0 : ns->entries->sym->name, &sym->declared_at);
879 : : }
880 : 232 : else if (sym->attr.allocatable)
881 : : {
882 : 0 : if (el == ns->entries)
883 : 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
884 : : "FUNCTION %s at %L", sym->name,
885 : 0 : ns->entries->sym->name, &sym->declared_at);
886 : : else
887 : 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
888 : : "FUNCTION %s at %L", sym->name,
889 : 0 : ns->entries->sym->name, &sym->declared_at);
890 : : }
891 : : else
892 : : {
893 : 232 : ts = &sym->ts;
894 : 232 : if (ts->type == BT_UNKNOWN)
895 : 9 : ts = gfc_get_default_type (sym->name, NULL);
896 : 232 : switch (ts->type)
897 : : {
898 : 84 : case BT_INTEGER:
899 : 84 : if (ts->kind == gfc_default_integer_kind)
900 : : sym = NULL;
901 : : break;
902 : 99 : case BT_REAL:
903 : 99 : if (ts->kind == gfc_default_real_kind
904 : 18 : || ts->kind == gfc_default_double_kind)
905 : : sym = NULL;
906 : : break;
907 : 19 : case BT_COMPLEX:
908 : 19 : if (ts->kind == gfc_default_complex_kind)
909 : : sym = NULL;
910 : : break;
911 : 27 : case BT_LOGICAL:
912 : 27 : if (ts->kind == gfc_default_logical_kind)
913 : : sym = NULL;
914 : : break;
915 : : case BT_UNKNOWN:
916 : : /* We will issue error elsewhere. */
917 : : sym = NULL;
918 : : break;
919 : : default:
920 : : break;
921 : : }
922 : 3 : if (sym)
923 : : {
924 : 3 : if (el == ns->entries)
925 : 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
926 : : "in FUNCTION %s at %L", sym->name,
927 : 1 : gfc_typename (ts), ns->entries->sym->name,
928 : : &sym->declared_at);
929 : : else
930 : 2 : gfc_error ("ENTRY result %s cannot be of type %s "
931 : : "in FUNCTION %s at %L", sym->name,
932 : 2 : gfc_typename (ts), ns->entries->sym->name,
933 : : &sym->declared_at);
934 : : }
935 : : }
936 : : }
937 : : }
938 : : }
939 : :
940 : 106 : cleanup:
941 : 668 : proc->attr.access = ACCESS_PRIVATE;
942 : 668 : proc->attr.entry_master = 1;
943 : :
944 : : /* Merge all the entry point arguments. */
945 : 2088 : for (el = ns->entries; el; el = el->next)
946 : 1420 : merge_argument_lists (proc, el->sym->formal);
947 : :
948 : : /* Check the master formal arguments for any that are not
949 : : present in all entry points. */
950 : 2088 : for (el = ns->entries; el; el = el->next)
951 : 1420 : check_argument_lists (proc, el->sym->formal);
952 : :
953 : : /* Use the master function for the function body. */
954 : 668 : ns->proc_name = proc;
955 : :
956 : : /* Finalize the new symbols. */
957 : 668 : gfc_commit_symbols ();
958 : :
959 : : /* Restore the original namespace. */
960 : 668 : gfc_current_ns = old_ns;
961 : : }
962 : :
963 : :
964 : : /* Forward declaration. */
965 : : static bool is_non_constant_shape_array (gfc_symbol *sym);
966 : :
967 : :
968 : : /* Resolve common variables. */
969 : : static void
970 : 338298 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
971 : : {
972 : 338298 : gfc_symbol *csym = common_block->head;
973 : 338298 : gfc_gsymbol *gsym;
974 : :
975 : 344269 : for (; csym; csym = csym->common_next)
976 : : {
977 : 5971 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
978 : 5971 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
979 : : {
980 : 3 : if (csym->common_block)
981 : 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
982 : : "COMMON block at %L", gsym->name,
983 : : &gsym->where, &csym->common_block->where);
984 : : else
985 : 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
986 : : "COMMON block", gsym->name, &gsym->where);
987 : : }
988 : :
989 : : /* gfc_add_in_common may have been called before, but the reported errors
990 : : have been ignored to continue parsing.
991 : : We do the checks again here, unless the symbol is USE associated. */
992 : 5971 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
993 : : {
994 : 5698 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
995 : 5698 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
996 : : &common_block->where);
997 : : }
998 : :
999 : 5971 : if (csym->value || csym->attr.data)
1000 : : {
1001 : 132 : if (!csym->ns->is_block_data)
1002 : 32 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1003 : : "but only in BLOCK DATA initialization is "
1004 : : "allowed", csym->name, &csym->declared_at);
1005 : 100 : else if (!named_common)
1006 : 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1007 : : "in a blank COMMON but initialization is only "
1008 : : "allowed in named common blocks", csym->name,
1009 : : &csym->declared_at);
1010 : : }
1011 : :
1012 : 5971 : if (UNLIMITED_POLY (csym))
1013 : 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1014 : : "[F2008:C5100]", csym->name, &csym->declared_at);
1015 : :
1016 : 5971 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1017 : : {
1018 : 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1019 : : "COMMON at %L", csym->name, &csym->declared_at,
1020 : : &common_block->where);
1021 : : /* Avoid confusing follow-on error. */
1022 : 1 : csym->error = 1;
1023 : : }
1024 : :
1025 : 5971 : if (csym->ts.type != BT_DERIVED)
1026 : 5924 : continue;
1027 : :
1028 : 47 : if (!(csym->ts.u.derived->attr.sequence
1029 : 3 : || csym->ts.u.derived->attr.is_bind_c))
1030 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1031 : : "has neither the SEQUENCE nor the BIND(C) "
1032 : : "attribute", csym->name, &csym->declared_at);
1033 : 47 : if (csym->ts.u.derived->attr.alloc_comp)
1034 : 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1035 : : "has an ultimate component that is "
1036 : : "allocatable", csym->name, &csym->declared_at);
1037 : 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1038 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1039 : : "may not have default initializer", csym->name,
1040 : : &csym->declared_at);
1041 : :
1042 : 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1043 : 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1044 : : }
1045 : 338298 : }
1046 : :
1047 : : /* Resolve common blocks. */
1048 : : static void
1049 : 336866 : resolve_common_blocks (gfc_symtree *common_root)
1050 : : {
1051 : 336866 : gfc_symbol *sym = NULL;
1052 : 336866 : gfc_gsymbol * gsym;
1053 : :
1054 : 336866 : if (common_root == NULL)
1055 : 336744 : return;
1056 : :
1057 : 1897 : if (common_root->left)
1058 : 212 : resolve_common_blocks (common_root->left);
1059 : 1897 : if (common_root->right)
1060 : 253 : resolve_common_blocks (common_root->right);
1061 : :
1062 : 1897 : resolve_common_vars (common_root->n.common, true);
1063 : :
1064 : : /* The common name is a global name - in Fortran 2003 also if it has a
1065 : : C binding name, since Fortran 2008 only the C binding name is a global
1066 : : identifier. */
1067 : 1897 : if (!common_root->n.common->binding_label
1068 : 1897 : || gfc_notification_std (GFC_STD_F2008))
1069 : : {
1070 : 3650 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1071 : 1825 : common_root->n.common->name);
1072 : :
1073 : 820 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1074 : 14 : && gsym->type == GSYM_COMMON
1075 : 1838 : && ((common_root->n.common->binding_label
1076 : 6 : && (!gsym->binding_label
1077 : 0 : || strcmp (common_root->n.common->binding_label,
1078 : : gsym->binding_label) != 0))
1079 : 7 : || (!common_root->n.common->binding_label
1080 : 7 : && gsym->binding_label)))
1081 : : {
1082 : 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1083 : : "identifier and must thus have the same binding name "
1084 : : "as the same-named COMMON block at %L: %s vs %s",
1085 : 6 : common_root->n.common->name, &common_root->n.common->where,
1086 : : &gsym->where,
1087 : : common_root->n.common->binding_label
1088 : : ? common_root->n.common->binding_label : "(blank)",
1089 : 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1090 : 6 : return;
1091 : : }
1092 : :
1093 : 1819 : if (gsym && gsym->type != GSYM_COMMON
1094 : 1 : && !common_root->n.common->binding_label)
1095 : : {
1096 : 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1097 : : "as entity at %L",
1098 : 0 : common_root->n.common->name, &common_root->n.common->where,
1099 : : &gsym->where);
1100 : 0 : return;
1101 : : }
1102 : 814 : if (gsym && gsym->type != GSYM_COMMON)
1103 : : {
1104 : 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1105 : : "%L sharing the identifier with global non-COMMON-block "
1106 : 1 : "entity at %L", common_root->n.common->name,
1107 : 1 : &common_root->n.common->where, &gsym->where);
1108 : 1 : return;
1109 : : }
1110 : 1005 : if (!gsym)
1111 : : {
1112 : 1005 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1113 : 1005 : gsym->type = GSYM_COMMON;
1114 : 1005 : gsym->where = common_root->n.common->where;
1115 : 1005 : gsym->defined = 1;
1116 : : }
1117 : 1818 : gsym->used = 1;
1118 : : }
1119 : :
1120 : 1890 : if (common_root->n.common->binding_label)
1121 : : {
1122 : 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1123 : : common_root->n.common->binding_label);
1124 : 76 : if (gsym && gsym->type != GSYM_COMMON)
1125 : : {
1126 : 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1127 : : "global identifier as entity at %L",
1128 : : &common_root->n.common->where,
1129 : 1 : common_root->n.common->binding_label, &gsym->where);
1130 : 1 : return;
1131 : : }
1132 : 57 : if (!gsym)
1133 : : {
1134 : 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1135 : 57 : gsym->type = GSYM_COMMON;
1136 : 57 : gsym->where = common_root->n.common->where;
1137 : 57 : gsym->defined = 1;
1138 : : }
1139 : 75 : gsym->used = 1;
1140 : : }
1141 : :
1142 : 1889 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1143 : 1889 : if (sym == NULL)
1144 : : return;
1145 : :
1146 : 122 : if (sym->attr.flavor == FL_PARAMETER)
1147 : 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1148 : 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1149 : :
1150 : 122 : if (sym->attr.external)
1151 : 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1152 : 1 : sym->name, &common_root->n.common->where);
1153 : :
1154 : 122 : if (sym->attr.intrinsic)
1155 : 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1156 : 2 : sym->name, &common_root->n.common->where);
1157 : 120 : else if (sym->attr.result
1158 : 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1159 : 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1160 : : "that is also a function result", sym->name,
1161 : 1 : &common_root->n.common->where);
1162 : 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1163 : 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1164 : 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1165 : : "that is also a global procedure", sym->name,
1166 : 3 : &common_root->n.common->where);
1167 : : }
1168 : :
1169 : :
1170 : : /* Resolve contained function types. Because contained functions can call one
1171 : : another, they have to be worked out before any of the contained procedures
1172 : : can be resolved.
1173 : :
1174 : : The good news is that if a function doesn't already have a type, the only
1175 : : way it can get one is through an IMPLICIT type or a RESULT variable, because
1176 : : by definition contained functions are contained namespace they're contained
1177 : : in, not in a sibling or parent namespace. */
1178 : :
1179 : : static void
1180 : 336401 : resolve_contained_functions (gfc_namespace *ns)
1181 : : {
1182 : 336401 : gfc_namespace *child;
1183 : 336401 : gfc_entry_list *el;
1184 : :
1185 : 336401 : resolve_formal_arglists (ns);
1186 : :
1187 : 372126 : for (child = ns->contained; child; child = child->sibling)
1188 : : {
1189 : : /* Resolve alternate entry points first. */
1190 : 35725 : resolve_entries (child);
1191 : :
1192 : : /* Then check function return types. */
1193 : 35725 : resolve_contained_fntype (child->proc_name, child);
1194 : 36230 : for (el = child->entries; el; el = el->next)
1195 : 505 : resolve_contained_fntype (el->sym, child);
1196 : : }
1197 : 336401 : }
1198 : :
1199 : :
1200 : :
1201 : : /* A Parameterized Derived Type constructor must contain values for
1202 : : the PDT KIND parameters or they must have a default initializer.
1203 : : Go through the constructor picking out the KIND expressions,
1204 : : storing them in 'param_list' and then call gfc_get_pdt_instance
1205 : : to obtain the PDT instance. */
1206 : :
1207 : : static gfc_actual_arglist *param_list, *param_tail, *param;
1208 : :
1209 : : static bool
1210 : 76 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1211 : : {
1212 : 76 : param = gfc_get_actual_arglist ();
1213 : 76 : if (!param_list)
1214 : 70 : param_list = param_tail = param;
1215 : : else
1216 : : {
1217 : 6 : param_tail->next = param;
1218 : 6 : param_tail = param_tail->next;
1219 : : }
1220 : :
1221 : 76 : param_tail->name = c->name;
1222 : 76 : if (expr)
1223 : 76 : param_tail->expr = gfc_copy_expr (expr);
1224 : 0 : else if (c->initializer)
1225 : 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1226 : : else
1227 : : {
1228 : 0 : param_tail->spec_type = SPEC_ASSUMED;
1229 : 0 : if (c->attr.pdt_kind)
1230 : : {
1231 : 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1232 : : "at %C has no value", param->name);
1233 : 0 : return false;
1234 : : }
1235 : : }
1236 : :
1237 : : return true;
1238 : : }
1239 : :
1240 : : static bool
1241 : 70 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1242 : : gfc_symbol *derived)
1243 : : {
1244 : 70 : gfc_constructor *cons = NULL;
1245 : 70 : gfc_component *comp;
1246 : 70 : bool t = true;
1247 : :
1248 : 70 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1249 : 70 : cons = gfc_constructor_first (expr->value.constructor);
1250 : 0 : else if (constr)
1251 : 0 : cons = *constr;
1252 : 70 : gcc_assert (cons);
1253 : :
1254 : 70 : comp = derived->components;
1255 : :
1256 : 234 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1257 : : {
1258 : 164 : if (cons->expr
1259 : 164 : && cons->expr->expr_type == EXPR_STRUCTURE
1260 : 0 : && comp->ts.type == BT_DERIVED)
1261 : : {
1262 : 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1263 : 0 : if (!t)
1264 : : return t;
1265 : : }
1266 : 164 : else if (comp->ts.type == BT_DERIVED)
1267 : : {
1268 : 0 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1269 : 0 : if (!t)
1270 : : return t;
1271 : : }
1272 : 164 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1273 : 76 : && derived->attr.pdt_template)
1274 : : {
1275 : 76 : t = get_pdt_spec_expr (comp, cons->expr);
1276 : 76 : if (!t)
1277 : : return t;
1278 : : }
1279 : : }
1280 : : return t;
1281 : : }
1282 : :
1283 : :
1284 : : static bool resolve_fl_derived0 (gfc_symbol *sym);
1285 : : static bool resolve_fl_struct (gfc_symbol *sym);
1286 : :
1287 : :
1288 : : /* Resolve all of the elements of a structure constructor and make sure that
1289 : : the types are correct. The 'init' flag indicates that the given
1290 : : constructor is an initializer. */
1291 : :
1292 : : static bool
1293 : 60833 : resolve_structure_cons (gfc_expr *expr, int init)
1294 : : {
1295 : 60833 : gfc_constructor *cons;
1296 : 60833 : gfc_component *comp;
1297 : 60833 : bool t;
1298 : 60833 : symbol_attribute a;
1299 : :
1300 : 60833 : t = true;
1301 : :
1302 : 60833 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1303 : : {
1304 : 58040 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1305 : 57890 : resolve_fl_derived0 (expr->ts.u.derived);
1306 : : else
1307 : 150 : resolve_fl_struct (expr->ts.u.derived);
1308 : :
1309 : : /* If this is a Parameterized Derived Type template, find the
1310 : : instance corresponding to the PDT kind parameters. */
1311 : 58040 : if (expr->ts.u.derived->attr.pdt_template)
1312 : : {
1313 : 70 : param_list = NULL;
1314 : 70 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1315 : 70 : if (!t)
1316 : : return t;
1317 : 70 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1318 : :
1319 : 70 : expr->param_list = gfc_copy_actual_arglist (param_list);
1320 : :
1321 : 70 : if (param_list)
1322 : 70 : gfc_free_actual_arglist (param_list);
1323 : :
1324 : 70 : if (!expr->ts.u.derived->attr.pdt_type)
1325 : : return false;
1326 : : }
1327 : : }
1328 : :
1329 : : /* A constructor may have references if it is the result of substituting a
1330 : : parameter variable. In this case we just pull out the component we
1331 : : want. */
1332 : 60833 : if (expr->ref)
1333 : 160 : comp = expr->ref->u.c.sym->components;
1334 : 60673 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1335 : : || expr->ts.type == BT_UNION)
1336 : 60671 : && expr->ts.u.derived)
1337 : 60671 : comp = expr->ts.u.derived->components;
1338 : : else
1339 : : return false;
1340 : :
1341 : 60831 : cons = gfc_constructor_first (expr->value.constructor);
1342 : :
1343 : 200940 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1344 : : {
1345 : 140111 : int rank;
1346 : :
1347 : 140111 : if (!cons->expr)
1348 : 9455 : continue;
1349 : :
1350 : : /* Unions use an EXPR_NULL contrived expression to tell the translation
1351 : : phase to generate an initializer of the appropriate length.
1352 : : Ignore it here. */
1353 : 130656 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1354 : 15 : continue;
1355 : :
1356 : 130641 : if (!gfc_resolve_expr (cons->expr))
1357 : : {
1358 : 0 : t = false;
1359 : 0 : continue;
1360 : : }
1361 : :
1362 : 130641 : rank = comp->as ? comp->as->rank : 0;
1363 : 130641 : if (comp->ts.type == BT_CLASS
1364 : 1731 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1365 : 1730 : && CLASS_DATA (comp)->as)
1366 : 513 : rank = CLASS_DATA (comp)->as->rank;
1367 : :
1368 : 130641 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1369 : 215 : gfc_find_vtab (&cons->expr->ts);
1370 : :
1371 : 130641 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1372 : 453 : && (comp->attr.allocatable || comp->attr.pointer || cons->expr->rank))
1373 : : {
1374 : 4 : gfc_error ("The rank of the element in the structure "
1375 : : "constructor at %L does not match that of the "
1376 : : "component (%d/%d)", &cons->expr->where,
1377 : : cons->expr->rank, rank);
1378 : 4 : t = false;
1379 : : }
1380 : :
1381 : : /* If we don't have the right type, try to convert it. */
1382 : :
1383 : 228524 : if (!comp->attr.proc_pointer &&
1384 : 97883 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1385 : : {
1386 : 11920 : if (strcmp (comp->name, "_extends") == 0)
1387 : : {
1388 : : /* Can afford to be brutal with the _extends initializer.
1389 : : The derived type can get lost because it is PRIVATE
1390 : : but it is not usage constrained by the standard. */
1391 : 8647 : cons->expr->ts = comp->ts;
1392 : : }
1393 : 3273 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1394 : : {
1395 : 2 : gfc_error ("The element in the structure constructor at %L, "
1396 : : "for pointer component %qs, is %s but should be %s",
1397 : 2 : &cons->expr->where, comp->name,
1398 : 2 : gfc_basic_typename (cons->expr->ts.type),
1399 : : gfc_basic_typename (comp->ts.type));
1400 : 2 : t = false;
1401 : : }
1402 : 3271 : else if (!UNLIMITED_POLY (comp))
1403 : : {
1404 : 3209 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1405 : 3209 : if (t)
1406 : 130641 : t = t2;
1407 : : }
1408 : : }
1409 : :
1410 : : /* For strings, the length of the constructor should be the same as
1411 : : the one of the structure, ensure this if the lengths are known at
1412 : : compile time and when we are dealing with PARAMETER or structure
1413 : : constructors. */
1414 : 130641 : if (cons->expr->ts.type == BT_CHARACTER
1415 : 3842 : && comp->ts.type == BT_CHARACTER
1416 : 3817 : && comp->ts.u.cl && comp->ts.u.cl->length
1417 : 2471 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1418 : 2436 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1419 : 920 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1420 : 920 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1421 : 920 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1422 : 920 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1423 : 920 : comp->ts.u.cl->length->value.integer) != 0)
1424 : : {
1425 : 11 : if (comp->attr.pointer)
1426 : : {
1427 : 3 : HOST_WIDE_INT la, lb;
1428 : 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1429 : 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1430 : 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1431 : : "component %qs in constructor at %L",
1432 : 3 : la, lb, comp->name, &cons->expr->where);
1433 : 3 : t = false;
1434 : : }
1435 : :
1436 : 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1437 : 4 : && cons->expr->rank != 0
1438 : 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1439 : : {
1440 : : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1441 : : to make use of the gfc_resolve_character_array_constructor
1442 : : machinery. The expression is later simplified away to
1443 : : an array of string literals. */
1444 : 1 : gfc_expr *para = cons->expr;
1445 : 1 : cons->expr = gfc_get_expr ();
1446 : 1 : cons->expr->ts = para->ts;
1447 : 1 : cons->expr->where = para->where;
1448 : 1 : cons->expr->expr_type = EXPR_ARRAY;
1449 : 1 : cons->expr->rank = para->rank;
1450 : 1 : cons->expr->corank = para->corank;
1451 : 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1452 : 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1453 : 1 : para, &cons->expr->where);
1454 : : }
1455 : :
1456 : 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1457 : : {
1458 : : /* Rely on the cleanup of the namespace to deal correctly with
1459 : : the old charlen. (There was a block here that attempted to
1460 : : remove the charlen but broke the chain in so doing.) */
1461 : 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1462 : 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1463 : 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1464 : 5 : gfc_resolve_character_array_constructor (cons->expr);
1465 : : }
1466 : : }
1467 : :
1468 : 130641 : if (cons->expr->expr_type == EXPR_NULL
1469 : 38882 : && !(comp->attr.pointer || comp->attr.allocatable
1470 : 19667 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1471 : 1093 : || (comp->ts.type == BT_CLASS
1472 : 1091 : && (CLASS_DATA (comp)->attr.class_pointer
1473 : 878 : || CLASS_DATA (comp)->attr.allocatable))))
1474 : : {
1475 : 2 : t = false;
1476 : 2 : gfc_error ("The NULL in the structure constructor at %L is "
1477 : : "being applied to component %qs, which is neither "
1478 : : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1479 : : comp->name);
1480 : : }
1481 : :
1482 : 130641 : if (comp->attr.proc_pointer && comp->ts.interface)
1483 : : {
1484 : : /* Check procedure pointer interface. */
1485 : 14497 : gfc_symbol *s2 = NULL;
1486 : 14497 : gfc_component *c2;
1487 : 14497 : const char *name;
1488 : 14497 : char err[200];
1489 : :
1490 : 14497 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1491 : 14497 : if (c2)
1492 : : {
1493 : 12 : s2 = c2->ts.interface;
1494 : 12 : name = c2->name;
1495 : : }
1496 : 14485 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1497 : : {
1498 : 0 : s2 = cons->expr->symtree->n.sym->result;
1499 : 0 : name = cons->expr->symtree->n.sym->result->name;
1500 : : }
1501 : 14485 : else if (cons->expr->expr_type != EXPR_NULL)
1502 : : {
1503 : 14079 : s2 = cons->expr->symtree->n.sym;
1504 : 14079 : name = cons->expr->symtree->n.sym->name;
1505 : : }
1506 : :
1507 : 14091 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1508 : : err, sizeof (err), NULL, NULL))
1509 : : {
1510 : 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1511 : : "component %qs in structure constructor at %L:"
1512 : 2 : " %s", comp->name, &cons->expr->where, err);
1513 : 2 : return false;
1514 : : }
1515 : : }
1516 : :
1517 : : /* Validate shape, except for dynamic or PDT arrays. */
1518 : 130639 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1519 : 1914 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1520 : 1225 : && !comp->attr.pdt_array)
1521 : : {
1522 : 1223 : mpz_t len;
1523 : 1223 : mpz_init (len);
1524 : 2543 : for (int n = 0; n < rank; n++)
1525 : : {
1526 : 1321 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1527 : 1320 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1528 : : {
1529 : 1 : gfc_error ("Bad array spec of component %qs referenced in "
1530 : : "structure constructor at %L",
1531 : 1 : comp->name, &cons->expr->where);
1532 : 1 : t = false;
1533 : 1 : break;
1534 : 1320 : };
1535 : 1320 : if (cons->expr->shape == NULL)
1536 : 12 : continue;
1537 : 1308 : mpz_set_ui (len, 1);
1538 : 1308 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1539 : 1308 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1540 : 1308 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1541 : : {
1542 : 9 : gfc_error ("The shape of component %qs in the structure "
1543 : : "constructor at %L differs from the shape of the "
1544 : : "declared component for dimension %d (%ld/%ld)",
1545 : : comp->name, &cons->expr->where, n+1,
1546 : : mpz_get_si (cons->expr->shape[n]),
1547 : : mpz_get_si (len));
1548 : 9 : t = false;
1549 : : }
1550 : : }
1551 : 1223 : mpz_clear (len);
1552 : : }
1553 : :
1554 : 130639 : if (!comp->attr.pointer || comp->attr.proc_pointer
1555 : 20881 : || cons->expr->expr_type == EXPR_NULL)
1556 : 121068 : continue;
1557 : :
1558 : 9571 : a = gfc_expr_attr (cons->expr);
1559 : :
1560 : 9571 : if (!a.pointer && !a.target)
1561 : : {
1562 : 1 : t = false;
1563 : 1 : gfc_error ("The element in the structure constructor at %L, "
1564 : : "for pointer component %qs should be a POINTER or "
1565 : 1 : "a TARGET", &cons->expr->where, comp->name);
1566 : : }
1567 : :
1568 : 9571 : if (init)
1569 : : {
1570 : : /* F08:C461. Additional checks for pointer initialization. */
1571 : 9503 : if (a.allocatable)
1572 : : {
1573 : 0 : t = false;
1574 : 0 : gfc_error ("Pointer initialization target at %L "
1575 : 0 : "must not be ALLOCATABLE", &cons->expr->where);
1576 : : }
1577 : 9503 : if (!a.save)
1578 : : {
1579 : 0 : t = false;
1580 : 0 : gfc_error ("Pointer initialization target at %L "
1581 : 0 : "must have the SAVE attribute", &cons->expr->where);
1582 : : }
1583 : : }
1584 : :
1585 : : /* F2023:C770: A designator that is an initial-data-target shall ...
1586 : : not have a vector subscript. */
1587 : 9571 : if (comp->attr.pointer && (a.pointer || a.target)
1588 : 19141 : && gfc_has_vector_index (cons->expr))
1589 : : {
1590 : 1 : gfc_error ("Pointer assignment target at %L has a vector subscript",
1591 : 1 : &cons->expr->where);
1592 : 1 : t = false;
1593 : : }
1594 : :
1595 : : /* F2003, C1272 (3). */
1596 : 9571 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1597 : 9571 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1598 : 9535 : || gfc_is_coindexed (cons->expr));
1599 : 33 : if (impure && gfc_pure (NULL))
1600 : : {
1601 : 1 : t = false;
1602 : 1 : gfc_error ("Invalid expression in the structure constructor for "
1603 : : "pointer component %qs at %L in PURE procedure",
1604 : 1 : comp->name, &cons->expr->where);
1605 : : }
1606 : :
1607 : 9571 : if (impure)
1608 : 33 : gfc_unset_implicit_pure (NULL);
1609 : : }
1610 : :
1611 : : return t;
1612 : : }
1613 : :
1614 : :
1615 : : /****************** Expression name resolution ******************/
1616 : :
1617 : : /* Returns 0 if a symbol was not declared with a type or
1618 : : attribute declaration statement, nonzero otherwise. */
1619 : :
1620 : : static bool
1621 : 729549 : was_declared (gfc_symbol *sym)
1622 : : {
1623 : 729549 : symbol_attribute a;
1624 : :
1625 : 729549 : a = sym->attr;
1626 : :
1627 : 729549 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1628 : : return 1;
1629 : :
1630 : 617939 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1631 : 609640 : || a.optional || a.pointer || a.save || a.target || a.volatile_
1632 : 609638 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1633 : 609584 : || a.asynchronous || a.codimension || a.subroutine)
1634 : 93312 : return 1;
1635 : :
1636 : : return 0;
1637 : : }
1638 : :
1639 : :
1640 : : /* Determine if a symbol is generic or not. */
1641 : :
1642 : : static int
1643 : 404738 : generic_sym (gfc_symbol *sym)
1644 : : {
1645 : 404738 : gfc_symbol *s;
1646 : :
1647 : 404738 : if (sym->attr.generic ||
1648 : 376447 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1649 : 29354 : return 1;
1650 : :
1651 : 375384 : if (was_declared (sym) || sym->ns->parent == NULL)
1652 : : return 0;
1653 : :
1654 : 75787 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1655 : :
1656 : 75787 : if (s != NULL)
1657 : : {
1658 : 133 : if (s == sym)
1659 : : return 0;
1660 : : else
1661 : 132 : return generic_sym (s);
1662 : : }
1663 : :
1664 : : return 0;
1665 : : }
1666 : :
1667 : :
1668 : : /* Determine if a symbol is specific or not. */
1669 : :
1670 : : static int
1671 : 375296 : specific_sym (gfc_symbol *sym)
1672 : : {
1673 : 375296 : gfc_symbol *s;
1674 : :
1675 : 375296 : if (sym->attr.if_source == IFSRC_IFBODY
1676 : 364251 : || sym->attr.proc == PROC_MODULE
1677 : : || sym->attr.proc == PROC_INTERNAL
1678 : : || sym->attr.proc == PROC_ST_FUNCTION
1679 : 289092 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1680 : 663657 : || sym->attr.external)
1681 : 89318 : return 1;
1682 : :
1683 : 285978 : if (was_declared (sym) || sym->ns->parent == NULL)
1684 : : return 0;
1685 : :
1686 : 75685 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1687 : :
1688 : 75685 : return (s == NULL) ? 0 : specific_sym (s);
1689 : : }
1690 : :
1691 : :
1692 : : /* Figure out if the procedure is specific, generic or unknown. */
1693 : :
1694 : : enum proc_type
1695 : : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1696 : :
1697 : : static proc_type
1698 : 404460 : procedure_kind (gfc_symbol *sym)
1699 : : {
1700 : 404460 : if (generic_sym (sym))
1701 : : return PTYPE_GENERIC;
1702 : :
1703 : 375249 : if (specific_sym (sym))
1704 : 89318 : return PTYPE_SPECIFIC;
1705 : :
1706 : : return PTYPE_UNKNOWN;
1707 : : }
1708 : :
1709 : : /* Check references to assumed size arrays. The flag need_full_assumed_size
1710 : : is nonzero when matching actual arguments. */
1711 : :
1712 : : static int need_full_assumed_size = 0;
1713 : :
1714 : : static bool
1715 : 1396483 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1716 : : {
1717 : 1396483 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1718 : : return false;
1719 : :
1720 : : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1721 : : What should it be? */
1722 : 3788 : if (e->ref
1723 : 3786 : && e->ref->u.ar.as
1724 : 3785 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1725 : 3290 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1726 : 3290 : && (e->ref->u.ar.type == AR_FULL))
1727 : : {
1728 : 25 : gfc_error ("The upper bound in the last dimension must "
1729 : : "appear in the reference to the assumed size "
1730 : : "array %qs at %L", sym->name, &e->where);
1731 : 25 : return true;
1732 : : }
1733 : : return false;
1734 : : }
1735 : :
1736 : :
1737 : : /* Look for bad assumed size array references in argument expressions
1738 : : of elemental and array valued intrinsic procedures. Since this is
1739 : : called from procedure resolution functions, it only recurses at
1740 : : operators. */
1741 : :
1742 : : static bool
1743 : 225473 : resolve_assumed_size_actual (gfc_expr *e)
1744 : : {
1745 : 225473 : if (e == NULL)
1746 : : return false;
1747 : :
1748 : 224978 : switch (e->expr_type)
1749 : : {
1750 : 108486 : case EXPR_VARIABLE:
1751 : 108486 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1752 : : return true;
1753 : : break;
1754 : :
1755 : 47320 : case EXPR_OP:
1756 : 47320 : if (resolve_assumed_size_actual (e->value.op.op1)
1757 : 47320 : || resolve_assumed_size_actual (e->value.op.op2))
1758 : 0 : return true;
1759 : : break;
1760 : :
1761 : : default:
1762 : : break;
1763 : : }
1764 : : return false;
1765 : : }
1766 : :
1767 : :
1768 : : /* Check a generic procedure, passed as an actual argument, to see if
1769 : : there is a matching specific name. If none, it is an error, and if
1770 : : more than one, the reference is ambiguous. */
1771 : : static int
1772 : 8 : count_specific_procs (gfc_expr *e)
1773 : : {
1774 : 8 : int n;
1775 : 8 : gfc_interface *p;
1776 : 8 : gfc_symbol *sym;
1777 : :
1778 : 8 : n = 0;
1779 : 8 : sym = e->symtree->n.sym;
1780 : :
1781 : 22 : for (p = sym->generic; p; p = p->next)
1782 : 14 : if (strcmp (sym->name, p->sym->name) == 0)
1783 : : {
1784 : 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1785 : : sym->name);
1786 : 8 : n++;
1787 : : }
1788 : :
1789 : 8 : if (n > 1)
1790 : 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1791 : : &e->where);
1792 : :
1793 : 8 : if (n == 0)
1794 : 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1795 : : "argument at %L", sym->name, &e->where);
1796 : :
1797 : 8 : return n;
1798 : : }
1799 : :
1800 : :
1801 : : /* See if a call to sym could possibly be a not allowed RECURSION because of
1802 : : a missing RECURSIVE declaration. This means that either sym is the current
1803 : : context itself, or sym is the parent of a contained procedure calling its
1804 : : non-RECURSIVE containing procedure.
1805 : : This also works if sym is an ENTRY. */
1806 : :
1807 : : static bool
1808 : 148186 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1809 : : {
1810 : 148186 : gfc_symbol* proc_sym;
1811 : 148186 : gfc_symbol* context_proc;
1812 : 148186 : gfc_namespace* real_context;
1813 : :
1814 : 148186 : if (sym->attr.flavor == FL_PROGRAM
1815 : : || gfc_fl_struct (sym->attr.flavor))
1816 : : return false;
1817 : :
1818 : : /* If we've got an ENTRY, find real procedure. */
1819 : 148185 : if (sym->attr.entry && sym->ns->entries)
1820 : 45 : proc_sym = sym->ns->entries->sym;
1821 : : else
1822 : : proc_sym = sym;
1823 : :
1824 : : /* If sym is RECURSIVE, all is well of course. */
1825 : 148185 : if (proc_sym->attr.recursive || flag_recursive)
1826 : : return false;
1827 : :
1828 : : /* Find the context procedure's "real" symbol if it has entries.
1829 : : We look for a procedure symbol, so recurse on the parents if we don't
1830 : : find one (like in case of a BLOCK construct). */
1831 : 1710 : for (real_context = context; ; real_context = real_context->parent)
1832 : : {
1833 : : /* We should find something, eventually! */
1834 : 125657 : gcc_assert (real_context);
1835 : :
1836 : 125657 : context_proc = (real_context->entries ? real_context->entries->sym
1837 : : : real_context->proc_name);
1838 : :
1839 : : /* In some special cases, there may not be a proc_name, like for this
1840 : : invalid code:
1841 : : real(bad_kind()) function foo () ...
1842 : : when checking the call to bad_kind ().
1843 : : In these cases, we simply return here and assume that the
1844 : : call is ok. */
1845 : 125657 : if (!context_proc)
1846 : : return false;
1847 : :
1848 : 125393 : if (context_proc->attr.flavor != FL_LABEL)
1849 : : break;
1850 : : }
1851 : :
1852 : : /* A call from sym's body to itself is recursion, of course. */
1853 : 123683 : if (context_proc == proc_sym)
1854 : : return true;
1855 : :
1856 : : /* The same is true if context is a contained procedure and sym the
1857 : : containing one. */
1858 : 123669 : if (context_proc->attr.contained)
1859 : : {
1860 : 20499 : gfc_symbol* parent_proc;
1861 : :
1862 : 20499 : gcc_assert (context->parent);
1863 : 20499 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1864 : : : context->parent->proc_name);
1865 : :
1866 : 20499 : if (parent_proc == proc_sym)
1867 : 9 : return true;
1868 : : }
1869 : :
1870 : : return false;
1871 : : }
1872 : :
1873 : :
1874 : : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1875 : : its typespec and formal argument list. */
1876 : :
1877 : : bool
1878 : 41218 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1879 : : {
1880 : 41218 : gfc_intrinsic_sym* isym = NULL;
1881 : 41218 : const char* symstd;
1882 : :
1883 : 41218 : if (sym->resolve_symbol_called >= 2)
1884 : : return true;
1885 : :
1886 : 31604 : sym->resolve_symbol_called = 2;
1887 : :
1888 : : /* Already resolved. */
1889 : 31604 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1890 : : return true;
1891 : :
1892 : : /* We already know this one is an intrinsic, so we don't call
1893 : : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1894 : : gfc_find_subroutine directly to check whether it is a function or
1895 : : subroutine. */
1896 : :
1897 : 23850 : if (sym->intmod_sym_id && sym->attr.subroutine)
1898 : : {
1899 : 8590 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1900 : 8590 : isym = gfc_intrinsic_subroutine_by_id (id);
1901 : 8590 : }
1902 : 15260 : else if (sym->intmod_sym_id)
1903 : : {
1904 : 11835 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1905 : 11835 : isym = gfc_intrinsic_function_by_id (id);
1906 : : }
1907 : 3425 : else if (!sym->attr.subroutine)
1908 : 3353 : isym = gfc_find_function (sym->name);
1909 : :
1910 : 23778 : if (isym && !sym->attr.subroutine)
1911 : : {
1912 : 15149 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1913 : 24 : && !sym->attr.implicit_type)
1914 : 10 : gfc_warning (OPT_Wsurprising,
1915 : : "Type specified for intrinsic function %qs at %L is"
1916 : : " ignored", sym->name, &sym->declared_at);
1917 : :
1918 : 18828 : if (!sym->attr.function &&
1919 : 3679 : !gfc_add_function(&sym->attr, sym->name, loc))
1920 : : return false;
1921 : :
1922 : 15149 : sym->ts = isym->ts;
1923 : : }
1924 : 8701 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1925 : : {
1926 : 8698 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1927 : : {
1928 : 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1929 : : " specifier", sym->name, &sym->declared_at);
1930 : 1 : return false;
1931 : : }
1932 : :
1933 : 8732 : if (!sym->attr.subroutine &&
1934 : 35 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1935 : : return false;
1936 : : }
1937 : : else
1938 : : {
1939 : 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1940 : : &sym->declared_at);
1941 : 3 : return false;
1942 : : }
1943 : :
1944 : 23845 : gfc_copy_formal_args_intr (sym, isym, NULL);
1945 : :
1946 : 23845 : sym->attr.pure = isym->pure;
1947 : 23845 : sym->attr.elemental = isym->elemental;
1948 : :
1949 : : /* Check it is actually available in the standard settings. */
1950 : 23845 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1951 : : {
1952 : 31 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1953 : : "available in the current standard settings but %s. Use "
1954 : : "an appropriate %<-std=*%> option or enable "
1955 : : "%<-fall-intrinsics%> in order to use it.",
1956 : : sym->name, &sym->declared_at, symstd);
1957 : 31 : return false;
1958 : : }
1959 : :
1960 : : return true;
1961 : : }
1962 : :
1963 : :
1964 : : /* Resolve a procedure expression, like passing it to a called procedure or as
1965 : : RHS for a procedure pointer assignment. */
1966 : :
1967 : : static bool
1968 : 1300498 : resolve_procedure_expression (gfc_expr* expr)
1969 : : {
1970 : 1300498 : gfc_symbol* sym;
1971 : :
1972 : 1300498 : if (expr->expr_type != EXPR_VARIABLE)
1973 : : return true;
1974 : 1300481 : gcc_assert (expr->symtree);
1975 : :
1976 : 1300481 : sym = expr->symtree->n.sym;
1977 : :
1978 : 1300481 : if (sym->attr.intrinsic)
1979 : 1346 : gfc_resolve_intrinsic (sym, &expr->where);
1980 : :
1981 : 1300481 : if (sym->attr.flavor != FL_PROCEDURE
1982 : 30375 : || (sym->attr.function && sym->result == sym))
1983 : : return true;
1984 : :
1985 : : /* A non-RECURSIVE procedure that is used as procedure expression within its
1986 : : own body is in danger of being called recursively. */
1987 : 16182 : if (is_illegal_recursion (sym, gfc_current_ns))
1988 : : {
1989 : 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
1990 : 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is"
1991 : : " possibly calling itself recursively in procedure %qs. "
1992 : : " Declare it RECURSIVE or use %<-frecursive%>",
1993 : 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
1994 : : else
1995 : 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1996 : : " itself recursively. Declare it RECURSIVE or use"
1997 : : " %<-frecursive%>", sym->name, &expr->where);
1998 : : }
1999 : :
2000 : : return true;
2001 : : }
2002 : :
2003 : :
2004 : : /* Check that name is not a derived type. */
2005 : :
2006 : : static bool
2007 : 3215 : is_dt_name (const char *name)
2008 : : {
2009 : 3215 : gfc_symbol *dt_list, *dt_first;
2010 : :
2011 : 3215 : dt_list = dt_first = gfc_derived_types;
2012 : 5645 : for (; dt_list; dt_list = dt_list->dt_next)
2013 : : {
2014 : 3541 : if (strcmp(dt_list->name, name) == 0)
2015 : : return true;
2016 : 3538 : if (dt_first == dt_list->dt_next)
2017 : : break;
2018 : : }
2019 : : return false;
2020 : : }
2021 : :
2022 : :
2023 : : /* Resolve an actual argument list. Most of the time, this is just
2024 : : resolving the expressions in the list.
2025 : : The exception is that we sometimes have to decide whether arguments
2026 : : that look like procedure arguments are really simple variable
2027 : : references. */
2028 : :
2029 : : static bool
2030 : 418284 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2031 : : bool no_formal_args)
2032 : : {
2033 : 418284 : gfc_symbol *sym = NULL;
2034 : 418284 : gfc_symtree *parent_st;
2035 : 418284 : gfc_expr *e;
2036 : 418284 : gfc_component *comp;
2037 : 418284 : int save_need_full_assumed_size;
2038 : 418284 : bool return_value = false;
2039 : 418284 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2040 : :
2041 : 418284 : actual_arg = true;
2042 : 418284 : first_actual_arg = true;
2043 : :
2044 : 1076277 : for (; arg; arg = arg->next)
2045 : : {
2046 : 658094 : e = arg->expr;
2047 : 658094 : if (e == NULL)
2048 : : {
2049 : : /* Check the label is a valid branching target. */
2050 : 2358 : if (arg->label)
2051 : : {
2052 : 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2053 : : {
2054 : 0 : gfc_error ("Label %d referenced at %L is never defined",
2055 : : arg->label->value, &arg->label->where);
2056 : 0 : goto cleanup;
2057 : : }
2058 : : }
2059 : 2358 : first_actual_arg = false;
2060 : 2358 : continue;
2061 : : }
2062 : :
2063 : 655736 : if (e->expr_type == EXPR_VARIABLE
2064 : 289981 : && e->symtree->n.sym->attr.generic
2065 : 8 : && no_formal_args
2066 : 655741 : && count_specific_procs (e) != 1)
2067 : 2 : goto cleanup;
2068 : :
2069 : 655734 : if (e->ts.type != BT_PROCEDURE)
2070 : : {
2071 : 584332 : save_need_full_assumed_size = need_full_assumed_size;
2072 : 584332 : if (e->expr_type != EXPR_VARIABLE)
2073 : 365755 : need_full_assumed_size = 0;
2074 : 584332 : if (!gfc_resolve_expr (e))
2075 : 60 : goto cleanup;
2076 : 584272 : need_full_assumed_size = save_need_full_assumed_size;
2077 : 584272 : goto argument_list;
2078 : : }
2079 : :
2080 : : /* See if the expression node should really be a variable reference. */
2081 : :
2082 : 71402 : sym = e->symtree->n.sym;
2083 : :
2084 : 71402 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2085 : : {
2086 : 3 : gfc_error ("Derived type %qs is used as an actual "
2087 : : "argument at %L", sym->name, &e->where);
2088 : 3 : goto cleanup;
2089 : : }
2090 : :
2091 : 71399 : if (sym->attr.flavor == FL_PROCEDURE
2092 : 68187 : || sym->attr.intrinsic
2093 : 68187 : || sym->attr.external)
2094 : : {
2095 : 3212 : int actual_ok;
2096 : :
2097 : : /* If a procedure is not already determined to be something else
2098 : : check if it is intrinsic. */
2099 : 3212 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2100 : 1254 : sym->attr.intrinsic = 1;
2101 : :
2102 : 3212 : if (sym->attr.proc == PROC_ST_FUNCTION)
2103 : : {
2104 : 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2105 : : "actual argument", sym->name, &e->where);
2106 : : }
2107 : :
2108 : 6424 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2109 : 3212 : sym->attr.subroutine);
2110 : 3212 : if (sym->attr.intrinsic && actual_ok == 0)
2111 : : {
2112 : 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2113 : : "actual argument", sym->name, &e->where);
2114 : : }
2115 : :
2116 : 3212 : if (sym->attr.contained && !sym->attr.use_assoc
2117 : 404 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2118 : : {
2119 : 216 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2120 : : " used as actual argument at %L",
2121 : : sym->name, &e->where))
2122 : 3 : goto cleanup;
2123 : : }
2124 : :
2125 : 3209 : if (sym->attr.elemental && !sym->attr.intrinsic)
2126 : : {
2127 : 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2128 : : "allowed as an actual argument at %L", sym->name,
2129 : : &e->where);
2130 : : }
2131 : :
2132 : : /* Check if a generic interface has a specific procedure
2133 : : with the same name before emitting an error. */
2134 : 3209 : if (sym->attr.generic && count_specific_procs (e) != 1)
2135 : 0 : goto cleanup;
2136 : :
2137 : : /* Just in case a specific was found for the expression. */
2138 : 3209 : sym = e->symtree->n.sym;
2139 : :
2140 : : /* If the symbol is the function that names the current (or
2141 : : parent) scope, then we really have a variable reference. */
2142 : :
2143 : 3209 : if (gfc_is_function_return_value (sym, sym->ns))
2144 : 0 : goto got_variable;
2145 : :
2146 : : /* If all else fails, see if we have a specific intrinsic. */
2147 : 3209 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2148 : : {
2149 : 0 : gfc_intrinsic_sym *isym;
2150 : :
2151 : 0 : isym = gfc_find_function (sym->name);
2152 : 0 : if (isym == NULL || !isym->specific)
2153 : : {
2154 : 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2155 : : "for the reference %qs at %L", sym->name,
2156 : : &e->where);
2157 : 0 : goto cleanup;
2158 : : }
2159 : 0 : sym->ts = isym->ts;
2160 : 0 : sym->attr.intrinsic = 1;
2161 : 0 : sym->attr.function = 1;
2162 : : }
2163 : :
2164 : 3209 : if (!gfc_resolve_expr (e))
2165 : 0 : goto cleanup;
2166 : 3209 : goto argument_list;
2167 : : }
2168 : :
2169 : : /* See if the name is a module procedure in a parent unit. */
2170 : :
2171 : 68187 : if (was_declared (sym) || sym->ns->parent == NULL)
2172 : 68094 : goto got_variable;
2173 : :
2174 : 93 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2175 : : {
2176 : 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2177 : 0 : goto cleanup;
2178 : : }
2179 : :
2180 : 93 : if (parent_st == NULL)
2181 : 93 : goto got_variable;
2182 : :
2183 : 0 : sym = parent_st->n.sym;
2184 : 0 : e->symtree = parent_st; /* Point to the right thing. */
2185 : :
2186 : 0 : if (sym->attr.flavor == FL_PROCEDURE
2187 : 0 : || sym->attr.intrinsic
2188 : 0 : || sym->attr.external)
2189 : : {
2190 : 0 : if (!gfc_resolve_expr (e))
2191 : 0 : goto cleanup;
2192 : 0 : goto argument_list;
2193 : : }
2194 : :
2195 : 0 : got_variable:
2196 : 68187 : e->expr_type = EXPR_VARIABLE;
2197 : 68187 : e->ts = sym->ts;
2198 : 68187 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2199 : 35468 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2200 : 3781 : && CLASS_DATA (sym)->as))
2201 : : {
2202 : 38165 : gfc_array_spec *as
2203 : 35442 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2204 : 35442 : e->rank = as->rank;
2205 : 35442 : e->corank = as->corank;
2206 : 35442 : e->ref = gfc_get_ref ();
2207 : 35442 : e->ref->type = REF_ARRAY;
2208 : 35442 : e->ref->u.ar.type = AR_FULL;
2209 : 35442 : e->ref->u.ar.as = as;
2210 : : }
2211 : :
2212 : : /* These symbols are set untyped by calls to gfc_set_default_type
2213 : : with 'error_flag' = false. Reset the untyped attribute so that
2214 : : the error will be generated in gfc_resolve_expr. */
2215 : 68187 : if (e->expr_type == EXPR_VARIABLE
2216 : 68187 : && sym->ts.type == BT_UNKNOWN
2217 : 36 : && sym->attr.untyped)
2218 : 5 : sym->attr.untyped = 0;
2219 : :
2220 : : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2221 : : primary.cc (match_actual_arg). If above code determines that it
2222 : : is a variable instead, it needs to be resolved as it was not
2223 : : done at the beginning of this function. */
2224 : 68187 : save_need_full_assumed_size = need_full_assumed_size;
2225 : 68187 : if (e->expr_type != EXPR_VARIABLE)
2226 : 0 : need_full_assumed_size = 0;
2227 : 68187 : if (!gfc_resolve_expr (e))
2228 : 22 : goto cleanup;
2229 : 68165 : need_full_assumed_size = save_need_full_assumed_size;
2230 : :
2231 : 655646 : argument_list:
2232 : : /* Check argument list functions %VAL, %LOC and %REF. There is
2233 : : nothing to do for %REF. */
2234 : 655646 : if (arg->name && arg->name[0] == '%')
2235 : : {
2236 : 42 : if (strcmp ("%VAL", arg->name) == 0)
2237 : : {
2238 : 28 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2239 : : {
2240 : 2 : gfc_error ("By-value argument at %L is not of numeric "
2241 : : "type", &e->where);
2242 : 2 : goto cleanup;
2243 : : }
2244 : :
2245 : 26 : if (e->rank)
2246 : : {
2247 : 1 : gfc_error ("By-value argument at %L cannot be an array or "
2248 : : "an array section", &e->where);
2249 : 1 : goto cleanup;
2250 : : }
2251 : :
2252 : : /* Intrinsics are still PROC_UNKNOWN here. However,
2253 : : since same file external procedures are not resolvable
2254 : : in gfortran, it is a good deal easier to leave them to
2255 : : intrinsic.cc. */
2256 : 25 : if (ptype != PROC_UNKNOWN
2257 : 25 : && ptype != PROC_DUMMY
2258 : 9 : && ptype != PROC_EXTERNAL
2259 : 9 : && ptype != PROC_MODULE)
2260 : : {
2261 : 3 : gfc_error ("By-value argument at %L is not allowed "
2262 : : "in this context", &e->where);
2263 : 3 : goto cleanup;
2264 : : }
2265 : : }
2266 : :
2267 : : /* Statement functions have already been excluded above. */
2268 : 14 : else if (strcmp ("%LOC", arg->name) == 0
2269 : 8 : && e->ts.type == BT_PROCEDURE)
2270 : : {
2271 : 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2272 : : {
2273 : 0 : gfc_error ("Passing internal procedure at %L by location "
2274 : : "not allowed", &e->where);
2275 : 0 : goto cleanup;
2276 : : }
2277 : : }
2278 : : }
2279 : :
2280 : 655640 : comp = gfc_get_proc_ptr_comp(e);
2281 : 655640 : if (e->expr_type == EXPR_VARIABLE
2282 : 288603 : && comp && comp->attr.elemental)
2283 : : {
2284 : 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2285 : : "allowed as an actual argument at %L", comp->name,
2286 : : &e->where);
2287 : : }
2288 : :
2289 : : /* Fortran 2008, C1237. */
2290 : 288603 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2291 : 655946 : && gfc_has_ultimate_pointer (e))
2292 : : {
2293 : 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2294 : : "component", &e->where);
2295 : 3 : goto cleanup;
2296 : : }
2297 : :
2298 : 655637 : if (e->expr_type == EXPR_VARIABLE
2299 : 288600 : && e->ts.type == BT_PROCEDURE
2300 : 3209 : && no_formal_args
2301 : 1505 : && sym->attr.flavor == FL_PROCEDURE
2302 : 1505 : && sym->attr.if_source == IFSRC_UNKNOWN
2303 : 142 : && !sym->attr.external
2304 : 2 : && !sym->attr.intrinsic
2305 : 2 : && !sym->attr.artificial
2306 : 2 : && !sym->ts.interface)
2307 : : {
2308 : : /* Emit a warning for -std=legacy and an error otherwise. */
2309 : 2 : if (gfc_option.warn_std == 0)
2310 : 0 : gfc_warning (0, "Procedure %qs at %L used as actual argument but "
2311 : : "does neither have an explicit interface nor the "
2312 : : "EXTERNAL attribute", sym->name, &e->where);
2313 : : else
2314 : : {
2315 : 2 : gfc_error ("Procedure %qs at %L used as actual argument but "
2316 : : "does neither have an explicit interface nor the "
2317 : : "EXTERNAL attribute", sym->name, &e->where);
2318 : 2 : goto cleanup;
2319 : : }
2320 : : }
2321 : :
2322 : 655635 : first_actual_arg = false;
2323 : : }
2324 : :
2325 : : return_value = true;
2326 : :
2327 : 418284 : cleanup:
2328 : 418284 : actual_arg = actual_arg_sav;
2329 : 418284 : first_actual_arg = first_actual_arg_sav;
2330 : :
2331 : 418284 : return return_value;
2332 : : }
2333 : :
2334 : :
2335 : : /* Do the checks of the actual argument list that are specific to elemental
2336 : : procedures. If called with c == NULL, we have a function, otherwise if
2337 : : expr == NULL, we have a subroutine. */
2338 : :
2339 : : static bool
2340 : 318786 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2341 : : {
2342 : 318786 : gfc_actual_arglist *arg0;
2343 : 318786 : gfc_actual_arglist *arg;
2344 : 318786 : gfc_symbol *esym = NULL;
2345 : 318786 : gfc_intrinsic_sym *isym = NULL;
2346 : 318786 : gfc_expr *e = NULL;
2347 : 318786 : gfc_intrinsic_arg *iformal = NULL;
2348 : 318786 : gfc_formal_arglist *eformal = NULL;
2349 : 318786 : bool formal_optional = false;
2350 : 318786 : bool set_by_optional = false;
2351 : 318786 : int i;
2352 : 318786 : int rank = 0;
2353 : :
2354 : : /* Is this an elemental procedure? */
2355 : 318786 : if (expr && expr->value.function.actual != NULL)
2356 : : {
2357 : 231482 : if (expr->value.function.esym != NULL
2358 : 43522 : && expr->value.function.esym->attr.elemental)
2359 : : {
2360 : : arg0 = expr->value.function.actual;
2361 : : esym = expr->value.function.esym;
2362 : : }
2363 : 215208 : else if (expr->value.function.isym != NULL
2364 : 186937 : && expr->value.function.isym->elemental)
2365 : : {
2366 : : arg0 = expr->value.function.actual;
2367 : : isym = expr->value.function.isym;
2368 : : }
2369 : : else
2370 : : return true;
2371 : : }
2372 : 87304 : else if (c && c->ext.actual != NULL)
2373 : : {
2374 : 69137 : arg0 = c->ext.actual;
2375 : :
2376 : 69137 : if (c->resolved_sym)
2377 : : esym = c->resolved_sym;
2378 : : else
2379 : 313 : esym = c->symtree->n.sym;
2380 : 69137 : gcc_assert (esym);
2381 : :
2382 : 69137 : if (!esym->attr.elemental)
2383 : : return true;
2384 : : }
2385 : : else
2386 : : return true;
2387 : :
2388 : : /* The rank of an elemental is the rank of its array argument(s). */
2389 : 171842 : for (arg = arg0; arg; arg = arg->next)
2390 : : {
2391 : 111353 : if (arg->expr != NULL && arg->expr->rank != 0)
2392 : : {
2393 : 10364 : rank = arg->expr->rank;
2394 : 10364 : if (arg->expr->expr_type == EXPR_VARIABLE
2395 : 5216 : && arg->expr->symtree->n.sym->attr.optional)
2396 : 10364 : set_by_optional = true;
2397 : :
2398 : : /* Function specific; set the result rank and shape. */
2399 : 10364 : if (expr)
2400 : : {
2401 : 8196 : expr->rank = rank;
2402 : 8196 : expr->corank = arg->expr->corank;
2403 : 8196 : if (!expr->shape && arg->expr->shape)
2404 : : {
2405 : 3923 : expr->shape = gfc_get_shape (rank);
2406 : 8638 : for (i = 0; i < rank; i++)
2407 : 4715 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2408 : : }
2409 : : }
2410 : : break;
2411 : : }
2412 : : }
2413 : :
2414 : : /* If it is an array, it shall not be supplied as an actual argument
2415 : : to an elemental procedure unless an array of the same rank is supplied
2416 : : as an actual argument corresponding to a nonoptional dummy argument of
2417 : : that elemental procedure(12.4.1.5). */
2418 : 70853 : formal_optional = false;
2419 : 70853 : if (isym)
2420 : 48612 : iformal = isym->formal;
2421 : : else
2422 : 22241 : eformal = esym->formal;
2423 : :
2424 : 187491 : for (arg = arg0; arg; arg = arg->next)
2425 : : {
2426 : 116638 : if (eformal)
2427 : : {
2428 : 39899 : if (eformal->sym && eformal->sym->attr.optional)
2429 : 39899 : formal_optional = true;
2430 : 39899 : eformal = eformal->next;
2431 : : }
2432 : 76739 : else if (isym && iformal)
2433 : : {
2434 : 66709 : if (iformal->optional)
2435 : 13298 : formal_optional = true;
2436 : 66709 : iformal = iformal->next;
2437 : : }
2438 : 10030 : else if (isym)
2439 : 10022 : formal_optional = true;
2440 : :
2441 : 116638 : if (pedantic && arg->expr != NULL
2442 : 71201 : && arg->expr->expr_type == EXPR_VARIABLE
2443 : 34507 : && arg->expr->symtree->n.sym->attr.optional
2444 : 572 : && formal_optional
2445 : 479 : && arg->expr->rank
2446 : 153 : && (set_by_optional || arg->expr->rank != rank)
2447 : 42 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2448 : : {
2449 : 114 : bool t = false;
2450 : : gfc_actual_arglist *a;
2451 : :
2452 : : /* Scan the argument list for a non-optional argument with the
2453 : : same rank as arg. */
2454 : 114 : for (a = arg0; a; a = a->next)
2455 : 87 : if (a != arg
2456 : 45 : && a->expr->rank == arg->expr->rank
2457 : 39 : && (a->expr->expr_type != EXPR_VARIABLE
2458 : 37 : || (a->expr->expr_type == EXPR_VARIABLE
2459 : 37 : && !a->expr->symtree->n.sym->attr.optional)))
2460 : : {
2461 : : t = true;
2462 : : break;
2463 : : }
2464 : :
2465 : 42 : if (!t)
2466 : 27 : gfc_warning (OPT_Wpedantic,
2467 : : "%qs at %L is an array and OPTIONAL; If it is not "
2468 : : "present, then it cannot be the actual argument of "
2469 : : "an ELEMENTAL procedure unless there is a non-optional"
2470 : : " argument with the same rank "
2471 : : "(Fortran 2018, 15.5.2.12)",
2472 : : arg->expr->symtree->n.sym->name, &arg->expr->where);
2473 : : }
2474 : : }
2475 : :
2476 : 187480 : for (arg = arg0; arg; arg = arg->next)
2477 : : {
2478 : 116636 : if (arg->expr == NULL || arg->expr->rank == 0)
2479 : 103612 : continue;
2480 : :
2481 : : /* Being elemental, the last upper bound of an assumed size array
2482 : : argument must be present. */
2483 : 13024 : if (resolve_assumed_size_actual (arg->expr))
2484 : : return false;
2485 : :
2486 : : /* Elemental procedure's array actual arguments must conform. */
2487 : 13021 : if (e != NULL)
2488 : : {
2489 : 2660 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2490 : : return false;
2491 : : }
2492 : : else
2493 : 10361 : e = arg->expr;
2494 : : }
2495 : :
2496 : : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2497 : : is an array, the intent inout/out variable needs to be also an array. */
2498 : 70844 : if (rank > 0 && esym && expr == NULL)
2499 : 6637 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2500 : 4475 : arg = arg->next, eformal = eformal->next)
2501 : 4477 : if (eformal->sym
2502 : 4476 : && (eformal->sym->attr.intent == INTENT_OUT
2503 : 3394 : || eformal->sym->attr.intent == INTENT_INOUT)
2504 : 1476 : && arg->expr && arg->expr->rank == 0)
2505 : : {
2506 : 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2507 : : "ELEMENTAL subroutine %qs is a scalar, but another "
2508 : : "actual argument is an array", &arg->expr->where,
2509 : : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2510 : : : "INOUT", eformal->sym->name, esym->name);
2511 : 2 : return false;
2512 : : }
2513 : : return true;
2514 : : }
2515 : :
2516 : :
2517 : : /* This function does the checking of references to global procedures
2518 : : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2519 : : 77 and 95 standards. It checks for a gsymbol for the name, making
2520 : : one if it does not already exist. If it already exists, then the
2521 : : reference being resolved must correspond to the type of gsymbol.
2522 : : Otherwise, the new symbol is equipped with the attributes of the
2523 : : reference. The corresponding code that is called in creating
2524 : : global entities is parse.cc.
2525 : :
2526 : : In addition, for all but -std=legacy, the gsymbols are used to
2527 : : check the interfaces of external procedures from the same file.
2528 : : The namespace of the gsymbol is resolved and then, once this is
2529 : : done the interface is checked. */
2530 : :
2531 : :
2532 : : static bool
2533 : 14829 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2534 : : {
2535 : 14829 : if (!gsym_ns->proc_name->attr.recursive)
2536 : : return true;
2537 : :
2538 : 151 : if (sym->ns == gsym_ns)
2539 : : return false;
2540 : :
2541 : 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2542 : 0 : return false;
2543 : :
2544 : : return true;
2545 : : }
2546 : :
2547 : : static bool
2548 : 14829 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2549 : : {
2550 : 14829 : if (gsym_ns->entries)
2551 : : {
2552 : : gfc_entry_list *entry = gsym_ns->entries;
2553 : :
2554 : 3234 : for (; entry; entry = entry->next)
2555 : : {
2556 : 2281 : if (strcmp (sym->name, entry->sym->name) == 0)
2557 : : {
2558 : 946 : if (strcmp (gsym_ns->proc_name->name,
2559 : 946 : sym->ns->proc_name->name) == 0)
2560 : : return false;
2561 : :
2562 : 946 : if (sym->ns->parent
2563 : 0 : && strcmp (gsym_ns->proc_name->name,
2564 : 0 : sym->ns->parent->proc_name->name) == 0)
2565 : : return false;
2566 : : }
2567 : : }
2568 : : }
2569 : : return true;
2570 : : }
2571 : :
2572 : :
2573 : : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2574 : :
2575 : : bool
2576 : 15648 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2577 : : {
2578 : 15648 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2579 : :
2580 : 58670 : for ( ; arg; arg = arg->next)
2581 : : {
2582 : 27744 : if (!arg->sym)
2583 : 157 : continue;
2584 : :
2585 : 27587 : if (arg->sym->attr.allocatable) /* (2a) */
2586 : : {
2587 : 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2588 : 0 : return true;
2589 : : }
2590 : 27587 : else if (arg->sym->attr.asynchronous)
2591 : : {
2592 : 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2593 : 0 : return true;
2594 : : }
2595 : 27587 : else if (arg->sym->attr.optional)
2596 : : {
2597 : 75 : strncpy (errmsg, _("optional argument"), err_len);
2598 : 75 : return true;
2599 : : }
2600 : 27512 : else if (arg->sym->attr.pointer)
2601 : : {
2602 : 12 : strncpy (errmsg, _("pointer argument"), err_len);
2603 : 12 : return true;
2604 : : }
2605 : 27500 : else if (arg->sym->attr.target)
2606 : : {
2607 : 72 : strncpy (errmsg, _("target argument"), err_len);
2608 : 72 : return true;
2609 : : }
2610 : 27428 : else if (arg->sym->attr.value)
2611 : : {
2612 : 0 : strncpy (errmsg, _("value argument"), err_len);
2613 : 0 : return true;
2614 : : }
2615 : 27428 : else if (arg->sym->attr.volatile_)
2616 : : {
2617 : 1 : strncpy (errmsg, _("volatile argument"), err_len);
2618 : 1 : return true;
2619 : : }
2620 : 27427 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2621 : : {
2622 : 45 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2623 : 45 : return true;
2624 : : }
2625 : 27382 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2626 : : {
2627 : 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2628 : 1 : return true;
2629 : : }
2630 : 27381 : else if (arg->sym->attr.codimension) /* (2c) */
2631 : : {
2632 : 1 : strncpy (errmsg, _("coarray argument"), err_len);
2633 : 1 : return true;
2634 : : }
2635 : 27380 : else if (false) /* (2d) TODO: parametrized derived type */
2636 : : {
2637 : : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2638 : : return true;
2639 : : }
2640 : 27380 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2641 : : {
2642 : 162 : strncpy (errmsg, _("polymorphic argument"), err_len);
2643 : 162 : return true;
2644 : : }
2645 : 27218 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2646 : : {
2647 : 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2648 : 0 : return true;
2649 : : }
2650 : 27218 : else if (arg->sym->ts.type == BT_ASSUMED)
2651 : : {
2652 : : /* As assumed-type is unlimited polymorphic (cf. above).
2653 : : See also TS 29113, Note 6.1. */
2654 : 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2655 : 1 : return true;
2656 : : }
2657 : : }
2658 : :
2659 : 15278 : if (sym->attr.function)
2660 : : {
2661 : 3455 : gfc_symbol *res = sym->result ? sym->result : sym;
2662 : :
2663 : 3455 : if (res->attr.dimension) /* (3a) */
2664 : : {
2665 : 93 : strncpy (errmsg, _("array result"), err_len);
2666 : 93 : return true;
2667 : : }
2668 : 3362 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2669 : : {
2670 : 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2671 : 38 : return true;
2672 : : }
2673 : 3324 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2674 : 347 : && res->ts.u.cl->length
2675 : 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2676 : : {
2677 : 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2678 : 12 : return true;
2679 : : }
2680 : : }
2681 : :
2682 : 15135 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2683 : : {
2684 : 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2685 : 7 : return true;
2686 : : }
2687 : 15128 : else if (sym->attr.is_bind_c) /* (5) */
2688 : : {
2689 : 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2690 : 0 : return true;
2691 : : }
2692 : :
2693 : : return false;
2694 : : }
2695 : :
2696 : :
2697 : : static void
2698 : 29041 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2699 : : {
2700 : 29041 : gfc_gsymbol * gsym;
2701 : 29041 : gfc_namespace *ns;
2702 : 29041 : enum gfc_symbol_type type;
2703 : 29041 : char reason[200];
2704 : :
2705 : 29041 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2706 : :
2707 : 29041 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2708 : 29041 : sym->binding_label != NULL);
2709 : :
2710 : 29041 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2711 : 10 : gfc_global_used (gsym, where);
2712 : :
2713 : 29041 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2714 : 8979 : || sym->attr.if_source == IFSRC_IFBODY)
2715 : 24857 : && gsym->type != GSYM_UNKNOWN
2716 : 22701 : && !gsym->binding_label
2717 : 20438 : && gsym->ns
2718 : 14829 : && gsym->ns->proc_name
2719 : 14829 : && not_in_recursive (sym, gsym->ns)
2720 : 43870 : && not_entry_self_reference (sym, gsym->ns))
2721 : : {
2722 : 14829 : gfc_symbol *def_sym;
2723 : 14829 : def_sym = gsym->ns->proc_name;
2724 : :
2725 : 14829 : if (gsym->ns->resolved != -1)
2726 : : {
2727 : :
2728 : : /* Resolve the gsymbol namespace if needed. */
2729 : 14808 : if (!gsym->ns->resolved)
2730 : : {
2731 : 2765 : gfc_symbol *old_dt_list;
2732 : :
2733 : : /* Stash away derived types so that the backend_decls
2734 : : do not get mixed up. */
2735 : 2765 : old_dt_list = gfc_derived_types;
2736 : 2765 : gfc_derived_types = NULL;
2737 : :
2738 : 2765 : gfc_resolve (gsym->ns);
2739 : :
2740 : : /* Store the new derived types with the global namespace. */
2741 : 2765 : if (gfc_derived_types)
2742 : 305 : gsym->ns->derived_types = gfc_derived_types;
2743 : :
2744 : : /* Restore the derived types of this namespace. */
2745 : 2765 : gfc_derived_types = old_dt_list;
2746 : : }
2747 : :
2748 : : /* Make sure that translation for the gsymbol occurs before
2749 : : the procedure currently being resolved. */
2750 : 14808 : ns = gfc_global_ns_list;
2751 : 25112 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2752 : : {
2753 : 16752 : if (ns->sibling == gsym->ns)
2754 : : {
2755 : 6448 : ns->sibling = gsym->ns->sibling;
2756 : 6448 : gsym->ns->sibling = gfc_global_ns_list;
2757 : 6448 : gfc_global_ns_list = gsym->ns;
2758 : 6448 : break;
2759 : : }
2760 : : }
2761 : :
2762 : : /* This can happen if a binding name has been specified. */
2763 : 14808 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2764 : 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2765 : :
2766 : 14808 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2767 : : {
2768 : 953 : gfc_entry_list *entry;
2769 : 1659 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2770 : 1659 : if (strcmp (entry->sym->name, sym->name) == 0)
2771 : : {
2772 : 953 : def_sym = entry->sym;
2773 : 953 : break;
2774 : : }
2775 : : }
2776 : : }
2777 : :
2778 : 14829 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2779 : : {
2780 : 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2781 : : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2782 : 6 : gfc_typename (&def_sym->ts));
2783 : 29 : goto done;
2784 : : }
2785 : :
2786 : 14823 : if (sym->attr.if_source == IFSRC_UNKNOWN
2787 : 14823 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2788 : : {
2789 : 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2790 : : sym->name, &sym->declared_at, reason);
2791 : 8 : goto done;
2792 : : }
2793 : :
2794 : 14815 : bool bad_result_characteristics;
2795 : 14815 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2796 : : reason, sizeof(reason), NULL, NULL,
2797 : : &bad_result_characteristics))
2798 : : {
2799 : : /* Turn erros into warnings with -std=gnu and -std=legacy,
2800 : : unless a function returns a wrong type, which can lead
2801 : : to all kinds of ICEs and wrong code. */
2802 : :
2803 : 15 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2804 : 2 : && !bad_result_characteristics)
2805 : 2 : gfc_errors_to_warnings (true);
2806 : :
2807 : 15 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2808 : : sym->name, &sym->declared_at, reason);
2809 : 15 : sym->error = 1;
2810 : 15 : gfc_errors_to_warnings (false);
2811 : 15 : goto done;
2812 : : }
2813 : : }
2814 : :
2815 : 29041 : done:
2816 : :
2817 : 29041 : if (gsym->type == GSYM_UNKNOWN)
2818 : : {
2819 : 3878 : gsym->type = type;
2820 : 3878 : gsym->where = *where;
2821 : : }
2822 : :
2823 : 29041 : gsym->used = 1;
2824 : 29041 : }
2825 : :
2826 : :
2827 : : /************* Function resolution *************/
2828 : :
2829 : : /* Resolve a function call known to be generic.
2830 : : Section 14.1.2.4.1. */
2831 : :
2832 : : static match
2833 : 27135 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2834 : : {
2835 : 27135 : gfc_symbol *s;
2836 : :
2837 : 27135 : if (sym->attr.generic)
2838 : : {
2839 : 26030 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2840 : 26030 : if (s != NULL)
2841 : : {
2842 : 19733 : expr->value.function.name = s->name;
2843 : 19733 : expr->value.function.esym = s;
2844 : :
2845 : 19733 : if (s->ts.type != BT_UNKNOWN)
2846 : 19716 : expr->ts = s->ts;
2847 : 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2848 : 15 : expr->ts = s->result->ts;
2849 : :
2850 : 19733 : if (s->as != NULL)
2851 : : {
2852 : 54 : expr->rank = s->as->rank;
2853 : 54 : expr->corank = s->as->corank;
2854 : : }
2855 : 19679 : else if (s->result != NULL && s->result->as != NULL)
2856 : : {
2857 : 0 : expr->rank = s->result->as->rank;
2858 : 0 : expr->corank = s->result->as->corank;
2859 : : }
2860 : :
2861 : 19733 : gfc_set_sym_referenced (expr->value.function.esym);
2862 : :
2863 : 19733 : return MATCH_YES;
2864 : : }
2865 : :
2866 : : /* TODO: Need to search for elemental references in generic
2867 : : interface. */
2868 : : }
2869 : :
2870 : 7402 : if (sym->attr.intrinsic)
2871 : 1062 : return gfc_intrinsic_func_interface (expr, 0);
2872 : :
2873 : : return MATCH_NO;
2874 : : }
2875 : :
2876 : :
2877 : : static bool
2878 : 26994 : resolve_generic_f (gfc_expr *expr)
2879 : : {
2880 : 26994 : gfc_symbol *sym;
2881 : 26994 : match m;
2882 : 26994 : gfc_interface *intr = NULL;
2883 : :
2884 : 26994 : sym = expr->symtree->n.sym;
2885 : :
2886 : 27135 : for (;;)
2887 : : {
2888 : 27135 : m = resolve_generic_f0 (expr, sym);
2889 : 27135 : if (m == MATCH_YES)
2890 : : return true;
2891 : 6342 : else if (m == MATCH_ERROR)
2892 : : return false;
2893 : :
2894 : 6342 : generic:
2895 : 6345 : if (!intr)
2896 : 6305 : for (intr = sym->generic; intr; intr = intr->next)
2897 : 6221 : if (gfc_fl_struct (intr->sym->attr.flavor))
2898 : : break;
2899 : :
2900 : 6345 : if (sym->ns->parent == NULL)
2901 : : break;
2902 : 264 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2903 : :
2904 : 264 : if (sym == NULL)
2905 : : break;
2906 : 144 : if (!generic_sym (sym))
2907 : 3 : goto generic;
2908 : : }
2909 : :
2910 : : /* Last ditch attempt. See if the reference is to an intrinsic
2911 : : that possesses a matching interface. 14.1.2.4 */
2912 : 6201 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2913 : : {
2914 : 5 : if (gfc_init_expr_flag)
2915 : 1 : gfc_error ("Function %qs in initialization expression at %L "
2916 : : "must be an intrinsic function",
2917 : 1 : expr->symtree->n.sym->name, &expr->where);
2918 : : else
2919 : 4 : gfc_error ("There is no specific function for the generic %qs "
2920 : 4 : "at %L", expr->symtree->n.sym->name, &expr->where);
2921 : 5 : return false;
2922 : : }
2923 : :
2924 : 6196 : if (intr)
2925 : : {
2926 : 6161 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2927 : : NULL, false))
2928 : : return false;
2929 : 6141 : if (!gfc_use_derived (expr->ts.u.derived))
2930 : : return false;
2931 : 6141 : return resolve_structure_cons (expr, 0);
2932 : : }
2933 : :
2934 : 35 : m = gfc_intrinsic_func_interface (expr, 0);
2935 : 35 : if (m == MATCH_YES)
2936 : : return true;
2937 : :
2938 : 3 : if (m == MATCH_NO)
2939 : 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2940 : 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2941 : : &expr->where);
2942 : :
2943 : : return false;
2944 : : }
2945 : :
2946 : :
2947 : : /* Resolve a function call known to be specific. */
2948 : :
2949 : : static match
2950 : 27634 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2951 : : {
2952 : 27634 : match m;
2953 : :
2954 : 27634 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2955 : : {
2956 : 7889 : if (sym->attr.dummy)
2957 : : {
2958 : 276 : sym->attr.proc = PROC_DUMMY;
2959 : 276 : goto found;
2960 : : }
2961 : :
2962 : 7613 : sym->attr.proc = PROC_EXTERNAL;
2963 : 7613 : goto found;
2964 : : }
2965 : :
2966 : 19745 : if (sym->attr.proc == PROC_MODULE
2967 : : || sym->attr.proc == PROC_ST_FUNCTION
2968 : : || sym->attr.proc == PROC_INTERNAL)
2969 : 19007 : goto found;
2970 : :
2971 : 738 : if (sym->attr.intrinsic)
2972 : : {
2973 : 731 : m = gfc_intrinsic_func_interface (expr, 1);
2974 : 731 : if (m == MATCH_YES)
2975 : : return MATCH_YES;
2976 : 0 : if (m == MATCH_NO)
2977 : 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2978 : : "with an intrinsic", sym->name, &expr->where);
2979 : :
2980 : 0 : return MATCH_ERROR;
2981 : : }
2982 : :
2983 : : return MATCH_NO;
2984 : :
2985 : 26896 : found:
2986 : 26896 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2987 : :
2988 : 26896 : if (sym->result)
2989 : 26896 : expr->ts = sym->result->ts;
2990 : : else
2991 : 0 : expr->ts = sym->ts;
2992 : 26896 : expr->value.function.name = sym->name;
2993 : 26896 : expr->value.function.esym = sym;
2994 : : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2995 : : error(s). */
2996 : 26896 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2997 : : return MATCH_ERROR;
2998 : 26895 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2999 : : {
3000 : 322 : expr->rank = CLASS_DATA (sym)->as->rank;
3001 : 322 : expr->corank = CLASS_DATA (sym)->as->corank;
3002 : : }
3003 : 26573 : else if (sym->as != NULL)
3004 : : {
3005 : 2272 : expr->rank = sym->as->rank;
3006 : 2272 : expr->corank = sym->as->corank;
3007 : : }
3008 : :
3009 : : return MATCH_YES;
3010 : : }
3011 : :
3012 : :
3013 : : static bool
3014 : 27627 : resolve_specific_f (gfc_expr *expr)
3015 : : {
3016 : 27627 : gfc_symbol *sym;
3017 : 27627 : match m;
3018 : :
3019 : 27627 : sym = expr->symtree->n.sym;
3020 : :
3021 : 27634 : for (;;)
3022 : : {
3023 : 27634 : m = resolve_specific_f0 (sym, expr);
3024 : 27634 : if (m == MATCH_YES)
3025 : : return true;
3026 : 8 : if (m == MATCH_ERROR)
3027 : : return false;
3028 : :
3029 : 7 : if (sym->ns->parent == NULL)
3030 : : break;
3031 : :
3032 : 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3033 : :
3034 : 7 : if (sym == NULL)
3035 : : break;
3036 : : }
3037 : :
3038 : 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
3039 : 0 : expr->symtree->n.sym->name, &expr->where);
3040 : :
3041 : 0 : return true;
3042 : : }
3043 : :
3044 : : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3045 : : candidates in CANDIDATES_LEN. */
3046 : :
3047 : : static void
3048 : 212 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3049 : : char **&candidates,
3050 : : size_t &candidates_len)
3051 : : {
3052 : 388 : gfc_symtree *p;
3053 : :
3054 : 388 : if (sym == NULL)
3055 : : return;
3056 : 388 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3057 : 126 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3058 : 51 : vec_push (candidates, candidates_len, sym->name);
3059 : :
3060 : 388 : p = sym->left;
3061 : 388 : if (p)
3062 : 155 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3063 : :
3064 : 388 : p = sym->right;
3065 : 388 : if (p)
3066 : : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3067 : : }
3068 : :
3069 : :
3070 : : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3071 : :
3072 : : const char*
3073 : 57 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3074 : : {
3075 : 57 : char **candidates = NULL;
3076 : 57 : size_t candidates_len = 0;
3077 : 57 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3078 : 57 : return gfc_closest_fuzzy_match (fn, candidates);
3079 : : }
3080 : :
3081 : :
3082 : : /* Resolve a procedure call not known to be generic nor specific. */
3083 : :
3084 : : static bool
3085 : 270401 : resolve_unknown_f (gfc_expr *expr)
3086 : : {
3087 : 270401 : gfc_symbol *sym;
3088 : 270401 : gfc_typespec *ts;
3089 : :
3090 : 270401 : sym = expr->symtree->n.sym;
3091 : :
3092 : 270401 : if (sym->attr.dummy)
3093 : : {
3094 : 288 : sym->attr.proc = PROC_DUMMY;
3095 : 288 : expr->value.function.name = sym->name;
3096 : 288 : goto set_type;
3097 : : }
3098 : :
3099 : : /* See if we have an intrinsic function reference. */
3100 : :
3101 : 270113 : if (gfc_is_intrinsic (sym, 0, expr->where))
3102 : : {
3103 : 267855 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3104 : : return true;
3105 : : return false;
3106 : : }
3107 : :
3108 : : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3109 : : /* Intrinsics were handled above, only non-intrinsics left here. */
3110 : 2258 : if (sym->attr.flavor == FL_PROCEDURE
3111 : 2255 : && sym->attr.implicit_type
3112 : 374 : && sym->ns
3113 : 374 : && sym->ns->has_implicit_none_export)
3114 : : {
3115 : 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3116 : : "for symbol %qs at %L", sym->name, &sym->declared_at);
3117 : 3 : sym->error = 1;
3118 : 3 : return false;
3119 : : }
3120 : :
3121 : : /* The reference is to an external name. */
3122 : :
3123 : 2255 : sym->attr.proc = PROC_EXTERNAL;
3124 : 2255 : expr->value.function.name = sym->name;
3125 : 2255 : expr->value.function.esym = expr->symtree->n.sym;
3126 : :
3127 : 2255 : if (sym->as != NULL)
3128 : : {
3129 : 1 : expr->rank = sym->as->rank;
3130 : 1 : expr->corank = sym->as->corank;
3131 : : }
3132 : :
3133 : : /* Type of the expression is either the type of the symbol or the
3134 : : default type of the symbol. */
3135 : :
3136 : 2254 : set_type:
3137 : 2543 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3138 : :
3139 : 2543 : if (sym->ts.type != BT_UNKNOWN)
3140 : 2492 : expr->ts = sym->ts;
3141 : : else
3142 : : {
3143 : 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3144 : :
3145 : 51 : if (ts->type == BT_UNKNOWN)
3146 : : {
3147 : 41 : const char *guessed
3148 : 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3149 : 41 : if (guessed)
3150 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3151 : : "; did you mean %qs?",
3152 : : sym->name, &expr->where, guessed);
3153 : : else
3154 : 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3155 : : sym->name, &expr->where);
3156 : 41 : return false;
3157 : : }
3158 : : else
3159 : 10 : expr->ts = *ts;
3160 : : }
3161 : :
3162 : : return true;
3163 : : }
3164 : :
3165 : :
3166 : : /* Return true, if the symbol is an external procedure. */
3167 : : static bool
3168 : 834033 : is_external_proc (gfc_symbol *sym)
3169 : : {
3170 : 832347 : if (!sym->attr.dummy && !sym->attr.contained
3171 : 725983 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3172 : 158329 : && sym->attr.proc != PROC_ST_FUNCTION
3173 : 157734 : && !sym->attr.proc_pointer
3174 : 156626 : && !sym->attr.use_assoc
3175 : 892142 : && sym->name)
3176 : : return true;
3177 : :
3178 : : return false;
3179 : : }
3180 : :
3181 : :
3182 : : /* Figure out if a function reference is pure or not. Also set the name
3183 : : of the function for a potential error message. Return nonzero if the
3184 : : function is PURE, zero if not. */
3185 : : static bool
3186 : : pure_stmt_function (gfc_expr *, gfc_symbol *);
3187 : :
3188 : : bool
3189 : 251471 : gfc_pure_function (gfc_expr *e, const char **name)
3190 : : {
3191 : 251471 : bool pure;
3192 : 251471 : gfc_component *comp;
3193 : :
3194 : 251471 : *name = NULL;
3195 : :
3196 : 251471 : if (e->symtree != NULL
3197 : 251142 : && e->symtree->n.sym != NULL
3198 : 251142 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3199 : 305 : return pure_stmt_function (e, e->symtree->n.sym);
3200 : :
3201 : 251166 : comp = gfc_get_proc_ptr_comp (e);
3202 : 251166 : if (comp)
3203 : : {
3204 : 464 : pure = gfc_pure (comp->ts.interface);
3205 : 464 : *name = comp->name;
3206 : : }
3207 : 250702 : else if (e->value.function.esym)
3208 : : {
3209 : 52128 : pure = gfc_pure (e->value.function.esym);
3210 : 52128 : *name = e->value.function.esym->name;
3211 : : }
3212 : 198574 : else if (e->value.function.isym)
3213 : : {
3214 : 395074 : pure = e->value.function.isym->pure
3215 : 197537 : || e->value.function.isym->elemental;
3216 : 197537 : *name = e->value.function.isym->name;
3217 : : }
3218 : 1037 : else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
3219 : : {
3220 : : /* The function has been resolved, but esym is not yet set.
3221 : : This can happen with functions as dummy argument. */
3222 : 286 : pure = e->symtree->n.sym->attr.pure;
3223 : 286 : *name = e->symtree->n.sym->name;
3224 : : }
3225 : : else
3226 : : {
3227 : : /* Implicit functions are not pure. */
3228 : 751 : pure = 0;
3229 : 751 : *name = e->value.function.name;
3230 : : }
3231 : :
3232 : : return pure;
3233 : : }
3234 : :
3235 : :
3236 : : /* Check if the expression is a reference to an implicitly pure function. */
3237 : :
3238 : : bool
3239 : 37527 : gfc_implicit_pure_function (gfc_expr *e)
3240 : : {
3241 : 37527 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3242 : 37527 : if (comp)
3243 : 448 : return gfc_implicit_pure (comp->ts.interface);
3244 : 37079 : else if (e->value.function.esym)
3245 : 31719 : return gfc_implicit_pure (e->value.function.esym);
3246 : : else
3247 : : return 0;
3248 : : }
3249 : :
3250 : :
3251 : : static bool
3252 : 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3253 : : int *f ATTRIBUTE_UNUSED)
3254 : : {
3255 : 981 : const char *name;
3256 : :
3257 : : /* Don't bother recursing into other statement functions
3258 : : since they will be checked individually for purity. */
3259 : 981 : if (e->expr_type != EXPR_FUNCTION
3260 : 343 : || !e->symtree
3261 : 343 : || e->symtree->n.sym == sym
3262 : 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3263 : : return false;
3264 : :
3265 : 19 : return gfc_pure_function (e, &name) ? false : true;
3266 : : }
3267 : :
3268 : :
3269 : : static bool
3270 : 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3271 : : {
3272 : 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3273 : : }
3274 : :
3275 : :
3276 : : /* Check if an impure function is allowed in the current context. */
3277 : :
3278 : 239740 : static bool check_pure_function (gfc_expr *e)
3279 : : {
3280 : 239740 : const char *name = NULL;
3281 : 239740 : code_stack *stack;
3282 : 239740 : bool saw_block = false;
3283 : :
3284 : : /* A BLOCK construct within a DO CONCURRENT construct leads to
3285 : : gfc_do_concurrent_flag = 0 when the check for an impure function
3286 : : occurs. Check the stack to see if the source code has a nested
3287 : : BLOCK construct. */
3288 : :
3289 : 554051 : for (stack = cs_base; stack; stack = stack->prev)
3290 : : {
3291 : 314313 : if (!saw_block && stack->current->op == EXEC_BLOCK)
3292 : : {
3293 : 6938 : saw_block = true;
3294 : 6938 : continue;
3295 : : }
3296 : :
3297 : 5150 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3298 : : {
3299 : 9 : bool is_pure;
3300 : 314311 : is_pure = (e->value.function.isym
3301 : 8 : && (e->value.function.isym->pure
3302 : 1 : || e->value.function.isym->elemental))
3303 : 10 : || (e->value.function.esym
3304 : 1 : && (e->value.function.esym->attr.pure
3305 : 1 : || e->value.function.esym->attr.elemental));
3306 : 2 : if (!is_pure)
3307 : : {
3308 : 2 : gfc_error ("Reference to impure function at %L inside a "
3309 : : "DO CONCURRENT", &e->where);
3310 : 2 : return false;
3311 : : }
3312 : : }
3313 : : }
3314 : :
3315 : 239738 : if (!gfc_pure_function (e, &name) && name)
3316 : : {
3317 : 36261 : if (forall_flag)
3318 : : {
3319 : 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3320 : : "FORALL %s", name, &e->where,
3321 : : forall_flag == 2 ? "mask" : "block");
3322 : 4 : return false;
3323 : : }
3324 : 36257 : else if (gfc_do_concurrent_flag)
3325 : : {
3326 : 2 : gfc_error ("Reference to impure function %qs at %L inside a "
3327 : : "DO CONCURRENT %s", name, &e->where,
3328 : : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3329 : 2 : return false;
3330 : : }
3331 : 36255 : else if (gfc_pure (NULL))
3332 : : {
3333 : 5 : gfc_error ("Reference to impure function %qs at %L "
3334 : : "within a PURE procedure", name, &e->where);
3335 : 5 : return false;
3336 : : }
3337 : 36250 : if (!gfc_implicit_pure_function (e))
3338 : 29943 : gfc_unset_implicit_pure (NULL);
3339 : : }
3340 : : return true;
3341 : : }
3342 : :
3343 : :
3344 : : /* Update current procedure's array_outer_dependency flag, considering
3345 : : a call to procedure SYM. */
3346 : :
3347 : : static void
3348 : 130054 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3349 : : {
3350 : : /* Check to see if this is a sibling function that has not yet
3351 : : been resolved. */
3352 : 130054 : gfc_namespace *sibling = gfc_current_ns->sibling;
3353 : 246365 : for (; sibling; sibling = sibling->sibling)
3354 : : {
3355 : 123094 : if (sibling->proc_name == sym)
3356 : : {
3357 : 6783 : gfc_resolve (sibling);
3358 : 6783 : break;
3359 : : }
3360 : : }
3361 : :
3362 : : /* If SYM has references to outer arrays, so has the procedure calling
3363 : : SYM. If SYM is a procedure pointer, we can assume the worst. */
3364 : 130054 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3365 : 66936 : && gfc_current_ns->proc_name)
3366 : 66892 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3367 : 130054 : }
3368 : :
3369 : :
3370 : : /* Resolve a function call, which means resolving the arguments, then figuring
3371 : : out which entity the name refers to. */
3372 : :
3373 : : static bool
3374 : 337961 : resolve_function (gfc_expr *expr)
3375 : : {
3376 : 337961 : gfc_actual_arglist *arg;
3377 : 337961 : gfc_symbol *sym;
3378 : 337961 : bool t;
3379 : 337961 : int temp;
3380 : 337961 : procedure_type p = PROC_INTRINSIC;
3381 : 337961 : bool no_formal_args;
3382 : :
3383 : 337961 : sym = NULL;
3384 : 337961 : if (expr->symtree)
3385 : 337632 : sym = expr->symtree->n.sym;
3386 : :
3387 : : /* If this is a procedure pointer component, it has already been resolved. */
3388 : 337961 : if (gfc_is_proc_ptr_comp (expr))
3389 : : return true;
3390 : :
3391 : : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3392 : : another caf_get. */
3393 : 337564 : if (sym && sym->attr.intrinsic
3394 : 8341 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3395 : 8341 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3396 : : return true;
3397 : :
3398 : 337564 : if (expr->ref)
3399 : : {
3400 : 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3401 : : &expr->where);
3402 : 1 : return false;
3403 : : }
3404 : :
3405 : 337234 : if (sym && sym->attr.intrinsic
3406 : 345904 : && !gfc_resolve_intrinsic (sym, &expr->where))
3407 : : return false;
3408 : :
3409 : 337563 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3410 : : {
3411 : 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3412 : 4 : return false;
3413 : : }
3414 : :
3415 : : /* If this is a deferred TBP with an abstract interface (which may
3416 : : of course be referenced), expr->value.function.esym will be set. */
3417 : 337230 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3418 : : {
3419 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3420 : : sym->name, &expr->where);
3421 : 1 : return false;
3422 : : }
3423 : :
3424 : : /* If this is a deferred TBP with an abstract interface, its result
3425 : : cannot be an assumed length character (F2003: C418). */
3426 : 337229 : if (sym && sym->attr.abstract && sym->attr.function
3427 : 191 : && sym->result->ts.u.cl
3428 : 157 : && sym->result->ts.u.cl->length == NULL
3429 : 2 : && !sym->result->ts.deferred)
3430 : : {
3431 : 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3432 : : "character length result (F2008: C418)", sym->name,
3433 : : &sym->declared_at);
3434 : 1 : return false;
3435 : : }
3436 : :
3437 : : /* Switch off assumed size checking and do this again for certain kinds
3438 : : of procedure, once the procedure itself is resolved. */
3439 : 337557 : need_full_assumed_size++;
3440 : :
3441 : 337557 : if (expr->symtree && expr->symtree->n.sym)
3442 : 337228 : p = expr->symtree->n.sym->attr.proc;
3443 : :
3444 : 337557 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3445 : 1078 : inquiry_argument = true;
3446 : 337228 : no_formal_args = sym && is_external_proc (sym)
3447 : 351086 : && gfc_sym_get_dummy_args (sym) == NULL;
3448 : :
3449 : 337557 : if (!resolve_actual_arglist (expr->value.function.actual,
3450 : : p, no_formal_args))
3451 : : {
3452 : 67 : inquiry_argument = false;
3453 : 67 : return false;
3454 : : }
3455 : :
3456 : 337490 : inquiry_argument = false;
3457 : :
3458 : : /* Resume assumed_size checking. */
3459 : 337490 : need_full_assumed_size--;
3460 : :
3461 : : /* If the procedure is external, check for usage. */
3462 : 337490 : if (sym && is_external_proc (sym))
3463 : 13509 : resolve_global_procedure (sym, &expr->where, 0);
3464 : :
3465 : 337490 : if (sym && sym->ts.type == BT_CHARACTER
3466 : 3231 : && sym->ts.u.cl
3467 : 3171 : && sym->ts.u.cl->length == NULL
3468 : 659 : && !sym->attr.dummy
3469 : 652 : && !sym->ts.deferred
3470 : 2 : && expr->value.function.esym == NULL
3471 : 2 : && !sym->attr.contained)
3472 : : {
3473 : : /* Internal procedures are taken care of in resolve_contained_fntype. */
3474 : 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3475 : : "be used at %L since it is not a dummy argument",
3476 : : sym->name, &expr->where);
3477 : 1 : return false;
3478 : : }
3479 : :
3480 : : /* Add and check formal interface when -fc-prototypes-external is in
3481 : : force, see comment in resolve_call(). */
3482 : :
3483 : 337489 : if (warn_external_argument_mismatch && sym && sym->attr.dummy
3484 : 18 : && sym->attr.external)
3485 : : {
3486 : 18 : if (sym->formal)
3487 : : {
3488 : 6 : bool conflict;
3489 : 6 : conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
3490 : : sym->formal, 0, 0, 0, NULL);
3491 : 6 : if (conflict)
3492 : : {
3493 : 6 : sym->ext_dummy_arglist_mismatch = 1;
3494 : 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
3495 : : "Different argument lists in external dummy "
3496 : : "function %s at %L and %L", sym->name,
3497 : : &expr->where, &sym->formal_at);
3498 : : }
3499 : : }
3500 : 12 : else if (!sym->formal_resolved)
3501 : : {
3502 : 6 : gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
3503 : 6 : sym->formal_at = expr->where;
3504 : : }
3505 : : }
3506 : : /* See if function is already resolved. */
3507 : :
3508 : 337489 : if (expr->value.function.name != NULL
3509 : 325808 : || expr->value.function.isym != NULL)
3510 : : {
3511 : 12467 : if (expr->ts.type == BT_UNKNOWN)
3512 : 3 : expr->ts = sym->ts;
3513 : : t = true;
3514 : : }
3515 : : else
3516 : : {
3517 : : /* Apply the rules of section 14.1.2. */
3518 : :
3519 : 325022 : switch (procedure_kind (sym))
3520 : : {
3521 : 26994 : case PTYPE_GENERIC:
3522 : 26994 : t = resolve_generic_f (expr);
3523 : 26994 : break;
3524 : :
3525 : 27627 : case PTYPE_SPECIFIC:
3526 : 27627 : t = resolve_specific_f (expr);
3527 : 27627 : break;
3528 : :
3529 : 270401 : case PTYPE_UNKNOWN:
3530 : 270401 : t = resolve_unknown_f (expr);
3531 : 270401 : break;
3532 : :
3533 : : default:
3534 : : gfc_internal_error ("resolve_function(): bad function type");
3535 : : }
3536 : : }
3537 : :
3538 : : /* If the expression is still a function (it might have simplified),
3539 : : then we check to see if we are calling an elemental function. */
3540 : :
3541 : 337489 : if (expr->expr_type != EXPR_FUNCTION)
3542 : : return t;
3543 : :
3544 : : /* Walk the argument list looking for invalid BOZ. */
3545 : 727623 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3546 : 488325 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3547 : : {
3548 : 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3549 : : "actual argument in a function reference",
3550 : : &arg->expr->where);
3551 : 5 : return false;
3552 : : }
3553 : :
3554 : 239298 : temp = need_full_assumed_size;
3555 : 239298 : need_full_assumed_size = 0;
3556 : :
3557 : 239298 : if (!resolve_elemental_actual (expr, NULL))
3558 : : return false;
3559 : :
3560 : 239295 : if (omp_workshare_flag
3561 : 32 : && expr->value.function.esym
3562 : 239300 : && ! gfc_elemental (expr->value.function.esym))
3563 : : {
3564 : 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3565 : 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3566 : : &expr->where);
3567 : 4 : t = false;
3568 : : }
3569 : :
3570 : : #define GENERIC_ID expr->value.function.isym->id
3571 : 239291 : else if (expr->value.function.actual != NULL
3572 : 231479 : && expr->value.function.isym != NULL
3573 : 186936 : && GENERIC_ID != GFC_ISYM_LBOUND
3574 : : && GENERIC_ID != GFC_ISYM_LCOBOUND
3575 : : && GENERIC_ID != GFC_ISYM_UCOBOUND
3576 : : && GENERIC_ID != GFC_ISYM_LEN
3577 : : && GENERIC_ID != GFC_ISYM_LOC
3578 : : && GENERIC_ID != GFC_ISYM_C_LOC
3579 : : && GENERIC_ID != GFC_ISYM_PRESENT)
3580 : : {
3581 : : /* Array intrinsics must also have the last upper bound of an
3582 : : assumed size array argument. UBOUND and SIZE have to be
3583 : : excluded from the check if the second argument is anything
3584 : : than a constant. */
3585 : :
3586 : 527777 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3587 : : {
3588 : 366219 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3589 : 45056 : && arg == expr->value.function.actual
3590 : 16622 : && arg->next != NULL && arg->next->expr)
3591 : : {
3592 : 8226 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3593 : : break;
3594 : :
3595 : 8002 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3596 : : break;
3597 : :
3598 : 8002 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3599 : 8002 : < arg->expr->rank)
3600 : : break;
3601 : : }
3602 : :
3603 : 363816 : if (arg->expr != NULL
3604 : 243565 : && arg->expr->rank > 0
3605 : 481625 : && resolve_assumed_size_actual (arg->expr))
3606 : : return false;
3607 : : }
3608 : : }
3609 : : #undef GENERIC_ID
3610 : :
3611 : 239292 : need_full_assumed_size = temp;
3612 : :
3613 : 239292 : if (!check_pure_function(expr))
3614 : 12 : t = false;
3615 : :
3616 : : /* Functions without the RECURSIVE attribution are not allowed to
3617 : : * call themselves. */
3618 : 239292 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3619 : : {
3620 : 50898 : gfc_symbol *esym;
3621 : 50898 : esym = expr->value.function.esym;
3622 : :
3623 : 50898 : if (is_illegal_recursion (esym, gfc_current_ns))
3624 : : {
3625 : 5 : if (esym->attr.entry && esym->ns->entries)
3626 : 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3627 : : " function %qs is not RECURSIVE",
3628 : 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3629 : : else
3630 : 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3631 : : " is not RECURSIVE", esym->name, &expr->where);
3632 : :
3633 : : t = false;
3634 : : }
3635 : : }
3636 : :
3637 : : /* Character lengths of use associated functions may contains references to
3638 : : symbols not referenced from the current program unit otherwise. Make sure
3639 : : those symbols are marked as referenced. */
3640 : :
3641 : 239292 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3642 : 3369 : && expr->value.function.esym->attr.use_assoc)
3643 : : {
3644 : 1238 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3645 : : }
3646 : :
3647 : : /* Make sure that the expression has a typespec that works. */
3648 : 239292 : if (expr->ts.type == BT_UNKNOWN)
3649 : : {
3650 : 890 : if (expr->symtree->n.sym->result
3651 : 881 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3652 : 559 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3653 : 559 : expr->ts = expr->symtree->n.sym->result->ts;
3654 : : }
3655 : :
3656 : : /* These derived types with an incomplete namespace, arising from use
3657 : : association, cause gfc_get_derived_vtab to segfault. If the function
3658 : : namespace does not suffice, something is badly wrong. */
3659 : 239292 : if (expr->ts.type == BT_DERIVED
3660 : 9003 : && !expr->ts.u.derived->ns->proc_name)
3661 : : {
3662 : 3 : gfc_symbol *der;
3663 : 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3664 : 3 : if (der)
3665 : : {
3666 : 3 : expr->ts.u.derived->refs--;
3667 : 3 : expr->ts.u.derived = der;
3668 : 3 : der->refs++;
3669 : : }
3670 : : else
3671 : 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3672 : : }
3673 : :
3674 : 239292 : if (!expr->ref && !expr->value.function.isym)
3675 : : {
3676 : 52235 : if (expr->value.function.esym)
3677 : 51198 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3678 : : else
3679 : 1037 : update_current_proc_array_outer_dependency (sym);
3680 : : }
3681 : 187057 : else if (expr->ref)
3682 : : /* typebound procedure: Assume the worst. */
3683 : 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3684 : :
3685 : 239292 : if (expr->value.function.esym
3686 : 51198 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3687 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
3688 : : "Using function %qs at %L is deprecated",
3689 : : sym->name, &expr->where);
3690 : : return t;
3691 : : }
3692 : :
3693 : :
3694 : : /************* Subroutine resolution *************/
3695 : :
3696 : : static bool
3697 : 75526 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3698 : : {
3699 : 75526 : code_stack *stack;
3700 : 75526 : bool saw_block = false;
3701 : :
3702 : 75526 : if (gfc_pure (sym))
3703 : : return true;
3704 : :
3705 : : /* A BLOCK construct within a DO CONCURRENT construct leads to
3706 : : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3707 : : occurs. Walk up the stack to see if the source code has a nested
3708 : : construct. */
3709 : :
3710 : 156302 : for (stack = cs_base; stack; stack = stack->prev)
3711 : : {
3712 : 86181 : if (stack->current->op == EXEC_BLOCK)
3713 : : {
3714 : 1877 : saw_block = true;
3715 : 1877 : continue;
3716 : : }
3717 : :
3718 : 84304 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3719 : : {
3720 : :
3721 : 2 : bool is_pure = true;
3722 : 86181 : is_pure = sym->attr.pure || sym->attr.elemental;
3723 : :
3724 : 2 : if (!is_pure)
3725 : : {
3726 : 2 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3727 : : "is not PURE", loc);
3728 : 2 : return false;
3729 : : }
3730 : : }
3731 : : }
3732 : :
3733 : 70121 : if (forall_flag)
3734 : : {
3735 : 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3736 : : name, loc);
3737 : 0 : return false;
3738 : : }
3739 : 70121 : else if (gfc_do_concurrent_flag)
3740 : : {
3741 : 6 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3742 : : "PURE", name, loc);
3743 : 6 : return false;
3744 : : }
3745 : 70115 : else if (gfc_pure (NULL))
3746 : : {
3747 : 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3748 : 4 : return false;
3749 : : }
3750 : :
3751 : 70111 : gfc_unset_implicit_pure (NULL);
3752 : 70111 : return true;
3753 : : }
3754 : :
3755 : :
3756 : : static match
3757 : 2219 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3758 : : {
3759 : 2219 : gfc_symbol *s;
3760 : :
3761 : 2219 : if (sym->attr.generic)
3762 : : {
3763 : 2218 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3764 : 2218 : if (s != NULL)
3765 : : {
3766 : 2209 : c->resolved_sym = s;
3767 : 2209 : if (!pure_subroutine (s, s->name, &c->loc))
3768 : : return MATCH_ERROR;
3769 : 2209 : return MATCH_YES;
3770 : : }
3771 : :
3772 : : /* TODO: Need to search for elemental references in generic interface. */
3773 : : }
3774 : :
3775 : 10 : if (sym->attr.intrinsic)
3776 : 1 : return gfc_intrinsic_sub_interface (c, 0);
3777 : :
3778 : : return MATCH_NO;
3779 : : }
3780 : :
3781 : :
3782 : : static bool
3783 : 2217 : resolve_generic_s (gfc_code *c)
3784 : : {
3785 : 2217 : gfc_symbol *sym;
3786 : 2217 : match m;
3787 : :
3788 : 2217 : sym = c->symtree->n.sym;
3789 : :
3790 : 2219 : for (;;)
3791 : : {
3792 : 2219 : m = resolve_generic_s0 (c, sym);
3793 : 2219 : if (m == MATCH_YES)
3794 : : return true;
3795 : 9 : else if (m == MATCH_ERROR)
3796 : : return false;
3797 : :
3798 : 9 : generic:
3799 : 9 : if (sym->ns->parent == NULL)
3800 : : break;
3801 : 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3802 : :
3803 : 3 : if (sym == NULL)
3804 : : break;
3805 : 2 : if (!generic_sym (sym))
3806 : 0 : goto generic;
3807 : : }
3808 : :
3809 : : /* Last ditch attempt. See if the reference is to an intrinsic
3810 : : that possesses a matching interface. 14.1.2.4 */
3811 : 7 : sym = c->symtree->n.sym;
3812 : :
3813 : 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3814 : : {
3815 : 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3816 : : sym->name, &c->loc);
3817 : 4 : return false;
3818 : : }
3819 : :
3820 : 3 : m = gfc_intrinsic_sub_interface (c, 0);
3821 : 3 : if (m == MATCH_YES)
3822 : : return true;
3823 : 1 : if (m == MATCH_NO)
3824 : 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3825 : : "intrinsic subroutine interface", sym->name, &c->loc);
3826 : :
3827 : : return false;
3828 : : }
3829 : :
3830 : :
3831 : : /* Resolve a subroutine call known to be specific. */
3832 : :
3833 : : static match
3834 : 61691 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3835 : : {
3836 : 61691 : match m;
3837 : :
3838 : 61691 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3839 : : {
3840 : 5625 : if (sym->attr.dummy)
3841 : : {
3842 : 256 : sym->attr.proc = PROC_DUMMY;
3843 : 256 : goto found;
3844 : : }
3845 : :
3846 : 5369 : sym->attr.proc = PROC_EXTERNAL;
3847 : 5369 : goto found;
3848 : : }
3849 : :
3850 : 56066 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3851 : 56066 : goto found;
3852 : :
3853 : 0 : if (sym->attr.intrinsic)
3854 : : {
3855 : 0 : m = gfc_intrinsic_sub_interface (c, 1);
3856 : 0 : if (m == MATCH_YES)
3857 : : return MATCH_YES;
3858 : 0 : if (m == MATCH_NO)
3859 : 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3860 : : "with an intrinsic", sym->name, &c->loc);
3861 : :
3862 : 0 : return MATCH_ERROR;
3863 : : }
3864 : :
3865 : : return MATCH_NO;
3866 : :
3867 : 61691 : found:
3868 : 61691 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3869 : :
3870 : 61691 : c->resolved_sym = sym;
3871 : 61691 : if (!pure_subroutine (sym, sym->name, &c->loc))
3872 : : return MATCH_ERROR;
3873 : :
3874 : : return MATCH_YES;
3875 : : }
3876 : :
3877 : :
3878 : : static bool
3879 : 61691 : resolve_specific_s (gfc_code *c)
3880 : : {
3881 : 61691 : gfc_symbol *sym;
3882 : 61691 : match m;
3883 : :
3884 : 61691 : sym = c->symtree->n.sym;
3885 : :
3886 : 61691 : for (;;)
3887 : : {
3888 : 61691 : m = resolve_specific_s0 (c, sym);
3889 : 61691 : if (m == MATCH_YES)
3890 : : return true;
3891 : 7 : if (m == MATCH_ERROR)
3892 : : return false;
3893 : :
3894 : 0 : if (sym->ns->parent == NULL)
3895 : : break;
3896 : :
3897 : 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3898 : :
3899 : 0 : if (sym == NULL)
3900 : : break;
3901 : : }
3902 : :
3903 : 0 : sym = c->symtree->n.sym;
3904 : 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3905 : : sym->name, &c->loc);
3906 : :
3907 : 0 : return false;
3908 : : }
3909 : :
3910 : :
3911 : : /* Resolve a subroutine call not known to be generic nor specific. */
3912 : :
3913 : : static bool
3914 : 15530 : resolve_unknown_s (gfc_code *c)
3915 : : {
3916 : 15530 : gfc_symbol *sym;
3917 : :
3918 : 15530 : sym = c->symtree->n.sym;
3919 : :
3920 : 15530 : if (sym->attr.dummy)
3921 : : {
3922 : 20 : sym->attr.proc = PROC_DUMMY;
3923 : 20 : goto found;
3924 : : }
3925 : :
3926 : : /* See if we have an intrinsic function reference. */
3927 : :
3928 : 15510 : if (gfc_is_intrinsic (sym, 1, c->loc))
3929 : : {
3930 : 4026 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3931 : : return true;
3932 : 309 : return false;
3933 : : }
3934 : :
3935 : : /* The reference is to an external name. */
3936 : :
3937 : 11484 : found:
3938 : 11504 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3939 : :
3940 : 11504 : c->resolved_sym = sym;
3941 : :
3942 : 11504 : return pure_subroutine (sym, sym->name, &c->loc);
3943 : : }
3944 : :
3945 : :
3946 : :
3947 : : static bool
3948 : 805 : check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e,
3949 : : gfc_code *c, gfc_namespace *ns)
3950 : : {
3951 : 805 : locus *here;
3952 : :
3953 : : /* If the type has been imported then its vtype functions are OK. */
3954 : 805 : if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype)
3955 : : return true;
3956 : :
3957 : : if (e)
3958 : 791 : here = &e->where;
3959 : : else
3960 : 7 : here = &c->loc;
3961 : :
3962 : 798 : if (s && !s->import_only)
3963 : 705 : s = gfc_find_symtree (ns->sym_root, sym->name);
3964 : :
3965 : 798 : if (ns->import_state == IMPORT_ONLY
3966 : 75 : && sym->ns != ns
3967 : 58 : && (!s || !s->import_only))
3968 : : {
3969 : 21 : gfc_error ("F2018: C8102 %qs at %L is host associated but does not "
3970 : : "appear in an IMPORT or IMPORT, ONLY list", sym->name, here);
3971 : 21 : return false;
3972 : : }
3973 : 777 : else if (ns->import_state == IMPORT_NONE
3974 : 27 : && sym->ns != ns)
3975 : : {
3976 : 12 : gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that "
3977 : : "has IMPORT, NONE", sym->name, here);
3978 : 12 : return false;
3979 : : }
3980 : : return true;
3981 : : }
3982 : :
3983 : :
3984 : : static bool
3985 : 6919 : check_import_status (gfc_expr *e)
3986 : : {
3987 : 6919 : gfc_symtree *st;
3988 : 6919 : gfc_ref *ref;
3989 : 6919 : gfc_symbol *sym, *der;
3990 : 6919 : gfc_namespace *ns = gfc_current_ns;
3991 : :
3992 : 6919 : switch (e->expr_type)
3993 : : {
3994 : 727 : case EXPR_VARIABLE:
3995 : 727 : case EXPR_FUNCTION:
3996 : 727 : case EXPR_SUBSTRING:
3997 : 727 : sym = e->symtree ? e->symtree->n.sym : NULL;
3998 : :
3999 : : /* Check the symbol itself. */
4000 : 727 : if (sym
4001 : 727 : && !(ns->proc_name
4002 : : && (sym == ns->proc_name))
4003 : 1450 : && !check_sym_import_status (sym, e->symtree, e, NULL, ns))
4004 : : return false;
4005 : :
4006 : : /* Check the declared derived type. */
4007 : 717 : if (sym->ts.type == BT_DERIVED)
4008 : : {
4009 : 16 : der = sym->ts.u.derived;
4010 : 16 : st = gfc_find_symtree (ns->sym_root, der->name);
4011 : :
4012 : 16 : if (!check_sym_import_status (der, st, e, NULL, ns))
4013 : : return false;
4014 : : }
4015 : 701 : else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym))
4016 : : {
4017 : 44 : der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived
4018 : : : sym->ts.u.derived;
4019 : 44 : st = gfc_find_symtree (ns->sym_root, der->name);
4020 : :
4021 : 44 : if (!check_sym_import_status (der, st, e, NULL, ns))
4022 : : return false;
4023 : : }
4024 : :
4025 : : /* Check the declared derived types of component references. */
4026 : 724 : for (ref = e->ref; ref; ref = ref->next)
4027 : 20 : if (ref->type == REF_COMPONENT)
4028 : : {
4029 : 19 : gfc_component *c = ref->u.c.component;
4030 : 19 : if (c->ts.type == BT_DERIVED)
4031 : : {
4032 : 7 : der = c->ts.u.derived;
4033 : 7 : st = gfc_find_symtree (ns->sym_root, der->name);
4034 : 7 : if (!check_sym_import_status (der, st, e, NULL, ns))
4035 : : return false;
4036 : : }
4037 : 12 : else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c))
4038 : : {
4039 : 0 : der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived
4040 : : : c->ts.u.derived;
4041 : 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4042 : 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4043 : : return false;
4044 : : }
4045 : : }
4046 : :
4047 : : break;
4048 : :
4049 : 8 : case EXPR_ARRAY:
4050 : 8 : case EXPR_STRUCTURE:
4051 : : /* Check the declared derived type. */
4052 : 8 : if (e->ts.type == BT_DERIVED)
4053 : : {
4054 : 8 : der = e->ts.u.derived;
4055 : 8 : st = gfc_find_symtree (ns->sym_root, der->name);
4056 : :
4057 : 8 : if (!check_sym_import_status (der, st, e, NULL, ns))
4058 : : return false;
4059 : : }
4060 : 0 : else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e))
4061 : : {
4062 : 0 : der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived
4063 : : : e->ts.u.derived;
4064 : 0 : st = gfc_find_symtree (ns->sym_root, der->name);
4065 : :
4066 : 0 : if (!check_sym_import_status (der, st, e, NULL, ns))
4067 : : return false;
4068 : : }
4069 : :
4070 : : break;
4071 : :
4072 : : /* Either not applicable or resolved away
4073 : : case EXPR_OP:
4074 : : case EXPR_UNKNOWN:
4075 : : case EXPR_CONSTANT:
4076 : : case EXPR_NULL:
4077 : : case EXPR_COMPCALL:
4078 : : case EXPR_PPC: */
4079 : :
4080 : : default:
4081 : : break;
4082 : : }
4083 : :
4084 : : return true;
4085 : : }
4086 : :
4087 : :
4088 : : /* Resolve a subroutine call. Although it was tempting to use the same code
4089 : : for functions, subroutines and functions are stored differently and this
4090 : : makes things awkward. */
4091 : :
4092 : :
4093 : : static bool
4094 : 79528 : resolve_call (gfc_code *c)
4095 : : {
4096 : 79528 : bool t;
4097 : 79528 : procedure_type ptype = PROC_INTRINSIC;
4098 : 79528 : gfc_symbol *csym, *sym;
4099 : 79528 : bool no_formal_args;
4100 : :
4101 : 79528 : csym = c->symtree ? c->symtree->n.sym : NULL;
4102 : :
4103 : 79528 : if (csym && csym->ts.type != BT_UNKNOWN)
4104 : : {
4105 : 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
4106 : : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
4107 : 4 : return false;
4108 : : }
4109 : :
4110 : 79524 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
4111 : : {
4112 : 16724 : gfc_symtree *st;
4113 : 16724 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
4114 : 16724 : sym = st ? st->n.sym : NULL;
4115 : 16724 : if (sym && csym != sym
4116 : 3 : && sym->ns == gfc_current_ns
4117 : 3 : && sym->attr.flavor == FL_PROCEDURE
4118 : 3 : && sym->attr.contained)
4119 : : {
4120 : 3 : sym->refs++;
4121 : 3 : if (csym->attr.generic)
4122 : 2 : c->symtree->n.sym = sym;
4123 : : else
4124 : 1 : c->symtree = st;
4125 : 3 : csym = c->symtree->n.sym;
4126 : : }
4127 : : }
4128 : :
4129 : : /* If this ia a deferred TBP, c->expr1 will be set. */
4130 : 79524 : if (!c->expr1 && csym)
4131 : : {
4132 : 77863 : if (csym->attr.abstract)
4133 : : {
4134 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
4135 : : csym->name, &c->loc);
4136 : 1 : return false;
4137 : : }
4138 : :
4139 : : /* Subroutines without the RECURSIVE attribution are not allowed to
4140 : : call themselves. */
4141 : 77862 : if (is_illegal_recursion (csym, gfc_current_ns))
4142 : : {
4143 : 4 : if (csym->attr.entry && csym->ns->entries)
4144 : 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
4145 : : "as subroutine %qs is not RECURSIVE",
4146 : 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
4147 : : else
4148 : 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
4149 : : "as it is not RECURSIVE", csym->name, &c->loc);
4150 : :
4151 : 79523 : t = false;
4152 : : }
4153 : : }
4154 : :
4155 : : /* Switch off assumed size checking and do this again for certain kinds
4156 : : of procedure, once the procedure itself is resolved. */
4157 : 79523 : need_full_assumed_size++;
4158 : :
4159 : 79523 : if (csym)
4160 : 79523 : ptype = csym->attr.proc;
4161 : :
4162 : 79523 : no_formal_args = csym && is_external_proc (csym)
4163 : 15538 : && gfc_sym_get_dummy_args (csym) == NULL;
4164 : 79523 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
4165 : : return false;
4166 : :
4167 : : /* Resume assumed_size checking. */
4168 : 79489 : need_full_assumed_size--;
4169 : :
4170 : : /* If external, check for usage. */
4171 : 79489 : if (csym && is_external_proc (csym))
4172 : 15532 : resolve_global_procedure (csym, &c->loc, 1);
4173 : :
4174 : : /* If we have an external dummy argument, we want to write out its arguments
4175 : : with -fc-prototypes-external. Code like
4176 : :
4177 : : subroutine foo(a,n)
4178 : : external a
4179 : : if (n == 1) call a(1)
4180 : : if (n == 2) call a(2,3)
4181 : : end subroutine foo
4182 : :
4183 : : is actually legal Fortran, but it is not possible to generate a C23-
4184 : : compliant prototype for this, so we just record the fact here and
4185 : : handle that during -fc-prototypes-external processing. */
4186 : :
4187 : 79489 : if (warn_external_argument_mismatch && csym && csym->attr.dummy
4188 : 14 : && csym->attr.external)
4189 : : {
4190 : 14 : if (csym->formal)
4191 : : {
4192 : 6 : bool conflict;
4193 : 6 : conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
4194 : : 0, 0, 0, NULL);
4195 : 6 : if (conflict)
4196 : : {
4197 : 6 : csym->ext_dummy_arglist_mismatch = 1;
4198 : 6 : gfc_warning (OPT_Wexternal_argument_mismatch,
4199 : : "Different argument lists in external dummy "
4200 : : "subroutine %s at %L and %L", csym->name,
4201 : : &c->loc, &csym->formal_at);
4202 : : }
4203 : : }
4204 : 8 : else if (!csym->formal_resolved)
4205 : : {
4206 : 7 : gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
4207 : 7 : csym->formal_at = c->loc;
4208 : : }
4209 : : }
4210 : :
4211 : 79489 : t = true;
4212 : 79489 : if (c->resolved_sym == NULL)
4213 : : {
4214 : 79438 : c->resolved_isym = NULL;
4215 : 79438 : switch (procedure_kind (csym))
4216 : : {
4217 : 2217 : case PTYPE_GENERIC:
4218 : 2217 : t = resolve_generic_s (c);
4219 : 2217 : break;
4220 : :
4221 : 61691 : case PTYPE_SPECIFIC:
4222 : 61691 : t = resolve_specific_s (c);
4223 : 61691 : break;
4224 : :
4225 : 15530 : case PTYPE_UNKNOWN:
4226 : 15530 : t = resolve_unknown_s (c);
4227 : 15530 : break;
4228 : :
4229 : : default:
4230 : : gfc_internal_error ("resolve_subroutine(): bad function type");
4231 : : }
4232 : : }
4233 : :
4234 : : /* Some checks of elemental subroutine actual arguments. */
4235 : 79488 : if (!resolve_elemental_actual (NULL, c))
4236 : : return false;
4237 : :
4238 : 79480 : if (!c->expr1)
4239 : 77819 : update_current_proc_array_outer_dependency (csym);
4240 : : else
4241 : : /* Typebound procedure: Assume the worst. */
4242 : 1661 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
4243 : :
4244 : 79480 : if (c->resolved_sym
4245 : 79167 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
4246 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
4247 : : "Using subroutine %qs at %L is deprecated",
4248 : : c->resolved_sym->name, &c->loc);
4249 : :
4250 : 79480 : csym = c->resolved_sym ? c->resolved_sym : csym;
4251 : 79480 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym
4252 : 2 : && csym != gfc_current_ns->proc_name)
4253 : 1 : return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns);
4254 : :
4255 : : return t;
4256 : : }
4257 : :
4258 : :
4259 : : /* Compare the shapes of two arrays that have non-NULL shapes. If both
4260 : : op1->shape and op2->shape are non-NULL return true if their shapes
4261 : : match. If both op1->shape and op2->shape are non-NULL return false
4262 : : if their shapes do not match. If either op1->shape or op2->shape is
4263 : : NULL, return true. */
4264 : :
4265 : : static bool
4266 : 31691 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
4267 : : {
4268 : 31691 : bool t;
4269 : 31691 : int i;
4270 : :
4271 : 31691 : t = true;
4272 : :
4273 : 31691 : if (op1->shape != NULL && op2->shape != NULL)
4274 : : {
4275 : 42560 : for (i = 0; i < op1->rank; i++)
4276 : : {
4277 : 22704 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
4278 : : {
4279 : 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
4280 : : &op1->where, &op2->where);
4281 : 3 : t = false;
4282 : 3 : break;
4283 : : }
4284 : : }
4285 : : }
4286 : :
4287 : 31691 : return t;
4288 : : }
4289 : :
4290 : : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4291 : : For example A .AND. B becomes IAND(A, B). */
4292 : : static gfc_expr *
4293 : 668 : logical_to_bitwise (gfc_expr *e)
4294 : : {
4295 : 668 : gfc_expr *tmp, *op1, *op2;
4296 : 668 : gfc_isym_id isym;
4297 : 668 : gfc_actual_arglist *args = NULL;
4298 : :
4299 : 668 : gcc_assert (e->expr_type == EXPR_OP);
4300 : :
4301 : 668 : isym = GFC_ISYM_NONE;
4302 : 668 : op1 = e->value.op.op1;
4303 : 668 : op2 = e->value.op.op2;
4304 : :
4305 : 668 : switch (e->value.op.op)
4306 : : {
4307 : : case INTRINSIC_NOT:
4308 : : isym = GFC_ISYM_NOT;
4309 : : break;
4310 : 126 : case INTRINSIC_AND:
4311 : 126 : isym = GFC_ISYM_IAND;
4312 : 126 : break;
4313 : 127 : case INTRINSIC_OR:
4314 : 127 : isym = GFC_ISYM_IOR;
4315 : 127 : break;
4316 : 270 : case INTRINSIC_NEQV:
4317 : 270 : isym = GFC_ISYM_IEOR;
4318 : 270 : break;
4319 : 126 : case INTRINSIC_EQV:
4320 : : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4321 : : Change the old expression to NEQV, which will get replaced by IEOR,
4322 : : and wrap it in NOT. */
4323 : 126 : tmp = gfc_copy_expr (e);
4324 : 126 : tmp->value.op.op = INTRINSIC_NEQV;
4325 : 126 : tmp = logical_to_bitwise (tmp);
4326 : 126 : isym = GFC_ISYM_NOT;
4327 : 126 : op1 = tmp;
4328 : 126 : op2 = NULL;
4329 : 126 : break;
4330 : 0 : default:
4331 : 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4332 : : }
4333 : :
4334 : : /* Inherit the original operation's operands as arguments. */
4335 : 668 : args = gfc_get_actual_arglist ();
4336 : 668 : args->expr = op1;
4337 : 668 : if (op2)
4338 : : {
4339 : 523 : args->next = gfc_get_actual_arglist ();
4340 : 523 : args->next->expr = op2;
4341 : : }
4342 : :
4343 : : /* Convert the expression to a function call. */
4344 : 668 : e->expr_type = EXPR_FUNCTION;
4345 : 668 : e->value.function.actual = args;
4346 : 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4347 : 668 : e->value.function.name = e->value.function.isym->name;
4348 : 668 : e->value.function.esym = NULL;
4349 : :
4350 : : /* Make up a pre-resolved function call symtree if we need to. */
4351 : 668 : if (!e->symtree || !e->symtree->n.sym)
4352 : : {
4353 : 668 : gfc_symbol *sym;
4354 : 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4355 : 668 : sym = e->symtree->n.sym;
4356 : 668 : sym->result = sym;
4357 : 668 : sym->attr.flavor = FL_PROCEDURE;
4358 : 668 : sym->attr.function = 1;
4359 : 668 : sym->attr.elemental = 1;
4360 : 668 : sym->attr.pure = 1;
4361 : 668 : sym->attr.referenced = 1;
4362 : 668 : gfc_intrinsic_symbol (sym);
4363 : 668 : gfc_commit_symbol (sym);
4364 : : }
4365 : :
4366 : 668 : args->name = e->value.function.isym->formal->name;
4367 : 668 : if (e->value.function.isym->formal->next)
4368 : 523 : args->next->name = e->value.function.isym->formal->next->name;
4369 : :
4370 : 668 : return e;
4371 : : }
4372 : :
4373 : : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4374 : : candidates in CANDIDATES_LEN. */
4375 : : static void
4376 : 69 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4377 : : char **&candidates,
4378 : : size_t &candidates_len)
4379 : : {
4380 : 71 : gfc_symtree *p;
4381 : :
4382 : 71 : if (uop == NULL)
4383 : : return;
4384 : :
4385 : : /* Not sure how to properly filter here. Use all for a start.
4386 : : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4387 : : these as i suppose they don't make terribly sense. */
4388 : :
4389 : 71 : if (uop->n.uop->op != NULL)
4390 : 2 : vec_push (candidates, candidates_len, uop->name);
4391 : :
4392 : 71 : p = uop->left;
4393 : 71 : if (p)
4394 : 0 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4395 : :
4396 : 71 : p = uop->right;
4397 : 71 : if (p)
4398 : : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4399 : : }
4400 : :
4401 : : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4402 : :
4403 : : static const char*
4404 : 69 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4405 : : {
4406 : 69 : char **candidates = NULL;
4407 : 69 : size_t candidates_len = 0;
4408 : 69 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4409 : 69 : return gfc_closest_fuzzy_match (op, candidates);
4410 : : }
4411 : :
4412 : :
4413 : : /* Callback finding an impure function as an operand to an .and. or
4414 : : .or. expression. Remember the last function warned about to
4415 : : avoid double warnings when recursing. */
4416 : :
4417 : : static int
4418 : 190935 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4419 : : void *data)
4420 : : {
4421 : 190935 : gfc_expr *f = *e;
4422 : 190935 : const char *name;
4423 : 190935 : static gfc_expr *last = NULL;
4424 : 190935 : bool *found = (bool *) data;
4425 : :
4426 : 190935 : if (f->expr_type == EXPR_FUNCTION)
4427 : : {
4428 : 11708 : *found = 1;
4429 : 11708 : if (f != last && !gfc_pure_function (f, &name)
4430 : 12983 : && !gfc_implicit_pure_function (f))
4431 : : {
4432 : 1136 : if (name)
4433 : 1136 : gfc_warning (OPT_Wfunction_elimination,
4434 : : "Impure function %qs at %L might not be evaluated",
4435 : : name, &f->where);
4436 : : else
4437 : 0 : gfc_warning (OPT_Wfunction_elimination,
4438 : : "Impure function at %L might not be evaluated",
4439 : : &f->where);
4440 : : }
4441 : 11708 : last = f;
4442 : : }
4443 : :
4444 : 190935 : return 0;
4445 : : }
4446 : :
4447 : : /* Return true if TYPE is character based, false otherwise. */
4448 : :
4449 : : static int
4450 : 1373 : is_character_based (bt type)
4451 : : {
4452 : 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4453 : : }
4454 : :
4455 : :
4456 : : /* If expression is a hollerith, convert it to character and issue a warning
4457 : : for the conversion. */
4458 : :
4459 : : static void
4460 : 408 : convert_hollerith_to_character (gfc_expr *e)
4461 : : {
4462 : 408 : if (e->ts.type == BT_HOLLERITH)
4463 : : {
4464 : 108 : gfc_typespec t;
4465 : 108 : gfc_clear_ts (&t);
4466 : 108 : t.type = BT_CHARACTER;
4467 : 108 : t.kind = e->ts.kind;
4468 : 108 : gfc_convert_type_warn (e, &t, 2, 1);
4469 : : }
4470 : 408 : }
4471 : :
4472 : : /* Convert to numeric and issue a warning for the conversion. */
4473 : :
4474 : : static void
4475 : 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4476 : : {
4477 : 240 : gfc_typespec t;
4478 : 240 : gfc_clear_ts (&t);
4479 : 240 : t.type = b->ts.type;
4480 : 240 : t.kind = b->ts.kind;
4481 : 240 : gfc_convert_type_warn (a, &t, 2, 1);
4482 : 240 : }
4483 : :
4484 : : /* Resolve an operator expression node. This can involve replacing the
4485 : : operation with a user defined function call. CHECK_INTERFACES is a
4486 : : helper macro. */
4487 : :
4488 : : #define CHECK_INTERFACES \
4489 : : { \
4490 : : match m = gfc_extend_expr (e); \
4491 : : if (m == MATCH_YES) \
4492 : : return true; \
4493 : : if (m == MATCH_ERROR) \
4494 : : return false; \
4495 : : }
4496 : :
4497 : : static bool
4498 : 520814 : resolve_operator (gfc_expr *e)
4499 : : {
4500 : 520814 : gfc_expr *op1, *op2;
4501 : : /* One error uses 3 names; additional space for wording (also via gettext). */
4502 : 520814 : bool t = true;
4503 : :
4504 : : /* Reduce stacked parentheses to single pair */
4505 : 520814 : while (e->expr_type == EXPR_OP
4506 : 520936 : && e->value.op.op == INTRINSIC_PARENTHESES
4507 : 20596 : && e->value.op.op1->expr_type == EXPR_OP
4508 : 537224 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4509 : : {
4510 : 122 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4511 : 122 : gfc_replace_expr (e, tmp);
4512 : : }
4513 : :
4514 : : /* Resolve all subnodes-- give them types. */
4515 : :
4516 : 520814 : switch (e->value.op.op)
4517 : : {
4518 : 471976 : default:
4519 : 471976 : if (!gfc_resolve_expr (e->value.op.op2))
4520 : 520814 : t = false;
4521 : :
4522 : : /* Fall through. */
4523 : :
4524 : 520814 : case INTRINSIC_NOT:
4525 : 520814 : case INTRINSIC_UPLUS:
4526 : 520814 : case INTRINSIC_UMINUS:
4527 : 520814 : case INTRINSIC_PARENTHESES:
4528 : 520814 : if (!gfc_resolve_expr (e->value.op.op1))
4529 : : return false;
4530 : 520646 : if (e->value.op.op1
4531 : 520637 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4532 : : {
4533 : 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4534 : 0 : "unary operator %qs", &e->value.op.op1->where,
4535 : : gfc_op2string (e->value.op.op));
4536 : 0 : return false;
4537 : : }
4538 : 520646 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4539 : 6 : && e->value.op.op == INTRINSIC_UMINUS)
4540 : : {
4541 : 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4542 : : &e->value.op.op1->where);
4543 : 2 : return false;
4544 : : }
4545 : 520644 : break;
4546 : : }
4547 : :
4548 : : /* Typecheck the new node. */
4549 : :
4550 : 520644 : op1 = e->value.op.op1;
4551 : 520644 : op2 = e->value.op.op2;
4552 : 520644 : if (op1 == NULL && op2 == NULL)
4553 : : return false;
4554 : : /* Error out if op2 did not resolve. We already diagnosed op1. */
4555 : 520635 : if (t == false)
4556 : : return false;
4557 : :
4558 : : /* op1 and op2 cannot both be BOZ. */
4559 : 520569 : if (op1 && op1->ts.type == BT_BOZ
4560 : 0 : && op2 && op2->ts.type == BT_BOZ)
4561 : : {
4562 : 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4563 : 0 : "binary operator %qs", &op1->where, &op2->where,
4564 : : gfc_op2string (e->value.op.op));
4565 : 0 : return false;
4566 : : }
4567 : :
4568 : 520569 : if ((op1 && op1->expr_type == EXPR_NULL)
4569 : 520567 : || (op2 && op2->expr_type == EXPR_NULL))
4570 : : {
4571 : 3 : CHECK_INTERFACES
4572 : 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4573 : 3 : return false;
4574 : : }
4575 : :
4576 : 520566 : switch (e->value.op.op)
4577 : : {
4578 : 8027 : case INTRINSIC_UPLUS:
4579 : 8027 : case INTRINSIC_UMINUS:
4580 : 8027 : if (op1->ts.type == BT_INTEGER
4581 : : || op1->ts.type == BT_REAL
4582 : : || op1->ts.type == BT_COMPLEX
4583 : : || op1->ts.type == BT_UNSIGNED)
4584 : : {
4585 : 7958 : e->ts = op1->ts;
4586 : 7958 : break;
4587 : : }
4588 : :
4589 : 69 : CHECK_INTERFACES
4590 : 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4591 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4592 : 43 : return false;
4593 : :
4594 : 151882 : case INTRINSIC_POWER:
4595 : 151882 : case INTRINSIC_PLUS:
4596 : 151882 : case INTRINSIC_MINUS:
4597 : 151882 : case INTRINSIC_TIMES:
4598 : 151882 : case INTRINSIC_DIVIDE:
4599 : :
4600 : : /* UNSIGNED cannot appear in a mixed expression without explicit
4601 : : conversion. */
4602 : 151882 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4603 : : {
4604 : 3 : CHECK_INTERFACES
4605 : 3 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4606 : : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4607 : : gfc_typename (op1), gfc_typename (op2));
4608 : 3 : return false;
4609 : : }
4610 : :
4611 : 151879 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4612 : : {
4613 : : /* Do not perform conversions if operands are not conformable as
4614 : : required for the binary intrinsic operators (F2018:10.1.5).
4615 : : Defer to a possibly overloading user-defined operator. */
4616 : 151423 : if (!gfc_op_rank_conformable (op1, op2))
4617 : : {
4618 : 36 : CHECK_INTERFACES
4619 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4620 : 0 : &op1->where, &op2->where);
4621 : 0 : return false;
4622 : : }
4623 : :
4624 : 151387 : gfc_type_convert_binary (e, 1);
4625 : 151387 : break;
4626 : : }
4627 : :
4628 : 456 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4629 : : {
4630 : 227 : CHECK_INTERFACES
4631 : 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4632 : : "numeric operator %qs at %L",
4633 : : gfc_op2string (e->value.op.op), &e->where);
4634 : 2 : return false;
4635 : : }
4636 : : else
4637 : : {
4638 : 229 : CHECK_INTERFACES
4639 : 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4640 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4641 : : gfc_typename (op2));
4642 : 3 : return false;
4643 : : }
4644 : :
4645 : 2250 : case INTRINSIC_CONCAT:
4646 : 2250 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4647 : 2225 : && op1->ts.kind == op2->ts.kind)
4648 : : {
4649 : 2216 : e->ts.type = BT_CHARACTER;
4650 : 2216 : e->ts.kind = op1->ts.kind;
4651 : 2216 : break;
4652 : : }
4653 : :
4654 : 34 : CHECK_INTERFACES
4655 : 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4656 : : &e->where, gfc_typename (op1), gfc_typename (op2));
4657 : 10 : return false;
4658 : :
4659 : 69038 : case INTRINSIC_AND:
4660 : 69038 : case INTRINSIC_OR:
4661 : 69038 : case INTRINSIC_EQV:
4662 : 69038 : case INTRINSIC_NEQV:
4663 : 69038 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4664 : : {
4665 : 68487 : e->ts.type = BT_LOGICAL;
4666 : 68487 : e->ts.kind = gfc_kind_max (op1, op2);
4667 : 68487 : if (op1->ts.kind < e->ts.kind)
4668 : 138 : gfc_convert_type (op1, &e->ts, 2);
4669 : 68349 : else if (op2->ts.kind < e->ts.kind)
4670 : 117 : gfc_convert_type (op2, &e->ts, 2);
4671 : :
4672 : 68487 : if (flag_frontend_optimize &&
4673 : 57470 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4674 : : {
4675 : : /* Warn about short-circuiting
4676 : : with impure function as second operand. */
4677 : 51494 : bool op2_f = false;
4678 : 51494 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4679 : : }
4680 : : break;
4681 : : }
4682 : :
4683 : : /* Logical ops on integers become bitwise ops with -fdec. */
4684 : 551 : else if (flag_dec
4685 : 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4686 : : {
4687 : 523 : e->ts.type = BT_INTEGER;
4688 : 523 : e->ts.kind = gfc_kind_max (op1, op2);
4689 : 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4690 : 289 : gfc_convert_type (op1, &e->ts, 1);
4691 : 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4692 : 144 : gfc_convert_type (op2, &e->ts, 1);
4693 : 523 : e = logical_to_bitwise (e);
4694 : 523 : goto simplify_op;
4695 : : }
4696 : :
4697 : 28 : CHECK_INTERFACES
4698 : 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4699 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4700 : : gfc_typename (op2));
4701 : 16 : return false;
4702 : :
4703 : 20321 : case INTRINSIC_NOT:
4704 : : /* Logical ops on integers become bitwise ops with -fdec. */
4705 : 20321 : if (flag_dec && op1->ts.type == BT_INTEGER)
4706 : : {
4707 : 19 : e->ts.type = BT_INTEGER;
4708 : 19 : e->ts.kind = op1->ts.kind;
4709 : 19 : e = logical_to_bitwise (e);
4710 : 19 : goto simplify_op;
4711 : : }
4712 : :
4713 : 20302 : if (op1->ts.type == BT_LOGICAL)
4714 : : {
4715 : 20296 : e->ts.type = BT_LOGICAL;
4716 : 20296 : e->ts.kind = op1->ts.kind;
4717 : 20296 : break;
4718 : : }
4719 : :
4720 : 6 : CHECK_INTERFACES
4721 : 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4722 : : gfc_typename (op1));
4723 : 3 : return false;
4724 : :
4725 : 21092 : case INTRINSIC_GT:
4726 : 21092 : case INTRINSIC_GT_OS:
4727 : 21092 : case INTRINSIC_GE:
4728 : 21092 : case INTRINSIC_GE_OS:
4729 : 21092 : case INTRINSIC_LT:
4730 : 21092 : case INTRINSIC_LT_OS:
4731 : 21092 : case INTRINSIC_LE:
4732 : 21092 : case INTRINSIC_LE_OS:
4733 : 21092 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4734 : : {
4735 : 18 : CHECK_INTERFACES
4736 : 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4737 : 0 : return false;
4738 : : }
4739 : :
4740 : : /* Fall through. */
4741 : :
4742 : 248308 : case INTRINSIC_EQ:
4743 : 248308 : case INTRINSIC_EQ_OS:
4744 : 248308 : case INTRINSIC_NE:
4745 : 248308 : case INTRINSIC_NE_OS:
4746 : :
4747 : 248308 : if (flag_dec
4748 : 1038 : && is_character_based (op1->ts.type)
4749 : 248643 : && is_character_based (op2->ts.type))
4750 : : {
4751 : 204 : convert_hollerith_to_character (op1);
4752 : 204 : convert_hollerith_to_character (op2);
4753 : : }
4754 : :
4755 : 248308 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4756 : 36945 : && op1->ts.kind == op2->ts.kind)
4757 : : {
4758 : 36908 : e->ts.type = BT_LOGICAL;
4759 : 36908 : e->ts.kind = gfc_default_logical_kind;
4760 : 36908 : break;
4761 : : }
4762 : :
4763 : : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4764 : 211400 : if (op1->ts.type == BT_BOZ)
4765 : : {
4766 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4767 : : "as an operand of a relational operator"),
4768 : : &op1->where))
4769 : : return false;
4770 : :
4771 : 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4772 : : return false;
4773 : :
4774 : 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4775 : : return false;
4776 : : }
4777 : :
4778 : : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4779 : 211400 : if (op2->ts.type == BT_BOZ)
4780 : : {
4781 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4782 : : " as an operand of a relational operator"),
4783 : : &op2->where))
4784 : : return false;
4785 : :
4786 : 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4787 : : return false;
4788 : :
4789 : 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4790 : : return false;
4791 : : }
4792 : 211400 : if (flag_dec
4793 : 211400 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4794 : 120 : convert_to_numeric (op1, op2);
4795 : :
4796 : 211400 : if (flag_dec
4797 : 211400 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4798 : 120 : convert_to_numeric (op2, op1);
4799 : :
4800 : 211400 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4801 : : {
4802 : : /* Do not perform conversions if operands are not conformable as
4803 : : required for the binary intrinsic operators (F2018:10.1.5).
4804 : : Defer to a possibly overloading user-defined operator. */
4805 : 210271 : if (!gfc_op_rank_conformable (op1, op2))
4806 : : {
4807 : 70 : CHECK_INTERFACES
4808 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4809 : 0 : &op1->where, &op2->where);
4810 : 0 : return false;
4811 : : }
4812 : :
4813 : 210201 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4814 : : {
4815 : 1 : CHECK_INTERFACES
4816 : 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4817 : 1 : "%s and %s", &op1->where, &op2->where,
4818 : : gfc_typename (op1), gfc_typename (op2));
4819 : 1 : return false;
4820 : : }
4821 : :
4822 : 210200 : gfc_type_convert_binary (e, 1);
4823 : :
4824 : 210200 : e->ts.type = BT_LOGICAL;
4825 : 210200 : e->ts.kind = gfc_default_logical_kind;
4826 : :
4827 : 210200 : if (warn_compare_reals)
4828 : : {
4829 : 69 : gfc_intrinsic_op op = e->value.op.op;
4830 : :
4831 : : /* Type conversion has made sure that the types of op1 and op2
4832 : : agree, so it is only necessary to check the first one. */
4833 : 69 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4834 : 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4835 : 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4836 : : {
4837 : 13 : const char *msg;
4838 : :
4839 : 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4840 : : msg = G_("Equality comparison for %s at %L");
4841 : : else
4842 : 6 : msg = G_("Inequality comparison for %s at %L");
4843 : :
4844 : 13 : gfc_warning (OPT_Wcompare_reals, msg,
4845 : : gfc_typename (op1), &op1->where);
4846 : : }
4847 : : }
4848 : :
4849 : : break;
4850 : : }
4851 : :
4852 : 1129 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4853 : : {
4854 : 2 : CHECK_INTERFACES
4855 : 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4856 : : &e->where,
4857 : 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4858 : : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4859 : 2 : }
4860 : : else
4861 : : {
4862 : 1127 : CHECK_INTERFACES
4863 : 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4864 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4865 : : gfc_typename (op2));
4866 : : }
4867 : :
4868 : : return false;
4869 : :
4870 : 294 : case INTRINSIC_USER:
4871 : 294 : if (e->value.op.uop->op == NULL)
4872 : : {
4873 : 69 : const char *name = e->value.op.uop->name;
4874 : 69 : const char *guessed;
4875 : 69 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4876 : 69 : CHECK_INTERFACES
4877 : 11 : if (guessed)
4878 : 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4879 : : "%qs?", name, &e->where, guessed);
4880 : : else
4881 : 10 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4882 : : }
4883 : 225 : else if (op2 == NULL)
4884 : : {
4885 : 48 : CHECK_INTERFACES
4886 : 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4887 : 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4888 : : }
4889 : : else
4890 : : {
4891 : 177 : e->value.op.uop->op->sym->attr.referenced = 1;
4892 : 177 : CHECK_INTERFACES
4893 : 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
4894 : 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
4895 : : gfc_typename (op2));
4896 : : }
4897 : :
4898 : : return false;
4899 : :
4900 : 20428 : case INTRINSIC_PARENTHESES:
4901 : 20428 : e->ts = op1->ts;
4902 : 20428 : if (e->ts.type == BT_CHARACTER)
4903 : 301 : e->ts.u.cl = op1->ts.u.cl;
4904 : : break;
4905 : :
4906 : 0 : default:
4907 : 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
4908 : : }
4909 : :
4910 : : /* Deal with arrayness of an operand through an operator. */
4911 : :
4912 : 517880 : switch (e->value.op.op)
4913 : : {
4914 : 469198 : case INTRINSIC_PLUS:
4915 : 469198 : case INTRINSIC_MINUS:
4916 : 469198 : case INTRINSIC_TIMES:
4917 : 469198 : case INTRINSIC_DIVIDE:
4918 : 469198 : case INTRINSIC_POWER:
4919 : 469198 : case INTRINSIC_CONCAT:
4920 : 469198 : case INTRINSIC_AND:
4921 : 469198 : case INTRINSIC_OR:
4922 : 469198 : case INTRINSIC_EQV:
4923 : 469198 : case INTRINSIC_NEQV:
4924 : 469198 : case INTRINSIC_EQ:
4925 : 469198 : case INTRINSIC_EQ_OS:
4926 : 469198 : case INTRINSIC_NE:
4927 : 469198 : case INTRINSIC_NE_OS:
4928 : 469198 : case INTRINSIC_GT:
4929 : 469198 : case INTRINSIC_GT_OS:
4930 : 469198 : case INTRINSIC_GE:
4931 : 469198 : case INTRINSIC_GE_OS:
4932 : 469198 : case INTRINSIC_LT:
4933 : 469198 : case INTRINSIC_LT_OS:
4934 : 469198 : case INTRINSIC_LE:
4935 : 469198 : case INTRINSIC_LE_OS:
4936 : :
4937 : 469198 : if (op1->rank == 0 && op2->rank == 0)
4938 : 418320 : e->rank = 0;
4939 : :
4940 : 469198 : if (op1->rank == 0 && op2->rank != 0)
4941 : : {
4942 : 2611 : e->rank = op2->rank;
4943 : :
4944 : 2611 : if (e->shape == NULL)
4945 : 2581 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
4946 : : }
4947 : :
4948 : 469198 : if (op1->rank != 0 && op2->rank == 0)
4949 : : {
4950 : 16515 : e->rank = op1->rank;
4951 : :
4952 : 16515 : if (e->shape == NULL)
4953 : 16497 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4954 : : }
4955 : :
4956 : 469198 : if (op1->rank != 0 && op2->rank != 0)
4957 : : {
4958 : 31752 : if (op1->rank == op2->rank)
4959 : : {
4960 : 31752 : e->rank = op1->rank;
4961 : 31752 : if (e->shape == NULL)
4962 : : {
4963 : 31691 : t = compare_shapes (op1, op2);
4964 : 31691 : if (!t)
4965 : 3 : e->shape = NULL;
4966 : : else
4967 : 31688 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4968 : : }
4969 : : }
4970 : : else
4971 : : {
4972 : : /* Allow higher level expressions to work. */
4973 : 0 : e->rank = 0;
4974 : :
4975 : : /* Try user-defined operators, and otherwise throw an error. */
4976 : 0 : CHECK_INTERFACES
4977 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4978 : 0 : &op1->where, &op2->where);
4979 : 0 : return false;
4980 : : }
4981 : : }
4982 : : break;
4983 : :
4984 : 48682 : case INTRINSIC_PARENTHESES:
4985 : 48682 : case INTRINSIC_NOT:
4986 : 48682 : case INTRINSIC_UPLUS:
4987 : 48682 : case INTRINSIC_UMINUS:
4988 : : /* Simply copy arrayness attribute */
4989 : 48682 : e->rank = op1->rank;
4990 : 48682 : e->corank = op1->corank;
4991 : :
4992 : 48682 : if (e->shape == NULL)
4993 : 48676 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4994 : :
4995 : : break;
4996 : :
4997 : : default:
4998 : : break;
4999 : : }
5000 : :
5001 : 518422 : simplify_op:
5002 : :
5003 : : /* Attempt to simplify the expression. */
5004 : 3 : if (t)
5005 : : {
5006 : 518419 : t = gfc_simplify_expr (e, 0);
5007 : : /* Some calls do not succeed in simplification and return false
5008 : : even though there is no error; e.g. variable references to
5009 : : PARAMETER arrays. */
5010 : 518419 : if (!gfc_is_constant_expr (e))
5011 : 475514 : t = true;
5012 : : }
5013 : : return t;
5014 : : }
5015 : :
5016 : : static bool
5017 : 150 : resolve_conditional (gfc_expr *expr)
5018 : : {
5019 : 150 : gfc_expr *condition, *true_expr, *false_expr;
5020 : :
5021 : 150 : condition = expr->value.conditional.condition;
5022 : 150 : true_expr = expr->value.conditional.true_expr;
5023 : 150 : false_expr = expr->value.conditional.false_expr;
5024 : :
5025 : 300 : if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
5026 : 300 : || !gfc_resolve_expr (false_expr))
5027 : 0 : return false;
5028 : :
5029 : 150 : if (condition->ts.type != BT_LOGICAL || condition->rank != 0)
5030 : : {
5031 : 2 : gfc_error (
5032 : : "Condition in conditional expression must be a scalar logical at %L",
5033 : : &condition->where);
5034 : 2 : return false;
5035 : : }
5036 : :
5037 : 148 : if (true_expr->ts.type != false_expr->ts.type)
5038 : : {
5039 : 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5040 : : "must have the same declared type",
5041 : : &true_expr->where, &false_expr->where);
5042 : 1 : return false;
5043 : : }
5044 : :
5045 : 147 : if (true_expr->ts.kind != false_expr->ts.kind)
5046 : : {
5047 : 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5048 : : "must have the same kind parameter",
5049 : : &true_expr->where, &false_expr->where);
5050 : 1 : return false;
5051 : : }
5052 : :
5053 : 146 : if (true_expr->rank != false_expr->rank)
5054 : : {
5055 : 1 : gfc_error ("expr at %L and expr at %L in conditional expression "
5056 : : "must have the same rank",
5057 : : &true_expr->where, &false_expr->where);
5058 : 1 : return false;
5059 : : }
5060 : :
5061 : : /* TODO: support more data types for conditional expressions */
5062 : 145 : if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
5063 : 145 : && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
5064 : 55 : && true_expr->ts.type != BT_CHARACTER)
5065 : : {
5066 : 1 : gfc_error (
5067 : : "Sorry, only integer, logical, real, complex and character types are "
5068 : : "currently supported for conditional expressions at %L",
5069 : : &expr->where);
5070 : 1 : return false;
5071 : : }
5072 : :
5073 : : /* TODO: support arrays in conditional expressions */
5074 : 144 : if (true_expr->rank > 0)
5075 : : {
5076 : 1 : gfc_error ("Sorry, array is currently unsupported for conditional "
5077 : : "expressions at %L",
5078 : : &expr->where);
5079 : 1 : return false;
5080 : : }
5081 : :
5082 : 143 : expr->ts = true_expr->ts;
5083 : 143 : expr->rank = true_expr->rank;
5084 : 143 : return true;
5085 : : }
5086 : :
5087 : : /************** Array resolution subroutines **************/
5088 : :
5089 : : enum compare_result
5090 : : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
5091 : :
5092 : : /* Compare two integer expressions. */
5093 : :
5094 : : static compare_result
5095 : 453202 : compare_bound (gfc_expr *a, gfc_expr *b)
5096 : : {
5097 : 453202 : int i;
5098 : :
5099 : 453202 : if (a == NULL || a->expr_type != EXPR_CONSTANT
5100 : 296441 : || b == NULL || b->expr_type != EXPR_CONSTANT)
5101 : : return CMP_UNKNOWN;
5102 : :
5103 : : /* If either of the types isn't INTEGER, we must have
5104 : : raised an error earlier. */
5105 : :
5106 : 206188 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
5107 : : return CMP_UNKNOWN;
5108 : :
5109 : 206184 : i = mpz_cmp (a->value.integer, b->value.integer);
5110 : :
5111 : 206184 : if (i < 0)
5112 : : return CMP_LT;
5113 : 97166 : if (i > 0)
5114 : 38583 : return CMP_GT;
5115 : : return CMP_EQ;
5116 : : }
5117 : :
5118 : :
5119 : : /* Compare an integer expression with an integer. */
5120 : :
5121 : : static compare_result
5122 : 72963 : compare_bound_int (gfc_expr *a, int b)
5123 : : {
5124 : 72963 : int i;
5125 : :
5126 : 72963 : if (a == NULL
5127 : 31284 : || a->expr_type != EXPR_CONSTANT
5128 : 28461 : || a->ts.type != BT_INTEGER)
5129 : : return CMP_UNKNOWN;
5130 : :
5131 : 28461 : i = mpz_cmp_si (a->value.integer, b);
5132 : :
5133 : 28461 : if (i < 0)
5134 : : return CMP_LT;
5135 : 24422 : if (i > 0)
5136 : 21347 : return CMP_GT;
5137 : : return CMP_EQ;
5138 : : }
5139 : :
5140 : :
5141 : : /* Compare an integer expression with a mpz_t. */
5142 : :
5143 : : static compare_result
5144 : 67695 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
5145 : : {
5146 : 67695 : int i;
5147 : :
5148 : 67695 : if (a == NULL
5149 : 55101 : || a->expr_type != EXPR_CONSTANT
5150 : 52987 : || a->ts.type != BT_INTEGER)
5151 : : return CMP_UNKNOWN;
5152 : :
5153 : 52984 : i = mpz_cmp (a->value.integer, b);
5154 : :
5155 : 52984 : if (i < 0)
5156 : : return CMP_LT;
5157 : 24094 : if (i > 0)
5158 : 10336 : return CMP_GT;
5159 : : return CMP_EQ;
5160 : : }
5161 : :
5162 : :
5163 : : /* Compute the last value of a sequence given by a triplet.
5164 : : Return 0 if it wasn't able to compute the last value, or if the
5165 : : sequence if empty, and 1 otherwise. */
5166 : :
5167 : : static int
5168 : 50816 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
5169 : : gfc_expr *stride, mpz_t last)
5170 : : {
5171 : 50816 : mpz_t rem;
5172 : :
5173 : 50816 : if (start == NULL || start->expr_type != EXPR_CONSTANT
5174 : 36051 : || end == NULL || end->expr_type != EXPR_CONSTANT
5175 : 31497 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
5176 : : return 0;
5177 : :
5178 : 31178 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
5179 : 31177 : || (stride != NULL && stride->ts.type != BT_INTEGER))
5180 : : return 0;
5181 : :
5182 : 6476 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
5183 : : {
5184 : 24827 : if (compare_bound (start, end) == CMP_GT)
5185 : : return 0;
5186 : 23438 : mpz_set (last, end->value.integer);
5187 : 23438 : return 1;
5188 : : }
5189 : :
5190 : 6350 : if (compare_bound_int (stride, 0) == CMP_GT)
5191 : : {
5192 : : /* Stride is positive */
5193 : 5130 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
5194 : : return 0;
5195 : : }
5196 : : else
5197 : : {
5198 : : /* Stride is negative */
5199 : 1220 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
5200 : : return 0;
5201 : : }
5202 : :
5203 : 6330 : mpz_init (rem);
5204 : 6330 : mpz_sub (rem, end->value.integer, start->value.integer);
5205 : 6330 : mpz_tdiv_r (rem, rem, stride->value.integer);
5206 : 6330 : mpz_sub (last, end->value.integer, rem);
5207 : 6330 : mpz_clear (rem);
5208 : :
5209 : 6330 : return 1;
5210 : : }
5211 : :
5212 : :
5213 : : /* Compare a single dimension of an array reference to the array
5214 : : specification. */
5215 : :
5216 : : static bool
5217 : 208450 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
5218 : : {
5219 : 208450 : mpz_t last_value;
5220 : :
5221 : 208450 : if (ar->dimen_type[i] == DIMEN_STAR)
5222 : : {
5223 : 413 : gcc_assert (ar->stride[i] == NULL);
5224 : : /* This implies [*] as [*:] and [*:3] are not possible. */
5225 : 413 : if (ar->start[i] == NULL)
5226 : : {
5227 : 339 : gcc_assert (ar->end[i] == NULL);
5228 : : return true;
5229 : : }
5230 : : }
5231 : :
5232 : : /* Given start, end and stride values, calculate the minimum and
5233 : : maximum referenced indexes. */
5234 : :
5235 : 208111 : switch (ar->dimen_type[i])
5236 : : {
5237 : : case DIMEN_VECTOR:
5238 : : case DIMEN_THIS_IMAGE:
5239 : : break;
5240 : :
5241 : 150931 : case DIMEN_STAR:
5242 : 150931 : case DIMEN_ELEMENT:
5243 : 150931 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
5244 : : {
5245 : 2 : if (i < as->rank)
5246 : 2 : gfc_warning (0, "Array reference at %L is out of bounds "
5247 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5248 : 2 : mpz_get_si (ar->start[i]->value.integer),
5249 : 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
5250 : : else
5251 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5252 : : "(%ld < %ld) in codimension %d", &ar->c_where[i],
5253 : 0 : mpz_get_si (ar->start[i]->value.integer),
5254 : 0 : mpz_get_si (as->lower[i]->value.integer),
5255 : 0 : i + 1 - as->rank);
5256 : 2 : return true;
5257 : : }
5258 : 150929 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
5259 : : {
5260 : 39 : if (i < as->rank)
5261 : 39 : gfc_warning (0, "Array reference at %L is out of bounds "
5262 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5263 : 39 : mpz_get_si (ar->start[i]->value.integer),
5264 : 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
5265 : : else
5266 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
5267 : : "(%ld > %ld) in codimension %d", &ar->c_where[i],
5268 : 0 : mpz_get_si (ar->start[i]->value.integer),
5269 : 0 : mpz_get_si (as->upper[i]->value.integer),
5270 : 0 : i + 1 - as->rank);
5271 : 39 : return true;
5272 : : }
5273 : :
5274 : : break;
5275 : :
5276 : 50861 : case DIMEN_RANGE:
5277 : 50861 : {
5278 : : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
5279 : : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
5280 : :
5281 : 50861 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
5282 : 50861 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
5283 : :
5284 : : /* Check for zero stride, which is not allowed. */
5285 : 50861 : if (comp_stride_zero == CMP_EQ)
5286 : : {
5287 : 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
5288 : 1 : return false;
5289 : : }
5290 : :
5291 : : /* if start == end || (stride > 0 && start < end)
5292 : : || (stride < 0 && start > end),
5293 : : then the array section contains at least one element. In this
5294 : : case, there is an out-of-bounds access if
5295 : : (start < lower || start > upper). */
5296 : 50860 : if (comp_start_end == CMP_EQ
5297 : 50127 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
5298 : 47600 : && comp_start_end == CMP_LT)
5299 : 22246 : || (comp_stride_zero == CMP_LT
5300 : 22246 : && comp_start_end == CMP_GT))
5301 : : {
5302 : 29814 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
5303 : : {
5304 : 27 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5305 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5306 : 27 : mpz_get_si (AR_START->value.integer),
5307 : 27 : mpz_get_si (as->lower[i]->value.integer), i+1);
5308 : 27 : return true;
5309 : : }
5310 : 29787 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
5311 : : {
5312 : 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
5313 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5314 : 17 : mpz_get_si (AR_START->value.integer),
5315 : 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
5316 : 17 : return true;
5317 : : }
5318 : : }
5319 : :
5320 : : /* If we can compute the highest index of the array section,
5321 : : then it also has to be between lower and upper. */
5322 : 50816 : mpz_init (last_value);
5323 : 50816 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5324 : : last_value))
5325 : : {
5326 : 29768 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5327 : : {
5328 : 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5329 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5330 : : mpz_get_si (last_value),
5331 : 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5332 : 3 : mpz_clear (last_value);
5333 : 3 : return true;
5334 : : }
5335 : 29765 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5336 : : {
5337 : 7 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5338 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5339 : : mpz_get_si (last_value),
5340 : 7 : mpz_get_si (as->upper[i]->value.integer), i+1);
5341 : 7 : mpz_clear (last_value);
5342 : 7 : return true;
5343 : : }
5344 : : }
5345 : 50806 : mpz_clear (last_value);
5346 : :
5347 : : #undef AR_START
5348 : : #undef AR_END
5349 : : }
5350 : 50806 : break;
5351 : :
5352 : 0 : default:
5353 : 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5354 : : }
5355 : :
5356 : : return true;
5357 : : }
5358 : :
5359 : :
5360 : : /* Compare an array reference with an array specification. */
5361 : :
5362 : : static bool
5363 : 414057 : compare_spec_to_ref (gfc_array_ref *ar)
5364 : : {
5365 : 414057 : gfc_array_spec *as;
5366 : 414057 : int i;
5367 : :
5368 : 414057 : as = ar->as;
5369 : 414057 : i = as->rank - 1;
5370 : : /* TODO: Full array sections are only allowed as actual parameters. */
5371 : 414057 : if (as->type == AS_ASSUMED_SIZE
5372 : 5765 : && (/*ar->type == AR_FULL
5373 : 5765 : ||*/ (ar->type == AR_SECTION
5374 : 514 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5375 : : {
5376 : 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5377 : : "not specified at %L", &ar->where);
5378 : 5 : return false;
5379 : : }
5380 : :
5381 : 414052 : if (ar->type == AR_FULL)
5382 : : return true;
5383 : :
5384 : 157721 : if (as->rank != ar->dimen)
5385 : : {
5386 : 28 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5387 : : &ar->where, ar->dimen, as->rank);
5388 : 28 : return false;
5389 : : }
5390 : :
5391 : : /* ar->codimen == 0 is a local array. */
5392 : 157693 : if (as->corank != ar->codimen && ar->codimen != 0)
5393 : : {
5394 : 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5395 : : &ar->where, ar->codimen, as->corank);
5396 : 0 : return false;
5397 : : }
5398 : :
5399 : 358438 : for (i = 0; i < as->rank; i++)
5400 : 200746 : if (!check_dimension (i, ar, as))
5401 : : return false;
5402 : :
5403 : : /* Local access has no coarray spec. */
5404 : 157692 : if (ar->codimen != 0)
5405 : 14745 : for (i = as->rank; i < as->rank + as->corank; i++)
5406 : : {
5407 : 7706 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5408 : 5268 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5409 : : {
5410 : 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5411 : 2 : i + 1 - as->rank, &ar->where);
5412 : 2 : return false;
5413 : : }
5414 : 7704 : if (!check_dimension (i, ar, as))
5415 : : return false;
5416 : : }
5417 : :
5418 : : return true;
5419 : : }
5420 : :
5421 : :
5422 : : /* Resolve one part of an array index. */
5423 : :
5424 : : static bool
5425 : 708187 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5426 : : int force_index_integer_kind)
5427 : : {
5428 : 708187 : gfc_typespec ts;
5429 : :
5430 : 708187 : if (index == NULL)
5431 : : return true;
5432 : :
5433 : 210965 : if (!gfc_resolve_expr (index))
5434 : : return false;
5435 : :
5436 : 210942 : if (check_scalar && index->rank != 0)
5437 : : {
5438 : 2 : gfc_error ("Array index at %L must be scalar", &index->where);
5439 : 2 : return false;
5440 : : }
5441 : :
5442 : 210940 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5443 : : {
5444 : 3 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5445 : : &index->where, gfc_basic_typename (index->ts.type));
5446 : 3 : return false;
5447 : : }
5448 : :
5449 : 210937 : if (index->ts.type == BT_REAL)
5450 : 336 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5451 : : &index->where))
5452 : : return false;
5453 : :
5454 : 210937 : if ((index->ts.kind != gfc_index_integer_kind
5455 : 206253 : && force_index_integer_kind)
5456 : 180494 : || (index->ts.type != BT_INTEGER
5457 : : && index->ts.type != BT_UNKNOWN))
5458 : : {
5459 : 30778 : gfc_clear_ts (&ts);
5460 : 30778 : ts.type = BT_INTEGER;
5461 : 30778 : ts.kind = gfc_index_integer_kind;
5462 : :
5463 : 30778 : gfc_convert_type_warn (index, &ts, 2, 0);
5464 : : }
5465 : :
5466 : : return true;
5467 : : }
5468 : :
5469 : : /* Resolve one part of an array index. */
5470 : :
5471 : : bool
5472 : 472343 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5473 : : {
5474 : 472343 : return gfc_resolve_index_1 (index, check_scalar, 1);
5475 : : }
5476 : :
5477 : : /* Resolve a dim argument to an intrinsic function. */
5478 : :
5479 : : bool
5480 : 23817 : gfc_resolve_dim_arg (gfc_expr *dim)
5481 : : {
5482 : 23817 : if (dim == NULL)
5483 : : return true;
5484 : :
5485 : 23817 : if (!gfc_resolve_expr (dim))
5486 : : return false;
5487 : :
5488 : 23817 : if (dim->rank != 0)
5489 : : {
5490 : 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5491 : 0 : return false;
5492 : :
5493 : : }
5494 : :
5495 : 23817 : if (dim->ts.type != BT_INTEGER)
5496 : : {
5497 : 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5498 : 0 : return false;
5499 : : }
5500 : :
5501 : 23817 : if (dim->ts.kind != gfc_index_integer_kind)
5502 : : {
5503 : 15209 : gfc_typespec ts;
5504 : :
5505 : 15209 : gfc_clear_ts (&ts);
5506 : 15209 : ts.type = BT_INTEGER;
5507 : 15209 : ts.kind = gfc_index_integer_kind;
5508 : :
5509 : 15209 : gfc_convert_type_warn (dim, &ts, 2, 0);
5510 : : }
5511 : :
5512 : : return true;
5513 : : }
5514 : :
5515 : : /* Given an expression that contains array references, update those array
5516 : : references to point to the right array specifications. While this is
5517 : : filled in during matching, this information is difficult to save and load
5518 : : in a module, so we take care of it here.
5519 : :
5520 : : The idea here is that the original array reference comes from the
5521 : : base symbol. We traverse the list of reference structures, setting
5522 : : the stored reference to references. Component references can
5523 : : provide an additional array specification. */
5524 : : static void
5525 : : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5526 : :
5527 : : static bool
5528 : 897 : find_array_spec (gfc_expr *e)
5529 : : {
5530 : 897 : gfc_array_spec *as;
5531 : 897 : gfc_component *c;
5532 : 897 : gfc_ref *ref;
5533 : 897 : bool class_as = false;
5534 : :
5535 : 897 : if (e->symtree->n.sym->assoc)
5536 : : {
5537 : 217 : if (e->symtree->n.sym->assoc->target)
5538 : 217 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5539 : 217 : resolve_assoc_var (e->symtree->n.sym, false);
5540 : : }
5541 : :
5542 : 897 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5543 : : {
5544 : 112 : as = CLASS_DATA (e->symtree->n.sym)->as;
5545 : 112 : class_as = true;
5546 : : }
5547 : : else
5548 : 785 : as = e->symtree->n.sym->as;
5549 : :
5550 : 2034 : for (ref = e->ref; ref; ref = ref->next)
5551 : 1144 : switch (ref->type)
5552 : : {
5553 : 899 : case REF_ARRAY:
5554 : 899 : if (as == NULL)
5555 : : {
5556 : 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5557 : 14 : ? ref->u.ar.where : e->where);
5558 : 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5559 : : &loc);
5560 : 7 : return false;
5561 : : }
5562 : :
5563 : 892 : ref->u.ar.as = as;
5564 : 892 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5565 : : as = NULL;
5566 : : break;
5567 : :
5568 : 221 : case REF_COMPONENT:
5569 : 221 : c = ref->u.c.component;
5570 : 221 : if (c->attr.dimension)
5571 : : {
5572 : 90 : if (as != NULL && !(class_as && as == c->as))
5573 : 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5574 : 90 : as = c->as;
5575 : : }
5576 : :
5577 : : break;
5578 : :
5579 : : case REF_SUBSTRING:
5580 : : case REF_INQUIRY:
5581 : : break;
5582 : : }
5583 : :
5584 : 890 : if (as != NULL)
5585 : 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5586 : :
5587 : : return true;
5588 : : }
5589 : :
5590 : :
5591 : : /* Resolve an array reference. */
5592 : :
5593 : : static bool
5594 : 414782 : resolve_array_ref (gfc_array_ref *ar)
5595 : : {
5596 : 414782 : int i, check_scalar;
5597 : 414782 : gfc_expr *e;
5598 : :
5599 : 650598 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5600 : : {
5601 : 235844 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5602 : :
5603 : : /* Do not force gfc_index_integer_kind for the start. We can
5604 : : do fine with any integer kind. This avoids temporary arrays
5605 : : created for indexing with a vector. */
5606 : 235844 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5607 : : return false;
5608 : 235818 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5609 : : return false;
5610 : 235816 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5611 : : return false;
5612 : :
5613 : 235816 : e = ar->start[i];
5614 : :
5615 : 235816 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5616 : 141404 : switch (e->rank)
5617 : : {
5618 : 140540 : case 0:
5619 : 140540 : ar->dimen_type[i] = DIMEN_ELEMENT;
5620 : 140540 : break;
5621 : :
5622 : 864 : case 1:
5623 : 864 : ar->dimen_type[i] = DIMEN_VECTOR;
5624 : 864 : if (e->expr_type == EXPR_VARIABLE
5625 : 446 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5626 : 13 : ar->start[i] = gfc_get_parentheses (e);
5627 : : break;
5628 : :
5629 : 0 : default:
5630 : 0 : gfc_error ("Array index at %L is an array of rank %d",
5631 : : &ar->c_where[i], e->rank);
5632 : 0 : return false;
5633 : : }
5634 : :
5635 : : /* Fill in the upper bound, which may be lower than the
5636 : : specified one for something like a(2:10:5), which is
5637 : : identical to a(2:7:5). Only relevant for strides not equal
5638 : : to one. Don't try a division by zero. */
5639 : 235816 : if (ar->dimen_type[i] == DIMEN_RANGE
5640 : 70842 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5641 : 8205 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5642 : 8058 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5643 : : {
5644 : 8057 : mpz_t size, end;
5645 : :
5646 : 8057 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5647 : : {
5648 : 6360 : if (ar->end[i] == NULL)
5649 : : {
5650 : 7888 : ar->end[i] =
5651 : 3944 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5652 : : &ar->where);
5653 : 3944 : mpz_set (ar->end[i]->value.integer, end);
5654 : : }
5655 : 2416 : else if (ar->end[i]->ts.type == BT_INTEGER
5656 : 2416 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5657 : : {
5658 : 2416 : mpz_set (ar->end[i]->value.integer, end);
5659 : : }
5660 : : else
5661 : 0 : gcc_unreachable ();
5662 : :
5663 : 6360 : mpz_clear (size);
5664 : 6360 : mpz_clear (end);
5665 : : }
5666 : : }
5667 : : }
5668 : :
5669 : 414754 : if (ar->type == AR_FULL)
5670 : : {
5671 : 259288 : if (ar->as->rank == 0)
5672 : 2923 : ar->type = AR_ELEMENT;
5673 : :
5674 : : /* Make sure array is the same as array(:,:), this way
5675 : : we don't need to special case all the time. */
5676 : 259288 : ar->dimen = ar->as->rank;
5677 : 619796 : for (i = 0; i < ar->dimen; i++)
5678 : : {
5679 : 360508 : ar->dimen_type[i] = DIMEN_RANGE;
5680 : :
5681 : 360508 : gcc_assert (ar->start[i] == NULL);
5682 : 360508 : gcc_assert (ar->end[i] == NULL);
5683 : 360508 : gcc_assert (ar->stride[i] == NULL);
5684 : : }
5685 : : }
5686 : :
5687 : : /* If the reference type is unknown, figure out what kind it is. */
5688 : :
5689 : 414754 : if (ar->type == AR_UNKNOWN)
5690 : : {
5691 : 143260 : ar->type = AR_ELEMENT;
5692 : 278620 : for (i = 0; i < ar->dimen; i++)
5693 : 172322 : if (ar->dimen_type[i] == DIMEN_RANGE
5694 : 172322 : || ar->dimen_type[i] == DIMEN_VECTOR)
5695 : : {
5696 : 36962 : ar->type = AR_SECTION;
5697 : 36962 : break;
5698 : : }
5699 : : }
5700 : :
5701 : 414754 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5702 : : return false;
5703 : :
5704 : 414718 : if (ar->as->corank && ar->codimen == 0)
5705 : : {
5706 : 1655 : int n;
5707 : 1655 : ar->codimen = ar->as->corank;
5708 : 4546 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5709 : 2891 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5710 : : }
5711 : :
5712 : 414718 : if (ar->codimen)
5713 : : {
5714 : 10647 : if (ar->team_type == TEAM_NUMBER)
5715 : : {
5716 : 40 : if (!gfc_resolve_expr (ar->team))
5717 : : return false;
5718 : :
5719 : 40 : if (ar->team->rank != 0)
5720 : : {
5721 : 0 : gfc_error ("TEAM_NUMBER argument at %L must be scalar",
5722 : : &ar->team->where);
5723 : 0 : return false;
5724 : : }
5725 : :
5726 : 40 : if (ar->team->ts.type != BT_INTEGER)
5727 : : {
5728 : 4 : gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
5729 : : "type, found %s",
5730 : 4 : &ar->team->where,
5731 : : gfc_basic_typename (ar->team->ts.type));
5732 : 4 : return false;
5733 : : }
5734 : : }
5735 : 10607 : else if (ar->team_type == TEAM_TEAM)
5736 : : {
5737 : 28 : if (!gfc_resolve_expr (ar->team))
5738 : : return false;
5739 : :
5740 : 28 : if (ar->team->rank != 0)
5741 : : {
5742 : 2 : gfc_error ("TEAM argument at %L must be scalar",
5743 : : &ar->team->where);
5744 : 2 : return false;
5745 : : }
5746 : :
5747 : 26 : if (ar->team->ts.type != BT_DERIVED
5748 : 24 : || ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5749 : 24 : || ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5750 : : {
5751 : 2 : gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
5752 : : "the intrinsic module ISO_FORTRAN_ENV, found %s",
5753 : 2 : &ar->team->where,
5754 : : gfc_basic_typename (ar->team->ts.type));
5755 : 2 : return false;
5756 : : }
5757 : : }
5758 : 10639 : if (ar->stat)
5759 : : {
5760 : 45 : if (!gfc_resolve_expr (ar->stat))
5761 : : return false;
5762 : :
5763 : 45 : if (ar->stat->rank != 0)
5764 : : {
5765 : 2 : gfc_error ("STAT argument at %L must be scalar",
5766 : : &ar->stat->where);
5767 : 2 : return false;
5768 : : }
5769 : :
5770 : 43 : if (ar->stat->ts.type != BT_INTEGER)
5771 : : {
5772 : 2 : gfc_error ("STAT argument at %L must be of INTEGER "
5773 : : "type, found %s",
5774 : 2 : &ar->stat->where,
5775 : : gfc_basic_typename (ar->stat->ts.type));
5776 : 2 : return false;
5777 : : }
5778 : :
5779 : 41 : if (ar->stat->expr_type != EXPR_VARIABLE)
5780 : : {
5781 : 0 : gfc_error ("STAT's expression at %L must be a variable",
5782 : : &ar->stat->where);
5783 : 0 : return false;
5784 : : }
5785 : : }
5786 : : }
5787 : : return true;
5788 : : }
5789 : :
5790 : :
5791 : : bool
5792 : 8363 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5793 : : {
5794 : 8363 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5795 : :
5796 : 8363 : if (ref->u.ss.start != NULL)
5797 : : {
5798 : 8363 : if (!gfc_resolve_expr (ref->u.ss.start))
5799 : : return false;
5800 : :
5801 : 8363 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5802 : : {
5803 : 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5804 : : &ref->u.ss.start->where);
5805 : 1 : return false;
5806 : : }
5807 : :
5808 : 8362 : if (ref->u.ss.start->rank != 0)
5809 : : {
5810 : 0 : gfc_error ("Substring start index at %L must be scalar",
5811 : : &ref->u.ss.start->where);
5812 : 0 : return false;
5813 : : }
5814 : :
5815 : 8362 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5816 : 8362 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5817 : 37 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5818 : : {
5819 : 1 : gfc_error ("Substring start index at %L is less than one",
5820 : : &ref->u.ss.start->where);
5821 : 1 : return false;
5822 : : }
5823 : : }
5824 : :
5825 : 8361 : if (ref->u.ss.end != NULL)
5826 : : {
5827 : 8167 : if (!gfc_resolve_expr (ref->u.ss.end))
5828 : : return false;
5829 : :
5830 : 8167 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5831 : : {
5832 : 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5833 : : &ref->u.ss.end->where);
5834 : 1 : return false;
5835 : : }
5836 : :
5837 : 8166 : if (ref->u.ss.end->rank != 0)
5838 : : {
5839 : 0 : gfc_error ("Substring end index at %L must be scalar",
5840 : : &ref->u.ss.end->where);
5841 : 0 : return false;
5842 : : }
5843 : :
5844 : 8166 : if (ref->u.ss.length != NULL
5845 : 7832 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5846 : 8178 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5847 : 12 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5848 : : {
5849 : 4 : gfc_error ("Substring end index at %L exceeds the string length",
5850 : : &ref->u.ss.start->where);
5851 : 4 : return false;
5852 : : }
5853 : :
5854 : 8162 : if (compare_bound_mpz_t (ref->u.ss.end,
5855 : 8162 : gfc_integer_kinds[k].huge) == CMP_GT
5856 : 8162 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5857 : 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5858 : : {
5859 : 4 : gfc_error ("Substring end index at %L is too large",
5860 : : &ref->u.ss.end->where);
5861 : 4 : return false;
5862 : : }
5863 : : /* If the substring has the same length as the original
5864 : : variable, the reference itself can be deleted. */
5865 : :
5866 : 8158 : if (ref->u.ss.length != NULL
5867 : 7824 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5868 : 9072 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5869 : 228 : *equal_length = true;
5870 : : }
5871 : :
5872 : : return true;
5873 : : }
5874 : :
5875 : :
5876 : : /* This function supplies missing substring charlens. */
5877 : :
5878 : : void
5879 : 4561 : gfc_resolve_substring_charlen (gfc_expr *e)
5880 : : {
5881 : 4561 : gfc_ref *char_ref;
5882 : 4561 : gfc_expr *start, *end;
5883 : 4561 : gfc_typespec *ts = NULL;
5884 : 4561 : mpz_t diff;
5885 : :
5886 : 8884 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5887 : : {
5888 : 7038 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5889 : : break;
5890 : 4323 : if (char_ref->type == REF_COMPONENT)
5891 : 328 : ts = &char_ref->u.c.component->ts;
5892 : : }
5893 : :
5894 : 4561 : if (!char_ref || char_ref->type == REF_INQUIRY)
5895 : 1908 : return;
5896 : :
5897 : 2715 : gcc_assert (char_ref->next == NULL);
5898 : :
5899 : 2715 : if (e->ts.u.cl)
5900 : : {
5901 : 120 : if (e->ts.u.cl->length)
5902 : 108 : gfc_free_expr (e->ts.u.cl->length);
5903 : 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5904 : : return;
5905 : : }
5906 : :
5907 : 2703 : if (!e->ts.u.cl)
5908 : 2595 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5909 : :
5910 : 2703 : if (char_ref->u.ss.start)
5911 : 2703 : start = gfc_copy_expr (char_ref->u.ss.start);
5912 : : else
5913 : 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5914 : :
5915 : 2703 : if (char_ref->u.ss.end)
5916 : 2653 : end = gfc_copy_expr (char_ref->u.ss.end);
5917 : 50 : else if (e->expr_type == EXPR_VARIABLE)
5918 : : {
5919 : 50 : if (!ts)
5920 : 32 : ts = &e->symtree->n.sym->ts;
5921 : 50 : end = gfc_copy_expr (ts->u.cl->length);
5922 : : }
5923 : : else
5924 : : end = NULL;
5925 : :
5926 : 2703 : if (!start || !end)
5927 : : {
5928 : 50 : gfc_free_expr (start);
5929 : 50 : gfc_free_expr (end);
5930 : 50 : return;
5931 : : }
5932 : :
5933 : : /* Length = (end - start + 1).
5934 : : Check first whether it has a constant length. */
5935 : 2653 : if (gfc_dep_difference (end, start, &diff))
5936 : : {
5937 : 2538 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5938 : : &e->where);
5939 : :
5940 : 2538 : mpz_add_ui (len->value.integer, diff, 1);
5941 : 2538 : mpz_clear (diff);
5942 : 2538 : e->ts.u.cl->length = len;
5943 : : /* The check for length < 0 is handled below */
5944 : : }
5945 : : else
5946 : : {
5947 : 115 : e->ts.u.cl->length = gfc_subtract (end, start);
5948 : 115 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5949 : : gfc_get_int_expr (gfc_charlen_int_kind,
5950 : : NULL, 1));
5951 : : }
5952 : :
5953 : : /* F2008, 6.4.1: Both the starting point and the ending point shall
5954 : : be within the range 1, 2, ..., n unless the starting point exceeds
5955 : : the ending point, in which case the substring has length zero. */
5956 : :
5957 : 2653 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5958 : 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5959 : :
5960 : 2653 : e->ts.u.cl->length->ts.type = BT_INTEGER;
5961 : 2653 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5962 : :
5963 : : /* Make sure that the length is simplified. */
5964 : 2653 : gfc_simplify_expr (e->ts.u.cl->length, 1);
5965 : 2653 : gfc_resolve_expr (e->ts.u.cl->length);
5966 : : }
5967 : :
5968 : :
5969 : : /* Convert an array reference to an array element so that PDT KIND and LEN
5970 : : or inquiry references are always scalar. */
5971 : :
5972 : : static void
5973 : 21 : reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref)
5974 : : {
5975 : 21 : gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5976 : 21 : int dim;
5977 : :
5978 : 21 : array_ref->u.ar.type = AR_ELEMENT;
5979 : 21 : expr->rank = 0;
5980 : : /* Suppress the runtime bounds check. */
5981 : 21 : expr->no_bounds_check = 1;
5982 : 42 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5983 : : {
5984 : 21 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5985 : 21 : if (array_ref->u.ar.start[dim])
5986 : 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
5987 : :
5988 : 21 : if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim])
5989 : 9 : array_ref->u.ar.start[dim]
5990 : 9 : = gfc_copy_expr (array_ref->u.ar.as->lower[dim]);
5991 : : else
5992 : 12 : array_ref->u.ar.start[dim] = gfc_copy_expr (unity);
5993 : :
5994 : 21 : if (array_ref->u.ar.end[dim])
5995 : 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
5996 : 21 : if (array_ref->u.ar.stride[dim])
5997 : 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
5998 : : }
5999 : 21 : gfc_free_expr (unity);
6000 : 21 : }
6001 : :
6002 : :
6003 : : /* Resolve subtype references. */
6004 : :
6005 : : bool
6006 : 527392 : gfc_resolve_ref (gfc_expr *expr)
6007 : : {
6008 : 527392 : int current_part_dimension, n_components, seen_part_dimension;
6009 : 527392 : gfc_ref *ref, **prev, *array_ref;
6010 : 527392 : bool equal_length;
6011 : 527392 : gfc_symbol *last_pdt = NULL;
6012 : :
6013 : 1034107 : for (ref = expr->ref; ref; ref = ref->next)
6014 : 507612 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
6015 : : {
6016 : 897 : if (!find_array_spec (expr))
6017 : : return false;
6018 : : break;
6019 : : }
6020 : :
6021 : 1542528 : for (prev = &expr->ref; *prev != NULL;
6022 : 507673 : prev = *prev == NULL ? prev : &(*prev)->next)
6023 : 507757 : switch ((*prev)->type)
6024 : : {
6025 : 414782 : case REF_ARRAY:
6026 : 414782 : if (!resolve_array_ref (&(*prev)->u.ar))
6027 : : return false;
6028 : : break;
6029 : :
6030 : : case REF_COMPONENT:
6031 : : case REF_INQUIRY:
6032 : : break;
6033 : :
6034 : 8082 : case REF_SUBSTRING:
6035 : 8082 : equal_length = false;
6036 : 8082 : if (!gfc_resolve_substring (*prev, &equal_length))
6037 : : return false;
6038 : :
6039 : 8074 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
6040 : : {
6041 : : /* Remove the reference and move the charlen, if any. */
6042 : 203 : ref = *prev;
6043 : 203 : *prev = ref->next;
6044 : 203 : ref->next = NULL;
6045 : 203 : expr->ts.u.cl = ref->u.ss.length;
6046 : 203 : ref->u.ss.length = NULL;
6047 : 203 : gfc_free_ref_list (ref);
6048 : : }
6049 : : break;
6050 : : }
6051 : :
6052 : : /* Check constraints on part references. */
6053 : :
6054 : 527301 : current_part_dimension = 0;
6055 : 527301 : seen_part_dimension = 0;
6056 : 527301 : n_components = 0;
6057 : 527301 : array_ref = NULL;
6058 : :
6059 : 527301 : if (expr->expr_type == EXPR_VARIABLE
6060 : 439463 : && expr->symtree->n.sym->ts.type == BT_DERIVED
6061 : 75876 : && expr->symtree->n.sym->ts.u.derived->attr.pdt_type)
6062 : 527301 : last_pdt = expr->symtree->n.sym->ts.u.derived;
6063 : :
6064 : 1034746 : for (ref = expr->ref; ref; ref = ref->next)
6065 : : {
6066 : 507456 : switch (ref->type)
6067 : : {
6068 : 414699 : case REF_ARRAY:
6069 : 414699 : array_ref = ref;
6070 : 414699 : switch (ref->u.ar.type)
6071 : : {
6072 : 256363 : case AR_FULL:
6073 : : /* Coarray scalar. */
6074 : 256363 : if (ref->u.ar.as->rank == 0)
6075 : : {
6076 : : current_part_dimension = 0;
6077 : : break;
6078 : : }
6079 : : /* Fall through. */
6080 : 296031 : case AR_SECTION:
6081 : 296031 : current_part_dimension = 1;
6082 : 296031 : break;
6083 : :
6084 : 118668 : case AR_ELEMENT:
6085 : 118668 : array_ref = NULL;
6086 : 118668 : current_part_dimension = 0;
6087 : 118668 : break;
6088 : :
6089 : 0 : case AR_UNKNOWN:
6090 : 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
6091 : : }
6092 : :
6093 : : break;
6094 : :
6095 : 84089 : case REF_COMPONENT:
6096 : 84089 : if (current_part_dimension || seen_part_dimension)
6097 : : {
6098 : : /* F03:C614. */
6099 : 6151 : if (ref->u.c.component->attr.pointer
6100 : 6148 : || ref->u.c.component->attr.proc_pointer
6101 : 6147 : || (ref->u.c.component->ts.type == BT_CLASS
6102 : 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
6103 : : {
6104 : 4 : gfc_error ("Component to the right of a part reference "
6105 : : "with nonzero rank must not have the POINTER "
6106 : : "attribute at %L", &expr->where);
6107 : 4 : return false;
6108 : : }
6109 : 6147 : else if (ref->u.c.component->attr.allocatable
6110 : 6141 : || (ref->u.c.component->ts.type == BT_CLASS
6111 : 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
6112 : :
6113 : : {
6114 : 7 : gfc_error ("Component to the right of a part reference "
6115 : : "with nonzero rank must not have the ALLOCATABLE "
6116 : : "attribute at %L", &expr->where);
6117 : 7 : return false;
6118 : : }
6119 : : }
6120 : :
6121 : : /* Sometimes the component in a component reference is that of the
6122 : : pdt_template. Point to the component of pdt_type instead. This
6123 : : ensures that the component gets a backend_decl in translation. */
6124 : 84078 : if (last_pdt)
6125 : : {
6126 : 1567 : gfc_component *cmp = last_pdt->components;
6127 : 4123 : for (; cmp; cmp = cmp->next)
6128 : 4015 : if (!strcmp (cmp->name, ref->u.c.component->name))
6129 : : {
6130 : 1459 : ref->u.c.component = cmp;
6131 : 1459 : break;
6132 : : }
6133 : 1567 : ref->u.c.sym = last_pdt;
6134 : : }
6135 : :
6136 : : /* Convert pdt_templates, if necessary, and update 'last_pdt'. */
6137 : 84078 : if (ref->u.c.component->ts.type == BT_DERIVED)
6138 : : {
6139 : 18794 : if (ref->u.c.component->ts.u.derived->attr.pdt_template)
6140 : : {
6141 : 0 : if (gfc_get_pdt_instance (ref->u.c.component->param_list,
6142 : : &ref->u.c.component->ts.u.derived,
6143 : : NULL) != MATCH_YES)
6144 : : return false;
6145 : 0 : last_pdt = ref->u.c.component->ts.u.derived;
6146 : : }
6147 : 18794 : else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
6148 : 267 : last_pdt = ref->u.c.component->ts.u.derived;
6149 : : else
6150 : : last_pdt = NULL;
6151 : : }
6152 : :
6153 : : /* The F08 standard requires(See R425, R431, R435, and in particular
6154 : : Note 6.7) that a PDT parameter reference be a scalar even if
6155 : : the designator is an array." */
6156 : 84078 : if (array_ref && last_pdt && last_pdt->attr.pdt_type
6157 : 77 : && (ref->u.c.component->attr.pdt_kind
6158 : 77 : || ref->u.c.component->attr.pdt_len))
6159 : 7 : reset_array_ref_to_scalar (expr, array_ref);
6160 : :
6161 : 84078 : n_components++;
6162 : 84078 : break;
6163 : :
6164 : : case REF_SUBSTRING:
6165 : : break;
6166 : :
6167 : 797 : case REF_INQUIRY:
6168 : : /* Implement requirement in note 9.7 of F2018 that the result of the
6169 : : LEN inquiry be a scalar. */
6170 : 797 : if (ref->u.i == INQUIRY_LEN && array_ref
6171 : 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
6172 : 40 : || expr->ts.type == BT_INTEGER))
6173 : 14 : reset_array_ref_to_scalar (expr, array_ref);
6174 : : break;
6175 : : }
6176 : :
6177 : 507445 : if (((ref->type == REF_COMPONENT && n_components > 1)
6178 : 495361 : || ref->next == NULL)
6179 : : && current_part_dimension
6180 : 447612 : && seen_part_dimension)
6181 : : {
6182 : 0 : gfc_error ("Two or more part references with nonzero rank must "
6183 : : "not be specified at %L", &expr->where);
6184 : 0 : return false;
6185 : : }
6186 : :
6187 : 507445 : if (ref->type == REF_COMPONENT)
6188 : : {
6189 : 84078 : if (current_part_dimension)
6190 : 5959 : seen_part_dimension = 1;
6191 : :
6192 : : /* reset to make sure */
6193 : : current_part_dimension = 0;
6194 : : }
6195 : : }
6196 : :
6197 : : return true;
6198 : : }
6199 : :
6200 : :
6201 : : /* Given an expression, determine its shape. This is easier than it sounds.
6202 : : Leaves the shape array NULL if it is not possible to determine the shape. */
6203 : :
6204 : : static void
6205 : 2555184 : expression_shape (gfc_expr *e)
6206 : : {
6207 : 2555184 : mpz_t array[GFC_MAX_DIMENSIONS];
6208 : 2555184 : int i;
6209 : :
6210 : 2555184 : if (e->rank <= 0 || e->shape != NULL)
6211 : 2385025 : return;
6212 : :
6213 : 685760 : for (i = 0; i < e->rank; i++)
6214 : 463304 : if (!gfc_array_dimen_size (e, i, &array[i]))
6215 : 170159 : goto fail;
6216 : :
6217 : 222456 : e->shape = gfc_get_shape (e->rank);
6218 : :
6219 : 222456 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
6220 : :
6221 : 222456 : return;
6222 : :
6223 : 170159 : fail:
6224 : 171830 : for (i--; i >= 0; i--)
6225 : 1671 : mpz_clear (array[i]);
6226 : : }
6227 : :
6228 : :
6229 : : /* Given a variable expression node, compute the rank of the expression by
6230 : : examining the base symbol and any reference structures it may have. */
6231 : :
6232 : : void
6233 : 2555184 : gfc_expression_rank (gfc_expr *e)
6234 : : {
6235 : 2555184 : gfc_ref *ref, *last_arr_ref = nullptr;
6236 : 2555184 : int i, rank, corank;
6237 : :
6238 : : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
6239 : : could lead to serious confusion... */
6240 : 2555184 : gcc_assert (e->expr_type != EXPR_COMPCALL);
6241 : :
6242 : 2555184 : if (e->ref == NULL)
6243 : : {
6244 : 1888686 : if (e->expr_type == EXPR_ARRAY)
6245 : 67937 : goto done;
6246 : : /* Constructors can have a rank different from one via RESHAPE(). */
6247 : :
6248 : 1820749 : if (e->symtree != NULL)
6249 : : {
6250 : : /* After errors the ts.u.derived of a CLASS might not be set. */
6251 : 1820737 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
6252 : 13677 : && e->symtree->n.sym->ts.u.derived
6253 : 13672 : && CLASS_DATA (e->symtree->n.sym))
6254 : 1820737 : ? CLASS_DATA (e->symtree->n.sym)->as
6255 : : : e->symtree->n.sym->as;
6256 : 1820737 : if (as)
6257 : : {
6258 : 586 : e->rank = as->rank;
6259 : 586 : e->corank = as->corank;
6260 : 586 : goto done;
6261 : : }
6262 : : }
6263 : 1820163 : e->rank = 0;
6264 : 1820163 : e->corank = 0;
6265 : 1820163 : goto done;
6266 : : }
6267 : :
6268 : : rank = 0;
6269 : : corank = 0;
6270 : :
6271 : 1047478 : for (ref = e->ref; ref; ref = ref->next)
6272 : : {
6273 : 764648 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
6274 : 547 : && ref->u.c.component->attr.function && !ref->next)
6275 : : {
6276 : 356 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
6277 : 356 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
6278 : : }
6279 : :
6280 : 764648 : if (ref->type != REF_ARRAY)
6281 : 149753 : continue;
6282 : :
6283 : 614895 : last_arr_ref = ref;
6284 : 614895 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
6285 : : {
6286 : 339548 : rank = ref->u.ar.as->rank;
6287 : 339548 : break;
6288 : : }
6289 : :
6290 : 275347 : if (ref->u.ar.type == AR_SECTION)
6291 : : {
6292 : : /* Figure out the rank of the section. */
6293 : 44120 : if (rank != 0)
6294 : 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
6295 : :
6296 : 110438 : for (i = 0; i < ref->u.ar.dimen; i++)
6297 : 66318 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6298 : 66318 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6299 : 57704 : rank++;
6300 : :
6301 : : break;
6302 : : }
6303 : : }
6304 : 666498 : if (last_arr_ref && last_arr_ref->u.ar.as
6305 : 597642 : && last_arr_ref->u.ar.as->rank != -1)
6306 : : {
6307 : 14912 : for (i = last_arr_ref->u.ar.as->rank;
6308 : 604458 : i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
6309 : : {
6310 : : /* For unknown dimen in non-resolved as assume full corank. */
6311 : 15651 : if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
6312 : 15178 : || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6313 : 266 : && !last_arr_ref->u.ar.as->resolved))
6314 : : {
6315 : : corank = last_arr_ref->u.ar.as->corank;
6316 : : break;
6317 : : }
6318 : 14912 : else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
6319 : 14912 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6320 : 14829 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
6321 : 12912 : corank++;
6322 : 2000 : else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
6323 : 0 : gfc_internal_error ("Illegal coarray index");
6324 : : }
6325 : : }
6326 : :
6327 : 666498 : e->rank = rank;
6328 : 666498 : e->corank = corank;
6329 : :
6330 : 2555184 : done:
6331 : 2555184 : expression_shape (e);
6332 : 2555184 : }
6333 : :
6334 : :
6335 : : /* Given two expressions, check that their rank is conformable, i.e. either
6336 : : both have the same rank or at least one is a scalar. */
6337 : :
6338 : : bool
6339 : 12182555 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
6340 : : {
6341 : 12182555 : if (op1->expr_type == EXPR_VARIABLE)
6342 : 723858 : gfc_expression_rank (op1);
6343 : 12182555 : if (op2->expr_type == EXPR_VARIABLE)
6344 : 443947 : gfc_expression_rank (op2);
6345 : :
6346 : 74600 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
6347 : 12256829 : && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
6348 : 20 : || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
6349 : : }
6350 : :
6351 : : /* Resolve a variable expression. */
6352 : :
6353 : : static bool
6354 : 1301346 : resolve_variable (gfc_expr *e)
6355 : : {
6356 : 1301346 : gfc_symbol *sym;
6357 : 1301346 : bool t;
6358 : :
6359 : 1301346 : t = true;
6360 : :
6361 : 1301346 : if (e->symtree == NULL)
6362 : : return false;
6363 : 1300927 : sym = e->symtree->n.sym;
6364 : :
6365 : : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6366 : : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6367 : 1300927 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6368 : : {
6369 : 183 : if (!actual_arg || inquiry_argument)
6370 : : {
6371 : 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6372 : : "be used as actual argument", sym->name, &e->where);
6373 : 2 : return false;
6374 : : }
6375 : : }
6376 : : /* TS 29113, 407b. */
6377 : 1300744 : else if (e->ts.type == BT_ASSUMED)
6378 : : {
6379 : 571 : if (!actual_arg)
6380 : : {
6381 : 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6382 : : "as actual argument", sym->name, &e->where);
6383 : 20 : return false;
6384 : : }
6385 : 551 : else if (inquiry_argument && !first_actual_arg)
6386 : : {
6387 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6388 : : for all inquiry functions in resolve_function; the reason is
6389 : : that the function-name resolution happens too late in that
6390 : : function. */
6391 : 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6392 : : "an inquiry function shall be the first argument",
6393 : : sym->name, &e->where);
6394 : 0 : return false;
6395 : : }
6396 : : }
6397 : : /* TS 29113, C535b. */
6398 : 1300173 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6399 : 36167 : && sym->ts.u.derived && CLASS_DATA (sym)
6400 : 36162 : && CLASS_DATA (sym)->as
6401 : 13918 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6402 : 1299263 : || (sym->ts.type != BT_CLASS && sym->as
6403 : 355315 : && sym->as->type == AS_ASSUMED_RANK))
6404 : 7888 : && !sym->attr.select_rank_temporary
6405 : 7888 : && !(sym->assoc && sym->assoc->ar))
6406 : : {
6407 : 7888 : if (!actual_arg
6408 : 1247 : && !(cs_base && cs_base->current
6409 : 1246 : && (cs_base->current->op == EXEC_SELECT_RANK
6410 : 188 : || sym->attr.target)))
6411 : : {
6412 : 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6413 : : "actual argument", sym->name, &e->where);
6414 : 144 : return false;
6415 : : }
6416 : 7744 : else if (inquiry_argument && !first_actual_arg)
6417 : : {
6418 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6419 : : for all inquiry functions in resolve_function; the reason is
6420 : : that the function-name resolution happens too late in that
6421 : : function. */
6422 : 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6423 : : "to an inquiry function shall be the first argument",
6424 : : sym->name, &e->where);
6425 : 0 : return false;
6426 : : }
6427 : : }
6428 : :
6429 : 1300761 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6430 : 181 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6431 : 180 : && e->ref->next == NULL))
6432 : : {
6433 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6434 : : "a subobject reference", sym->name, &e->ref->u.ar.where);
6435 : 1 : return false;
6436 : : }
6437 : : /* TS 29113, 407b. */
6438 : 1300760 : else if (e->ts.type == BT_ASSUMED && e->ref
6439 : 687 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6440 : 680 : && e->ref->next == NULL))
6441 : : {
6442 : 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6443 : : "reference", sym->name, &e->ref->u.ar.where);
6444 : 7 : return false;
6445 : : }
6446 : :
6447 : : /* TS 29113, C535b. */
6448 : 1300753 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6449 : 36167 : && sym->ts.u.derived && CLASS_DATA (sym)
6450 : 36162 : && CLASS_DATA (sym)->as
6451 : 13918 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6452 : 1299843 : || (sym->ts.type != BT_CLASS && sym->as
6453 : 355851 : && sym->as->type == AS_ASSUMED_RANK))
6454 : 8028 : && !(sym->assoc && sym->assoc->ar)
6455 : 8028 : && e->ref
6456 : 8028 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6457 : 8024 : && e->ref->next == NULL))
6458 : : {
6459 : 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6460 : : "reference", sym->name, &e->ref->u.ar.where);
6461 : 4 : return false;
6462 : : }
6463 : :
6464 : : /* Guessed type variables are associate_names whose selector had not been
6465 : : parsed at the time that the construct was parsed. Now the namespace is
6466 : : being resolved, the TKR of the selector will be available for fixup of
6467 : : the associate_name. */
6468 : 1300749 : if (IS_INFERRED_TYPE (e) && e->ref)
6469 : : {
6470 : 378 : gfc_fixup_inferred_type_refs (e);
6471 : : /* KIND inquiry ref returns the kind of the target. */
6472 : 378 : if (e->expr_type == EXPR_CONSTANT)
6473 : : return true;
6474 : : }
6475 : 1300371 : else if (sym->attr.select_type_temporary
6476 : 8835 : && sym->ns->assoc_name_inferred)
6477 : 92 : gfc_fixup_inferred_type_refs (e);
6478 : :
6479 : : /* For variables that are used in an associate (target => object) where
6480 : : the object's basetype is array valued while the target is scalar,
6481 : : the ts' type of the component refs is still array valued, which
6482 : : can't be translated that way. */
6483 : 1300737 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6484 : 563 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6485 : 563 : && sym->assoc->target->ts.u.derived
6486 : 563 : && CLASS_DATA (sym->assoc->target)
6487 : 563 : && CLASS_DATA (sym->assoc->target)->as)
6488 : : {
6489 : : gfc_ref *ref = e->ref;
6490 : 657 : while (ref)
6491 : : {
6492 : 499 : switch (ref->type)
6493 : : {
6494 : 216 : case REF_COMPONENT:
6495 : 216 : ref->u.c.sym = sym->ts.u.derived;
6496 : : /* Stop the loop. */
6497 : 216 : ref = NULL;
6498 : 216 : break;
6499 : 283 : default:
6500 : 283 : ref = ref->next;
6501 : 283 : break;
6502 : : }
6503 : : }
6504 : : }
6505 : :
6506 : : /* If this is an associate-name, it may be parsed with an array reference
6507 : : in error even though the target is scalar. Fail directly in this case.
6508 : : TODO Understand why class scalar expressions must be excluded. */
6509 : 1300737 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6510 : : {
6511 : 11009 : if (sym->ts.type == BT_CLASS)
6512 : 242 : gfc_fix_class_refs (e);
6513 : 11009 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6514 : 2025 : && e->ref->type == REF_ARRAY)
6515 : : {
6516 : : /* Unambiguously scalar! */
6517 : 3 : if (sym->assoc->target
6518 : 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6519 : 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6520 : 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6521 : : sym->name, &e->where);
6522 : 3 : return false;
6523 : : }
6524 : 11006 : else if ((sym->attr.dimension || sym->attr.codimension)
6525 : 6858 : && (!e->ref || e->ref->type != REF_ARRAY))
6526 : : {
6527 : : /* This can happen because the parser did not detect that the
6528 : : associate name is an array and the expression had no array
6529 : : part_ref. */
6530 : 144 : gfc_ref *ref = gfc_get_ref ();
6531 : 144 : ref->type = REF_ARRAY;
6532 : 144 : ref->u.ar.type = AR_FULL;
6533 : 144 : if (sym->as)
6534 : : {
6535 : 143 : ref->u.ar.as = sym->as;
6536 : 143 : ref->u.ar.dimen = sym->as->rank;
6537 : : }
6538 : 144 : ref->next = e->ref;
6539 : 144 : e->ref = ref;
6540 : : }
6541 : : }
6542 : :
6543 : 1300734 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6544 : 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6545 : :
6546 : : /* On the other hand, the parser may not have known this is an array;
6547 : : in this case, we have to add a FULL reference. */
6548 : 1300734 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6549 : : {
6550 : 0 : e->ref = gfc_get_ref ();
6551 : 0 : e->ref->type = REF_ARRAY;
6552 : 0 : e->ref->u.ar.type = AR_FULL;
6553 : 0 : e->ref->u.ar.dimen = 0;
6554 : : }
6555 : :
6556 : : /* Like above, but for class types, where the checking whether an array
6557 : : ref is present is more complicated. Furthermore make sure not to add
6558 : : the full array ref to _vptr or _len refs. */
6559 : 1300734 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6560 : 968 : && CLASS_DATA (sym)
6561 : 968 : && (CLASS_DATA (sym)->attr.dimension
6562 : 417 : || CLASS_DATA (sym)->attr.codimension)
6563 : 555 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6564 : : {
6565 : 531 : gfc_ref *ref, *newref;
6566 : :
6567 : 531 : newref = gfc_get_ref ();
6568 : 531 : newref->type = REF_ARRAY;
6569 : 531 : newref->u.ar.type = AR_FULL;
6570 : 531 : newref->u.ar.dimen = 0;
6571 : :
6572 : : /* Because this is an associate var and the first ref either is a ref to
6573 : : the _data component or not, no traversal of the ref chain is
6574 : : needed. The array ref needs to be inserted after the _data ref,
6575 : : or when that is not present, which may happened for polymorphic
6576 : : types, then at the first position. */
6577 : 531 : ref = e->ref;
6578 : 531 : if (!ref)
6579 : 18 : e->ref = newref;
6580 : 513 : else if (ref->type == REF_COMPONENT
6581 : 230 : && strcmp ("_data", ref->u.c.component->name) == 0)
6582 : : {
6583 : 230 : if (!ref->next || ref->next->type != REF_ARRAY)
6584 : : {
6585 : 12 : newref->next = ref->next;
6586 : 12 : ref->next = newref;
6587 : : }
6588 : : else
6589 : : /* Array ref present already. */
6590 : 218 : gfc_free_ref_list (newref);
6591 : : }
6592 : 283 : else if (ref->type == REF_ARRAY)
6593 : : /* Array ref present already. */
6594 : 283 : gfc_free_ref_list (newref);
6595 : : else
6596 : : {
6597 : 0 : newref->next = ref;
6598 : 0 : e->ref = newref;
6599 : : }
6600 : : }
6601 : 1300203 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6602 : : {
6603 : 485 : gfc_ref *ref;
6604 : 908 : for (ref = e->ref; ref; ref = ref->next)
6605 : 453 : if (ref->type == REF_SUBSTRING)
6606 : : break;
6607 : 485 : if (ref == NULL)
6608 : 455 : e->ts = sym->ts;
6609 : : }
6610 : :
6611 : 1300734 : if (e->ref && !gfc_resolve_ref (e))
6612 : : return false;
6613 : :
6614 : 1300648 : if (sym->attr.flavor == FL_PROCEDURE
6615 : 30393 : && (!sym->attr.function
6616 : 17868 : || (sym->attr.function && sym->result
6617 : 17420 : && sym->result->attr.proc_pointer
6618 : 562 : && !sym->result->attr.function)))
6619 : : {
6620 : 12525 : e->ts.type = BT_PROCEDURE;
6621 : 12525 : goto resolve_procedure;
6622 : : }
6623 : :
6624 : 1288123 : if (sym->ts.type != BT_UNKNOWN)
6625 : 1287484 : gfc_variable_attr (e, &e->ts);
6626 : 639 : else if (sym->attr.flavor == FL_PROCEDURE
6627 : 12 : && sym->attr.function && sym->result
6628 : 12 : && sym->result->ts.type != BT_UNKNOWN
6629 : 10 : && sym->result->attr.proc_pointer)
6630 : 10 : e->ts = sym->result->ts;
6631 : : else
6632 : : {
6633 : : /* Must be a simple variable reference. */
6634 : 629 : if (!gfc_set_default_type (sym, 1, sym->ns))
6635 : : return false;
6636 : 503 : e->ts = sym->ts;
6637 : : }
6638 : :
6639 : 1287997 : if (check_assumed_size_reference (sym, e))
6640 : : return false;
6641 : :
6642 : : /* Deal with forward references to entries during gfc_resolve_code, to
6643 : : satisfy, at least partially, 12.5.2.5. */
6644 : 1287978 : if (gfc_current_ns->entries
6645 : 3060 : && current_entry_id == sym->entry_id
6646 : 1000 : && cs_base
6647 : 914 : && cs_base->current
6648 : 914 : && cs_base->current->op != EXEC_ENTRY)
6649 : : {
6650 : 914 : gfc_entry_list *entry;
6651 : 914 : gfc_formal_arglist *formal;
6652 : 914 : int n;
6653 : 914 : bool seen, saved_specification_expr;
6654 : :
6655 : : /* If the symbol is a dummy... */
6656 : 914 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6657 : : {
6658 : : entry = gfc_current_ns->entries;
6659 : : seen = false;
6660 : :
6661 : : /* ...test if the symbol is a parameter of previous entries. */
6662 : 1033 : for (; entry && entry->id <= current_entry_id; entry = entry->next)
6663 : 1006 : for (formal = entry->sym->formal; formal; formal = formal->next)
6664 : : {
6665 : 997 : if (formal->sym && sym->name == formal->sym->name)
6666 : : {
6667 : : seen = true;
6668 : : break;
6669 : : }
6670 : : }
6671 : :
6672 : : /* If it has not been seen as a dummy, this is an error. */
6673 : 453 : if (!seen)
6674 : : {
6675 : 3 : if (specification_expr)
6676 : 2 : gfc_error ("Variable %qs, used in a specification expression"
6677 : : ", is referenced at %L before the ENTRY statement "
6678 : : "in which it is a parameter",
6679 : : sym->name, &cs_base->current->loc);
6680 : : else
6681 : 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6682 : : "statement in which it is a parameter",
6683 : : sym->name, &cs_base->current->loc);
6684 : : t = false;
6685 : : }
6686 : : }
6687 : :
6688 : : /* Now do the same check on the specification expressions. */
6689 : 914 : saved_specification_expr = specification_expr;
6690 : 914 : specification_expr = true;
6691 : 914 : if (sym->ts.type == BT_CHARACTER
6692 : 914 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6693 : : t = false;
6694 : :
6695 : 914 : if (sym->as)
6696 : : {
6697 : 271 : for (n = 0; n < sym->as->rank; n++)
6698 : : {
6699 : 159 : if (!gfc_resolve_expr (sym->as->lower[n]))
6700 : 0 : t = false;
6701 : 159 : if (!gfc_resolve_expr (sym->as->upper[n]))
6702 : 1 : t = false;
6703 : : }
6704 : : }
6705 : 914 : specification_expr = saved_specification_expr;
6706 : :
6707 : 914 : if (t)
6708 : : /* Update the symbol's entry level. */
6709 : 909 : sym->entry_id = current_entry_id + 1;
6710 : : }
6711 : :
6712 : : /* If a symbol has been host_associated mark it. This is used latter,
6713 : : to identify if aliasing is possible via host association. */
6714 : 1287978 : if (sym->attr.flavor == FL_VARIABLE
6715 : 1250958 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6716 : 5387 : || !sym->ns->code->ext.block.assoc)
6717 : 1249429 : && gfc_current_ns->parent
6718 : 595492 : && (gfc_current_ns->parent == sym->ns
6719 : 558255 : || (gfc_current_ns->parent->parent
6720 : 10705 : && gfc_current_ns->parent->parent == sym->ns)))
6721 : 43602 : sym->attr.host_assoc = 1;
6722 : :
6723 : 1287978 : if (gfc_current_ns->proc_name
6724 : 1284577 : && sym->attr.dimension
6725 : 350465 : && (sym->ns != gfc_current_ns
6726 : 326814 : || sym->attr.use_assoc
6727 : 322845 : || sym->attr.in_common))
6728 : 32408 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6729 : :
6730 : 1300503 : resolve_procedure:
6731 : 1300503 : if (t && !resolve_procedure_expression (e))
6732 : : t = false;
6733 : :
6734 : : /* F2008, C617 and C1229. */
6735 : 1299476 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6736 : 1394947 : && gfc_is_coindexed (e))
6737 : : {
6738 : 304 : gfc_ref *ref, *ref2 = NULL;
6739 : :
6740 : 383 : for (ref = e->ref; ref; ref = ref->next)
6741 : : {
6742 : 383 : if (ref->type == REF_COMPONENT)
6743 : 79 : ref2 = ref;
6744 : 383 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6745 : : break;
6746 : : }
6747 : :
6748 : 608 : for ( ; ref; ref = ref->next)
6749 : 316 : if (ref->type == REF_COMPONENT)
6750 : : break;
6751 : :
6752 : : /* Expression itself is not coindexed object. */
6753 : 304 : if (ref && e->ts.type == BT_CLASS)
6754 : : {
6755 : 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6756 : : &e->where);
6757 : 3 : t = false;
6758 : : }
6759 : :
6760 : : /* Expression itself is coindexed object. */
6761 : 292 : if (ref == NULL)
6762 : : {
6763 : 292 : gfc_component *c;
6764 : 292 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6765 : 408 : for ( ; c; c = c->next)
6766 : 116 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6767 : : {
6768 : 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6769 : : "subcomponent at %L", &e->where);
6770 : 0 : t = false;
6771 : 0 : break;
6772 : : }
6773 : : }
6774 : : }
6775 : :
6776 : 1300503 : if (t)
6777 : 1300495 : gfc_expression_rank (e);
6778 : :
6779 : 1300503 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6780 : 3 : gfc_warning (OPT_Wdeprecated_declarations,
6781 : : "Using variable %qs at %L is deprecated",
6782 : : sym->name, &e->where);
6783 : : /* Simplify cases where access to a parameter array results in a
6784 : : single constant. Suppress errors since those will have been
6785 : : issued before, as warnings. */
6786 : 1300503 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6787 : : {
6788 : 2671 : gfc_push_suppress_errors ();
6789 : 2671 : gfc_simplify_expr (e, 1);
6790 : 2671 : gfc_pop_suppress_errors ();
6791 : : }
6792 : :
6793 : : return t;
6794 : : }
6795 : :
6796 : :
6797 : : /* 'sym' was initially guessed to be derived type but has been corrected
6798 : : in resolve_assoc_var to be a class entity or the derived type correcting.
6799 : : If a class entity it will certainly need the _data reference or the
6800 : : reference derived type symbol correcting in the first component ref if
6801 : : a derived type. */
6802 : :
6803 : : void
6804 : 856 : gfc_fixup_inferred_type_refs (gfc_expr *e)
6805 : : {
6806 : 856 : gfc_ref *ref, *new_ref;
6807 : 856 : gfc_symbol *sym, *derived;
6808 : 856 : gfc_expr *target;
6809 : 856 : sym = e->symtree->n.sym;
6810 : :
6811 : : /* An associate_name whose selector is (i) a component ref of a selector
6812 : : that is a inferred type associate_name; or (ii) an intrinsic type that
6813 : : has been inferred from an inquiry ref. */
6814 : 856 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
6815 : : {
6816 : 282 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
6817 : 282 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
6818 : 282 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
6819 : : {
6820 : 60 : ref = e->ref;
6821 : : /* A substring misidentified as an array section. */
6822 : 60 : if (sym->ts.type == BT_CHARACTER
6823 : 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
6824 : 6 : && !ref->u.ar.stride[0])
6825 : : {
6826 : 6 : new_ref = gfc_get_ref ();
6827 : 6 : new_ref->type = REF_SUBSTRING;
6828 : 6 : new_ref->u.ss.start = ref->u.ar.start[0];
6829 : 6 : new_ref->u.ss.end = ref->u.ar.end[0];
6830 : 6 : new_ref->u.ss.length = sym->ts.u.cl;
6831 : 6 : *ref = *new_ref;
6832 : 6 : free (new_ref);
6833 : : }
6834 : : else
6835 : : {
6836 : 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
6837 : 24 : gfc_error ("Invalid array reference at %L", &e->where);
6838 : 54 : e->ref = ref->next;
6839 : 54 : free (ref);
6840 : : }
6841 : : }
6842 : :
6843 : : /* It is possible for an inquiry reference to be mistaken for a
6844 : : component reference. Correct this now. */
6845 : 282 : ref = e->ref;
6846 : 282 : if (ref && ref->type == REF_ARRAY)
6847 : 138 : ref = ref->next;
6848 : 150 : if (ref && ref->type == REF_COMPONENT
6849 : 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
6850 : : {
6851 : 12 : e->symtree->n.sym = sym;
6852 : 12 : *ref = *new_ref;
6853 : 12 : gfc_free_ref_list (new_ref);
6854 : : }
6855 : :
6856 : : /* The kind of the associate name is best evaluated directly from the
6857 : : selector because of the guesses made in primary.cc, when the type
6858 : : is still unknown. */
6859 : 282 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
6860 : : {
6861 : 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6862 : 12 : sym->assoc->target->ts.kind);
6863 : 12 : gfc_replace_expr (e, ne);
6864 : : }
6865 : :
6866 : : /* Now that the references are all sorted out, set the expression rank
6867 : : and return. */
6868 : 282 : gfc_expression_rank (e);
6869 : 282 : return;
6870 : : }
6871 : :
6872 : 574 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
6873 : : : sym->ts.u.derived;
6874 : :
6875 : : /* Ensure that class symbols have an array spec and ensure that there
6876 : : is a _data field reference following class type references. */
6877 : 574 : if (sym->ts.type == BT_CLASS
6878 : 196 : && sym->assoc->target->ts.type == BT_CLASS)
6879 : : {
6880 : 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
6881 : 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
6882 : 196 : sym->attr.dimension = 0;
6883 : 196 : sym->attr.codimension = 0;
6884 : 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
6885 : 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
6886 : 196 : if (e->ref && (e->ref->type != REF_COMPONENT
6887 : 160 : || e->ref->u.c.component->name[0] != '_'))
6888 : : {
6889 : 82 : ref = gfc_get_ref ();
6890 : 82 : ref->type = REF_COMPONENT;
6891 : 82 : ref->next = e->ref;
6892 : 82 : e->ref = ref;
6893 : 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
6894 : : true, true, NULL);
6895 : 82 : ref->u.c.sym = sym->ts.u.derived;
6896 : : }
6897 : : }
6898 : :
6899 : : /* Proceed as far as the first component reference and ensure that the
6900 : : correct derived type is being used. */
6901 : 837 : for (ref = e->ref; ref; ref = ref->next)
6902 : 801 : if (ref->type == REF_COMPONENT)
6903 : : {
6904 : 538 : if (ref->u.c.component->name[0] != '_')
6905 : 342 : ref->u.c.sym = derived;
6906 : : else
6907 : 196 : ref->u.c.sym = sym->ts.u.derived;
6908 : : break;
6909 : : }
6910 : :
6911 : : /* Verify that the type inferrence mechanism has not introduced a spurious
6912 : : array reference. This can happen with an associate name, whose selector
6913 : : is an element of another inferred type. */
6914 : 574 : target = e->symtree->n.sym->assoc->target;
6915 : 574 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
6916 : 162 : && e != target && !target->rank)
6917 : : {
6918 : : /* First case: array ref after the scalar class or derived
6919 : : associate_name. */
6920 : 162 : if (e->ref && e->ref->type == REF_ARRAY
6921 : 7 : && e->ref->u.ar.type != AR_ELEMENT)
6922 : : {
6923 : 7 : ref = e->ref;
6924 : 7 : if (ref->u.ar.type == AR_UNKNOWN)
6925 : 1 : gfc_error ("Invalid array reference at %L", &e->where);
6926 : 7 : e->ref = ref->next;
6927 : 7 : free (ref);
6928 : :
6929 : : /* If it hasn't a ref to the '_data' field supply one. */
6930 : 7 : if (sym->ts.type == BT_CLASS
6931 : 0 : && !(e->ref->type == REF_COMPONENT
6932 : 0 : && strcmp (e->ref->u.c.component->name, "_data")))
6933 : : {
6934 : 0 : gfc_ref *new_ref;
6935 : 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
6936 : : "_data", true, true, &new_ref);
6937 : 0 : new_ref->next = e->ref;
6938 : 0 : e->ref = new_ref;
6939 : : }
6940 : : }
6941 : : /* 2nd case: a ref to the '_data' field followed by an array ref. */
6942 : 155 : else if (e->ref && e->ref->type == REF_COMPONENT
6943 : 155 : && strcmp (e->ref->u.c.component->name, "_data") == 0
6944 : 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
6945 : 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
6946 : : {
6947 : 0 : ref = e->ref->next;
6948 : 0 : if (ref->u.ar.type == AR_UNKNOWN)
6949 : 0 : gfc_error ("Invalid array reference at %L", &e->where);
6950 : 0 : e->ref->next = e->ref->next->next;
6951 : 0 : free (ref);
6952 : : }
6953 : : }
6954 : :
6955 : : /* Now that all the references are OK, get the expression rank. */
6956 : 574 : gfc_expression_rank (e);
6957 : : }
6958 : :
6959 : :
6960 : : /* Checks to see that the correct symbol has been host associated.
6961 : : The only situations where this arises are:
6962 : : (i) That in which a twice contained function is parsed after
6963 : : the host association is made. On detecting this, change
6964 : : the symbol in the expression and convert the array reference
6965 : : into an actual arglist if the old symbol is a variable; or
6966 : : (ii) That in which an external function is typed but not declared
6967 : : explicitly to be external. Here, the old symbol is changed
6968 : : from a variable to an external function. */
6969 : : static bool
6970 : 1639307 : check_host_association (gfc_expr *e)
6971 : : {
6972 : 1639307 : gfc_symbol *sym, *old_sym;
6973 : 1639307 : gfc_symtree *st;
6974 : 1639307 : int n;
6975 : 1639307 : gfc_ref *ref;
6976 : 1639307 : gfc_actual_arglist *arg, *tail = NULL;
6977 : 1639307 : bool retval = e->expr_type == EXPR_FUNCTION;
6978 : :
6979 : : /* If the expression is the result of substitution in
6980 : : interface.cc(gfc_extend_expr) because there is no way in
6981 : : which the host association can be wrong. */
6982 : 1639307 : if (e->symtree == NULL
6983 : 1638559 : || e->symtree->n.sym == NULL
6984 : 1638559 : || e->user_operator)
6985 : : return retval;
6986 : :
6987 : 1636788 : old_sym = e->symtree->n.sym;
6988 : :
6989 : 1636788 : if (gfc_current_ns->parent
6990 : 717507 : && old_sym->ns != gfc_current_ns)
6991 : : {
6992 : : /* Use the 'USE' name so that renamed module symbols are
6993 : : correctly handled. */
6994 : 88256 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
6995 : :
6996 : 88256 : if (sym && old_sym != sym
6997 : 500 : && sym->attr.flavor == FL_PROCEDURE
6998 : 105 : && sym->attr.contained)
6999 : : {
7000 : : /* Clear the shape, since it might not be valid. */
7001 : 83 : gfc_free_shape (&e->shape, e->rank);
7002 : :
7003 : : /* Give the expression the right symtree! */
7004 : 83 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7005 : 83 : gcc_assert (st != NULL);
7006 : :
7007 : 83 : if (old_sym->attr.flavor == FL_PROCEDURE
7008 : 59 : || e->expr_type == EXPR_FUNCTION)
7009 : : {
7010 : : /* Original was function so point to the new symbol, since
7011 : : the actual argument list is already attached to the
7012 : : expression. */
7013 : 30 : e->value.function.esym = NULL;
7014 : 30 : e->symtree = st;
7015 : : }
7016 : : else
7017 : : {
7018 : : /* Original was variable so convert array references into
7019 : : an actual arglist. This does not need any checking now
7020 : : since resolve_function will take care of it. */
7021 : 53 : e->value.function.actual = NULL;
7022 : 53 : e->expr_type = EXPR_FUNCTION;
7023 : 53 : e->symtree = st;
7024 : :
7025 : : /* Ambiguity will not arise if the array reference is not
7026 : : the last reference. */
7027 : 55 : for (ref = e->ref; ref; ref = ref->next)
7028 : 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7029 : : break;
7030 : :
7031 : 53 : if ((ref == NULL || ref->type != REF_ARRAY)
7032 : 17 : && sym->attr.proc == PROC_INTERNAL)
7033 : : {
7034 : 4 : gfc_error ("%qs at %L is host associated at %L into "
7035 : : "a contained procedure with an internal "
7036 : : "procedure of the same name", sym->name,
7037 : : &old_sym->declared_at, &e->where);
7038 : 4 : return false;
7039 : : }
7040 : :
7041 : 13 : if (ref == NULL)
7042 : : return false;
7043 : :
7044 : 36 : gcc_assert (ref->type == REF_ARRAY);
7045 : :
7046 : : /* Grab the start expressions from the array ref and
7047 : : copy them into actual arguments. */
7048 : 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7049 : : {
7050 : 48 : arg = gfc_get_actual_arglist ();
7051 : 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7052 : 48 : if (e->value.function.actual == NULL)
7053 : 36 : tail = e->value.function.actual = arg;
7054 : : else
7055 : : {
7056 : 12 : tail->next = arg;
7057 : 12 : tail = arg;
7058 : : }
7059 : : }
7060 : :
7061 : : /* Dump the reference list and set the rank. */
7062 : 36 : gfc_free_ref_list (e->ref);
7063 : 36 : e->ref = NULL;
7064 : 36 : e->rank = sym->as ? sym->as->rank : 0;
7065 : 36 : e->corank = sym->as ? sym->as->corank : 0;
7066 : : }
7067 : :
7068 : 66 : gfc_resolve_expr (e);
7069 : 66 : sym->refs++;
7070 : : }
7071 : : /* This case corresponds to a call, from a block or a contained
7072 : : procedure, to an external function, which has not been declared
7073 : : as being external in the main program but has been typed. */
7074 : 88173 : else if (sym && old_sym != sym
7075 : 417 : && !e->ref
7076 : 255 : && sym->ts.type == BT_UNKNOWN
7077 : 21 : && old_sym->ts.type != BT_UNKNOWN
7078 : 19 : && sym->attr.flavor == FL_PROCEDURE
7079 : 19 : && old_sym->attr.flavor == FL_VARIABLE
7080 : 7 : && sym->ns->parent == old_sym->ns
7081 : 7 : && sym->ns->proc_name
7082 : 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7083 : 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7084 : 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7085 : : {
7086 : 6 : old_sym->attr.flavor = FL_PROCEDURE;
7087 : 6 : old_sym->attr.external = 1;
7088 : 6 : old_sym->attr.function = 1;
7089 : 6 : old_sym->result = old_sym;
7090 : 6 : gfc_resolve_expr (e);
7091 : : }
7092 : : }
7093 : : /* This might have changed! */
7094 : 1636771 : return e->expr_type == EXPR_FUNCTION;
7095 : : }
7096 : :
7097 : :
7098 : : static void
7099 : 1436 : gfc_resolve_character_operator (gfc_expr *e)
7100 : : {
7101 : 1436 : gfc_expr *op1 = e->value.op.op1;
7102 : 1436 : gfc_expr *op2 = e->value.op.op2;
7103 : 1436 : gfc_expr *e1 = NULL;
7104 : 1436 : gfc_expr *e2 = NULL;
7105 : :
7106 : 1436 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7107 : :
7108 : 1436 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7109 : 761 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7110 : 675 : else if (op1->expr_type == EXPR_CONSTANT)
7111 : 268 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7112 : 268 : op1->value.character.length);
7113 : :
7114 : 1436 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7115 : 749 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7116 : 687 : else if (op2->expr_type == EXPR_CONSTANT)
7117 : 457 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7118 : 457 : op2->value.character.length);
7119 : :
7120 : 1436 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7121 : :
7122 : 1436 : if (!e1 || !e2)
7123 : : {
7124 : 535 : gfc_free_expr (e1);
7125 : 535 : gfc_free_expr (e2);
7126 : :
7127 : 535 : return;
7128 : : }
7129 : :
7130 : 901 : e->ts.u.cl->length = gfc_add (e1, e2);
7131 : 901 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7132 : 901 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7133 : 901 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7134 : 901 : gfc_resolve_expr (e->ts.u.cl->length);
7135 : :
7136 : 901 : return;
7137 : : }
7138 : :
7139 : :
7140 : : /* Ensure that an character expression has a charlen and, if possible, a
7141 : : length expression. */
7142 : :
7143 : : static void
7144 : 177355 : fixup_charlen (gfc_expr *e)
7145 : : {
7146 : : /* The cases fall through so that changes in expression type and the need
7147 : : for multiple fixes are picked up. In all circumstances, a charlen should
7148 : : be available for the middle end to hang a backend_decl on. */
7149 : 177355 : switch (e->expr_type)
7150 : : {
7151 : 1436 : case EXPR_OP:
7152 : 1436 : gfc_resolve_character_operator (e);
7153 : : /* FALLTHRU */
7154 : :
7155 : 1491 : case EXPR_ARRAY:
7156 : 1491 : if (e->expr_type == EXPR_ARRAY)
7157 : 55 : gfc_resolve_character_array_constructor (e);
7158 : : /* FALLTHRU */
7159 : :
7160 : 1947 : case EXPR_SUBSTRING:
7161 : 1947 : if (!e->ts.u.cl && e->ref)
7162 : 452 : gfc_resolve_substring_charlen (e);
7163 : : /* FALLTHRU */
7164 : :
7165 : 177355 : default:
7166 : 177355 : if (!e->ts.u.cl)
7167 : 175412 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7168 : :
7169 : 177355 : break;
7170 : : }
7171 : 177355 : }
7172 : :
7173 : :
7174 : : /* Update an actual argument to include the passed-object for type-bound
7175 : : procedures at the right position. */
7176 : :
7177 : : static gfc_actual_arglist*
7178 : 2918 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7179 : : const char *name)
7180 : : {
7181 : 2942 : gcc_assert (argpos > 0);
7182 : :
7183 : 2942 : if (argpos == 1)
7184 : : {
7185 : 2793 : gfc_actual_arglist* result;
7186 : :
7187 : 2793 : result = gfc_get_actual_arglist ();
7188 : 2793 : result->expr = po;
7189 : 2793 : result->next = lst;
7190 : 2793 : if (name)
7191 : 514 : result->name = name;
7192 : :
7193 : 2793 : return result;
7194 : : }
7195 : :
7196 : 149 : if (lst)
7197 : 125 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7198 : : else
7199 : 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7200 : : return lst;
7201 : : }
7202 : :
7203 : :
7204 : : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7205 : :
7206 : : static gfc_expr*
7207 : 7048 : extract_compcall_passed_object (gfc_expr* e)
7208 : : {
7209 : 7048 : gfc_expr* po;
7210 : :
7211 : 7048 : if (e->expr_type == EXPR_UNKNOWN)
7212 : : {
7213 : 0 : gfc_error ("Error in typebound call at %L",
7214 : : &e->where);
7215 : 0 : return NULL;
7216 : : }
7217 : :
7218 : 7048 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7219 : :
7220 : 7048 : if (e->value.compcall.base_object)
7221 : 1514 : po = gfc_copy_expr (e->value.compcall.base_object);
7222 : : else
7223 : : {
7224 : 5534 : po = gfc_get_expr ();
7225 : 5534 : po->expr_type = EXPR_VARIABLE;
7226 : 5534 : po->symtree = e->symtree;
7227 : 5534 : po->ref = gfc_copy_ref (e->ref);
7228 : 5534 : po->where = e->where;
7229 : : }
7230 : :
7231 : 7048 : if (!gfc_resolve_expr (po))
7232 : : return NULL;
7233 : :
7234 : : return po;
7235 : : }
7236 : :
7237 : :
7238 : : /* Update the arglist of an EXPR_COMPCALL expression to include the
7239 : : passed-object. */
7240 : :
7241 : : static bool
7242 : 3246 : update_compcall_arglist (gfc_expr* e)
7243 : : {
7244 : 3246 : gfc_expr* po;
7245 : 3246 : gfc_typebound_proc* tbp;
7246 : :
7247 : 3246 : tbp = e->value.compcall.tbp;
7248 : :
7249 : 3246 : if (tbp->error)
7250 : : return false;
7251 : :
7252 : 3245 : po = extract_compcall_passed_object (e);
7253 : 3245 : if (!po)
7254 : : return false;
7255 : :
7256 : 3245 : if (tbp->nopass || e->value.compcall.ignore_pass)
7257 : : {
7258 : 1081 : gfc_free_expr (po);
7259 : 1081 : return true;
7260 : : }
7261 : :
7262 : 2164 : if (tbp->pass_arg_num <= 0)
7263 : : return false;
7264 : :
7265 : 2163 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7266 : : tbp->pass_arg_num,
7267 : : tbp->pass_arg);
7268 : :
7269 : 2163 : return true;
7270 : : }
7271 : :
7272 : :
7273 : : /* Extract the passed object from a PPC call (a copy of it). */
7274 : :
7275 : : static gfc_expr*
7276 : 85 : extract_ppc_passed_object (gfc_expr *e)
7277 : : {
7278 : 85 : gfc_expr *po;
7279 : 85 : gfc_ref **ref;
7280 : :
7281 : 85 : po = gfc_get_expr ();
7282 : 85 : po->expr_type = EXPR_VARIABLE;
7283 : 85 : po->symtree = e->symtree;
7284 : 85 : po->ref = gfc_copy_ref (e->ref);
7285 : 85 : po->where = e->where;
7286 : :
7287 : : /* Remove PPC reference. */
7288 : 85 : ref = &po->ref;
7289 : 91 : while ((*ref)->next)
7290 : 6 : ref = &(*ref)->next;
7291 : 85 : gfc_free_ref_list (*ref);
7292 : 85 : *ref = NULL;
7293 : :
7294 : 85 : if (!gfc_resolve_expr (po))
7295 : 0 : return NULL;
7296 : :
7297 : : return po;
7298 : : }
7299 : :
7300 : :
7301 : : /* Update the actual arglist of a procedure pointer component to include the
7302 : : passed-object. */
7303 : :
7304 : : static bool
7305 : 573 : update_ppc_arglist (gfc_expr* e)
7306 : : {
7307 : 573 : gfc_expr* po;
7308 : 573 : gfc_component *ppc;
7309 : 573 : gfc_typebound_proc* tb;
7310 : :
7311 : 573 : ppc = gfc_get_proc_ptr_comp (e);
7312 : 573 : if (!ppc)
7313 : : return false;
7314 : :
7315 : 573 : tb = ppc->tb;
7316 : :
7317 : 573 : if (tb->error)
7318 : : return false;
7319 : 571 : else if (tb->nopass)
7320 : : return true;
7321 : :
7322 : 85 : po = extract_ppc_passed_object (e);
7323 : 85 : if (!po)
7324 : : return false;
7325 : :
7326 : : /* F08:R739. */
7327 : 85 : if (po->rank != 0)
7328 : : {
7329 : 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7330 : 0 : return false;
7331 : : }
7332 : :
7333 : : /* F08:C611. */
7334 : 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7335 : : {
7336 : 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7337 : : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7338 : 1 : return false;
7339 : : }
7340 : :
7341 : 84 : gcc_assert (tb->pass_arg_num > 0);
7342 : 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7343 : : tb->pass_arg_num,
7344 : : tb->pass_arg);
7345 : :
7346 : 84 : return true;
7347 : : }
7348 : :
7349 : :
7350 : : /* Check that the object a TBP is called on is valid, i.e. it must not be
7351 : : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7352 : :
7353 : : static bool
7354 : 3257 : check_typebound_baseobject (gfc_expr* e)
7355 : : {
7356 : 3257 : gfc_expr* base;
7357 : 3257 : bool return_value = false;
7358 : :
7359 : 3257 : base = extract_compcall_passed_object (e);
7360 : 3257 : if (!base)
7361 : : return false;
7362 : :
7363 : 3254 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7364 : : {
7365 : 1 : gfc_error ("Error in typebound call at %L", &e->where);
7366 : 1 : goto cleanup;
7367 : : }
7368 : :
7369 : 3253 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7370 : 1 : return false;
7371 : :
7372 : : /* F08:C611. */
7373 : 3252 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7374 : : {
7375 : 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7376 : : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7377 : 3 : goto cleanup;
7378 : : }
7379 : :
7380 : : /* F08:C1230. If the procedure called is NOPASS,
7381 : : the base object must be scalar. */
7382 : 3249 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7383 : : {
7384 : 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7385 : : " be scalar", &e->where);
7386 : 1 : goto cleanup;
7387 : : }
7388 : :
7389 : : return_value = true;
7390 : :
7391 : 3253 : cleanup:
7392 : 3253 : gfc_free_expr (base);
7393 : 3253 : return return_value;
7394 : : }
7395 : :
7396 : :
7397 : : /* Resolve a call to a type-bound procedure, either function or subroutine,
7398 : : statically from the data in an EXPR_COMPCALL expression. The adapted
7399 : : arglist and the target-procedure symtree are returned. */
7400 : :
7401 : : static bool
7402 : 3246 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7403 : : gfc_actual_arglist** actual)
7404 : : {
7405 : 3246 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7406 : 3246 : gcc_assert (!e->value.compcall.tbp->is_generic);
7407 : :
7408 : : /* Update the actual arglist for PASS. */
7409 : 3246 : if (!update_compcall_arglist (e))
7410 : : return false;
7411 : :
7412 : 3244 : *actual = e->value.compcall.actual;
7413 : 3244 : *target = e->value.compcall.tbp->u.specific;
7414 : :
7415 : 3244 : gfc_free_ref_list (e->ref);
7416 : 3244 : e->ref = NULL;
7417 : 3244 : e->value.compcall.actual = NULL;
7418 : :
7419 : : /* If we find a deferred typebound procedure, check for derived types
7420 : : that an overriding typebound procedure has not been missed. */
7421 : 3244 : if (e->value.compcall.name
7422 : 3244 : && !e->value.compcall.tbp->non_overridable
7423 : 3226 : && e->value.compcall.base_object
7424 : 757 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7425 : : {
7426 : 470 : gfc_symtree *st;
7427 : 470 : gfc_symbol *derived;
7428 : :
7429 : : /* Use the derived type of the base_object. */
7430 : 470 : derived = e->value.compcall.base_object->ts.u.derived;
7431 : 470 : st = NULL;
7432 : :
7433 : : /* If necessary, go through the inheritance chain. */
7434 : 1411 : while (!st && derived)
7435 : : {
7436 : : /* Look for the typebound procedure 'name'. */
7437 : 471 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7438 : 470 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7439 : : e->value.compcall.name);
7440 : 471 : if (!st)
7441 : 1 : derived = gfc_get_derived_super_type (derived);
7442 : : }
7443 : :
7444 : : /* Now find the specific name in the derived type namespace. */
7445 : 470 : if (st && st->n.tb && st->n.tb->u.specific)
7446 : 470 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7447 : 470 : derived->ns, 1, &st);
7448 : 470 : if (st)
7449 : 470 : *target = st;
7450 : : }
7451 : :
7452 : 3244 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7453 : 3244 : && !e->value.compcall.tbp->deferred)
7454 : 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7455 : : " itself recursively. Declare it RECURSIVE or use"
7456 : : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7457 : :
7458 : : return true;
7459 : : }
7460 : :
7461 : :
7462 : : /* Get the ultimate declared type from an expression. In addition,
7463 : : return the last class/derived type reference and the copy of the
7464 : : reference list. If check_types is set true, derived types are
7465 : : identified as well as class references. */
7466 : : static gfc_symbol*
7467 : 3215 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7468 : : gfc_expr *e, bool check_types)
7469 : : {
7470 : 3215 : gfc_symbol *declared;
7471 : 3215 : gfc_ref *ref;
7472 : :
7473 : 3215 : declared = NULL;
7474 : 3215 : if (class_ref)
7475 : 2811 : *class_ref = NULL;
7476 : 3215 : if (new_ref)
7477 : 2524 : *new_ref = gfc_copy_ref (e->ref);
7478 : :
7479 : 3986 : for (ref = e->ref; ref; ref = ref->next)
7480 : : {
7481 : 771 : if (ref->type != REF_COMPONENT)
7482 : 283 : continue;
7483 : :
7484 : 488 : if ((ref->u.c.component->ts.type == BT_CLASS
7485 : 242 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7486 : 413 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7487 : : {
7488 : 339 : declared = ref->u.c.component->ts.u.derived;
7489 : 339 : if (class_ref)
7490 : 320 : *class_ref = ref;
7491 : : }
7492 : : }
7493 : :
7494 : 3215 : if (declared == NULL)
7495 : 2902 : declared = e->symtree->n.sym->ts.u.derived;
7496 : :
7497 : 3215 : return declared;
7498 : : }
7499 : :
7500 : :
7501 : : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7502 : : which of the specific bindings (if any) matches the arglist and transform
7503 : : the expression into a call of that binding. */
7504 : :
7505 : : static bool
7506 : 3248 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7507 : : {
7508 : 3248 : gfc_typebound_proc* genproc;
7509 : 3248 : const char* genname;
7510 : 3248 : gfc_symtree *st;
7511 : 3248 : gfc_symbol *derived;
7512 : :
7513 : 3248 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7514 : 3248 : genname = e->value.compcall.name;
7515 : 3248 : genproc = e->value.compcall.tbp;
7516 : :
7517 : 3248 : if (!genproc->is_generic)
7518 : : return true;
7519 : :
7520 : : /* Try the bindings on this type and in the inheritance hierarchy. */
7521 : 416 : for (; genproc; genproc = genproc->overridden)
7522 : : {
7523 : 414 : gfc_tbp_generic* g;
7524 : :
7525 : 414 : gcc_assert (genproc->is_generic);
7526 : 642 : for (g = genproc->u.generic; g; g = g->next)
7527 : : {
7528 : 632 : gfc_symbol* target;
7529 : 632 : gfc_actual_arglist* args;
7530 : 632 : bool matches;
7531 : :
7532 : 632 : gcc_assert (g->specific);
7533 : :
7534 : 632 : if (g->specific->error)
7535 : 0 : continue;
7536 : :
7537 : 632 : target = g->specific->u.specific->n.sym;
7538 : :
7539 : : /* Get the right arglist by handling PASS/NOPASS. */
7540 : 632 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7541 : 632 : if (!g->specific->nopass)
7542 : : {
7543 : 546 : gfc_expr* po;
7544 : 546 : po = extract_compcall_passed_object (e);
7545 : 546 : if (!po)
7546 : : {
7547 : 0 : gfc_free_actual_arglist (args);
7548 : 0 : return false;
7549 : : }
7550 : :
7551 : 546 : gcc_assert (g->specific->pass_arg_num > 0);
7552 : 546 : gcc_assert (!g->specific->error);
7553 : 546 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7554 : : g->specific->pass_arg);
7555 : : }
7556 : 632 : resolve_actual_arglist (args, target->attr.proc,
7557 : 632 : is_external_proc (target)
7558 : 632 : && gfc_sym_get_dummy_args (target) == NULL);
7559 : :
7560 : : /* Check if this arglist matches the formal. */
7561 : 632 : matches = gfc_arglist_matches_symbol (&args, target);
7562 : :
7563 : : /* Clean up and break out of the loop if we've found it. */
7564 : 632 : gfc_free_actual_arglist (args);
7565 : 632 : if (matches)
7566 : : {
7567 : 404 : e->value.compcall.tbp = g->specific;
7568 : 404 : genname = g->specific_st->name;
7569 : : /* Pass along the name for CLASS methods, where the vtab
7570 : : procedure pointer component has to be referenced. */
7571 : 404 : if (name)
7572 : 159 : *name = genname;
7573 : 404 : goto success;
7574 : : }
7575 : : }
7576 : : }
7577 : :
7578 : : /* Nothing matching found! */
7579 : 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7580 : : " %qs at %L", genname, &e->where);
7581 : 2 : return false;
7582 : :
7583 : 404 : success:
7584 : : /* Make sure that we have the right specific instance for the name. */
7585 : 404 : derived = get_declared_from_expr (NULL, NULL, e, true);
7586 : :
7587 : 404 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7588 : 404 : if (st)
7589 : 404 : e->value.compcall.tbp = st->n.tb;
7590 : :
7591 : : return true;
7592 : : }
7593 : :
7594 : :
7595 : : /* Resolve a call to a type-bound subroutine. */
7596 : :
7597 : : static bool
7598 : 1676 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7599 : : {
7600 : 1676 : gfc_actual_arglist* newactual;
7601 : 1676 : gfc_symtree* target;
7602 : :
7603 : : /* Check that's really a SUBROUTINE. */
7604 : 1676 : if (!c->expr1->value.compcall.tbp->subroutine)
7605 : : {
7606 : 17 : if (!c->expr1->value.compcall.tbp->is_generic
7607 : 15 : && c->expr1->value.compcall.tbp->u.specific
7608 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7609 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7610 : 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7611 : : else
7612 : : {
7613 : 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7614 : : c->expr1->value.compcall.name, &c->loc);
7615 : 5 : return false;
7616 : : }
7617 : : }
7618 : :
7619 : 1671 : if (!check_typebound_baseobject (c->expr1))
7620 : : return false;
7621 : :
7622 : : /* Pass along the name for CLASS methods, where the vtab
7623 : : procedure pointer component has to be referenced. */
7624 : 1664 : if (name)
7625 : 473 : *name = c->expr1->value.compcall.name;
7626 : :
7627 : 1664 : if (!resolve_typebound_generic_call (c->expr1, name))
7628 : : return false;
7629 : :
7630 : : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7631 : 1663 : if (overridable)
7632 : 370 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7633 : :
7634 : : /* Transform into an ordinary EXEC_CALL for now. */
7635 : :
7636 : 1663 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7637 : : return false;
7638 : :
7639 : 1661 : c->ext.actual = newactual;
7640 : 1661 : c->symtree = target;
7641 : 1661 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7642 : :
7643 : 1661 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7644 : :
7645 : 1661 : gfc_free_expr (c->expr1);
7646 : 1661 : c->expr1 = gfc_get_expr ();
7647 : 1661 : c->expr1->expr_type = EXPR_FUNCTION;
7648 : 1661 : c->expr1->symtree = target;
7649 : 1661 : c->expr1->where = c->loc;
7650 : :
7651 : 1661 : return resolve_call (c);
7652 : : }
7653 : :
7654 : :
7655 : : /* Resolve a component-call expression. */
7656 : : static bool
7657 : 1605 : resolve_compcall (gfc_expr* e, const char **name)
7658 : : {
7659 : 1605 : gfc_actual_arglist* newactual;
7660 : 1605 : gfc_symtree* target;
7661 : :
7662 : : /* Check that's really a FUNCTION. */
7663 : 1605 : if (!e->value.compcall.tbp->function)
7664 : : {
7665 : 19 : if (e->symtree && e->symtree->n.sym->resolve_symbol_called)
7666 : 5 : gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name,
7667 : : &e->where);
7668 : 19 : return false;
7669 : : }
7670 : :
7671 : :
7672 : : /* These must not be assign-calls! */
7673 : 1586 : gcc_assert (!e->value.compcall.assign);
7674 : :
7675 : 1586 : if (!check_typebound_baseobject (e))
7676 : : return false;
7677 : :
7678 : : /* Pass along the name for CLASS methods, where the vtab
7679 : : procedure pointer component has to be referenced. */
7680 : 1584 : if (name)
7681 : 858 : *name = e->value.compcall.name;
7682 : :
7683 : 1584 : if (!resolve_typebound_generic_call (e, name))
7684 : : return false;
7685 : 1583 : gcc_assert (!e->value.compcall.tbp->is_generic);
7686 : :
7687 : : /* Take the rank from the function's symbol. */
7688 : 1583 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7689 : : {
7690 : 154 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7691 : 154 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7692 : : }
7693 : :
7694 : : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7695 : : arglist to the TBP's binding target. */
7696 : :
7697 : 1583 : if (!resolve_typebound_static (e, &target, &newactual))
7698 : : return false;
7699 : :
7700 : 1583 : e->value.function.actual = newactual;
7701 : 1583 : e->value.function.name = NULL;
7702 : 1583 : e->value.function.esym = target->n.sym;
7703 : 1583 : e->value.function.isym = NULL;
7704 : 1583 : e->symtree = target;
7705 : 1583 : e->ts = target->n.sym->ts;
7706 : 1583 : e->expr_type = EXPR_FUNCTION;
7707 : :
7708 : : /* Resolution is not necessary if this is a class subroutine; this
7709 : : function only has to identify the specific proc. Resolution of
7710 : : the call will be done next in resolve_typebound_call. */
7711 : 1583 : return gfc_resolve_expr (e);
7712 : : }
7713 : :
7714 : :
7715 : : static bool resolve_fl_derived (gfc_symbol *sym);
7716 : :
7717 : :
7718 : : /* Resolve a typebound function, or 'method'. First separate all
7719 : : the non-CLASS references by calling resolve_compcall directly. */
7720 : :
7721 : : static bool
7722 : 1605 : resolve_typebound_function (gfc_expr* e)
7723 : : {
7724 : 1605 : gfc_symbol *declared;
7725 : 1605 : gfc_component *c;
7726 : 1605 : gfc_ref *new_ref;
7727 : 1605 : gfc_ref *class_ref;
7728 : 1605 : gfc_symtree *st;
7729 : 1605 : const char *name;
7730 : 1605 : gfc_typespec ts;
7731 : 1605 : gfc_expr *expr;
7732 : 1605 : bool overridable;
7733 : :
7734 : 1605 : st = e->symtree;
7735 : :
7736 : : /* Deal with typebound operators for CLASS objects. */
7737 : 1605 : expr = e->value.compcall.base_object;
7738 : 1605 : overridable = !e->value.compcall.tbp->non_overridable;
7739 : 1605 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7740 : : {
7741 : : /* Since the typebound operators are generic, we have to ensure
7742 : : that any delays in resolution are corrected and that the vtab
7743 : : is present. */
7744 : 184 : ts = expr->ts;
7745 : 184 : declared = ts.u.derived;
7746 : 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7747 : 184 : if (c->ts.u.derived == NULL)
7748 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7749 : :
7750 : 184 : if (!resolve_compcall (e, &name))
7751 : : return false;
7752 : :
7753 : : /* Use the generic name if it is there. */
7754 : 184 : name = name ? name : e->value.function.esym->name;
7755 : 184 : e->symtree = expr->symtree;
7756 : 184 : e->ref = gfc_copy_ref (expr->ref);
7757 : 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7758 : :
7759 : : /* Trim away the extraneous references that emerge from nested
7760 : : use of interface.cc (extend_expr). */
7761 : 184 : if (class_ref && class_ref->next)
7762 : : {
7763 : 0 : gfc_free_ref_list (class_ref->next);
7764 : 0 : class_ref->next = NULL;
7765 : : }
7766 : 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7767 : : {
7768 : 0 : gfc_free_ref_list (e->ref);
7769 : 0 : e->ref = NULL;
7770 : : }
7771 : :
7772 : 184 : gfc_add_vptr_component (e);
7773 : 184 : gfc_add_component_ref (e, name);
7774 : 184 : e->value.function.esym = NULL;
7775 : 184 : if (expr->expr_type != EXPR_VARIABLE)
7776 : 80 : e->base_expr = expr;
7777 : 184 : return true;
7778 : : }
7779 : :
7780 : 1421 : if (st == NULL)
7781 : 157 : return resolve_compcall (e, NULL);
7782 : :
7783 : 1264 : if (!gfc_resolve_ref (e))
7784 : : return false;
7785 : :
7786 : : /* Get the CLASS declared type. */
7787 : 1264 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
7788 : :
7789 : 1264 : if (!resolve_fl_derived (declared))
7790 : : return false;
7791 : :
7792 : : /* Weed out cases of the ultimate component being a derived type. */
7793 : 1264 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7794 : 1179 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7795 : : {
7796 : 576 : gfc_free_ref_list (new_ref);
7797 : 576 : return resolve_compcall (e, NULL);
7798 : : }
7799 : :
7800 : 688 : c = gfc_find_component (declared, "_data", true, true, NULL);
7801 : :
7802 : : /* Treat the call as if it is a typebound procedure, in order to roll
7803 : : out the correct name for the specific function. */
7804 : 688 : if (!resolve_compcall (e, &name))
7805 : : {
7806 : 15 : gfc_free_ref_list (new_ref);
7807 : 15 : return false;
7808 : : }
7809 : 673 : ts = e->ts;
7810 : :
7811 : 673 : if (overridable)
7812 : : {
7813 : : /* Convert the expression to a procedure pointer component call. */
7814 : 671 : e->value.function.esym = NULL;
7815 : 671 : e->symtree = st;
7816 : :
7817 : 671 : if (new_ref)
7818 : 124 : e->ref = new_ref;
7819 : :
7820 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7821 : 671 : gfc_add_vptr_component (e);
7822 : 671 : gfc_add_component_ref (e, name);
7823 : :
7824 : : /* Recover the typespec for the expression. This is really only
7825 : : necessary for generic procedures, where the additional call
7826 : : to gfc_add_component_ref seems to throw the collection of the
7827 : : correct typespec. */
7828 : 671 : e->ts = ts;
7829 : : }
7830 : 2 : else if (new_ref)
7831 : 0 : gfc_free_ref_list (new_ref);
7832 : :
7833 : : return true;
7834 : : }
7835 : :
7836 : : /* Resolve a typebound subroutine, or 'method'. First separate all
7837 : : the non-CLASS references by calling resolve_typebound_call
7838 : : directly. */
7839 : :
7840 : : static bool
7841 : 1676 : resolve_typebound_subroutine (gfc_code *code)
7842 : : {
7843 : 1676 : gfc_symbol *declared;
7844 : 1676 : gfc_component *c;
7845 : 1676 : gfc_ref *new_ref;
7846 : 1676 : gfc_ref *class_ref;
7847 : 1676 : gfc_symtree *st;
7848 : 1676 : const char *name;
7849 : 1676 : gfc_typespec ts;
7850 : 1676 : gfc_expr *expr;
7851 : 1676 : bool overridable;
7852 : :
7853 : 1676 : st = code->expr1->symtree;
7854 : :
7855 : : /* Deal with typebound operators for CLASS objects. */
7856 : 1676 : expr = code->expr1->value.compcall.base_object;
7857 : 1676 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
7858 : 1676 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7859 : : {
7860 : : /* If the base_object is not a variable, the corresponding actual
7861 : : argument expression must be stored in e->base_expression so
7862 : : that the corresponding tree temporary can be used as the base
7863 : : object in gfc_conv_procedure_call. */
7864 : 103 : if (expr->expr_type != EXPR_VARIABLE)
7865 : : {
7866 : : gfc_actual_arglist *args;
7867 : :
7868 : : args= code->expr1->value.function.actual;
7869 : : for (; args; args = args->next)
7870 : : if (expr == args->expr)
7871 : : expr = args->expr;
7872 : : }
7873 : :
7874 : : /* Since the typebound operators are generic, we have to ensure
7875 : : that any delays in resolution are corrected and that the vtab
7876 : : is present. */
7877 : 103 : declared = expr->ts.u.derived;
7878 : 103 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7879 : 103 : if (c->ts.u.derived == NULL)
7880 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7881 : :
7882 : 103 : if (!resolve_typebound_call (code, &name, NULL))
7883 : : return false;
7884 : :
7885 : : /* Use the generic name if it is there. */
7886 : 103 : name = name ? name : code->expr1->value.function.esym->name;
7887 : 103 : code->expr1->symtree = expr->symtree;
7888 : 103 : code->expr1->ref = gfc_copy_ref (expr->ref);
7889 : :
7890 : : /* Trim away the extraneous references that emerge from nested
7891 : : use of interface.cc (extend_expr). */
7892 : 103 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
7893 : 103 : if (class_ref && class_ref->next)
7894 : : {
7895 : 0 : gfc_free_ref_list (class_ref->next);
7896 : 0 : class_ref->next = NULL;
7897 : : }
7898 : 103 : else if (code->expr1->ref && !class_ref)
7899 : : {
7900 : 12 : gfc_free_ref_list (code->expr1->ref);
7901 : 12 : code->expr1->ref = NULL;
7902 : : }
7903 : :
7904 : : /* Now use the procedure in the vtable. */
7905 : 103 : gfc_add_vptr_component (code->expr1);
7906 : 103 : gfc_add_component_ref (code->expr1, name);
7907 : 103 : code->expr1->value.function.esym = NULL;
7908 : 103 : if (expr->expr_type != EXPR_VARIABLE)
7909 : 0 : code->expr1->base_expr = expr;
7910 : 103 : return true;
7911 : : }
7912 : :
7913 : 1573 : if (st == NULL)
7914 : 313 : return resolve_typebound_call (code, NULL, NULL);
7915 : :
7916 : 1260 : if (!gfc_resolve_ref (code->expr1))
7917 : : return false;
7918 : :
7919 : : /* Get the CLASS declared type. */
7920 : 1260 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
7921 : :
7922 : : /* Weed out cases of the ultimate component being a derived type. */
7923 : 1260 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7924 : 1197 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7925 : : {
7926 : 885 : gfc_free_ref_list (new_ref);
7927 : 885 : return resolve_typebound_call (code, NULL, NULL);
7928 : : }
7929 : :
7930 : 375 : if (!resolve_typebound_call (code, &name, &overridable))
7931 : : {
7932 : 5 : gfc_free_ref_list (new_ref);
7933 : 5 : return false;
7934 : : }
7935 : 370 : ts = code->expr1->ts;
7936 : :
7937 : 370 : if (overridable)
7938 : : {
7939 : : /* Convert the expression to a procedure pointer component call. */
7940 : 368 : code->expr1->value.function.esym = NULL;
7941 : 368 : code->expr1->symtree = st;
7942 : :
7943 : 368 : if (new_ref)
7944 : 92 : code->expr1->ref = new_ref;
7945 : :
7946 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7947 : 368 : gfc_add_vptr_component (code->expr1);
7948 : 368 : gfc_add_component_ref (code->expr1, name);
7949 : :
7950 : : /* Recover the typespec for the expression. This is really only
7951 : : necessary for generic procedures, where the additional call
7952 : : to gfc_add_component_ref seems to throw the collection of the
7953 : : correct typespec. */
7954 : 368 : code->expr1->ts = ts;
7955 : : }
7956 : 2 : else if (new_ref)
7957 : 0 : gfc_free_ref_list (new_ref);
7958 : :
7959 : : return true;
7960 : : }
7961 : :
7962 : :
7963 : : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7964 : :
7965 : : static bool
7966 : 123 : resolve_ppc_call (gfc_code* c)
7967 : : {
7968 : 123 : gfc_component *comp;
7969 : :
7970 : 123 : comp = gfc_get_proc_ptr_comp (c->expr1);
7971 : 123 : gcc_assert (comp != NULL);
7972 : :
7973 : 123 : c->resolved_sym = c->expr1->symtree->n.sym;
7974 : 123 : c->expr1->expr_type = EXPR_VARIABLE;
7975 : :
7976 : 123 : if (!comp->attr.subroutine)
7977 : 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
7978 : :
7979 : 123 : if (!gfc_resolve_ref (c->expr1))
7980 : : return false;
7981 : :
7982 : 123 : if (!update_ppc_arglist (c->expr1))
7983 : : return false;
7984 : :
7985 : 122 : c->ext.actual = c->expr1->value.compcall.actual;
7986 : :
7987 : 122 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
7988 : 122 : !(comp->ts.interface
7989 : 93 : && comp->ts.interface->formal)))
7990 : : return false;
7991 : :
7992 : 122 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
7993 : : return false;
7994 : :
7995 : 121 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
7996 : :
7997 : 121 : return true;
7998 : : }
7999 : :
8000 : :
8001 : : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8002 : :
8003 : : static bool
8004 : 450 : resolve_expr_ppc (gfc_expr* e)
8005 : : {
8006 : 450 : gfc_component *comp;
8007 : :
8008 : 450 : comp = gfc_get_proc_ptr_comp (e);
8009 : 450 : gcc_assert (comp != NULL);
8010 : :
8011 : : /* Convert to EXPR_FUNCTION. */
8012 : 450 : e->expr_type = EXPR_FUNCTION;
8013 : 450 : e->value.function.isym = NULL;
8014 : 450 : e->value.function.actual = e->value.compcall.actual;
8015 : 450 : e->ts = comp->ts;
8016 : 450 : if (comp->as != NULL)
8017 : : {
8018 : 28 : e->rank = comp->as->rank;
8019 : 28 : e->corank = comp->as->corank;
8020 : : }
8021 : :
8022 : 450 : if (!comp->attr.function)
8023 : 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8024 : :
8025 : 450 : if (!gfc_resolve_ref (e))
8026 : : return false;
8027 : :
8028 : 450 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8029 : 450 : !(comp->ts.interface
8030 : 449 : && comp->ts.interface->formal)))
8031 : : return false;
8032 : :
8033 : 450 : if (!update_ppc_arglist (e))
8034 : : return false;
8035 : :
8036 : 448 : if (!check_pure_function(e))
8037 : : return false;
8038 : :
8039 : 447 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8040 : :
8041 : 447 : return true;
8042 : : }
8043 : :
8044 : :
8045 : : static bool
8046 : 11853 : gfc_is_expandable_expr (gfc_expr *e)
8047 : : {
8048 : 11853 : gfc_constructor *con;
8049 : :
8050 : 11853 : if (e->expr_type == EXPR_ARRAY)
8051 : : {
8052 : : /* Traverse the constructor looking for variables that are flavor
8053 : : parameter. Parameters must be expanded since they are fully used at
8054 : : compile time. */
8055 : 11853 : con = gfc_constructor_first (e->value.constructor);
8056 : 31710 : for (; con; con = gfc_constructor_next (con))
8057 : : {
8058 : 13677 : if (con->expr->expr_type == EXPR_VARIABLE
8059 : 4992 : && con->expr->symtree
8060 : 4992 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8061 : 4913 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8062 : : return true;
8063 : 8685 : if (con->expr->expr_type == EXPR_ARRAY
8064 : 8685 : && gfc_is_expandable_expr (con->expr))
8065 : : return true;
8066 : : }
8067 : : }
8068 : :
8069 : : return false;
8070 : : }
8071 : :
8072 : :
8073 : : /* Sometimes variables in specification expressions of the result
8074 : : of module procedures in submodules wind up not being the 'real'
8075 : : dummy. Find this, if possible, in the namespace of the first
8076 : : formal argument. */
8077 : :
8078 : : static void
8079 : 3449 : fixup_unique_dummy (gfc_expr *e)
8080 : : {
8081 : 3449 : gfc_symtree *st = NULL;
8082 : 3449 : gfc_symbol *s = NULL;
8083 : :
8084 : 3449 : if (e->symtree->n.sym->ns->proc_name
8085 : 3419 : && e->symtree->n.sym->ns->proc_name->formal)
8086 : 3419 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8087 : :
8088 : 3419 : if (s != NULL)
8089 : 3419 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8090 : :
8091 : 3449 : if (st != NULL
8092 : 14 : && st->n.sym != NULL
8093 : 14 : && st->n.sym->attr.dummy)
8094 : 14 : e->symtree = st;
8095 : 3449 : }
8096 : :
8097 : :
8098 : : /* Resolve an expression. That is, make sure that types of operands agree
8099 : : with their operators, intrinsic operators are converted to function calls
8100 : : for overloaded types and unresolved function references are resolved. */
8101 : :
8102 : : bool
8103 : 7000592 : gfc_resolve_expr (gfc_expr *e)
8104 : : {
8105 : 7000592 : bool t;
8106 : 7000592 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8107 : :
8108 : 7000592 : if (e == NULL || e->do_not_resolve_again)
8109 : : return true;
8110 : :
8111 : : /* inquiry_argument only applies to variables. */
8112 : 5118575 : inquiry_save = inquiry_argument;
8113 : 5118575 : actual_arg_save = actual_arg;
8114 : 5118575 : first_actual_arg_save = first_actual_arg;
8115 : :
8116 : 5118575 : if (e->expr_type != EXPR_VARIABLE)
8117 : : {
8118 : 3817193 : inquiry_argument = false;
8119 : 3817193 : actual_arg = false;
8120 : 3817193 : first_actual_arg = false;
8121 : : }
8122 : 1301382 : else if (e->symtree != NULL
8123 : 1300963 : && *e->symtree->name == '@'
8124 : 4157 : && e->symtree->n.sym->attr.dummy)
8125 : : {
8126 : : /* Deal with submodule specification expressions that are not
8127 : : found to be referenced in module.cc(read_cleanup). */
8128 : 3449 : fixup_unique_dummy (e);
8129 : : }
8130 : :
8131 : 5118575 : switch (e->expr_type)
8132 : : {
8133 : 520814 : case EXPR_OP:
8134 : 520814 : t = resolve_operator (e);
8135 : 520814 : break;
8136 : :
8137 : 150 : case EXPR_CONDITIONAL:
8138 : 150 : t = resolve_conditional (e);
8139 : 150 : break;
8140 : :
8141 : 1639307 : case EXPR_FUNCTION:
8142 : 1639307 : case EXPR_VARIABLE:
8143 : :
8144 : 1639307 : if (check_host_association (e))
8145 : 337961 : t = resolve_function (e);
8146 : : else
8147 : 1301346 : t = resolve_variable (e);
8148 : :
8149 : 1639307 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8150 : 6909 : && e->ref->type != REF_SUBSTRING)
8151 : 2161 : gfc_resolve_substring_charlen (e);
8152 : :
8153 : : break;
8154 : :
8155 : 1605 : case EXPR_COMPCALL:
8156 : 1605 : t = resolve_typebound_function (e);
8157 : 1605 : break;
8158 : :
8159 : 507 : case EXPR_SUBSTRING:
8160 : 507 : t = gfc_resolve_ref (e);
8161 : 507 : break;
8162 : :
8163 : : case EXPR_CONSTANT:
8164 : : case EXPR_NULL:
8165 : : t = true;
8166 : : break;
8167 : :
8168 : 450 : case EXPR_PPC:
8169 : 450 : t = resolve_expr_ppc (e);
8170 : 450 : break;
8171 : :
8172 : 68160 : case EXPR_ARRAY:
8173 : 68160 : t = false;
8174 : 68160 : if (!gfc_resolve_ref (e))
8175 : : break;
8176 : :
8177 : 68160 : t = gfc_resolve_array_constructor (e);
8178 : : /* Also try to expand a constructor. */
8179 : 68160 : if (t)
8180 : : {
8181 : 68064 : gfc_expression_rank (e);
8182 : 68064 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8183 : 62981 : gfc_expand_constructor (e, false);
8184 : : }
8185 : :
8186 : : /* This provides the opportunity for the length of constructors with
8187 : : character valued function elements to propagate the string length
8188 : : to the expression. */
8189 : 68064 : if (t && e->ts.type == BT_CHARACTER)
8190 : : {
8191 : : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8192 : : here rather then add a duplicate test for it above. */
8193 : 10049 : gfc_expand_constructor (e, false);
8194 : 10049 : t = gfc_resolve_character_array_constructor (e);
8195 : : }
8196 : :
8197 : : break;
8198 : :
8199 : 16195 : case EXPR_STRUCTURE:
8200 : 16195 : t = gfc_resolve_ref (e);
8201 : 16195 : if (!t)
8202 : : break;
8203 : :
8204 : 16195 : t = resolve_structure_cons (e, 0);
8205 : 16195 : if (!t)
8206 : : break;
8207 : :
8208 : 16183 : t = gfc_simplify_expr (e, 0);
8209 : 16183 : break;
8210 : :
8211 : 0 : default:
8212 : 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8213 : : }
8214 : :
8215 : 5118575 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8216 : 177355 : fixup_charlen (e);
8217 : :
8218 : 5118575 : inquiry_argument = inquiry_save;
8219 : 5118575 : actual_arg = actual_arg_save;
8220 : 5118575 : first_actual_arg = first_actual_arg_save;
8221 : :
8222 : : /* For some reason, resolving these expressions a second time mangles
8223 : : the typespec of the expression itself. */
8224 : 5118575 : if (t && e->expr_type == EXPR_VARIABLE
8225 : 1298515 : && e->symtree->n.sym->attr.select_rank_temporary
8226 : 3422 : && UNLIMITED_POLY (e->symtree->n.sym))
8227 : 83 : e->do_not_resolve_again = 1;
8228 : :
8229 : 5116099 : if (t && gfc_current_ns->import_state != IMPORT_NOT_SET)
8230 : 6919 : t = check_import_status (e);
8231 : :
8232 : : return t;
8233 : : }
8234 : :
8235 : :
8236 : : /* Resolve an expression from an iterator. They must be scalar and have
8237 : : INTEGER or (optionally) REAL type. */
8238 : :
8239 : : static bool
8240 : 149469 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8241 : : const char *name_msgid)
8242 : : {
8243 : 149469 : if (!gfc_resolve_expr (expr))
8244 : : return false;
8245 : :
8246 : 149464 : if (expr->rank != 0)
8247 : : {
8248 : 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8249 : 0 : return false;
8250 : : }
8251 : :
8252 : 149464 : if (expr->ts.type != BT_INTEGER)
8253 : : {
8254 : 274 : if (expr->ts.type == BT_REAL)
8255 : : {
8256 : 274 : if (real_ok)
8257 : 271 : return gfc_notify_std (GFC_STD_F95_DEL,
8258 : : "%s at %L must be integer",
8259 : 271 : _(name_msgid), &expr->where);
8260 : : else
8261 : : {
8262 : 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8263 : : &expr->where);
8264 : 3 : return false;
8265 : : }
8266 : : }
8267 : : else
8268 : : {
8269 : 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8270 : 0 : return false;
8271 : : }
8272 : : }
8273 : : return true;
8274 : : }
8275 : :
8276 : :
8277 : : /* Resolve the expressions in an iterator structure. If REAL_OK is
8278 : : false allow only INTEGER type iterators, otherwise allow REAL types.
8279 : : Set own_scope to true for ac-implied-do and data-implied-do as those
8280 : : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8281 : :
8282 : : bool
8283 : 37376 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8284 : : {
8285 : 37376 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8286 : : return false;
8287 : :
8288 : 37372 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8289 : 37372 : _("iterator variable")))
8290 : : return false;
8291 : :
8292 : 37366 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8293 : : "Start expression in DO loop"))
8294 : : return false;
8295 : :
8296 : 37365 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8297 : : "End expression in DO loop"))
8298 : : return false;
8299 : :
8300 : 37362 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8301 : : "Step expression in DO loop"))
8302 : : return false;
8303 : :
8304 : : /* Convert start, end, and step to the same type as var. */
8305 : 37361 : if (iter->start->ts.kind != iter->var->ts.kind
8306 : 37081 : || iter->start->ts.type != iter->var->ts.type)
8307 : 315 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8308 : :
8309 : 37361 : if (iter->end->ts.kind != iter->var->ts.kind
8310 : 37108 : || iter->end->ts.type != iter->var->ts.type)
8311 : 278 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8312 : :
8313 : 37361 : if (iter->step->ts.kind != iter->var->ts.kind
8314 : 37117 : || iter->step->ts.type != iter->var->ts.type)
8315 : 280 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8316 : :
8317 : 37361 : if (iter->step->expr_type == EXPR_CONSTANT)
8318 : : {
8319 : 36239 : if ((iter->step->ts.type == BT_INTEGER
8320 : 36156 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8321 : 72393 : || (iter->step->ts.type == BT_REAL
8322 : 83 : && mpfr_sgn (iter->step->value.real) == 0))
8323 : : {
8324 : 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8325 : 3 : &iter->step->where);
8326 : 3 : return false;
8327 : : }
8328 : : }
8329 : :
8330 : 37358 : if (iter->start->expr_type == EXPR_CONSTANT
8331 : 34267 : && iter->end->expr_type == EXPR_CONSTANT
8332 : 26845 : && iter->step->expr_type == EXPR_CONSTANT)
8333 : : {
8334 : 26578 : int sgn, cmp;
8335 : 26578 : if (iter->start->ts.type == BT_INTEGER)
8336 : : {
8337 : 26524 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8338 : 26524 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8339 : : }
8340 : : else
8341 : : {
8342 : 54 : sgn = mpfr_sgn (iter->step->value.real);
8343 : 54 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8344 : : }
8345 : 26578 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8346 : 146 : gfc_warning (OPT_Wzerotrip,
8347 : : "DO loop at %L will be executed zero times",
8348 : 146 : &iter->step->where);
8349 : : }
8350 : :
8351 : 37358 : if (iter->end->expr_type == EXPR_CONSTANT
8352 : 27210 : && iter->end->ts.type == BT_INTEGER
8353 : 27156 : && iter->step->expr_type == EXPR_CONSTANT
8354 : 26846 : && iter->step->ts.type == BT_INTEGER
8355 : 26846 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8356 : 26478 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8357 : : {
8358 : 25732 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8359 : 25732 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8360 : :
8361 : 25732 : if (is_step_positive
8362 : 25364 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8363 : 7 : gfc_warning (OPT_Wundefined_do_loop,
8364 : : "DO loop at %L is undefined as it overflows",
8365 : 7 : &iter->step->where);
8366 : : else if (!is_step_positive
8367 : 368 : && mpz_cmp (iter->end->value.integer,
8368 : 368 : gfc_integer_kinds[k].min_int) == 0)
8369 : 7 : gfc_warning (OPT_Wundefined_do_loop,
8370 : : "DO loop at %L is undefined as it underflows",
8371 : 7 : &iter->step->where);
8372 : : }
8373 : :
8374 : : return true;
8375 : : }
8376 : :
8377 : :
8378 : : /* Traversal function for find_forall_index. f == 2 signals that
8379 : : that variable itself is not to be checked - only the references. */
8380 : :
8381 : : static bool
8382 : 42544 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8383 : : {
8384 : 42544 : if (expr->expr_type != EXPR_VARIABLE)
8385 : : return false;
8386 : :
8387 : : /* A scalar assignment */
8388 : 18167 : if (!expr->ref || *f == 1)
8389 : : {
8390 : 12114 : if (expr->symtree->n.sym == sym)
8391 : : return true;
8392 : : else
8393 : : return false;
8394 : : }
8395 : :
8396 : 6053 : if (*f == 2)
8397 : 1730 : *f = 1;
8398 : : return false;
8399 : : }
8400 : :
8401 : :
8402 : : /* Check whether the FORALL index appears in the expression or not.
8403 : : Returns true if SYM is found in EXPR. */
8404 : :
8405 : : bool
8406 : 26952 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8407 : : {
8408 : 26952 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8409 : : return true;
8410 : : else
8411 : : return false;
8412 : : }
8413 : :
8414 : : /* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
8415 : : This constraint specifies rules for variables in locality-specs. */
8416 : :
8417 : : static int
8418 : 685 : do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
8419 : : {
8420 : 685 : struct check_default_none_data *dt = (struct check_default_none_data *) data;
8421 : :
8422 : 685 : if ((*expr)->expr_type == EXPR_VARIABLE)
8423 : : {
8424 : 21 : gfc_symbol *sym = (*expr)->symtree->n.sym;
8425 : 21 : for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
8426 : 23 : list; list = list->next)
8427 : : {
8428 : 5 : if (list->expr->symtree->n.sym == sym)
8429 : : {
8430 : 3 : gfc_error ("Variable %qs referenced in concurrent-header at %L "
8431 : : "must not appear in LOCAL locality-spec at %L",
8432 : : sym->name, &(*expr)->where, &list->expr->where);
8433 : 3 : *walk_subtrees = 0;
8434 : 3 : return 1;
8435 : : }
8436 : : }
8437 : : }
8438 : :
8439 : 682 : *walk_subtrees = 1;
8440 : 682 : return 0;
8441 : : }
8442 : :
8443 : : static int
8444 : 3899 : check_default_none_expr (gfc_expr **e, int *, void *data)
8445 : : {
8446 : 3899 : struct check_default_none_data *d = (struct check_default_none_data*) data;
8447 : :
8448 : 3899 : if ((*e)->expr_type == EXPR_VARIABLE)
8449 : : {
8450 : 1767 : gfc_symbol *sym = (*e)->symtree->n.sym;
8451 : :
8452 : 1767 : if (d->sym_hash->contains (sym))
8453 : 1263 : sym->mark = 1;
8454 : :
8455 : 504 : else if (d->default_none)
8456 : : {
8457 : 6 : gfc_namespace *ns2 = d->ns;
8458 : 10 : while (ns2)
8459 : : {
8460 : 6 : if (ns2 == sym->ns)
8461 : : break;
8462 : 4 : ns2 = ns2->parent;
8463 : : }
8464 : :
8465 : : /* A DO CONCURRENT iterator cannot appear in a locality spec. */
8466 : 6 : if (sym->ns->code->ext.concur.forall_iterator)
8467 : : {
8468 : : gfc_forall_iterator *iter
8469 : : = sym->ns->code->ext.concur.forall_iterator;
8470 : 5 : for (; iter; iter = iter->next)
8471 : 3 : if (iter->var->symtree
8472 : 1 : && strcmp(sym->name, iter->var->symtree->name) == 0)
8473 : 1 : return 0;
8474 : : }
8475 : :
8476 : : /* A named constant is not a variable, so skip test. */
8477 : 5 : if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
8478 : : {
8479 : 1 : gfc_error ("Variable %qs at %L not specified in a locality spec "
8480 : : "of DO CONCURRENT at %L but required due to "
8481 : : "DEFAULT (NONE)",
8482 : 1 : sym->name, &(*e)->where, &d->code->loc);
8483 : 1 : d->sym_hash->add (sym);
8484 : : }
8485 : : }
8486 : : }
8487 : : return 0;
8488 : : }
8489 : :
8490 : : static void
8491 : 200 : resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
8492 : : {
8493 : 200 : struct check_default_none_data data;
8494 : 200 : data.code = code;
8495 : 200 : data.sym_hash = new hash_set<gfc_symbol *>;
8496 : 200 : data.ns = ns;
8497 : 200 : data.default_none = code->ext.concur.default_none;
8498 : :
8499 : 1000 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8500 : : {
8501 : 800 : const char *name;
8502 : 800 : switch (locality)
8503 : : {
8504 : : case LOCALITY_LOCAL: name = "LOCAL"; break;
8505 : 200 : case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
8506 : 200 : case LOCALITY_SHARED: name = "SHARED"; break;
8507 : 200 : case LOCALITY_REDUCE: name = "REDUCE"; break;
8508 : : default: gcc_unreachable ();
8509 : : }
8510 : :
8511 : 1187 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8512 : 387 : list = list->next)
8513 : : {
8514 : 387 : gfc_expr *expr = list->expr;
8515 : :
8516 : 387 : if (locality == LOCALITY_REDUCE
8517 : 72 : && (expr->expr_type == EXPR_FUNCTION
8518 : 48 : || expr->expr_type == EXPR_OP))
8519 : 35 : continue;
8520 : :
8521 : 363 : if (!gfc_resolve_expr (expr))
8522 : 3 : continue;
8523 : :
8524 : 360 : if (expr->expr_type != EXPR_VARIABLE
8525 : 360 : || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
8526 : 360 : || (expr->ref
8527 : 147 : && (expr->ref->type != REF_ARRAY
8528 : 147 : || expr->ref->u.ar.type != AR_FULL
8529 : 143 : || expr->ref->next)))
8530 : : {
8531 : 4 : gfc_error ("Expected variable name in %s locality spec at %L",
8532 : : name, &expr->where);
8533 : 4 : continue;
8534 : : }
8535 : :
8536 : 356 : gfc_symbol *sym = expr->symtree->n.sym;
8537 : :
8538 : 356 : if (data.sym_hash->contains (sym))
8539 : : {
8540 : 4 : gfc_error ("Variable %qs at %L has already been specified in a "
8541 : : "locality-spec", sym->name, &expr->where);
8542 : 4 : continue;
8543 : : }
8544 : :
8545 : 352 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8546 : 704 : iter; iter = iter->next)
8547 : : {
8548 : 352 : if (iter->var->symtree->n.sym == sym)
8549 : : {
8550 : 1 : gfc_error ("Index variable %qs at %L cannot be specified in a "
8551 : : "locality-spec", sym->name, &expr->where);
8552 : 1 : continue;
8553 : : }
8554 : :
8555 : 351 : data.sym_hash->add (iter->var->symtree->n.sym);
8556 : : }
8557 : :
8558 : 352 : if (locality == LOCALITY_LOCAL
8559 : 352 : || locality == LOCALITY_LOCAL_INIT
8560 : 352 : || locality == LOCALITY_REDUCE)
8561 : : {
8562 : 198 : if (sym->attr.optional)
8563 : 3 : gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
8564 : : "locality-spec at %L",
8565 : : sym->name, name, &expr->where);
8566 : :
8567 : 198 : if (sym->attr.dimension
8568 : 66 : && sym->as
8569 : 66 : && sym->as->type == AS_ASSUMED_SIZE)
8570 : 0 : gfc_error ("Assumed-size array not permitted for %qs in %s "
8571 : : "locality-spec at %L",
8572 : : sym->name, name, &expr->where);
8573 : :
8574 : 198 : gfc_check_vardef_context (expr, false, false, false, name);
8575 : : }
8576 : :
8577 : 198 : if (locality == LOCALITY_LOCAL
8578 : : || locality == LOCALITY_LOCAL_INIT)
8579 : : {
8580 : 181 : symbol_attribute attr = gfc_expr_attr (expr);
8581 : :
8582 : 181 : if (attr.allocatable)
8583 : 2 : gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
8584 : : "locality-spec at %L",
8585 : : sym->name, name, &expr->where);
8586 : :
8587 : 179 : else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
8588 : 2 : gfc_error ("Nonpointer polymorphic dummy argument not permitted"
8589 : : " for %qs in %s locality-spec at %L",
8590 : : sym->name, name, &expr->where);
8591 : :
8592 : 177 : else if (attr.codimension)
8593 : 0 : gfc_error ("Coarray not permitted for %qs in %s locality-spec "
8594 : : "at %L",
8595 : : sym->name, name, &expr->where);
8596 : :
8597 : 177 : else if (expr->ts.type == BT_DERIVED
8598 : 177 : && gfc_is_finalizable (expr->ts.u.derived, NULL))
8599 : 0 : gfc_error ("Finalizable type not permitted for %qs in %s "
8600 : : "locality-spec at %L",
8601 : : sym->name, name, &expr->where);
8602 : :
8603 : 177 : else if (gfc_has_ultimate_allocatable (expr))
8604 : 4 : gfc_error ("Type with ultimate allocatable component not "
8605 : : "permitted for %qs in %s locality-spec at %L",
8606 : : sym->name, name, &expr->where);
8607 : : }
8608 : :
8609 : 171 : else if (locality == LOCALITY_REDUCE)
8610 : : {
8611 : 17 : if (sym->attr.asynchronous)
8612 : 1 : gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
8613 : : "REDUCE locality-spec at %L",
8614 : : sym->name, &expr->where);
8615 : 17 : if (sym->attr.volatile_)
8616 : 1 : gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
8617 : : "locality-spec at %L", sym->name, &expr->where);
8618 : : }
8619 : :
8620 : 352 : data.sym_hash->add (sym);
8621 : : }
8622 : :
8623 : 800 : if (locality == LOCALITY_LOCAL)
8624 : : {
8625 : 200 : gcc_assert (locality == 0);
8626 : :
8627 : 200 : for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
8628 : 417 : iter; iter = iter->next)
8629 : : {
8630 : 217 : gfc_expr_walker (&iter->start,
8631 : : do_concur_locality_specs_f2023,
8632 : : &data);
8633 : :
8634 : 217 : gfc_expr_walker (&iter->end,
8635 : : do_concur_locality_specs_f2023,
8636 : : &data);
8637 : :
8638 : 217 : gfc_expr_walker (&iter->stride,
8639 : : do_concur_locality_specs_f2023,
8640 : : &data);
8641 : : }
8642 : :
8643 : 200 : if (code->expr1)
8644 : 7 : gfc_expr_walker (&code->expr1,
8645 : : do_concur_locality_specs_f2023,
8646 : : &data);
8647 : : }
8648 : : }
8649 : :
8650 : 200 : gfc_expr *reduce_op = NULL;
8651 : :
8652 : 200 : for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
8653 : 248 : list; list = list->next)
8654 : : {
8655 : 48 : gfc_expr *expr = list->expr;
8656 : :
8657 : 48 : if (expr->expr_type != EXPR_VARIABLE)
8658 : : {
8659 : 24 : reduce_op = expr;
8660 : 24 : continue;
8661 : : }
8662 : :
8663 : 24 : if (reduce_op->expr_type == EXPR_OP)
8664 : : {
8665 : 17 : switch (reduce_op->value.op.op)
8666 : : {
8667 : 17 : case INTRINSIC_PLUS:
8668 : 17 : case INTRINSIC_TIMES:
8669 : 17 : if (!gfc_numeric_ts (&expr->ts))
8670 : 3 : gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
8671 : 3 : "got %s", expr->symtree->n.sym->name,
8672 : : &expr->where, gfc_basic_typename (expr->ts.type));
8673 : : break;
8674 : 0 : case INTRINSIC_AND:
8675 : 0 : case INTRINSIC_OR:
8676 : 0 : case INTRINSIC_EQV:
8677 : 0 : case INTRINSIC_NEQV:
8678 : 0 : if (expr->ts.type != BT_LOGICAL)
8679 : 0 : gfc_error ("Expected logical type for %qs in REDUCE at %L, "
8680 : 0 : "got %qs", expr->symtree->n.sym->name,
8681 : : &expr->where, gfc_basic_typename (expr->ts.type));
8682 : : break;
8683 : 0 : default:
8684 : 0 : gcc_unreachable ();
8685 : : }
8686 : : }
8687 : :
8688 : 7 : else if (reduce_op->expr_type == EXPR_FUNCTION)
8689 : : {
8690 : 7 : switch (reduce_op->value.function.isym->id)
8691 : : {
8692 : 6 : case GFC_ISYM_MIN:
8693 : 6 : case GFC_ISYM_MAX:
8694 : 6 : if (expr->ts.type != BT_INTEGER
8695 : : && expr->ts.type != BT_REAL
8696 : : && expr->ts.type != BT_CHARACTER)
8697 : 2 : gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
8698 : : "in REDUCE with MIN/MAX at %L, got %s",
8699 : 2 : expr->symtree->n.sym->name, &expr->where,
8700 : : gfc_basic_typename (expr->ts.type));
8701 : : break;
8702 : 1 : case GFC_ISYM_IAND:
8703 : 1 : case GFC_ISYM_IOR:
8704 : 1 : case GFC_ISYM_IEOR:
8705 : 1 : if (expr->ts.type != BT_INTEGER)
8706 : 1 : gfc_error ("Expected integer type for %qs in REDUCE with "
8707 : : "IAND/IOR/IEOR at %L, got %s",
8708 : 1 : expr->symtree->n.sym->name, &expr->where,
8709 : : gfc_basic_typename (expr->ts.type));
8710 : : break;
8711 : 0 : default:
8712 : 0 : gcc_unreachable ();
8713 : : }
8714 : : }
8715 : :
8716 : : else
8717 : 0 : gcc_unreachable ();
8718 : : }
8719 : :
8720 : 1000 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8721 : : {
8722 : 1187 : for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
8723 : 387 : list = list->next)
8724 : : {
8725 : 387 : if (list->expr->expr_type == EXPR_VARIABLE)
8726 : 363 : list->expr->symtree->n.sym->mark = 0;
8727 : : }
8728 : : }
8729 : :
8730 : 200 : gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
8731 : : check_default_none_expr, &data);
8732 : :
8733 : 1000 : for (int locality = 0; locality < LOCALITY_NUM; locality++)
8734 : : {
8735 : 800 : gfc_expr_list **plist = &code->ext.concur.locality[locality];
8736 : 1187 : while (*plist)
8737 : : {
8738 : 387 : gfc_expr *expr = (*plist)->expr;
8739 : 387 : if (expr->expr_type == EXPR_VARIABLE)
8740 : : {
8741 : 363 : gfc_symbol *sym = expr->symtree->n.sym;
8742 : 363 : if (sym->mark == 0)
8743 : : {
8744 : 70 : gfc_warning (OPT_Wunused_variable, "Variable %qs in "
8745 : : "locality-spec at %L is not used",
8746 : : sym->name, &expr->where);
8747 : 70 : gfc_expr_list *tmp = *plist;
8748 : 70 : *plist = (*plist)->next;
8749 : 70 : gfc_free_expr (tmp->expr);
8750 : 70 : free (tmp);
8751 : 70 : continue;
8752 : 70 : }
8753 : : }
8754 : 317 : plist = &((*plist)->next);
8755 : : }
8756 : : }
8757 : :
8758 : 400 : delete data.sym_hash;
8759 : 200 : }
8760 : :
8761 : : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
8762 : : to be a scalar INTEGER variable. The subscripts and stride are scalar
8763 : : INTEGERs, and if stride is a constant it must be nonzero.
8764 : : Furthermore "A subscript or stride in a forall-triplet-spec shall
8765 : : not contain a reference to any index-name in the
8766 : : forall-triplet-spec-list in which it appears." (7.5.4.1) */
8767 : :
8768 : : static void
8769 : 2190 : resolve_forall_iterators (gfc_forall_iterator *it)
8770 : : {
8771 : 2190 : gfc_forall_iterator *iter, *iter2;
8772 : :
8773 : 6295 : for (iter = it; iter; iter = iter->next)
8774 : : {
8775 : 4105 : if (gfc_resolve_expr (iter->var)
8776 : 4105 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
8777 : 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
8778 : : &iter->var->where);
8779 : :
8780 : 4105 : if (gfc_resolve_expr (iter->start)
8781 : 4105 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
8782 : 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
8783 : : &iter->start->where);
8784 : 4105 : if (iter->var->ts.kind != iter->start->ts.kind)
8785 : 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8786 : :
8787 : 4105 : if (gfc_resolve_expr (iter->end)
8788 : 4105 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
8789 : 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
8790 : : &iter->end->where);
8791 : 4105 : if (iter->var->ts.kind != iter->end->ts.kind)
8792 : 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8793 : :
8794 : 4105 : if (gfc_resolve_expr (iter->stride))
8795 : : {
8796 : 4105 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
8797 : 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
8798 : : &iter->stride->where, "INTEGER");
8799 : :
8800 : 4105 : if (iter->stride->expr_type == EXPR_CONSTANT
8801 : 4102 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
8802 : 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
8803 : : &iter->stride->where);
8804 : : }
8805 : 4105 : if (iter->var->ts.kind != iter->stride->ts.kind)
8806 : 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
8807 : : }
8808 : :
8809 : 6295 : for (iter = it; iter; iter = iter->next)
8810 : 11051 : for (iter2 = iter; iter2; iter2 = iter2->next)
8811 : : {
8812 : 6946 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
8813 : 6944 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
8814 : 13888 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
8815 : 6 : gfc_error ("FORALL index %qs may not appear in triplet "
8816 : 6 : "specification at %L", iter->var->symtree->name,
8817 : 6 : &iter2->start->where);
8818 : : }
8819 : 2190 : }
8820 : :
8821 : :
8822 : : /* Given a pointer to a symbol that is a derived type, see if it's
8823 : : inaccessible, i.e. if it's defined in another module and the components are
8824 : : PRIVATE. The search is recursive if necessary. Returns zero if no
8825 : : inaccessible components are found, nonzero otherwise. */
8826 : :
8827 : : static bool
8828 : 1329 : derived_inaccessible (gfc_symbol *sym)
8829 : : {
8830 : 1329 : gfc_component *c;
8831 : :
8832 : 1329 : if (sym->attr.use_assoc && sym->attr.private_comp)
8833 : : return 1;
8834 : :
8835 : 3949 : for (c = sym->components; c; c = c->next)
8836 : : {
8837 : : /* Prevent an infinite loop through this function. */
8838 : 2633 : if (c->ts.type == BT_DERIVED
8839 : 288 : && (c->attr.pointer || c->attr.allocatable)
8840 : 72 : && sym == c->ts.u.derived)
8841 : 72 : continue;
8842 : :
8843 : 2561 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
8844 : : return 1;
8845 : : }
8846 : :
8847 : : return 0;
8848 : : }
8849 : :
8850 : :
8851 : : /* Resolve the argument of a deallocate expression. The expression must be
8852 : : a pointer or a full array. */
8853 : :
8854 : : static bool
8855 : 8047 : resolve_deallocate_expr (gfc_expr *e)
8856 : : {
8857 : 8047 : symbol_attribute attr;
8858 : 8047 : int allocatable, pointer;
8859 : 8047 : gfc_ref *ref;
8860 : 8047 : gfc_symbol *sym;
8861 : 8047 : gfc_component *c;
8862 : 8047 : bool unlimited;
8863 : :
8864 : 8047 : if (!gfc_resolve_expr (e))
8865 : : return false;
8866 : :
8867 : 8047 : if (e->expr_type != EXPR_VARIABLE)
8868 : 0 : goto bad;
8869 : :
8870 : 8047 : sym = e->symtree->n.sym;
8871 : 8047 : unlimited = UNLIMITED_POLY(sym);
8872 : :
8873 : 8047 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
8874 : : {
8875 : 1504 : allocatable = CLASS_DATA (sym)->attr.allocatable;
8876 : 1504 : pointer = CLASS_DATA (sym)->attr.class_pointer;
8877 : : }
8878 : : else
8879 : : {
8880 : 6543 : allocatable = sym->attr.allocatable;
8881 : 6543 : pointer = sym->attr.pointer;
8882 : : }
8883 : 16075 : for (ref = e->ref; ref; ref = ref->next)
8884 : : {
8885 : 8028 : switch (ref->type)
8886 : : {
8887 : 5980 : case REF_ARRAY:
8888 : 5980 : if (ref->u.ar.type != AR_FULL
8889 : 6168 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
8890 : 188 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
8891 : : allocatable = 0;
8892 : : break;
8893 : :
8894 : 2048 : case REF_COMPONENT:
8895 : 2048 : c = ref->u.c.component;
8896 : 2048 : if (c->ts.type == BT_CLASS)
8897 : : {
8898 : 291 : allocatable = CLASS_DATA (c)->attr.allocatable;
8899 : 291 : pointer = CLASS_DATA (c)->attr.class_pointer;
8900 : : }
8901 : : else
8902 : : {
8903 : 1757 : allocatable = c->attr.allocatable;
8904 : 1757 : pointer = c->attr.pointer;
8905 : : }
8906 : : break;
8907 : :
8908 : : case REF_SUBSTRING:
8909 : : case REF_INQUIRY:
8910 : 489 : allocatable = 0;
8911 : : break;
8912 : : }
8913 : : }
8914 : :
8915 : 8047 : attr = gfc_expr_attr (e);
8916 : :
8917 : 8047 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
8918 : : {
8919 : 3 : bad:
8920 : 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8921 : : &e->where);
8922 : 3 : return false;
8923 : : }
8924 : :
8925 : : /* F2008, C644. */
8926 : 8044 : if (gfc_is_coindexed (e))
8927 : : {
8928 : 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
8929 : 1 : return false;
8930 : : }
8931 : :
8932 : 8043 : if (pointer
8933 : 10382 : && !gfc_check_vardef_context (e, true, true, false,
8934 : 2339 : _("DEALLOCATE object")))
8935 : : return false;
8936 : 8041 : if (!gfc_check_vardef_context (e, false, true, false,
8937 : 8041 : _("DEALLOCATE object")))
8938 : : return false;
8939 : :
8940 : : return true;
8941 : : }
8942 : :
8943 : :
8944 : : /* Returns true if the expression e contains a reference to the symbol sym. */
8945 : : static bool
8946 : 46662 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
8947 : : {
8948 : 46662 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
8949 : 2081 : return true;
8950 : :
8951 : : return false;
8952 : : }
8953 : :
8954 : : bool
8955 : 20072 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
8956 : : {
8957 : 20072 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
8958 : : }
8959 : :
8960 : : /* Same as gfc_find_sym_in_expr, but do not descend into length type parameter
8961 : : of character expressions. */
8962 : : static bool
8963 : 20205 : gfc_find_var_in_expr (gfc_symbol *sym, gfc_expr *e)
8964 : : {
8965 : 0 : return gfc_traverse_expr (e, sym, sym_in_expr, -1);
8966 : : }
8967 : :
8968 : :
8969 : : /* Given the expression node e for an allocatable/pointer of derived type to be
8970 : : allocated, get the expression node to be initialized afterwards (needed for
8971 : : derived types with default initializers, and derived types with allocatable
8972 : : components that need nullification.) */
8973 : :
8974 : : gfc_expr *
8975 : 5585 : gfc_expr_to_initialize (gfc_expr *e)
8976 : : {
8977 : 5585 : gfc_expr *result;
8978 : 5585 : gfc_ref *ref;
8979 : 5585 : int i;
8980 : :
8981 : 5585 : result = gfc_copy_expr (e);
8982 : :
8983 : : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
8984 : 10989 : for (ref = result->ref; ref; ref = ref->next)
8985 : 8600 : if (ref->type == REF_ARRAY && ref->next == NULL)
8986 : : {
8987 : 3196 : if (ref->u.ar.dimen == 0
8988 : 64 : && ref->u.ar.as && ref->u.ar.as->corank)
8989 : : return result;
8990 : :
8991 : 3132 : ref->u.ar.type = AR_FULL;
8992 : :
8993 : 7105 : for (i = 0; i < ref->u.ar.dimen; i++)
8994 : 3973 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
8995 : :
8996 : : break;
8997 : : }
8998 : :
8999 : 5521 : gfc_free_shape (&result->shape, result->rank);
9000 : :
9001 : : /* Recalculate rank, shape, etc. */
9002 : 5521 : gfc_resolve_expr (result);
9003 : 5521 : return result;
9004 : : }
9005 : :
9006 : :
9007 : : /* If the last ref of an expression is an array ref, return a copy of the
9008 : : expression with that one removed. Otherwise, a copy of the original
9009 : : expression. This is used for allocate-expressions and pointer assignment
9010 : : LHS, where there may be an array specification that needs to be stripped
9011 : : off when using gfc_check_vardef_context. */
9012 : :
9013 : : static gfc_expr*
9014 : 27151 : remove_last_array_ref (gfc_expr* e)
9015 : : {
9016 : 27151 : gfc_expr* e2;
9017 : 27151 : gfc_ref** r;
9018 : :
9019 : 27151 : e2 = gfc_copy_expr (e);
9020 : 34764 : for (r = &e2->ref; *r; r = &(*r)->next)
9021 : 23587 : if ((*r)->type == REF_ARRAY && !(*r)->next)
9022 : : {
9023 : 15974 : gfc_free_ref_list (*r);
9024 : 15974 : *r = NULL;
9025 : 15974 : break;
9026 : : }
9027 : :
9028 : 27151 : return e2;
9029 : : }
9030 : :
9031 : :
9032 : : /* Used in resolve_allocate_expr to check that a allocation-object and
9033 : : a source-expr are conformable. This does not catch all possible
9034 : : cases; in particular a runtime checking is needed. */
9035 : :
9036 : : static bool
9037 : 1883 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
9038 : : {
9039 : 1883 : gfc_ref *tail;
9040 : 1883 : bool scalar;
9041 : :
9042 : 2602 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
9043 : :
9044 : : /* If MOLD= is present and is not scalar, and the allocate-object has an
9045 : : explicit-shape-spec, the ranks need not agree. This may be unintended,
9046 : : so let's emit a warning if -Wsurprising is given. */
9047 : 1883 : scalar = !tail || tail->type == REF_COMPONENT;
9048 : 1883 : if (e1->mold && e1->rank > 0
9049 : 163 : && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
9050 : : {
9051 : 26 : if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
9052 : 15 : gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
9053 : : "but MOLD= expression at %L has rank %d",
9054 : 6 : &e2->where, scalar ? 0 : tail->u.ar.as->rank,
9055 : : &e1->where, e1->rank);
9056 : 29 : return true;
9057 : : }
9058 : :
9059 : : /* First compare rank. */
9060 : 1854 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
9061 : 2 : || (!tail && e1->rank != e2->rank))
9062 : : {
9063 : 7 : gfc_error ("Source-expr at %L must be scalar or have the "
9064 : : "same rank as the allocate-object at %L",
9065 : : &e1->where, &e2->where);
9066 : 7 : return false;
9067 : : }
9068 : :
9069 : 1847 : if (e1->shape)
9070 : : {
9071 : 1354 : int i;
9072 : 1354 : mpz_t s;
9073 : :
9074 : 1354 : mpz_init (s);
9075 : :
9076 : 3124 : for (i = 0; i < e1->rank; i++)
9077 : : {
9078 : 1360 : if (tail->u.ar.start[i] == NULL)
9079 : : break;
9080 : :
9081 : 416 : if (tail->u.ar.end[i])
9082 : : {
9083 : 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
9084 : 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
9085 : 54 : mpz_add_ui (s, s, 1);
9086 : : }
9087 : : else
9088 : : {
9089 : 362 : mpz_set (s, tail->u.ar.start[i]->value.integer);
9090 : : }
9091 : :
9092 : 416 : if (mpz_cmp (e1->shape[i], s) != 0)
9093 : : {
9094 : 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
9095 : : "have the same shape", &e1->where, &e2->where);
9096 : 0 : mpz_clear (s);
9097 : 0 : return false;
9098 : : }
9099 : : }
9100 : :
9101 : 1354 : mpz_clear (s);
9102 : : }
9103 : :
9104 : : return true;
9105 : : }
9106 : :
9107 : :
9108 : : /* Resolve the expression in an ALLOCATE statement, doing the additional
9109 : : checks to see whether the expression is OK or not. The expression must
9110 : : have a trailing array reference that gives the size of the array. */
9111 : :
9112 : : static bool
9113 : 16863 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
9114 : : {
9115 : 16863 : int i, pointer, allocatable, dimension, is_abstract;
9116 : 16863 : int codimension;
9117 : 16863 : bool coindexed;
9118 : 16863 : bool unlimited;
9119 : 16863 : symbol_attribute attr;
9120 : 16863 : gfc_ref *ref, *ref2;
9121 : 16863 : gfc_expr *e2;
9122 : 16863 : gfc_array_ref *ar;
9123 : 16863 : gfc_symbol *sym = NULL;
9124 : 16863 : gfc_alloc *a;
9125 : 16863 : gfc_component *c;
9126 : 16863 : bool t;
9127 : :
9128 : : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
9129 : : checking of coarrays. */
9130 : 21231 : for (ref = e->ref; ref; ref = ref->next)
9131 : 17127 : if (ref->next == NULL)
9132 : : break;
9133 : :
9134 : 16863 : if (ref && ref->type == REF_ARRAY)
9135 : 11598 : ref->u.ar.in_allocate = true;
9136 : :
9137 : 16863 : if (!gfc_resolve_expr (e))
9138 : 1 : goto failure;
9139 : :
9140 : : /* Make sure the expression is allocatable or a pointer. If it is
9141 : : pointer, the next-to-last reference must be a pointer. */
9142 : :
9143 : 16862 : ref2 = NULL;
9144 : 16862 : if (e->symtree)
9145 : 16862 : sym = e->symtree->n.sym;
9146 : :
9147 : : /* Check whether ultimate component is abstract and CLASS. */
9148 : 33724 : is_abstract = 0;
9149 : :
9150 : : /* Is the allocate-object unlimited polymorphic? */
9151 : 16862 : unlimited = UNLIMITED_POLY(e);
9152 : :
9153 : 16862 : if (e->expr_type != EXPR_VARIABLE)
9154 : : {
9155 : 0 : allocatable = 0;
9156 : 0 : attr = gfc_expr_attr (e);
9157 : 0 : pointer = attr.pointer;
9158 : 0 : dimension = attr.dimension;
9159 : 0 : codimension = attr.codimension;
9160 : : }
9161 : : else
9162 : : {
9163 : 16862 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9164 : : {
9165 : 3314 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9166 : 3314 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9167 : 3314 : dimension = CLASS_DATA (sym)->attr.dimension;
9168 : 3314 : codimension = CLASS_DATA (sym)->attr.codimension;
9169 : 3314 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9170 : : }
9171 : : else
9172 : : {
9173 : 13548 : allocatable = sym->attr.allocatable;
9174 : 13548 : pointer = sym->attr.pointer;
9175 : 13548 : dimension = sym->attr.dimension;
9176 : 13548 : codimension = sym->attr.codimension;
9177 : : }
9178 : :
9179 : 16862 : coindexed = false;
9180 : :
9181 : 33983 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9182 : : {
9183 : 17123 : switch (ref->type)
9184 : : {
9185 : 12929 : case REF_ARRAY:
9186 : 12929 : if (ref->u.ar.codimen > 0)
9187 : : {
9188 : 659 : int n;
9189 : 940 : for (n = ref->u.ar.dimen;
9190 : 940 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9191 : 696 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9192 : : {
9193 : : coindexed = true;
9194 : : break;
9195 : : }
9196 : : }
9197 : :
9198 : 12929 : if (ref->next != NULL)
9199 : 1333 : pointer = 0;
9200 : : break;
9201 : :
9202 : 4194 : case REF_COMPONENT:
9203 : : /* F2008, C644. */
9204 : 4194 : if (coindexed)
9205 : : {
9206 : 2 : gfc_error ("Coindexed allocatable object at %L",
9207 : : &e->where);
9208 : 2 : goto failure;
9209 : : }
9210 : :
9211 : 4192 : c = ref->u.c.component;
9212 : 4192 : if (c->ts.type == BT_CLASS)
9213 : : {
9214 : 978 : allocatable = CLASS_DATA (c)->attr.allocatable;
9215 : 978 : pointer = CLASS_DATA (c)->attr.class_pointer;
9216 : 978 : dimension = CLASS_DATA (c)->attr.dimension;
9217 : 978 : codimension = CLASS_DATA (c)->attr.codimension;
9218 : 978 : is_abstract = CLASS_DATA (c)->attr.abstract;
9219 : : }
9220 : : else
9221 : : {
9222 : 3214 : allocatable = c->attr.allocatable;
9223 : 3214 : pointer = c->attr.pointer;
9224 : 3214 : dimension = c->attr.dimension;
9225 : 3214 : codimension = c->attr.codimension;
9226 : 3214 : is_abstract = c->attr.abstract;
9227 : : }
9228 : : break;
9229 : :
9230 : 0 : case REF_SUBSTRING:
9231 : 0 : case REF_INQUIRY:
9232 : 0 : allocatable = 0;
9233 : 0 : pointer = 0;
9234 : 0 : break;
9235 : : }
9236 : : }
9237 : : }
9238 : :
9239 : : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9240 : : pointer or an allocatable variable. */
9241 : 16860 : if (allocatable == 0 && pointer == 0)
9242 : : {
9243 : 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9244 : : &e->where);
9245 : 4 : goto failure;
9246 : : }
9247 : :
9248 : : /* Some checks for the SOURCE tag. */
9249 : 16856 : if (code->expr3)
9250 : : {
9251 : : /* Check F03:C632: "The source-expr shall be a scalar or have the same
9252 : : rank as allocate-object". This would require the MOLD argument to
9253 : : NULL() as source-expr for subsequent checking. However, even the
9254 : : resulting disassociated pointer or unallocated array has no shape that
9255 : : could be used for SOURCE= or MOLD=. */
9256 : 3772 : if (code->expr3->expr_type == EXPR_NULL)
9257 : : {
9258 : 4 : gfc_error ("The intrinsic NULL cannot be used as source-expr at %L",
9259 : : &code->expr3->where);
9260 : 4 : goto failure;
9261 : : }
9262 : :
9263 : : /* Check F03:C631. */
9264 : 3768 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9265 : : {
9266 : 10 : gfc_error ("Type of entity at %L is type incompatible with "
9267 : 10 : "source-expr at %L", &e->where, &code->expr3->where);
9268 : 10 : goto failure;
9269 : : }
9270 : :
9271 : : /* Check F03:C632 and restriction following Note 6.18. */
9272 : 3758 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9273 : 7 : goto failure;
9274 : :
9275 : : /* Check F03:C633. */
9276 : 3751 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9277 : : {
9278 : 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9279 : : "shall have the same kind type parameter",
9280 : : &e->where, &code->expr3->where);
9281 : 1 : goto failure;
9282 : : }
9283 : :
9284 : : /* Check F2008, C642. */
9285 : 3750 : if (code->expr3->ts.type == BT_DERIVED
9286 : 3750 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9287 : 1163 : || (code->expr3->ts.u.derived->from_intmod
9288 : : == INTMOD_ISO_FORTRAN_ENV
9289 : 0 : && code->expr3->ts.u.derived->intmod_sym_id
9290 : : == ISOFORTRAN_LOCK_TYPE)))
9291 : : {
9292 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
9293 : : "LOCK_TYPE nor have a LOCK_TYPE component if "
9294 : : "allocate-object at %L is a coarray",
9295 : 0 : &code->expr3->where, &e->where);
9296 : 0 : goto failure;
9297 : : }
9298 : :
9299 : : /* Check F2008:C639: "Corresponding kind type parameters of
9300 : : allocate-object and source-expr shall have the same values." */
9301 : 3750 : if (e->ts.type == BT_CHARACTER
9302 : 806 : && !e->ts.deferred
9303 : 162 : && e->ts.u.cl->length
9304 : 162 : && code->expr3->ts.type == BT_CHARACTER
9305 : 3912 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9306 : : "SOURCE= or MOLD= specifier"))
9307 : 17 : goto failure;
9308 : :
9309 : : /* Check TS18508, C702/C703. */
9310 : 3733 : if (code->expr3->ts.type == BT_DERIVED
9311 : 4896 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9312 : 1163 : || (code->expr3->ts.u.derived->from_intmod
9313 : : == INTMOD_ISO_FORTRAN_ENV
9314 : 0 : && code->expr3->ts.u.derived->intmod_sym_id
9315 : : == ISOFORTRAN_EVENT_TYPE)))
9316 : : {
9317 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
9318 : : "EVENT_TYPE nor have a EVENT_TYPE component if "
9319 : : "allocate-object at %L is a coarray",
9320 : 0 : &code->expr3->where, &e->where);
9321 : 0 : goto failure;
9322 : : }
9323 : : }
9324 : :
9325 : : /* Check F08:C629. */
9326 : 16817 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9327 : 153 : && !code->expr3)
9328 : : {
9329 : 2 : gcc_assert (e->ts.type == BT_CLASS);
9330 : 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9331 : : "type-spec or source-expr", sym->name, &e->where);
9332 : 2 : goto failure;
9333 : : }
9334 : :
9335 : : /* F2003:C626 (R623) A type-param-value in a type-spec shall be an asterisk
9336 : : if and only if each allocate-object is a dummy argument for which the
9337 : : corresponding type parameter is assumed. */
9338 : 16815 : if (code->ext.alloc.ts.type == BT_CHARACTER
9339 : 501 : && code->ext.alloc.ts.u.cl->length != NULL
9340 : 486 : && e->ts.type == BT_CHARACTER && !e->ts.deferred
9341 : 23 : && e->ts.u.cl->length == NULL
9342 : 2 : && e->symtree->n.sym->attr.dummy)
9343 : : {
9344 : 2 : gfc_error ("The type parameter in ALLOCATE statement with type-spec "
9345 : : "shall be an asterisk as allocate object %qs at %L is a "
9346 : : "dummy argument with assumed type parameter",
9347 : : sym->name, &e->where);
9348 : 2 : goto failure;
9349 : : }
9350 : :
9351 : : /* Check F08:C632. */
9352 : 16813 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9353 : 60 : && !UNLIMITED_POLY (e))
9354 : : {
9355 : 36 : int cmp;
9356 : :
9357 : 36 : if (!e->ts.u.cl->length)
9358 : 15 : goto failure;
9359 : :
9360 : 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9361 : 21 : code->ext.alloc.ts.u.cl->length);
9362 : 21 : if (cmp == 1 || cmp == -1 || cmp == -3)
9363 : : {
9364 : 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9365 : : "character-length parameter as in the declaration",
9366 : : sym->name, &e->where);
9367 : 2 : goto failure;
9368 : : }
9369 : : }
9370 : :
9371 : : /* In the variable definition context checks, gfc_expr_attr is used
9372 : : on the expression. This is fooled by the array specification
9373 : : present in e, thus we have to eliminate that one temporarily. */
9374 : 16796 : e2 = remove_last_array_ref (e);
9375 : 16796 : t = true;
9376 : 16796 : if (t && pointer)
9377 : 3796 : t = gfc_check_vardef_context (e2, true, true, false,
9378 : 3796 : _("ALLOCATE object"));
9379 : 3796 : if (t)
9380 : 16788 : t = gfc_check_vardef_context (e2, false, true, false,
9381 : 16788 : _("ALLOCATE object"));
9382 : 16796 : gfc_free_expr (e2);
9383 : 16796 : if (!t)
9384 : 11 : goto failure;
9385 : :
9386 : 16785 : code->ext.alloc.expr3_not_explicit = 0;
9387 : 16785 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9388 : 1575 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9389 : : {
9390 : : /* For class arrays, the initialization with SOURCE is done
9391 : : using _copy and trans_call. It is convenient to exploit that
9392 : : when the allocated type is different from the declared type but
9393 : : no SOURCE exists by setting expr3. */
9394 : 285 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9395 : 285 : code->ext.alloc.expr3_not_explicit = 1;
9396 : : }
9397 : 16500 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9398 : 2458 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9399 : 5 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9400 : : {
9401 : : /* We have to zero initialize the integer variable. */
9402 : 1 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9403 : 1 : code->ext.alloc.expr3_not_explicit = 1;
9404 : : }
9405 : :
9406 : 16785 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9407 : : {
9408 : : /* Make sure the vtab symbol is present when
9409 : : the module variables are generated. */
9410 : 2918 : gfc_typespec ts = e->ts;
9411 : 2918 : if (code->expr3)
9412 : 1306 : ts = code->expr3->ts;
9413 : 1612 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9414 : 707 : ts = code->ext.alloc.ts;
9415 : :
9416 : : /* Finding the vtab also publishes the type's symbol. Therefore this
9417 : : statement is necessary. */
9418 : 2918 : gfc_find_derived_vtab (ts.u.derived);
9419 : 2918 : }
9420 : 13867 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9421 : : {
9422 : : /* Again, make sure the vtab symbol is present when
9423 : : the module variables are generated. */
9424 : 433 : gfc_typespec *ts = NULL;
9425 : 433 : if (code->expr3)
9426 : 347 : ts = &code->expr3->ts;
9427 : : else
9428 : 86 : ts = &code->ext.alloc.ts;
9429 : :
9430 : 433 : gcc_assert (ts);
9431 : :
9432 : : /* Finding the vtab also publishes the type's symbol. Therefore this
9433 : : statement is necessary. */
9434 : 433 : gfc_find_vtab (ts);
9435 : : }
9436 : :
9437 : 16785 : if (dimension == 0 && codimension == 0)
9438 : 5218 : goto success;
9439 : :
9440 : : /* Make sure the last reference node is an array specification. */
9441 : :
9442 : 11567 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9443 : 10357 : || (dimension && ref2->u.ar.dimen == 0))
9444 : : {
9445 : : /* F08:C633. */
9446 : 1210 : if (code->expr3)
9447 : : {
9448 : 1209 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9449 : : "in ALLOCATE statement at %L", &e->where))
9450 : 0 : goto failure;
9451 : 1209 : if (code->expr3->rank != 0)
9452 : 1208 : *array_alloc_wo_spec = true;
9453 : : else
9454 : : {
9455 : 1 : gfc_error ("Array specification or array-valued SOURCE= "
9456 : : "expression required in ALLOCATE statement at %L",
9457 : : &e->where);
9458 : 1 : goto failure;
9459 : : }
9460 : : }
9461 : : else
9462 : : {
9463 : 1 : gfc_error ("Array specification required in ALLOCATE statement "
9464 : : "at %L", &e->where);
9465 : 1 : goto failure;
9466 : : }
9467 : : }
9468 : :
9469 : : /* Make sure that the array section reference makes sense in the
9470 : : context of an ALLOCATE specification. */
9471 : :
9472 : 11565 : ar = &ref2->u.ar;
9473 : :
9474 : 11565 : if (codimension)
9475 : 982 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9476 : : {
9477 : 580 : switch (ar->dimen_type[i])
9478 : : {
9479 : 2 : case DIMEN_THIS_IMAGE:
9480 : 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9481 : : "at %L", &e->where);
9482 : 2 : goto failure;
9483 : :
9484 : 83 : case DIMEN_RANGE:
9485 : : /* F2018:R937:
9486 : : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9487 : : */
9488 : 83 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9489 : : {
9490 : 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9491 : : "at %L", &e->where);
9492 : 8 : goto failure;
9493 : : }
9494 : 75 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9495 : : {
9496 : 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9497 : 2 : &ar->start[i]->where);
9498 : 2 : goto failure;
9499 : : }
9500 : : break;
9501 : :
9502 : 93 : case DIMEN_ELEMENT:
9503 : 93 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9504 : : {
9505 : 85 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9506 : 85 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9507 : : {
9508 : 1 : gfc_error ("Upper cobound is less than lower cobound "
9509 : : "of 1 at %L", &ar->start[i]->where);
9510 : 1 : goto failure;
9511 : : }
9512 : : }
9513 : : break;
9514 : :
9515 : : case DIMEN_STAR:
9516 : : break;
9517 : :
9518 : 0 : default:
9519 : 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9520 : : &e->where);
9521 : 0 : goto failure;
9522 : :
9523 : : }
9524 : : }
9525 : 28495 : for (i = 0; i < ar->dimen; i++)
9526 : : {
9527 : 16947 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9528 : 14268 : goto check_symbols;
9529 : :
9530 : 2679 : switch (ar->dimen_type[i])
9531 : : {
9532 : : case DIMEN_ELEMENT:
9533 : : break;
9534 : :
9535 : 2414 : case DIMEN_RANGE:
9536 : 2414 : if (ar->start[i] != NULL
9537 : 2414 : && ar->end[i] != NULL
9538 : 2413 : && ar->stride[i] == NULL)
9539 : : break;
9540 : :
9541 : : /* Fall through. */
9542 : :
9543 : 1 : case DIMEN_UNKNOWN:
9544 : 1 : case DIMEN_VECTOR:
9545 : 1 : case DIMEN_STAR:
9546 : 1 : case DIMEN_THIS_IMAGE:
9547 : 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9548 : : &e->where);
9549 : 1 : goto failure;
9550 : : }
9551 : :
9552 : 2413 : check_symbols:
9553 : 44234 : for (a = code->ext.alloc.list; a; a = a->next)
9554 : : {
9555 : 27291 : sym = a->expr->symtree->n.sym;
9556 : :
9557 : : /* TODO - check derived type components. */
9558 : 27291 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9559 : 9040 : continue;
9560 : :
9561 : 18251 : if ((ar->start[i] != NULL
9562 : 17573 : && gfc_find_var_in_expr (sym, ar->start[i]))
9563 : 35821 : || (ar->end[i] != NULL
9564 : 2632 : && gfc_find_var_in_expr (sym, ar->end[i])))
9565 : : {
9566 : 3 : gfc_error ("%qs must not appear in the array specification at "
9567 : : "%L in the same ALLOCATE statement where it is "
9568 : : "itself allocated", sym->name, &ar->where);
9569 : 3 : goto failure;
9570 : : }
9571 : : }
9572 : : }
9573 : :
9574 : 11712 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9575 : : {
9576 : 729 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9577 : 565 : || ar->dimen_type[i] == DIMEN_RANGE)
9578 : : {
9579 : 164 : if (i == (ar->dimen + ar->codimen - 1))
9580 : : {
9581 : 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9582 : : "statement at %L", &e->where);
9583 : 0 : goto failure;
9584 : : }
9585 : 164 : continue;
9586 : : }
9587 : :
9588 : 401 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9589 : 401 : && ar->stride[i] == NULL)
9590 : : break;
9591 : :
9592 : 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9593 : : &e->where);
9594 : 0 : goto failure;
9595 : : }
9596 : :
9597 : 11548 : success:
9598 : : return true;
9599 : :
9600 : : failure:
9601 : : return false;
9602 : : }
9603 : :
9604 : :
9605 : : static void
9606 : 19679 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9607 : : {
9608 : 19679 : gfc_expr *stat, *errmsg, *pe, *qe;
9609 : 19679 : gfc_alloc *a, *p, *q;
9610 : :
9611 : 19679 : stat = code->expr1;
9612 : 19679 : errmsg = code->expr2;
9613 : :
9614 : : /* Check the stat variable. */
9615 : 19679 : if (stat)
9616 : : {
9617 : 643 : if (!gfc_check_vardef_context (stat, false, false, false,
9618 : 643 : _("STAT variable")))
9619 : 8 : goto done_stat;
9620 : :
9621 : 635 : if (stat->ts.type != BT_INTEGER
9622 : 626 : || stat->rank > 0)
9623 : 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9624 : : "variable", &stat->where);
9625 : :
9626 : 635 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9627 : 0 : goto done_stat;
9628 : :
9629 : : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9630 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9631 : : */
9632 : 1315 : for (p = code->ext.alloc.list; p; p = p->next)
9633 : 687 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9634 : : {
9635 : 9 : gfc_ref *ref1, *ref2;
9636 : 9 : bool found = true;
9637 : :
9638 : 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9639 : 7 : ref1 = ref1->next, ref2 = ref2->next)
9640 : : {
9641 : 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9642 : 5 : continue;
9643 : 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9644 : : {
9645 : : found = false;
9646 : : break;
9647 : : }
9648 : : }
9649 : :
9650 : 9 : if (found)
9651 : : {
9652 : 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9653 : : "the same %s statement", &stat->where, fcn, fcn);
9654 : 7 : break;
9655 : : }
9656 : : }
9657 : : }
9658 : :
9659 : 19036 : done_stat:
9660 : :
9661 : : /* Check the errmsg variable. */
9662 : 19679 : if (errmsg)
9663 : : {
9664 : 146 : if (!stat)
9665 : 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9666 : : &errmsg->where);
9667 : :
9668 : 146 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9669 : 146 : _("ERRMSG variable")))
9670 : 6 : goto done_errmsg;
9671 : :
9672 : : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9673 : : F18:R930 errmsg-variable is scalar-default-char-variable
9674 : : F18:R906 default-char-variable is variable
9675 : : F18:C906 default-char-variable shall be default character. */
9676 : 140 : if (errmsg->ts.type != BT_CHARACTER
9677 : 138 : || errmsg->rank > 0
9678 : 137 : || errmsg->ts.kind != gfc_default_character_kind)
9679 : 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9680 : : "variable", &errmsg->where);
9681 : :
9682 : 140 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9683 : 0 : goto done_errmsg;
9684 : :
9685 : : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9686 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9687 : : */
9688 : 278 : for (p = code->ext.alloc.list; p; p = p->next)
9689 : 143 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9690 : : {
9691 : 9 : gfc_ref *ref1, *ref2;
9692 : 9 : bool found = true;
9693 : :
9694 : 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9695 : 7 : ref1 = ref1->next, ref2 = ref2->next)
9696 : : {
9697 : 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9698 : 4 : continue;
9699 : 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9700 : : {
9701 : : found = false;
9702 : : break;
9703 : : }
9704 : : }
9705 : :
9706 : 9 : if (found)
9707 : : {
9708 : 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9709 : : "the same %s statement", &errmsg->where, fcn, fcn);
9710 : 5 : break;
9711 : : }
9712 : : }
9713 : : }
9714 : :
9715 : 19533 : done_errmsg:
9716 : :
9717 : : /* Check that an allocate-object appears only once in the statement. */
9718 : :
9719 : 44589 : for (p = code->ext.alloc.list; p; p = p->next)
9720 : : {
9721 : 24910 : pe = p->expr;
9722 : 34101 : for (q = p->next; q; q = q->next)
9723 : : {
9724 : 9191 : qe = q->expr;
9725 : 9191 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9726 : : {
9727 : : /* This is a potential collision. */
9728 : 2093 : gfc_ref *pr = pe->ref;
9729 : 2093 : gfc_ref *qr = qe->ref;
9730 : :
9731 : : /* Follow the references until
9732 : : a) They start to differ, in which case there is no error;
9733 : : you can deallocate a%b and a%c in a single statement
9734 : : b) Both of them stop, which is an error
9735 : : c) One of them stops, which is also an error. */
9736 : 4517 : while (1)
9737 : : {
9738 : 3305 : if (pr == NULL && qr == NULL)
9739 : : {
9740 : 7 : gfc_error ("Allocate-object at %L also appears at %L",
9741 : : &pe->where, &qe->where);
9742 : 7 : break;
9743 : : }
9744 : 3298 : else if (pr != NULL && qr == NULL)
9745 : : {
9746 : 2 : gfc_error ("Allocate-object at %L is subobject of"
9747 : : " object at %L", &pe->where, &qe->where);
9748 : 2 : break;
9749 : : }
9750 : 3296 : else if (pr == NULL && qr != NULL)
9751 : : {
9752 : 2 : gfc_error ("Allocate-object at %L is subobject of"
9753 : : " object at %L", &qe->where, &pe->where);
9754 : 2 : break;
9755 : : }
9756 : : /* Here, pr != NULL && qr != NULL */
9757 : 3294 : gcc_assert(pr->type == qr->type);
9758 : 3294 : if (pr->type == REF_ARRAY)
9759 : : {
9760 : : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
9761 : : which are legal. */
9762 : 1065 : gcc_assert (qr->type == REF_ARRAY);
9763 : :
9764 : 1065 : if (pr->next && qr->next)
9765 : : {
9766 : : int i;
9767 : : gfc_array_ref *par = &(pr->u.ar);
9768 : : gfc_array_ref *qar = &(qr->u.ar);
9769 : :
9770 : 1840 : for (i=0; i<par->dimen; i++)
9771 : : {
9772 : 954 : if ((par->start[i] != NULL
9773 : 0 : || qar->start[i] != NULL)
9774 : 1908 : && gfc_dep_compare_expr (par->start[i],
9775 : 954 : qar->start[i]) != 0)
9776 : 168 : goto break_label;
9777 : : }
9778 : : }
9779 : : }
9780 : : else
9781 : : {
9782 : 2229 : if (pr->u.c.component->name != qr->u.c.component->name)
9783 : : break;
9784 : : }
9785 : :
9786 : 1212 : pr = pr->next;
9787 : 1212 : qr = qr->next;
9788 : 1212 : }
9789 : 9191 : break_label:
9790 : : ;
9791 : : }
9792 : : }
9793 : : }
9794 : :
9795 : 19679 : if (strcmp (fcn, "ALLOCATE") == 0)
9796 : : {
9797 : 13864 : bool arr_alloc_wo_spec = false;
9798 : :
9799 : : /* Resolving the expr3 in the loop over all objects to allocate would
9800 : : execute loop invariant code for each loop item. Therefore do it just
9801 : : once here. */
9802 : 13864 : if (code->expr3 && code->expr3->mold
9803 : 343 : && code->expr3->ts.type == BT_DERIVED)
9804 : : {
9805 : : /* Default initialization via MOLD (non-polymorphic). */
9806 : 20 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
9807 : 20 : if (rhs != NULL)
9808 : : {
9809 : 7 : gfc_resolve_expr (rhs);
9810 : 7 : gfc_free_expr (code->expr3);
9811 : 7 : code->expr3 = rhs;
9812 : : }
9813 : : }
9814 : 30727 : for (a = code->ext.alloc.list; a; a = a->next)
9815 : 16863 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
9816 : :
9817 : 13864 : if (arr_alloc_wo_spec && code->expr3)
9818 : : {
9819 : : /* Mark the allocate to have to take the array specification
9820 : : from the expr3. */
9821 : 1202 : code->ext.alloc.arr_spec_from_expr3 = 1;
9822 : : }
9823 : : }
9824 : : else
9825 : : {
9826 : 13862 : for (a = code->ext.alloc.list; a; a = a->next)
9827 : 8047 : resolve_deallocate_expr (a->expr);
9828 : : }
9829 : 19679 : }
9830 : :
9831 : :
9832 : : /************ SELECT CASE resolution subroutines ************/
9833 : :
9834 : : /* Callback function for our mergesort variant. Determines interval
9835 : : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
9836 : : op1 > op2. Assumes we're not dealing with the default case.
9837 : : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
9838 : : There are nine situations to check. */
9839 : :
9840 : : static int
9841 : 1542 : compare_cases (const gfc_case *op1, const gfc_case *op2)
9842 : : {
9843 : 1542 : int retval;
9844 : :
9845 : 1542 : if (op1->low == NULL) /* op1 = (:L) */
9846 : : {
9847 : : /* op2 = (:N), so overlap. */
9848 : 52 : retval = 0;
9849 : : /* op2 = (M:) or (M:N), L < M */
9850 : 52 : if (op2->low != NULL
9851 : 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9852 : : retval = -1;
9853 : : }
9854 : 1490 : else if (op1->high == NULL) /* op1 = (K:) */
9855 : : {
9856 : : /* op2 = (M:), so overlap. */
9857 : 10 : retval = 0;
9858 : : /* op2 = (:N) or (M:N), K > N */
9859 : 10 : if (op2->high != NULL
9860 : 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9861 : : retval = 1;
9862 : : }
9863 : : else /* op1 = (K:L) */
9864 : : {
9865 : 1480 : if (op2->low == NULL) /* op2 = (:N), K > N */
9866 : 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9867 : 18 : ? 1 : 0;
9868 : 1462 : else if (op2->high == NULL) /* op2 = (M:), L < M */
9869 : 14 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9870 : 10 : ? -1 : 0;
9871 : : else /* op2 = (M:N) */
9872 : : {
9873 : 1452 : retval = 0;
9874 : : /* L < M */
9875 : 1452 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9876 : : retval = -1;
9877 : : /* K > N */
9878 : 412 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9879 : 438 : retval = 1;
9880 : : }
9881 : : }
9882 : :
9883 : 1542 : return retval;
9884 : : }
9885 : :
9886 : :
9887 : : /* Merge-sort a double linked case list, detecting overlap in the
9888 : : process. LIST is the head of the double linked case list before it
9889 : : is sorted. Returns the head of the sorted list if we don't see any
9890 : : overlap, or NULL otherwise. */
9891 : :
9892 : : static gfc_case *
9893 : 642 : check_case_overlap (gfc_case *list)
9894 : : {
9895 : 642 : gfc_case *p, *q, *e, *tail;
9896 : 642 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
9897 : :
9898 : : /* If the passed list was empty, return immediately. */
9899 : 642 : if (!list)
9900 : : return NULL;
9901 : :
9902 : : overlap_seen = 0;
9903 : : insize = 1;
9904 : :
9905 : : /* Loop unconditionally. The only exit from this loop is a return
9906 : : statement, when we've finished sorting the case list. */
9907 : 1334 : for (;;)
9908 : : {
9909 : 988 : p = list;
9910 : 988 : list = NULL;
9911 : 988 : tail = NULL;
9912 : :
9913 : : /* Count the number of merges we do in this pass. */
9914 : 988 : nmerges = 0;
9915 : :
9916 : : /* Loop while there exists a merge to be done. */
9917 : 2491 : while (p)
9918 : : {
9919 : 1503 : int i;
9920 : :
9921 : : /* Count this merge. */
9922 : 1503 : nmerges++;
9923 : :
9924 : : /* Cut the list in two pieces by stepping INSIZE places
9925 : : forward in the list, starting from P. */
9926 : 1503 : psize = 0;
9927 : 1503 : q = p;
9928 : 3150 : for (i = 0; i < insize; i++)
9929 : : {
9930 : 2206 : psize++;
9931 : 2206 : q = q->right;
9932 : 2206 : if (!q)
9933 : : break;
9934 : : }
9935 : : qsize = insize;
9936 : :
9937 : : /* Now we have two lists. Merge them! */
9938 : 4918 : while (psize > 0 || (qsize > 0 && q != NULL))
9939 : : {
9940 : : /* See from which the next case to merge comes from. */
9941 : 771 : if (psize == 0)
9942 : : {
9943 : : /* P is empty so the next case must come from Q. */
9944 : 771 : e = q;
9945 : 771 : q = q->right;
9946 : 771 : qsize--;
9947 : : }
9948 : 2644 : else if (qsize == 0 || q == NULL)
9949 : : {
9950 : : /* Q is empty. */
9951 : 1102 : e = p;
9952 : 1102 : p = p->right;
9953 : 1102 : psize--;
9954 : : }
9955 : : else
9956 : : {
9957 : 1542 : cmp = compare_cases (p, q);
9958 : 1542 : if (cmp < 0)
9959 : : {
9960 : : /* The whole case range for P is less than the
9961 : : one for Q. */
9962 : 1100 : e = p;
9963 : 1100 : p = p->right;
9964 : 1100 : psize--;
9965 : : }
9966 : 442 : else if (cmp > 0)
9967 : : {
9968 : : /* The whole case range for Q is greater than
9969 : : the case range for P. */
9970 : 438 : e = q;
9971 : 438 : q = q->right;
9972 : 438 : qsize--;
9973 : : }
9974 : : else
9975 : : {
9976 : : /* The cases overlap, or they are the same
9977 : : element in the list. Either way, we must
9978 : : issue an error and get the next case from P. */
9979 : : /* FIXME: Sort P and Q by line number. */
9980 : 4 : gfc_error ("CASE label at %L overlaps with CASE "
9981 : : "label at %L", &p->where, &q->where);
9982 : 4 : overlap_seen = 1;
9983 : 4 : e = p;
9984 : 4 : p = p->right;
9985 : 4 : psize--;
9986 : : }
9987 : : }
9988 : :
9989 : : /* Add the next element to the merged list. */
9990 : 3415 : if (tail)
9991 : 2427 : tail->right = e;
9992 : : else
9993 : : list = e;
9994 : 3415 : e->left = tail;
9995 : 3415 : tail = e;
9996 : : }
9997 : :
9998 : : /* P has now stepped INSIZE places along, and so has Q. So
9999 : : they're the same. */
10000 : : p = q;
10001 : : }
10002 : 988 : tail->right = NULL;
10003 : :
10004 : : /* If we have done only one merge or none at all, we've
10005 : : finished sorting the cases. */
10006 : 988 : if (nmerges <= 1)
10007 : : {
10008 : 642 : if (!overlap_seen)
10009 : : return list;
10010 : : else
10011 : : return NULL;
10012 : : }
10013 : :
10014 : : /* Otherwise repeat, merging lists twice the size. */
10015 : 346 : insize *= 2;
10016 : 346 : }
10017 : : }
10018 : :
10019 : :
10020 : : /* Check to see if an expression is suitable for use in a CASE statement.
10021 : : Makes sure that all case expressions are scalar constants of the same
10022 : : type. Return false if anything is wrong. */
10023 : :
10024 : : static bool
10025 : 3257 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
10026 : : {
10027 : 3257 : if (e == NULL) return true;
10028 : :
10029 : 3164 : if (e->ts.type != case_expr->ts.type)
10030 : : {
10031 : 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
10032 : : &e->where, gfc_basic_typename (case_expr->ts.type));
10033 : 4 : return false;
10034 : : }
10035 : :
10036 : : /* C805 (R808) For a given case-construct, each case-value shall be of
10037 : : the same type as case-expr. For character type, length differences
10038 : : are allowed, but the kind type parameters shall be the same. */
10039 : :
10040 : 3160 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
10041 : : {
10042 : 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
10043 : : &e->where, case_expr->ts.kind);
10044 : 4 : return false;
10045 : : }
10046 : :
10047 : : /* Convert the case value kind to that of case expression kind,
10048 : : if needed */
10049 : :
10050 : 3156 : if (e->ts.kind != case_expr->ts.kind)
10051 : 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
10052 : :
10053 : 3156 : if (e->rank != 0)
10054 : : {
10055 : 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
10056 : : &e->where);
10057 : 0 : return false;
10058 : : }
10059 : :
10060 : : return true;
10061 : : }
10062 : :
10063 : :
10064 : : /* Given a completely parsed select statement, we:
10065 : :
10066 : : - Validate all expressions and code within the SELECT.
10067 : : - Make sure that the selection expression is not of the wrong type.
10068 : : - Make sure that no case ranges overlap.
10069 : : - Eliminate unreachable cases and unreachable code resulting from
10070 : : removing case labels.
10071 : :
10072 : : The standard does allow unreachable cases, e.g. CASE (5:3). But
10073 : : they are a hassle for code generation, and to prevent that, we just
10074 : : cut them out here. This is not necessary for overlapping cases
10075 : : because they are illegal and we never even try to generate code.
10076 : :
10077 : : We have the additional caveat that a SELECT construct could have
10078 : : been a computed GOTO in the source code. Fortunately we can fairly
10079 : : easily work around that here: The case_expr for a "real" SELECT CASE
10080 : : is in code->expr1, but for a computed GOTO it is in code->expr2. All
10081 : : we have to do is make sure that the case_expr is a scalar integer
10082 : : expression. */
10083 : :
10084 : : static void
10085 : 683 : resolve_select (gfc_code *code, bool select_type)
10086 : : {
10087 : 683 : gfc_code *body;
10088 : 683 : gfc_expr *case_expr;
10089 : 683 : gfc_case *cp, *default_case, *tail, *head;
10090 : 683 : int seen_unreachable;
10091 : 683 : int seen_logical;
10092 : 683 : int ncases;
10093 : 683 : bt type;
10094 : 683 : bool t;
10095 : :
10096 : 683 : if (code->expr1 == NULL)
10097 : : {
10098 : : /* This was actually a computed GOTO statement. */
10099 : 5 : case_expr = code->expr2;
10100 : 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
10101 : 3 : gfc_error ("Selection expression in computed GOTO statement "
10102 : : "at %L must be a scalar integer expression",
10103 : : &case_expr->where);
10104 : :
10105 : : /* Further checking is not necessary because this SELECT was built
10106 : : by the compiler, so it should always be OK. Just move the
10107 : : case_expr from expr2 to expr so that we can handle computed
10108 : : GOTOs as normal SELECTs from here on. */
10109 : 5 : code->expr1 = code->expr2;
10110 : 5 : code->expr2 = NULL;
10111 : 5 : return;
10112 : : }
10113 : :
10114 : 678 : case_expr = code->expr1;
10115 : 678 : type = case_expr->ts.type;
10116 : :
10117 : : /* F08:C830. */
10118 : 678 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
10119 : 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
10120 : :
10121 : : {
10122 : 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
10123 : : &case_expr->where, gfc_typename (case_expr));
10124 : :
10125 : : /* Punt. Going on here just produce more garbage error messages. */
10126 : 0 : return;
10127 : : }
10128 : :
10129 : : /* F08:R842. */
10130 : 678 : if (!select_type && case_expr->rank != 0)
10131 : : {
10132 : 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
10133 : : "expression", &case_expr->where);
10134 : :
10135 : : /* Punt. */
10136 : 1 : return;
10137 : : }
10138 : :
10139 : : /* Raise a warning if an INTEGER case value exceeds the range of
10140 : : the case-expr. Later, all expressions will be promoted to the
10141 : : largest kind of all case-labels. */
10142 : :
10143 : 677 : if (type == BT_INTEGER)
10144 : 1897 : for (body = code->block; body; body = body->block)
10145 : 2800 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10146 : : {
10147 : 1436 : if (cp->low
10148 : 1436 : && gfc_check_integer_range (cp->low->value.integer,
10149 : : case_expr->ts.kind) != ARITH_OK)
10150 : 6 : gfc_warning (0, "Expression in CASE statement at %L is "
10151 : 6 : "not in the range of %s", &cp->low->where,
10152 : : gfc_typename (case_expr));
10153 : :
10154 : 1436 : if (cp->high
10155 : 1153 : && cp->low != cp->high
10156 : 1544 : && gfc_check_integer_range (cp->high->value.integer,
10157 : : case_expr->ts.kind) != ARITH_OK)
10158 : 0 : gfc_warning (0, "Expression in CASE statement at %L is "
10159 : 0 : "not in the range of %s", &cp->high->where,
10160 : : gfc_typename (case_expr));
10161 : : }
10162 : :
10163 : : /* PR 19168 has a long discussion concerning a mismatch of the kinds
10164 : : of the SELECT CASE expression and its CASE values. Walk the lists
10165 : : of case values, and if we find a mismatch, promote case_expr to
10166 : : the appropriate kind. */
10167 : :
10168 : 677 : if (type == BT_LOGICAL || type == BT_INTEGER)
10169 : : {
10170 : 2083 : for (body = code->block; body; body = body->block)
10171 : : {
10172 : : /* Walk the case label list. */
10173 : 3061 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10174 : : {
10175 : : /* Intercept the DEFAULT case. It does not have a kind. */
10176 : 1571 : if (cp->low == NULL && cp->high == NULL)
10177 : 291 : continue;
10178 : :
10179 : : /* Unreachable case ranges are discarded, so ignore. */
10180 : 1235 : if (cp->low != NULL && cp->high != NULL
10181 : 1187 : && cp->low != cp->high
10182 : 1345 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10183 : 33 : continue;
10184 : :
10185 : 1247 : if (cp->low != NULL
10186 : 1247 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
10187 : 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10188 : :
10189 : 1247 : if (cp->high != NULL
10190 : 1247 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10191 : 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10192 : : }
10193 : : }
10194 : : }
10195 : :
10196 : : /* Assume there is no DEFAULT case. */
10197 : 677 : default_case = NULL;
10198 : 677 : head = tail = NULL;
10199 : 677 : ncases = 0;
10200 : 677 : seen_logical = 0;
10201 : :
10202 : 2472 : for (body = code->block; body; body = body->block)
10203 : : {
10204 : : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10205 : 1795 : t = true;
10206 : 1795 : seen_unreachable = 0;
10207 : :
10208 : : /* Walk the case label list, making sure that all case labels
10209 : : are legal. */
10210 : 3777 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10211 : : {
10212 : : /* Count the number of cases in the whole construct. */
10213 : 1993 : ncases++;
10214 : :
10215 : : /* Intercept the DEFAULT case. */
10216 : 1993 : if (cp->low == NULL && cp->high == NULL)
10217 : : {
10218 : 361 : if (default_case != NULL)
10219 : : {
10220 : 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10221 : : "by a second DEFAULT CASE at %L",
10222 : : &default_case->where, &cp->where);
10223 : 0 : t = false;
10224 : 0 : break;
10225 : : }
10226 : : else
10227 : : {
10228 : 361 : default_case = cp;
10229 : 361 : continue;
10230 : : }
10231 : : }
10232 : :
10233 : : /* Deal with single value cases and case ranges. Errors are
10234 : : issued from the validation function. */
10235 : 1632 : if (!validate_case_label_expr (cp->low, case_expr)
10236 : 1632 : || !validate_case_label_expr (cp->high, case_expr))
10237 : : {
10238 : : t = false;
10239 : : break;
10240 : : }
10241 : :
10242 : 1624 : if (type == BT_LOGICAL
10243 : 78 : && ((cp->low == NULL || cp->high == NULL)
10244 : 76 : || cp->low != cp->high))
10245 : : {
10246 : 2 : gfc_error ("Logical range in CASE statement at %L is not "
10247 : : "allowed",
10248 : 1 : cp->low ? &cp->low->where : &cp->high->where);
10249 : 2 : t = false;
10250 : 2 : break;
10251 : : }
10252 : :
10253 : 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10254 : : {
10255 : 76 : int value;
10256 : 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10257 : 76 : if (value & seen_logical)
10258 : : {
10259 : 1 : gfc_error ("Constant logical value in CASE statement "
10260 : : "is repeated at %L",
10261 : : &cp->low->where);
10262 : 1 : t = false;
10263 : 1 : break;
10264 : : }
10265 : 75 : seen_logical |= value;
10266 : : }
10267 : :
10268 : 1577 : if (cp->low != NULL && cp->high != NULL
10269 : 1530 : && cp->low != cp->high
10270 : 1733 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10271 : : {
10272 : 35 : if (warn_surprising)
10273 : 1 : gfc_warning (OPT_Wsurprising,
10274 : : "Range specification at %L can never be matched",
10275 : : &cp->where);
10276 : :
10277 : 35 : cp->unreachable = 1;
10278 : 35 : seen_unreachable = 1;
10279 : : }
10280 : : else
10281 : : {
10282 : : /* If the case range can be matched, it can also overlap with
10283 : : other cases. To make sure it does not, we put it in a
10284 : : double linked list here. We sort that with a merge sort
10285 : : later on to detect any overlapping cases. */
10286 : 1586 : if (!head)
10287 : : {
10288 : 642 : head = tail = cp;
10289 : 642 : head->right = head->left = NULL;
10290 : : }
10291 : : else
10292 : : {
10293 : 944 : tail->right = cp;
10294 : 944 : tail->right->left = tail;
10295 : 944 : tail = tail->right;
10296 : 944 : tail->right = NULL;
10297 : : }
10298 : : }
10299 : : }
10300 : :
10301 : : /* It there was a failure in the previous case label, give up
10302 : : for this case label list. Continue with the next block. */
10303 : 1795 : if (!t)
10304 : 11 : continue;
10305 : :
10306 : : /* See if any case labels that are unreachable have been seen.
10307 : : If so, we eliminate them. This is a bit of a kludge because
10308 : : the case lists for a single case statement (label) is a
10309 : : single forward linked lists. */
10310 : 1784 : if (seen_unreachable)
10311 : : {
10312 : : /* Advance until the first case in the list is reachable. */
10313 : 69 : while (body->ext.block.case_list != NULL
10314 : 69 : && body->ext.block.case_list->unreachable)
10315 : : {
10316 : 34 : gfc_case *n = body->ext.block.case_list;
10317 : 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10318 : 34 : n->next = NULL;
10319 : 34 : gfc_free_case_list (n);
10320 : : }
10321 : :
10322 : : /* Strip all other unreachable cases. */
10323 : 35 : if (body->ext.block.case_list)
10324 : : {
10325 : 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10326 : : {
10327 : 1 : if (cp->next->unreachable)
10328 : : {
10329 : 1 : gfc_case *n = cp->next;
10330 : 1 : cp->next = cp->next->next;
10331 : 1 : n->next = NULL;
10332 : 1 : gfc_free_case_list (n);
10333 : : }
10334 : : }
10335 : : }
10336 : : }
10337 : : }
10338 : :
10339 : : /* See if there were overlapping cases. If the check returns NULL,
10340 : : there was overlap. In that case we don't do anything. If head
10341 : : is non-NULL, we prepend the DEFAULT case. The sorted list can
10342 : : then used during code generation for SELECT CASE constructs with
10343 : : a case expression of a CHARACTER type. */
10344 : 677 : if (head)
10345 : : {
10346 : 642 : head = check_case_overlap (head);
10347 : :
10348 : : /* Prepend the default_case if it is there. */
10349 : 642 : if (head != NULL && default_case)
10350 : : {
10351 : 344 : default_case->left = NULL;
10352 : 344 : default_case->right = head;
10353 : 344 : head->left = default_case;
10354 : : }
10355 : : }
10356 : :
10357 : : /* Eliminate dead blocks that may be the result if we've seen
10358 : : unreachable case labels for a block. */
10359 : 2438 : for (body = code; body && body->block; body = body->block)
10360 : : {
10361 : 1761 : if (body->block->ext.block.case_list == NULL)
10362 : : {
10363 : : /* Cut the unreachable block from the code chain. */
10364 : 34 : gfc_code *c = body->block;
10365 : 34 : body->block = c->block;
10366 : :
10367 : : /* Kill the dead block, but not the blocks below it. */
10368 : 34 : c->block = NULL;
10369 : 34 : gfc_free_statements (c);
10370 : : }
10371 : : }
10372 : :
10373 : : /* More than two cases is legal but insane for logical selects.
10374 : : Issue a warning for it. */
10375 : 677 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10376 : 0 : gfc_warning (OPT_Wsurprising,
10377 : : "Logical SELECT CASE block at %L has more that two cases",
10378 : : &code->loc);
10379 : : }
10380 : :
10381 : :
10382 : : /* Check if a derived type is extensible. */
10383 : :
10384 : : bool
10385 : 23072 : gfc_type_is_extensible (gfc_symbol *sym)
10386 : : {
10387 : 23072 : return !(sym->attr.is_bind_c || sym->attr.sequence
10388 : 23056 : || (sym->attr.is_class
10389 : 2070 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10390 : : }
10391 : :
10392 : :
10393 : : static void
10394 : : resolve_types (gfc_namespace *ns);
10395 : :
10396 : : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10397 : : correct as well as possibly the array-spec. */
10398 : :
10399 : : static void
10400 : 12459 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10401 : : {
10402 : 12459 : gfc_expr* target;
10403 : 12459 : bool parentheses = false;
10404 : :
10405 : 12459 : gcc_assert (sym->assoc);
10406 : 12459 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10407 : :
10408 : : /* If this is for SELECT TYPE, the target may not yet be set. In that
10409 : : case, return. Resolution will be called later manually again when
10410 : : this is done. */
10411 : 12459 : target = sym->assoc->target;
10412 : 12459 : if (!target)
10413 : : return;
10414 : 7402 : gcc_assert (!sym->assoc->dangling);
10415 : :
10416 : 7402 : if (target->expr_type == EXPR_OP
10417 : 259 : && target->value.op.op == INTRINSIC_PARENTHESES
10418 : 42 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
10419 : : {
10420 : 23 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
10421 : 23 : gfc_free_expr (target);
10422 : 23 : target = sym->assoc->target;
10423 : 23 : parentheses = true;
10424 : : }
10425 : :
10426 : 7402 : if (resolve_target && !gfc_resolve_expr (target))
10427 : : return;
10428 : :
10429 : 7397 : if (sym->assoc->ar)
10430 : : {
10431 : : int dim;
10432 : : gfc_array_ref *ar = sym->assoc->ar;
10433 : 67 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10434 : : {
10435 : 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10436 : 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10437 : 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10438 : 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10439 : 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10440 : : "remapping of associate name %s at %L",
10441 : : sym->name, &sym->declared_at);
10442 : : }
10443 : : }
10444 : :
10445 : : /* For variable targets, we get some attributes from the target. */
10446 : 7397 : if (target->expr_type == EXPR_VARIABLE)
10447 : : {
10448 : 6475 : gfc_symbol *tsym, *dsym;
10449 : :
10450 : 6475 : gcc_assert (target->symtree);
10451 : 6475 : tsym = target->symtree->n.sym;
10452 : :
10453 : 6475 : if (gfc_expr_attr (target).proc_pointer)
10454 : : {
10455 : 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10456 : : tsym->name, &target->where);
10457 : 0 : return;
10458 : : }
10459 : :
10460 : 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10461 : 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10462 : 6476 : && dsym->attr.flavor == FL_DERIVED)
10463 : : {
10464 : 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10465 : : tsym->name, &target->where);
10466 : 1 : return;
10467 : : }
10468 : :
10469 : 6474 : if (tsym->attr.flavor == FL_PROCEDURE)
10470 : : {
10471 : 73 : bool is_error = true;
10472 : 73 : if (tsym->attr.function && tsym->result == tsym)
10473 : 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10474 : 137 : if (tsym == ns->proc_name)
10475 : : {
10476 : : is_error = false;
10477 : : break;
10478 : : }
10479 : 64 : if (is_error)
10480 : : {
10481 : 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10482 : : tsym->name, &target->where);
10483 : 13 : return;
10484 : : }
10485 : : }
10486 : :
10487 : 6461 : sym->attr.asynchronous = tsym->attr.asynchronous;
10488 : 6461 : sym->attr.volatile_ = tsym->attr.volatile_;
10489 : :
10490 : 12922 : sym->attr.target = tsym->attr.target
10491 : 6461 : || gfc_expr_attr (target).pointer;
10492 : 6461 : if (is_subref_array (target))
10493 : 402 : sym->attr.subref_array_pointer = 1;
10494 : : }
10495 : 922 : else if (target->ts.type == BT_PROCEDURE)
10496 : : {
10497 : 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10498 : : &target->where);
10499 : 0 : return;
10500 : : }
10501 : :
10502 : 7383 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10503 : : {
10504 : : /* By now, the type of the target has been fixed up. */
10505 : 293 : symbol_attribute attr;
10506 : :
10507 : 293 : if (sym->ts.type == BT_DERIVED
10508 : 166 : && target->ts.type == BT_CLASS
10509 : 31 : && !UNLIMITED_POLY (target))
10510 : : {
10511 : : /* Inferred to be derived type but the target has type class. */
10512 : 31 : sym->ts = CLASS_DATA (target)->ts;
10513 : 31 : if (!sym->as)
10514 : 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10515 : 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10516 : 31 : sym->attr.dimension = target->rank ? 1 : 0;
10517 : 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10518 : : target->corank);
10519 : 31 : sym->as = NULL;
10520 : : }
10521 : 262 : else if (target->ts.type == BT_DERIVED
10522 : 135 : && target->symtree && target->symtree->n.sym
10523 : 111 : && target->symtree->n.sym->ts.type == BT_CLASS
10524 : 0 : && IS_INFERRED_TYPE (target)
10525 : 0 : && target->ref && target->ref->next
10526 : 0 : && target->ref->next->type == REF_ARRAY
10527 : 0 : && !target->ref->next->next)
10528 : : {
10529 : : /* A inferred type selector whose symbol has been determined to be
10530 : : a class array but which only has an array reference. Change the
10531 : : associate name and the selector to class type. */
10532 : 0 : sym->ts = target->ts;
10533 : 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10534 : 0 : sym->attr.dimension = target->rank ? 1 : 0;
10535 : 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10536 : : target->corank);
10537 : 0 : sym->as = NULL;
10538 : 0 : target->ts = sym->ts;
10539 : : }
10540 : 262 : else if ((target->ts.type == BT_DERIVED)
10541 : 127 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10542 : 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10543 : : /* Confirmed to be either a derived type or misidentified to be a
10544 : : scalar class object, when the selector is a class array. */
10545 : 141 : sym->ts = target->ts;
10546 : : }
10547 : :
10548 : :
10549 : 7383 : if (target->expr_type == EXPR_NULL)
10550 : : {
10551 : 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10552 : 1 : return;
10553 : : }
10554 : 7382 : else if (target->ts.type == BT_UNKNOWN)
10555 : : {
10556 : 2 : gfc_error ("Selector at %L has no type", &target->where);
10557 : 2 : return;
10558 : : }
10559 : :
10560 : : /* Get type if this was not already set. Note that it can be
10561 : : some other type than the target in case this is a SELECT TYPE
10562 : : selector! So we must not update when the type is already there. */
10563 : 7380 : if (sym->ts.type == BT_UNKNOWN)
10564 : 220 : sym->ts = target->ts;
10565 : :
10566 : 7380 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10567 : :
10568 : : /* See if this is a valid association-to-variable. */
10569 : 14760 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10570 : 6461 : && !parentheses
10571 : 6440 : && !gfc_has_vector_subscript (target))
10572 : 7428 : || gfc_is_ptr_fcn (target));
10573 : :
10574 : : /* Finally resolve if this is an array or not. */
10575 : 7380 : if (target->expr_type == EXPR_FUNCTION && target->rank == 0
10576 : 137 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10577 : : {
10578 : 92 : gfc_expression_rank (target);
10579 : 92 : if (target->ts.type == BT_DERIVED
10580 : 45 : && !sym->as
10581 : 45 : && target->symtree->n.sym->as)
10582 : : {
10583 : 0 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10584 : 0 : sym->attr.dimension = 1;
10585 : : }
10586 : 92 : else if (target->ts.type == BT_CLASS
10587 : 47 : && CLASS_DATA (target)->as)
10588 : : {
10589 : 0 : target->rank = CLASS_DATA (target)->as->rank;
10590 : 0 : target->corank = CLASS_DATA (target)->as->corank;
10591 : 0 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10592 : : {
10593 : 0 : sym->ts = target->ts;
10594 : 0 : sym->attr.dimension = 0;
10595 : : }
10596 : : }
10597 : : }
10598 : :
10599 : :
10600 : 7380 : if (sym->attr.dimension && target->rank == 0)
10601 : : {
10602 : : /* primary.cc makes the assumption that a reference to an associate
10603 : : name followed by a left parenthesis is an array reference. */
10604 : 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10605 : : {
10606 : 12 : gfc_expression_rank (sym->assoc->target);
10607 : 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10608 : 12 : if (!sym->attr.dimension && sym->as)
10609 : 0 : sym->as = NULL;
10610 : : }
10611 : :
10612 : 17 : if (sym->attr.dimension && target->rank == 0)
10613 : : {
10614 : 5 : if (sym->ts.type != BT_CHARACTER)
10615 : 5 : gfc_error ("Associate-name %qs at %L is used as array",
10616 : : sym->name, &sym->declared_at);
10617 : 5 : sym->attr.dimension = 0;
10618 : 5 : return;
10619 : : }
10620 : : }
10621 : :
10622 : : /* We cannot deal with class selectors that need temporaries. */
10623 : 7375 : if (target->ts.type == BT_CLASS
10624 : 7375 : && gfc_ref_needs_temporary_p (target->ref))
10625 : : {
10626 : 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10627 : : "yet implemented", &target->where);
10628 : 1 : return;
10629 : : }
10630 : :
10631 : 7374 : if (target->ts.type == BT_CLASS)
10632 : 2706 : gfc_fix_class_refs (target);
10633 : :
10634 : 7374 : if ((target->rank > 0 || target->corank > 0)
10635 : 2653 : && !sym->attr.select_rank_temporary)
10636 : : {
10637 : 2653 : gfc_array_spec *as;
10638 : : /* The rank may be incorrectly guessed at parsing, therefore make sure
10639 : : it is corrected now. */
10640 : 2653 : if (sym->ts.type != BT_CLASS
10641 : 2097 : && (!sym->as || sym->as->corank != target->corank))
10642 : : {
10643 : 139 : if (!sym->as)
10644 : 132 : sym->as = gfc_get_array_spec ();
10645 : 139 : as = sym->as;
10646 : 139 : as->rank = target->rank;
10647 : 139 : as->type = AS_DEFERRED;
10648 : 139 : as->corank = target->corank;
10649 : 139 : sym->attr.dimension = 1;
10650 : 139 : if (as->corank != 0)
10651 : 7 : sym->attr.codimension = 1;
10652 : : }
10653 : 2514 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10654 : 555 : && (!CLASS_DATA (sym)->as
10655 : 555 : || CLASS_DATA (sym)->as->corank != target->corank))
10656 : : {
10657 : 0 : if (!CLASS_DATA (sym)->as)
10658 : 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10659 : 0 : as = CLASS_DATA (sym)->as;
10660 : 0 : as->rank = target->rank;
10661 : 0 : as->type = AS_DEFERRED;
10662 : 0 : as->corank = target->corank;
10663 : 0 : CLASS_DATA (sym)->attr.dimension = 1;
10664 : 0 : if (as->corank != 0)
10665 : 0 : CLASS_DATA (sym)->attr.codimension = 1;
10666 : : }
10667 : : }
10668 : 4721 : else if (!sym->attr.select_rank_temporary)
10669 : : {
10670 : : /* target's rank is 0, but the type of the sym is still array valued,
10671 : : which has to be corrected. */
10672 : 3338 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10673 : 675 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10674 : : {
10675 : 24 : gfc_array_spec *as;
10676 : 24 : symbol_attribute attr;
10677 : : /* The associated variable's type is still the array type
10678 : : correct this now. */
10679 : 24 : gfc_typespec *ts = &target->ts;
10680 : 24 : gfc_ref *ref;
10681 : : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10682 : : */
10683 : 24 : bool internal_ref = true;
10684 : :
10685 : 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10686 : : {
10687 : 48 : switch (ref->type)
10688 : : {
10689 : 24 : case REF_COMPONENT:
10690 : 24 : ts = &ref->u.c.component->ts;
10691 : 24 : internal_ref
10692 : 24 : = target->ref == ref && ref->next
10693 : 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10694 : : break;
10695 : 24 : case REF_ARRAY:
10696 : 24 : if (ts->type == BT_CLASS)
10697 : 0 : ts = &ts->u.derived->components->ts;
10698 : 24 : if (internal_ref && ref->u.ar.codimen > 0)
10699 : 0 : for (int i = ref->u.ar.dimen;
10700 : : internal_ref
10701 : 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
10702 : : ++i)
10703 : 0 : internal_ref
10704 : 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
10705 : : break;
10706 : : default:
10707 : : break;
10708 : : }
10709 : : }
10710 : : /* Only rewrite the type of this symbol, when the refs are not the
10711 : : internal ones for class and co-array this-image. */
10712 : 24 : if (!internal_ref)
10713 : : {
10714 : : /* Create a scalar instance of the current class type. Because
10715 : : the rank of a class array goes into its name, the type has to
10716 : : be rebuilt. The alternative of (re-)setting just the
10717 : : attributes and as in the current type, destroys the type also
10718 : : in other places. */
10719 : 0 : as = NULL;
10720 : 0 : sym->ts = *ts;
10721 : 0 : sym->ts.type = BT_CLASS;
10722 : 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10723 : 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
10724 : 0 : sym->as = NULL;
10725 : : }
10726 : : }
10727 : : }
10728 : :
10729 : : /* Mark this as an associate variable. */
10730 : 7374 : sym->attr.associate_var = 1;
10731 : :
10732 : : /* Fix up the type-spec for CHARACTER types. */
10733 : 7374 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
10734 : : {
10735 : 502 : gfc_ref *ref;
10736 : 787 : for (ref = target->ref; ref; ref = ref->next)
10737 : 311 : if (ref->type == REF_SUBSTRING
10738 : 74 : && (ref->u.ss.start == NULL
10739 : 74 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
10740 : 74 : || ref->u.ss.end == NULL
10741 : 54 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
10742 : : break;
10743 : :
10744 : 502 : if (!sym->ts.u.cl)
10745 : 182 : sym->ts.u.cl = target->ts.u.cl;
10746 : :
10747 : 502 : if (sym->ts.deferred
10748 : 189 : && sym->ts.u.cl == target->ts.u.cl)
10749 : : {
10750 : 110 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10751 : 110 : sym->ts.deferred = 1;
10752 : : }
10753 : :
10754 : 502 : if (!sym->ts.u.cl->length
10755 : 326 : && !sym->ts.deferred
10756 : 137 : && target->expr_type == EXPR_CONSTANT)
10757 : : {
10758 : 30 : sym->ts.u.cl->length =
10759 : 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
10760 : 30 : target->value.character.length);
10761 : : }
10762 : 472 : else if (((!sym->ts.u.cl->length
10763 : 176 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10764 : 302 : && target->expr_type != EXPR_VARIABLE)
10765 : 350 : || ref)
10766 : : {
10767 : 148 : if (!sym->ts.deferred)
10768 : : {
10769 : 44 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10770 : 44 : sym->ts.deferred = 1;
10771 : : }
10772 : :
10773 : : /* This is reset in trans-stmt.cc after the assignment
10774 : : of the target expression to the associate name. */
10775 : 148 : if (ref && sym->as)
10776 : 26 : sym->attr.pointer = 1;
10777 : : else
10778 : 122 : sym->attr.allocatable = 1;
10779 : : }
10780 : : }
10781 : :
10782 : 7374 : if (sym->ts.type == BT_CLASS
10783 : 1376 : && IS_INFERRED_TYPE (target)
10784 : 13 : && target->ts.type == BT_DERIVED
10785 : 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
10786 : 0 : && target->ref && target->ref->next && !target->ref->next->next
10787 : 0 : && target->ref->next->type == REF_ARRAY)
10788 : 0 : target->ts = target->symtree->n.sym->ts;
10789 : :
10790 : : /* If the target is a good class object, so is the associate variable. */
10791 : 7374 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
10792 : 688 : sym->attr.class_ok = 1;
10793 : :
10794 : : /* If the target is a contiguous pointer, so is the associate variable. */
10795 : 7374 : if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous)
10796 : 2 : sym->attr.contiguous = 1;
10797 : : }
10798 : :
10799 : :
10800 : : /* Ensure that SELECT TYPE expressions have the correct rank and a full
10801 : : array reference, where necessary. The symbols are artificial and so
10802 : : the dimension attribute and arrayspec can also be set. In addition,
10803 : : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
10804 : : This is corrected here as well.*/
10805 : :
10806 : : static void
10807 : 1652 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
10808 : : gfc_ref *ref)
10809 : : {
10810 : 1652 : gfc_ref *nref = (*expr1)->ref;
10811 : 1652 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
10812 : 1652 : gfc_symbol *sym2;
10813 : 1652 : gfc_expr *selector = gfc_copy_expr (expr2);
10814 : :
10815 : 1652 : (*expr1)->rank = rank;
10816 : 1652 : (*expr1)->corank = corank;
10817 : 1652 : if (selector)
10818 : : {
10819 : 310 : gfc_resolve_expr (selector);
10820 : 310 : if (selector->expr_type == EXPR_OP
10821 : 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
10822 : 2 : sym2 = selector->value.op.op1->symtree->n.sym;
10823 : 308 : else if (selector->expr_type == EXPR_VARIABLE
10824 : 7 : || selector->expr_type == EXPR_FUNCTION)
10825 : 308 : sym2 = selector->symtree->n.sym;
10826 : : else
10827 : 0 : gcc_unreachable ();
10828 : : }
10829 : : else
10830 : : sym2 = NULL;
10831 : :
10832 : 1652 : if (sym1->ts.type == BT_CLASS)
10833 : : {
10834 : 1652 : if ((*expr1)->ts.type != BT_CLASS)
10835 : 13 : (*expr1)->ts = sym1->ts;
10836 : :
10837 : 1652 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
10838 : 1652 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
10839 : 1652 : if (CLASS_DATA (sym1)->as == NULL && sym2)
10840 : 1 : CLASS_DATA (sym1)->as
10841 : 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
10842 : : }
10843 : : else
10844 : : {
10845 : 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
10846 : 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
10847 : 0 : if (sym1->as == NULL && sym2)
10848 : 0 : sym1->as = gfc_copy_array_spec (sym2->as);
10849 : : }
10850 : :
10851 : 2988 : for (; nref; nref = nref->next)
10852 : 2678 : if (nref->next == NULL)
10853 : : break;
10854 : :
10855 : 1652 : if (ref && nref && nref->type != REF_ARRAY)
10856 : 6 : nref->next = gfc_copy_ref (ref);
10857 : 1646 : else if (ref && !nref)
10858 : 301 : (*expr1)->ref = gfc_copy_ref (ref);
10859 : 1345 : else if (ref && nref->u.ar.codimen != corank)
10860 : : {
10861 : 912 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
10862 : 855 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
10863 : 57 : nref->u.ar.codimen = corank;
10864 : : }
10865 : 1652 : }
10866 : :
10867 : :
10868 : : static gfc_expr *
10869 : 6559 : build_loc_call (gfc_expr *sym_expr)
10870 : : {
10871 : 6559 : gfc_expr *loc_call;
10872 : 6559 : loc_call = gfc_get_expr ();
10873 : 6559 : loc_call->expr_type = EXPR_FUNCTION;
10874 : 6559 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
10875 : 6559 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
10876 : 6559 : loc_call->symtree->n.sym->attr.intrinsic = 1;
10877 : 6559 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
10878 : 6559 : gfc_commit_symbol (loc_call->symtree->n.sym);
10879 : 6559 : loc_call->ts.type = BT_INTEGER;
10880 : 6559 : loc_call->ts.kind = gfc_index_integer_kind;
10881 : 6559 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
10882 : 6559 : loc_call->value.function.actual = gfc_get_actual_arglist ();
10883 : 6559 : loc_call->value.function.actual->expr = sym_expr;
10884 : 6559 : loc_call->where = sym_expr->where;
10885 : 6559 : return loc_call;
10886 : : }
10887 : :
10888 : : /* Resolve a SELECT TYPE statement. */
10889 : :
10890 : : static void
10891 : 2931 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
10892 : : {
10893 : 2931 : gfc_symbol *selector_type;
10894 : 2931 : gfc_code *body, *new_st, *if_st, *tail;
10895 : 2931 : gfc_code *class_is = NULL, *default_case = NULL;
10896 : 2931 : gfc_case *c;
10897 : 2931 : gfc_symtree *st;
10898 : 2931 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
10899 : 2931 : gfc_namespace *ns;
10900 : 2931 : int error = 0;
10901 : 2931 : int rank = 0, corank = 0;
10902 : 2931 : gfc_ref* ref = NULL;
10903 : 2931 : gfc_expr *selector_expr = NULL;
10904 : 2931 : gfc_code *old_code = code;
10905 : :
10906 : 2931 : ns = code->ext.block.ns;
10907 : 2931 : if (code->expr2)
10908 : : {
10909 : : /* Set this, or coarray checks in resolve will fail. */
10910 : 624 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
10911 : : }
10912 : 2931 : gfc_resolve (ns);
10913 : :
10914 : : /* Check for F03:C813. */
10915 : 2931 : if (code->expr1->ts.type != BT_CLASS
10916 : 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
10917 : : {
10918 : 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
10919 : : "at %L", &code->loc);
10920 : 41 : return;
10921 : : }
10922 : :
10923 : : /* Prevent segfault, when class type is not initialized due to previous
10924 : : error. */
10925 : 2918 : if (!code->expr1->symtree->n.sym->attr.class_ok
10926 : 2916 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
10927 : : return;
10928 : :
10929 : 2911 : if (code->expr2)
10930 : : {
10931 : 615 : gfc_ref *ref2 = NULL;
10932 : 1443 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
10933 : 828 : if (ref->type == REF_COMPONENT
10934 : 426 : && ref->u.c.component->ts.type == BT_CLASS)
10935 : 828 : ref2 = ref;
10936 : :
10937 : 615 : if (ref2)
10938 : : {
10939 : 334 : if (code->expr1->symtree->n.sym->attr.untyped)
10940 : 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
10941 : 334 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
10942 : : }
10943 : : else
10944 : : {
10945 : 281 : if (code->expr1->symtree->n.sym->attr.untyped)
10946 : 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
10947 : : /* Sometimes the selector expression is given the typespec of the
10948 : : '_data' field, which is logical enough but inappropriate here. */
10949 : 281 : if (code->expr2->ts.type == BT_DERIVED
10950 : 80 : && code->expr2->symtree
10951 : 80 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
10952 : 80 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
10953 : 281 : selector_type = CLASS_DATA (code->expr2)
10954 : : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
10955 : : }
10956 : :
10957 : 615 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
10958 : : {
10959 : 296 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
10960 : 296 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
10961 : 296 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
10962 : : }
10963 : :
10964 : : /* F2008: C803 The selector expression must not be coindexed. */
10965 : 615 : if (gfc_is_coindexed (code->expr2))
10966 : : {
10967 : 3 : gfc_error ("Selector at %L must not be coindexed",
10968 : 3 : &code->expr2->where);
10969 : 3 : return;
10970 : : }
10971 : :
10972 : : }
10973 : : else
10974 : : {
10975 : 2296 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
10976 : :
10977 : 2296 : if (gfc_is_coindexed (code->expr1))
10978 : : {
10979 : 0 : gfc_error ("Selector at %L must not be coindexed",
10980 : 0 : &code->expr1->where);
10981 : 0 : return;
10982 : : }
10983 : : }
10984 : :
10985 : : /* Loop over TYPE IS / CLASS IS cases. */
10986 : 8162 : for (body = code->block; body; body = body->block)
10987 : : {
10988 : 5255 : c = body->ext.block.case_list;
10989 : :
10990 : 5255 : if (!error)
10991 : : {
10992 : : /* Check for repeated cases. */
10993 : 8196 : for (tail = code->block; tail; tail = tail->block)
10994 : : {
10995 : 8196 : gfc_case *d = tail->ext.block.case_list;
10996 : 8196 : if (tail == body)
10997 : : break;
10998 : :
10999 : 2950 : if (c->ts.type == d->ts.type
11000 : 516 : && ((c->ts.type == BT_DERIVED
11001 : 418 : && c->ts.u.derived && d->ts.u.derived
11002 : 418 : && !strcmp (c->ts.u.derived->name,
11003 : : d->ts.u.derived->name))
11004 : 515 : || c->ts.type == BT_UNKNOWN
11005 : 515 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11006 : 55 : && c->ts.kind == d->ts.kind)))
11007 : : {
11008 : 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
11009 : : &c->where, &d->where);
11010 : 1 : return;
11011 : : }
11012 : : }
11013 : : }
11014 : :
11015 : : /* Check F03:C815. */
11016 : 3329 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11017 : 2248 : && selector_type
11018 : 2248 : && !selector_type->attr.unlimited_polymorphic
11019 : 7181 : && !gfc_type_is_extensible (c->ts.u.derived))
11020 : : {
11021 : 1 : gfc_error ("Derived type %qs at %L must be extensible",
11022 : 1 : c->ts.u.derived->name, &c->where);
11023 : 1 : error++;
11024 : 1 : continue;
11025 : : }
11026 : :
11027 : : /* Check F03:C816. */
11028 : 5259 : if (c->ts.type != BT_UNKNOWN
11029 : 3667 : && selector_type && !selector_type->attr.unlimited_polymorphic
11030 : 7183 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
11031 : 1926 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
11032 : : {
11033 : 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11034 : 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
11035 : 2 : c->ts.u.derived->name, &c->where, selector_type->name);
11036 : : else
11037 : 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
11038 : : gfc_basic_typename (c->ts.type), &c->where);
11039 : 6 : error++;
11040 : 6 : continue;
11041 : : }
11042 : :
11043 : : /* Check F03:C814. */
11044 : 5247 : if (c->ts.type == BT_CHARACTER
11045 : 736 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
11046 : : {
11047 : 0 : gfc_error ("The type-spec at %L shall specify that each length "
11048 : : "type parameter is assumed", &c->where);
11049 : 0 : error++;
11050 : 0 : continue;
11051 : : }
11052 : :
11053 : : /* Intercept the DEFAULT case. */
11054 : 5247 : if (c->ts.type == BT_UNKNOWN)
11055 : : {
11056 : : /* Check F03:C818. */
11057 : 1586 : if (default_case)
11058 : : {
11059 : 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
11060 : : "by a second DEFAULT CASE at %L",
11061 : 1 : &default_case->ext.block.case_list->where, &c->where);
11062 : 1 : error++;
11063 : 1 : continue;
11064 : : }
11065 : :
11066 : : default_case = body;
11067 : : }
11068 : : }
11069 : :
11070 : 2907 : if (error > 0)
11071 : : return;
11072 : :
11073 : : /* Transform SELECT TYPE statement to BLOCK and associate selector to
11074 : : target if present. If there are any EXIT statements referring to the
11075 : : SELECT TYPE construct, this is no problem because the gfc_code
11076 : : reference stays the same and EXIT is equally possible from the BLOCK
11077 : : it is changed to. */
11078 : 2904 : code->op = EXEC_BLOCK;
11079 : 2904 : if (code->expr2)
11080 : : {
11081 : 612 : gfc_association_list* assoc;
11082 : :
11083 : 612 : assoc = gfc_get_association_list ();
11084 : 612 : assoc->st = code->expr1->symtree;
11085 : 612 : assoc->target = gfc_copy_expr (code->expr2);
11086 : 612 : assoc->target->where = code->expr2->where;
11087 : : /* assoc->variable will be set by resolve_assoc_var. */
11088 : :
11089 : 612 : code->ext.block.assoc = assoc;
11090 : 612 : code->expr1->symtree->n.sym->assoc = assoc;
11091 : :
11092 : 612 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11093 : : }
11094 : : else
11095 : 2292 : code->ext.block.assoc = NULL;
11096 : :
11097 : : /* Ensure that the selector rank and arrayspec are available to
11098 : : correct expressions in which they might be missing. */
11099 : 2904 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
11100 : : {
11101 : 310 : rank = code->expr2->rank;
11102 : 310 : corank = code->expr2->corank;
11103 : 584 : for (ref = code->expr2->ref; ref; ref = ref->next)
11104 : 575 : if (ref->next == NULL)
11105 : : break;
11106 : 310 : if (ref && ref->type == REF_ARRAY)
11107 : 301 : ref = gfc_copy_ref (ref);
11108 : :
11109 : : /* Fixup expr1 if necessary. */
11110 : 310 : if (rank || corank)
11111 : 310 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
11112 : : }
11113 : 2594 : else if (code->expr1->rank || code->expr1->corank)
11114 : : {
11115 : 833 : rank = code->expr1->rank;
11116 : 833 : corank = code->expr1->corank;
11117 : 833 : for (ref = code->expr1->ref; ref; ref = ref->next)
11118 : 833 : if (ref->next == NULL)
11119 : : break;
11120 : 833 : if (ref && ref->type == REF_ARRAY)
11121 : 833 : ref = gfc_copy_ref (ref);
11122 : : }
11123 : :
11124 : 2904 : gfc_expr *orig_expr1 = code->expr1;
11125 : :
11126 : : /* Add EXEC_SELECT to switch on type. */
11127 : 2904 : new_st = gfc_get_code (code->op);
11128 : 2904 : new_st->expr1 = code->expr1;
11129 : 2904 : new_st->expr2 = code->expr2;
11130 : 2904 : new_st->block = code->block;
11131 : 2904 : code->expr1 = code->expr2 = NULL;
11132 : 2904 : code->block = NULL;
11133 : 2904 : if (!ns->code)
11134 : 2904 : ns->code = new_st;
11135 : : else
11136 : 0 : ns->code->next = new_st;
11137 : 2904 : code = new_st;
11138 : 2904 : code->op = EXEC_SELECT_TYPE;
11139 : :
11140 : : /* Use the intrinsic LOC function to generate an integer expression
11141 : : for the vtable of the selector. Note that the rank of the selector
11142 : : expression has to be set to zero. */
11143 : 2904 : gfc_add_vptr_component (code->expr1);
11144 : 2904 : code->expr1->rank = 0;
11145 : 2904 : code->expr1->corank = 0;
11146 : 2904 : code->expr1 = build_loc_call (code->expr1);
11147 : 2904 : selector_expr = code->expr1->value.function.actual->expr;
11148 : :
11149 : : /* Loop over TYPE IS / CLASS IS cases. */
11150 : 8143 : for (body = code->block; body; body = body->block)
11151 : : {
11152 : 5239 : gfc_symbol *vtab;
11153 : 5239 : c = body->ext.block.case_list;
11154 : :
11155 : : /* Generate an index integer expression for address of the
11156 : : TYPE/CLASS vtable and store it in c->low. The hash expression
11157 : : is stored in c->high and is used to resolve intrinsic cases. */
11158 : 5239 : if (c->ts.type != BT_UNKNOWN)
11159 : : {
11160 : 3655 : gfc_expr *e;
11161 : 3655 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11162 : : {
11163 : 2239 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
11164 : 2239 : gcc_assert (vtab);
11165 : 2239 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
11166 : 2239 : c->ts.u.derived->hash_value);
11167 : : }
11168 : : else
11169 : : {
11170 : 1416 : vtab = gfc_find_vtab (&c->ts);
11171 : 1416 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
11172 : 1416 : e = CLASS_DATA (vtab)->initializer;
11173 : 1416 : c->high = gfc_copy_expr (e);
11174 : 1416 : if (c->high->ts.kind != gfc_integer_4_kind)
11175 : : {
11176 : 1 : gfc_typespec ts;
11177 : 1 : ts.kind = gfc_integer_4_kind;
11178 : 1 : ts.type = BT_INTEGER;
11179 : 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
11180 : : }
11181 : : }
11182 : :
11183 : 3655 : e = gfc_lval_expr_from_sym (vtab);
11184 : 3655 : c->low = build_loc_call (e);
11185 : : }
11186 : : else
11187 : 1584 : continue;
11188 : :
11189 : : /* Associate temporary to selector. This should only be done
11190 : : when this case is actually true, so build a new ASSOCIATE
11191 : : that does precisely this here (instead of using the
11192 : : 'global' one). */
11193 : :
11194 : : /* First check the derived type import status. */
11195 : 3655 : if (gfc_current_ns->import_state != IMPORT_NOT_SET
11196 : 6 : && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS))
11197 : : {
11198 : 12 : st = gfc_find_symtree (gfc_current_ns->sym_root,
11199 : 6 : c->ts.u.derived->name);
11200 : 6 : if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code,
11201 : : gfc_current_ns))
11202 : 6 : error++;
11203 : : }
11204 : :
11205 : 3655 : const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
11206 : 3655 : if (c->ts.type == BT_CLASS)
11207 : 321 : snprintf (name, sizeof (name), "__tmp_class_%s_%s",
11208 : 321 : c->ts.u.derived->name, var_name);
11209 : 3334 : else if (c->ts.type == BT_DERIVED)
11210 : 1918 : snprintf (name, sizeof (name), "__tmp_type_%s_%s",
11211 : 1918 : c->ts.u.derived->name, var_name);
11212 : 1416 : else if (c->ts.type == BT_CHARACTER)
11213 : : {
11214 : 736 : HOST_WIDE_INT charlen = 0;
11215 : 736 : if (c->ts.u.cl && c->ts.u.cl->length
11216 : 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11217 : 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11218 : 736 : snprintf (name, sizeof (name),
11219 : : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
11220 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
11221 : : var_name);
11222 : : }
11223 : : else
11224 : 680 : snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
11225 : : gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
11226 : :
11227 : 3655 : st = gfc_find_symtree (ns->sym_root, name);
11228 : 3655 : gcc_assert (st->n.sym->assoc);
11229 : 3655 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11230 : 3655 : st->n.sym->assoc->target->where = selector_expr->where;
11231 : 3655 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11232 : : {
11233 : 3334 : gfc_add_data_component (st->n.sym->assoc->target);
11234 : : /* Fixup the target expression if necessary. */
11235 : 3334 : if (rank || corank)
11236 : 1342 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11237 : : ref);
11238 : : }
11239 : :
11240 : 3655 : new_st = gfc_get_code (EXEC_BLOCK);
11241 : 3655 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11242 : 3655 : new_st->ext.block.ns->code = body->next;
11243 : 3655 : body->next = new_st;
11244 : :
11245 : : /* Chain in the new list only if it is marked as dangling. Otherwise
11246 : : there is a CASE label overlap and this is already used. Just ignore,
11247 : : the error is diagnosed elsewhere. */
11248 : 3655 : if (st->n.sym->assoc->dangling)
11249 : : {
11250 : 3654 : new_st->ext.block.assoc = st->n.sym->assoc;
11251 : 3654 : st->n.sym->assoc->dangling = 0;
11252 : : }
11253 : :
11254 : 3655 : resolve_assoc_var (st->n.sym, false);
11255 : : }
11256 : :
11257 : : /* Take out CLASS IS cases for separate treatment. */
11258 : : body = code;
11259 : 8143 : while (body && body->block)
11260 : : {
11261 : 5239 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11262 : : {
11263 : : /* Add to class_is list. */
11264 : 321 : if (class_is == NULL)
11265 : : {
11266 : 290 : class_is = body->block;
11267 : 290 : tail = class_is;
11268 : : }
11269 : : else
11270 : : {
11271 : 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11272 : 31 : tail->block = body->block;
11273 : 31 : tail = tail->block;
11274 : : }
11275 : : /* Remove from EXEC_SELECT list. */
11276 : 321 : body->block = body->block->block;
11277 : 321 : tail->block = NULL;
11278 : : }
11279 : : else
11280 : : body = body->block;
11281 : : }
11282 : :
11283 : 2904 : if (class_is)
11284 : : {
11285 : 290 : gfc_symbol *vtab;
11286 : :
11287 : 290 : if (!default_case)
11288 : : {
11289 : : /* Add a default case to hold the CLASS IS cases. */
11290 : 288 : for (tail = code; tail->block; tail = tail->block) ;
11291 : 180 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11292 : 180 : tail = tail->block;
11293 : 180 : tail->ext.block.case_list = gfc_get_case ();
11294 : 180 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11295 : 180 : tail->next = NULL;
11296 : 180 : default_case = tail;
11297 : : }
11298 : :
11299 : : /* More than one CLASS IS block? */
11300 : 290 : if (class_is->block)
11301 : : {
11302 : 37 : gfc_code **c1,*c2;
11303 : 37 : bool swapped;
11304 : : /* Sort CLASS IS blocks by extension level. */
11305 : 36 : do
11306 : : {
11307 : 37 : swapped = false;
11308 : 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11309 : : {
11310 : 61 : c2 = (*c1)->block;
11311 : : /* F03:C817 (check for doubles). */
11312 : 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11313 : 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11314 : : {
11315 : 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11316 : : "statement at %L",
11317 : : &c2->ext.block.case_list->where);
11318 : 1 : return;
11319 : : }
11320 : 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11321 : 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11322 : : {
11323 : : /* Swap. */
11324 : 24 : (*c1)->block = c2->block;
11325 : 24 : c2->block = *c1;
11326 : 24 : *c1 = c2;
11327 : 24 : swapped = true;
11328 : : }
11329 : : }
11330 : : }
11331 : : while (swapped);
11332 : : }
11333 : :
11334 : : /* Generate IF chain. */
11335 : 289 : if_st = gfc_get_code (EXEC_IF);
11336 : 289 : new_st = if_st;
11337 : 608 : for (body = class_is; body; body = body->block)
11338 : : {
11339 : 319 : new_st->block = gfc_get_code (EXEC_IF);
11340 : 319 : new_st = new_st->block;
11341 : : /* Set up IF condition: Call _gfortran_is_extension_of. */
11342 : 319 : new_st->expr1 = gfc_get_expr ();
11343 : 319 : new_st->expr1->expr_type = EXPR_FUNCTION;
11344 : 319 : new_st->expr1->ts.type = BT_LOGICAL;
11345 : 319 : new_st->expr1->ts.kind = 4;
11346 : 319 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11347 : 319 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11348 : 319 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11349 : : /* Set up arguments. */
11350 : 319 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11351 : 319 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11352 : 319 : new_st->expr1->value.function.actual->expr->where = code->loc;
11353 : 319 : new_st->expr1->where = code->loc;
11354 : 319 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11355 : 319 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11356 : 319 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11357 : 319 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11358 : 319 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11359 : 319 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11360 : : /* Set up types in formal arg list. */
11361 : 319 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11362 : 319 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11363 : 319 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11364 : 319 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11365 : :
11366 : 319 : new_st->next = body->next;
11367 : : }
11368 : 289 : if (default_case->next)
11369 : : {
11370 : 110 : new_st->block = gfc_get_code (EXEC_IF);
11371 : 110 : new_st = new_st->block;
11372 : 110 : new_st->next = default_case->next;
11373 : : }
11374 : :
11375 : : /* Replace CLASS DEFAULT code by the IF chain. */
11376 : 289 : default_case->next = if_st;
11377 : : }
11378 : :
11379 : : /* Resolve the internal code. This cannot be done earlier because
11380 : : it requires that the sym->assoc of selectors is set already. */
11381 : 2903 : gfc_current_ns = ns;
11382 : 2903 : gfc_resolve_blocks (code->block, gfc_current_ns);
11383 : 2903 : gfc_current_ns = old_ns;
11384 : :
11385 : 2903 : free (ref);
11386 : : }
11387 : :
11388 : :
11389 : : /* Resolve a SELECT RANK statement. */
11390 : :
11391 : : static void
11392 : 1018 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11393 : : {
11394 : 1018 : gfc_namespace *ns;
11395 : 1018 : gfc_code *body, *new_st, *tail;
11396 : 1018 : gfc_case *c;
11397 : 1018 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11398 : 1018 : char name[2 * GFC_MAX_SYMBOL_LEN];
11399 : 1018 : gfc_symtree *st;
11400 : 1018 : gfc_expr *selector_expr = NULL;
11401 : 1018 : int case_value;
11402 : 1018 : HOST_WIDE_INT charlen = 0;
11403 : :
11404 : 1018 : ns = code->ext.block.ns;
11405 : 1018 : gfc_resolve (ns);
11406 : :
11407 : 1018 : code->op = EXEC_BLOCK;
11408 : 1018 : if (code->expr2)
11409 : : {
11410 : 42 : gfc_association_list* assoc;
11411 : :
11412 : 42 : assoc = gfc_get_association_list ();
11413 : 42 : assoc->st = code->expr1->symtree;
11414 : 42 : assoc->target = gfc_copy_expr (code->expr2);
11415 : 42 : assoc->target->where = code->expr2->where;
11416 : : /* assoc->variable will be set by resolve_assoc_var. */
11417 : :
11418 : 42 : code->ext.block.assoc = assoc;
11419 : 42 : code->expr1->symtree->n.sym->assoc = assoc;
11420 : :
11421 : 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11422 : : }
11423 : : else
11424 : 976 : code->ext.block.assoc = NULL;
11425 : :
11426 : : /* Loop over RANK cases. Note that returning on the errors causes a
11427 : : cascade of further errors because the case blocks do not compile
11428 : : correctly. */
11429 : 3320 : for (body = code->block; body; body = body->block)
11430 : : {
11431 : 2302 : c = body->ext.block.case_list;
11432 : 2302 : if (c->low)
11433 : 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11434 : : else
11435 : : case_value = -2;
11436 : :
11437 : : /* Check for repeated cases. */
11438 : 5836 : for (tail = code->block; tail; tail = tail->block)
11439 : : {
11440 : 5836 : gfc_case *d = tail->ext.block.case_list;
11441 : 5836 : int case_value2;
11442 : :
11443 : 5836 : if (tail == body)
11444 : : break;
11445 : :
11446 : : /* Check F2018: C1153. */
11447 : 3534 : if (!c->low && !d->low)
11448 : 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11449 : : &c->where, &d->where);
11450 : :
11451 : 3534 : if (!c->low || !d->low)
11452 : 1253 : continue;
11453 : :
11454 : : /* Check F2018: C1153. */
11455 : 2281 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11456 : 2281 : if ((case_value == case_value2) && case_value == -1)
11457 : 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11458 : : &c->where, &d->where);
11459 : 2280 : else if (case_value == case_value2)
11460 : 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11461 : : case_value, &c->where, &d->where);
11462 : : }
11463 : :
11464 : 2302 : if (!c->low)
11465 : 919 : continue;
11466 : :
11467 : : /* Check F2018: C1155. */
11468 : 1383 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11469 : 1381 : || gfc_expr_attr (code->expr1).pointer))
11470 : 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11471 : 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11472 : : }
11473 : :
11474 : : /* Add EXEC_SELECT to switch on rank. */
11475 : 1018 : new_st = gfc_get_code (code->op);
11476 : 1018 : new_st->expr1 = code->expr1;
11477 : 1018 : new_st->expr2 = code->expr2;
11478 : 1018 : new_st->block = code->block;
11479 : 1018 : code->expr1 = code->expr2 = NULL;
11480 : 1018 : code->block = NULL;
11481 : 1018 : if (!ns->code)
11482 : 1018 : ns->code = new_st;
11483 : : else
11484 : 0 : ns->code->next = new_st;
11485 : 1018 : code = new_st;
11486 : 1018 : code->op = EXEC_SELECT_RANK;
11487 : :
11488 : 1018 : selector_expr = code->expr1;
11489 : :
11490 : : /* Loop over SELECT RANK cases. */
11491 : 3320 : for (body = code->block; body; body = body->block)
11492 : : {
11493 : 2302 : c = body->ext.block.case_list;
11494 : 2302 : int case_value;
11495 : :
11496 : : /* Pass on the default case. */
11497 : 2302 : if (c->low == NULL)
11498 : 919 : continue;
11499 : :
11500 : : /* Associate temporary to selector. This should only be done
11501 : : when this case is actually true, so build a new ASSOCIATE
11502 : : that does precisely this here (instead of using the
11503 : : 'global' one). */
11504 : 1383 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11505 : 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11506 : 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11507 : :
11508 : 1383 : if (c->ts.type == BT_CLASS)
11509 : 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11510 : 1238 : else if (c->ts.type == BT_DERIVED)
11511 : 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11512 : 1128 : else if (c->ts.type != BT_CHARACTER)
11513 : 569 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11514 : : else
11515 : 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11516 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11517 : :
11518 : 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11519 : 1383 : if (case_value >= 0)
11520 : 1350 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11521 : : else
11522 : 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11523 : :
11524 : 1383 : st = gfc_find_symtree (ns->sym_root, name);
11525 : 1383 : gcc_assert (st->n.sym->assoc);
11526 : :
11527 : 1383 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11528 : 1383 : st->n.sym->assoc->target->where = selector_expr->where;
11529 : :
11530 : 1383 : new_st = gfc_get_code (EXEC_BLOCK);
11531 : 1383 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11532 : 1383 : new_st->ext.block.ns->code = body->next;
11533 : 1383 : body->next = new_st;
11534 : :
11535 : : /* Chain in the new list only if it is marked as dangling. Otherwise
11536 : : there is a CASE label overlap and this is already used. Just ignore,
11537 : : the error is diagnosed elsewhere. */
11538 : 1383 : if (st->n.sym->assoc->dangling)
11539 : : {
11540 : 1381 : new_st->ext.block.assoc = st->n.sym->assoc;
11541 : 1381 : st->n.sym->assoc->dangling = 0;
11542 : : }
11543 : :
11544 : 1383 : resolve_assoc_var (st->n.sym, false);
11545 : : }
11546 : :
11547 : 1018 : gfc_current_ns = ns;
11548 : 1018 : gfc_resolve_blocks (code->block, gfc_current_ns);
11549 : 1018 : gfc_current_ns = old_ns;
11550 : 1018 : }
11551 : :
11552 : :
11553 : : /* Resolve a transfer statement. This is making sure that:
11554 : : -- a derived type being transferred has only non-pointer components
11555 : : -- a derived type being transferred doesn't have private components, unless
11556 : : it's being transferred from the module where the type was defined
11557 : : -- we're not trying to transfer a whole assumed size array. */
11558 : :
11559 : : static void
11560 : 45886 : resolve_transfer (gfc_code *code)
11561 : : {
11562 : 45886 : gfc_symbol *sym, *derived;
11563 : 45886 : gfc_ref *ref;
11564 : 45886 : gfc_expr *exp;
11565 : 45886 : bool write = false;
11566 : 45886 : bool formatted = false;
11567 : 45886 : gfc_dt *dt = code->ext.dt;
11568 : 45886 : gfc_symbol *dtio_sub = NULL;
11569 : :
11570 : 45886 : exp = code->expr1;
11571 : :
11572 : 91778 : while (exp != NULL && exp->expr_type == EXPR_OP
11573 : 46772 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11574 : 6 : exp = exp->value.op.op1;
11575 : :
11576 : 45886 : if (exp && exp->expr_type == EXPR_NULL
11577 : 2 : && code->ext.dt)
11578 : : {
11579 : 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11580 : : &exp->where);
11581 : 2 : return;
11582 : : }
11583 : :
11584 : : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11585 : : && exp->expr_type != EXPR_FUNCTION
11586 : : && exp->expr_type != EXPR_ARRAY
11587 : : && exp->expr_type != EXPR_STRUCTURE))
11588 : : return;
11589 : :
11590 : : /* If we are reading, the variable will be changed. Note that
11591 : : code->ext.dt may be NULL if the TRANSFER is related to
11592 : : an INQUIRE statement -- but in this case, we are not reading, either. */
11593 : 25086 : if (dt && dt->dt_io_kind->value.iokind == M_READ
11594 : 32506 : && !gfc_check_vardef_context (exp, false, false, false,
11595 : 7272 : _("item in READ")))
11596 : : return;
11597 : :
11598 : 25230 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11599 : 25230 : || exp->expr_type == EXPR_FUNCTION
11600 : 20881 : || exp->expr_type == EXPR_ARRAY
11601 : 46111 : ? &exp->ts : &exp->symtree->n.sym->ts;
11602 : :
11603 : : /* Go to actual component transferred. */
11604 : 32879 : for (ref = exp->ref; ref; ref = ref->next)
11605 : 7649 : if (ref->type == REF_COMPONENT)
11606 : 2167 : ts = &ref->u.c.component->ts;
11607 : :
11608 : 25230 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11609 : 25082 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11610 : : {
11611 : 698 : derived = ts->u.derived;
11612 : :
11613 : : /* Determine when to use the formatted DTIO procedure. */
11614 : 698 : if (dt && (dt->format_expr || dt->format_label))
11615 : 623 : formatted = true;
11616 : :
11617 : 698 : write = dt->dt_io_kind->value.iokind == M_WRITE
11618 : 698 : || dt->dt_io_kind->value.iokind == M_PRINT;
11619 : 698 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11620 : :
11621 : 698 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11622 : : {
11623 : 431 : dt->udtio = exp;
11624 : 431 : sym = exp->symtree->n.sym->ns->proc_name;
11625 : : /* Check to see if this is a nested DTIO call, with the
11626 : : dummy as the io-list object. */
11627 : 431 : if (sym && sym == dtio_sub && sym->formal
11628 : 30 : && sym->formal->sym == exp->symtree->n.sym
11629 : 30 : && exp->ref == NULL)
11630 : : {
11631 : 0 : if (!sym->attr.recursive)
11632 : : {
11633 : 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11634 : : sym->name, &sym->declared_at);
11635 : 0 : return;
11636 : : }
11637 : : }
11638 : : }
11639 : : }
11640 : :
11641 : 25230 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11642 : : {
11643 : 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11644 : : "it is processed by a defined input/output procedure",
11645 : : &code->loc);
11646 : 3 : return;
11647 : : }
11648 : :
11649 : 25227 : if (ts->type == BT_DERIVED)
11650 : : {
11651 : : /* Check that transferred derived type doesn't contain POINTER
11652 : : components unless it is processed by a defined input/output
11653 : : procedure". */
11654 : 666 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11655 : : {
11656 : 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11657 : : "components unless it is processed by a defined "
11658 : : "input/output procedure", &code->loc);
11659 : 2 : return;
11660 : : }
11661 : :
11662 : : /* F08:C935. */
11663 : 664 : if (ts->u.derived->attr.proc_pointer_comp)
11664 : : {
11665 : 2 : gfc_error ("Data transfer element at %L cannot have "
11666 : : "procedure pointer components", &code->loc);
11667 : 2 : return;
11668 : : }
11669 : :
11670 : 662 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11671 : : {
11672 : 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11673 : : "components unless it is processed by a defined "
11674 : : "input/output procedure", &code->loc);
11675 : 6 : return;
11676 : : }
11677 : :
11678 : : /* C_PTR and C_FUNPTR have private components which means they cannot
11679 : : be printed. However, if -std=gnu and not -pedantic, allow
11680 : : the component to be printed to help debugging. */
11681 : 656 : if (ts->u.derived->ts.f90_type == BT_VOID)
11682 : : {
11683 : 4 : gfc_error ("Data transfer element at %L "
11684 : : "cannot have PRIVATE components", &code->loc);
11685 : 4 : return;
11686 : : }
11687 : 652 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11688 : : {
11689 : 4 : gfc_error ("Data transfer element at %L cannot have "
11690 : : "PRIVATE components unless it is processed by "
11691 : : "a defined input/output procedure", &code->loc);
11692 : 4 : return;
11693 : : }
11694 : : }
11695 : :
11696 : 25209 : if (exp->expr_type == EXPR_STRUCTURE)
11697 : : return;
11698 : :
11699 : 25164 : if (exp->expr_type == EXPR_ARRAY)
11700 : : return;
11701 : :
11702 : 24788 : sym = exp->symtree->n.sym;
11703 : :
11704 : 24788 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
11705 : 81 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
11706 : : {
11707 : 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
11708 : : "an assumed-size array", &code->loc);
11709 : 1 : return;
11710 : : }
11711 : : }
11712 : :
11713 : :
11714 : : /*********** Toplevel code resolution subroutines ***********/
11715 : :
11716 : : /* Find the set of labels that are reachable from this block. We also
11717 : : record the last statement in each block. */
11718 : :
11719 : : static void
11720 : 664527 : find_reachable_labels (gfc_code *block)
11721 : : {
11722 : 664527 : gfc_code *c;
11723 : :
11724 : 664527 : if (!block)
11725 : : return;
11726 : :
11727 : 417353 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
11728 : :
11729 : : /* Collect labels in this block. We don't keep those corresponding
11730 : : to END {IF|SELECT}, these are checked in resolve_branch by going
11731 : : up through the code_stack. */
11732 : 1530506 : for (c = block; c; c = c->next)
11733 : : {
11734 : 1113153 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
11735 : 3661 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
11736 : : }
11737 : :
11738 : : /* Merge with labels from parent block. */
11739 : 417353 : if (cs_base->prev)
11740 : : {
11741 : 342950 : gcc_assert (cs_base->prev->reachable_labels);
11742 : 342950 : bitmap_ior_into (cs_base->reachable_labels,
11743 : : cs_base->prev->reachable_labels);
11744 : : }
11745 : : }
11746 : :
11747 : : static void
11748 : 136 : resolve_lock_unlock_event (gfc_code *code)
11749 : : {
11750 : 136 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
11751 : 136 : && (code->expr1->ts.type != BT_DERIVED
11752 : 95 : || code->expr1->expr_type != EXPR_VARIABLE
11753 : 95 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11754 : 94 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
11755 : 94 : || code->expr1->rank != 0
11756 : 124 : || (!gfc_is_coarray (code->expr1) &&
11757 : 31 : !gfc_is_coindexed (code->expr1))))
11758 : 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
11759 : 4 : &code->expr1->where);
11760 : 132 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
11761 : 39 : && (code->expr1->ts.type != BT_DERIVED
11762 : 39 : || code->expr1->expr_type != EXPR_VARIABLE
11763 : 39 : || code->expr1->ts.u.derived->from_intmod
11764 : : != INTMOD_ISO_FORTRAN_ENV
11765 : 39 : || code->expr1->ts.u.derived->intmod_sym_id
11766 : : != ISOFORTRAN_EVENT_TYPE
11767 : 39 : || code->expr1->rank != 0))
11768 : 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
11769 : : &code->expr1->where);
11770 : 23 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
11771 : 143 : && !gfc_is_coindexed (code->expr1))
11772 : 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
11773 : 0 : &code->expr1->where);
11774 : 132 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
11775 : 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
11776 : 0 : "coindexed", &code->expr1->where);
11777 : :
11778 : : /* Check STAT. */
11779 : 136 : if (code->expr2
11780 : 38 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
11781 : 38 : || code->expr2->expr_type != EXPR_VARIABLE))
11782 : 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11783 : : &code->expr2->where);
11784 : :
11785 : 136 : if (code->expr2
11786 : 174 : && !gfc_check_vardef_context (code->expr2, false, false, false,
11787 : 38 : _("STAT variable")))
11788 : : return;
11789 : :
11790 : : /* Check ERRMSG. */
11791 : 136 : if (code->expr3
11792 : 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
11793 : 2 : || code->expr3->expr_type != EXPR_VARIABLE))
11794 : 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
11795 : : &code->expr3->where);
11796 : :
11797 : 136 : if (code->expr3
11798 : 138 : && !gfc_check_vardef_context (code->expr3, false, false, false,
11799 : 2 : _("ERRMSG variable")))
11800 : : return;
11801 : :
11802 : : /* Check for LOCK the ACQUIRED_LOCK. */
11803 : 136 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11804 : 16 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
11805 : 16 : || code->expr4->expr_type != EXPR_VARIABLE))
11806 : 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
11807 : : "variable", &code->expr4->where);
11808 : :
11809 : 120 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11810 : 152 : && !gfc_check_vardef_context (code->expr4, false, false, false,
11811 : 16 : _("ACQUIRED_LOCK variable")))
11812 : : return;
11813 : :
11814 : : /* Check for EVENT WAIT the UNTIL_COUNT. */
11815 : 136 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
11816 : : {
11817 : 24 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
11818 : 24 : || code->expr4->rank != 0)
11819 : 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
11820 : 0 : "expression", &code->expr4->where);
11821 : : }
11822 : : }
11823 : :
11824 : : static void
11825 : 195 : resolve_team_argument (gfc_expr *team)
11826 : : {
11827 : 195 : gfc_resolve_expr (team);
11828 : 195 : if (team->rank != 0 || team->ts.type != BT_DERIVED
11829 : 188 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11830 : 188 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
11831 : : {
11832 : 7 : gfc_error ("TEAM argument at %L must be a scalar expression "
11833 : : "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
11834 : : &team->where);
11835 : : }
11836 : 195 : }
11837 : :
11838 : : static void
11839 : 1228 : resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
11840 : : gfc_expr *e)
11841 : : {
11842 : 1228 : gfc_resolve_expr (e);
11843 : 1228 : if (e
11844 : 139 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
11845 : 124 : || e->expr_type != EXPR_VARIABLE))
11846 : 15 : gfc_error ("%s argument at %L must be a scalar %s variable of at least "
11847 : : "kind %d", name, &e->where, gfc_basic_typename (exp_type),
11848 : : exp_kind);
11849 : 1228 : }
11850 : :
11851 : : void
11852 : 614 : gfc_resolve_sync_stat (struct sync_stat *sync_stat)
11853 : : {
11854 : 614 : resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
11855 : 614 : resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
11856 : : gfc_default_character_kind,
11857 : : sync_stat->errmsg);
11858 : 614 : }
11859 : :
11860 : : static void
11861 : 214 : resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
11862 : : gfc_expr *e)
11863 : : {
11864 : 214 : gfc_resolve_expr (e);
11865 : 214 : if (e
11866 : 140 : && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
11867 : 3 : gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
11868 : : name, &e->where, gfc_basic_typename (exp_type), exp_kind);
11869 : 214 : }
11870 : :
11871 : : static void
11872 : 107 : resolve_form_team (gfc_code *code)
11873 : : {
11874 : 107 : resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
11875 : : code->expr1);
11876 : 107 : resolve_team_argument (code->expr2);
11877 : 107 : resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
11878 : : code->expr3);
11879 : 107 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11880 : 107 : }
11881 : :
11882 : : static void resolve_block_construct (gfc_code *);
11883 : :
11884 : : static void
11885 : 66 : resolve_change_team (gfc_code *code)
11886 : : {
11887 : 66 : resolve_team_argument (code->expr1);
11888 : 66 : gfc_resolve_sync_stat (&code->ext.block.sync_stat);
11889 : 132 : resolve_block_construct (code);
11890 : : /* Map the coarray bounds as selected. */
11891 : 68 : for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
11892 : 2 : if (a->ar)
11893 : : {
11894 : 2 : gfc_array_spec *src = a->ar->as, *dst;
11895 : 2 : if (a->st->n.sym->ts.type == BT_CLASS)
11896 : 0 : dst = CLASS_DATA (a->st->n.sym)->as;
11897 : : else
11898 : 2 : dst = a->st->n.sym->as;
11899 : 2 : dst->corank = src->corank;
11900 : 2 : dst->cotype = src->cotype;
11901 : 4 : for (int i = 0; i < src->corank; ++i)
11902 : : {
11903 : 2 : dst->lower[dst->rank + i] = src->lower[i];
11904 : 2 : dst->upper[dst->rank + i] = src->upper[i];
11905 : 2 : src->lower[i] = src->upper[i] = nullptr;
11906 : : }
11907 : 2 : gfc_free_array_spec (src);
11908 : 2 : free (a->ar);
11909 : 2 : a->ar = nullptr;
11910 : 2 : dst->resolved = false;
11911 : 2 : gfc_resolve_array_spec (dst, 0);
11912 : : }
11913 : 66 : }
11914 : :
11915 : : static void
11916 : 22 : resolve_sync_team (gfc_code *code)
11917 : : {
11918 : 22 : resolve_team_argument (code->expr1);
11919 : 22 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11920 : 22 : }
11921 : :
11922 : : static void
11923 : 64 : resolve_end_team (gfc_code *code)
11924 : : {
11925 : 64 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11926 : 64 : }
11927 : :
11928 : : static void
11929 : 50 : resolve_critical (gfc_code *code)
11930 : : {
11931 : 50 : gfc_symtree *symtree;
11932 : 50 : gfc_symbol *lock_type;
11933 : 50 : char name[GFC_MAX_SYMBOL_LEN];
11934 : 50 : static int serial = 0;
11935 : :
11936 : 50 : gfc_resolve_sync_stat (&code->ext.sync_stat);
11937 : :
11938 : 50 : if (flag_coarray != GFC_FCOARRAY_LIB)
11939 : 30 : return;
11940 : :
11941 : 20 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11942 : : GFC_PREFIX ("lock_type"));
11943 : 20 : if (symtree)
11944 : 10 : lock_type = symtree->n.sym;
11945 : : else
11946 : : {
11947 : 10 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
11948 : : false) != 0)
11949 : 0 : gcc_unreachable ();
11950 : 10 : lock_type = symtree->n.sym;
11951 : 10 : lock_type->attr.flavor = FL_DERIVED;
11952 : 10 : lock_type->attr.zero_comp = 1;
11953 : 10 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
11954 : 10 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
11955 : : }
11956 : :
11957 : 20 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
11958 : 20 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
11959 : 0 : gcc_unreachable ();
11960 : :
11961 : 20 : code->resolved_sym = symtree->n.sym;
11962 : 20 : symtree->n.sym->attr.flavor = FL_VARIABLE;
11963 : 20 : symtree->n.sym->attr.referenced = 1;
11964 : 20 : symtree->n.sym->attr.artificial = 1;
11965 : 20 : symtree->n.sym->attr.codimension = 1;
11966 : 20 : symtree->n.sym->ts.type = BT_DERIVED;
11967 : 20 : symtree->n.sym->ts.u.derived = lock_type;
11968 : 20 : symtree->n.sym->as = gfc_get_array_spec ();
11969 : 20 : symtree->n.sym->as->corank = 1;
11970 : 20 : symtree->n.sym->as->type = AS_EXPLICIT;
11971 : 20 : symtree->n.sym->as->cotype = AS_EXPLICIT;
11972 : 20 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
11973 : : NULL, 1);
11974 : 20 : gfc_commit_symbols();
11975 : : }
11976 : :
11977 : :
11978 : : static void
11979 : 747 : resolve_sync (gfc_code *code)
11980 : : {
11981 : : /* Check imageset. The * case matches expr1 == NULL. */
11982 : 747 : if (code->expr1)
11983 : : {
11984 : 48 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
11985 : 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
11986 : : "INTEGER expression", &code->expr1->where);
11987 : 48 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
11988 : 23 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
11989 : 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
11990 : : &code->expr1->where);
11991 : 47 : else if (code->expr1->expr_type == EXPR_ARRAY
11992 : 47 : && gfc_simplify_expr (code->expr1, 0))
11993 : : {
11994 : 18 : gfc_constructor *cons;
11995 : 18 : cons = gfc_constructor_first (code->expr1->value.constructor);
11996 : 54 : for (; cons; cons = gfc_constructor_next (cons))
11997 : 18 : if (cons->expr->expr_type == EXPR_CONSTANT
11998 : 18 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
11999 : 0 : gfc_error ("Imageset argument at %L must between 1 and "
12000 : : "num_images()", &cons->expr->where);
12001 : : }
12002 : : }
12003 : :
12004 : : /* Check STAT. */
12005 : 747 : gfc_resolve_expr (code->expr2);
12006 : 747 : if (code->expr2)
12007 : : {
12008 : 84 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
12009 : 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
12010 : : &code->expr2->where);
12011 : : else
12012 : 83 : gfc_check_vardef_context (code->expr2, false, false, false,
12013 : 83 : _("STAT variable"));
12014 : : }
12015 : :
12016 : : /* Check ERRMSG. */
12017 : 747 : gfc_resolve_expr (code->expr3);
12018 : 747 : if (code->expr3)
12019 : : {
12020 : 75 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
12021 : 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
12022 : : &code->expr3->where);
12023 : : else
12024 : 71 : gfc_check_vardef_context (code->expr3, false, false, false,
12025 : 71 : _("ERRMSG variable"));
12026 : : }
12027 : 747 : }
12028 : :
12029 : :
12030 : : /* Given a branch to a label, see if the branch is conforming.
12031 : : The code node describes where the branch is located. */
12032 : :
12033 : : static void
12034 : 107298 : resolve_branch (gfc_st_label *label, gfc_code *code)
12035 : : {
12036 : 107298 : code_stack *stack;
12037 : :
12038 : 107298 : if (label == NULL)
12039 : : return;
12040 : :
12041 : : /* Step one: is this a valid branching target? */
12042 : :
12043 : 2460 : if (label->defined == ST_LABEL_UNKNOWN)
12044 : : {
12045 : 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
12046 : : &code->loc);
12047 : 4 : return;
12048 : : }
12049 : :
12050 : 2456 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
12051 : : {
12052 : 4 : gfc_error ("Statement at %L is not a valid branch target statement "
12053 : : "for the branch statement at %L", &label->where, &code->loc);
12054 : 4 : return;
12055 : : }
12056 : :
12057 : : /* Step two: make sure this branch is not a branch to itself ;-) */
12058 : :
12059 : 2452 : if (code->here == label)
12060 : : {
12061 : 0 : gfc_warning (0, "Branch at %L may result in an infinite loop",
12062 : : &code->loc);
12063 : 0 : return;
12064 : : }
12065 : :
12066 : : /* Step three: See if the label is in the same block as the
12067 : : branching statement. The hard work has been done by setting up
12068 : : the bitmap reachable_labels. */
12069 : :
12070 : 2452 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
12071 : : {
12072 : : /* Check now whether there is a CRITICAL construct; if so, check
12073 : : whether the label is still visible outside of the CRITICAL block,
12074 : : which is invalid. */
12075 : 6267 : for (stack = cs_base; stack; stack = stack->prev)
12076 : : {
12077 : 3883 : if (stack->current->op == EXEC_CRITICAL
12078 : 3883 : && bitmap_bit_p (stack->reachable_labels, label->value))
12079 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
12080 : : "label at %L", &code->loc, &label->where);
12081 : 3881 : else if (stack->current->op == EXEC_DO_CONCURRENT
12082 : 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12083 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
12084 : : "for label at %L", &code->loc, &label->where);
12085 : 3881 : else if (stack->current->op == EXEC_CHANGE_TEAM
12086 : 3881 : && bitmap_bit_p (stack->reachable_labels, label->value))
12087 : 1 : gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
12088 : : "for label at %L", &code->loc, &label->where);
12089 : : }
12090 : :
12091 : : return;
12092 : : }
12093 : :
12094 : : /* Step four: If we haven't found the label in the bitmap, it may
12095 : : still be the label of the END of the enclosing block, in which
12096 : : case we find it by going up the code_stack. */
12097 : :
12098 : 167 : for (stack = cs_base; stack; stack = stack->prev)
12099 : : {
12100 : 131 : if (stack->current->next && stack->current->next->here == label)
12101 : : break;
12102 : 101 : if (stack->current->op == EXEC_CRITICAL)
12103 : : {
12104 : : /* Note: A label at END CRITICAL does not leave the CRITICAL
12105 : : construct as END CRITICAL is still part of it. */
12106 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
12107 : : " at %L", &code->loc, &label->where);
12108 : 2 : return;
12109 : : }
12110 : 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
12111 : : {
12112 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
12113 : : "label at %L", &code->loc, &label->where);
12114 : 0 : return;
12115 : : }
12116 : : }
12117 : :
12118 : 66 : if (stack)
12119 : : {
12120 : 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
12121 : : return;
12122 : : }
12123 : :
12124 : : /* The label is not in an enclosing block, so illegal. This was
12125 : : allowed in Fortran 66, so we allow it as extension. No
12126 : : further checks are necessary in this case. */
12127 : 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
12128 : : "as the GOTO statement at %L", &label->where,
12129 : : &code->loc);
12130 : 36 : return;
12131 : : }
12132 : :
12133 : :
12134 : : /* Check whether EXPR1 has the same shape as EXPR2. */
12135 : :
12136 : : static bool
12137 : 1461 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
12138 : : {
12139 : 1461 : mpz_t shape[GFC_MAX_DIMENSIONS];
12140 : 1461 : mpz_t shape2[GFC_MAX_DIMENSIONS];
12141 : 1461 : bool result = false;
12142 : 1461 : int i;
12143 : :
12144 : : /* Compare the rank. */
12145 : 1461 : if (expr1->rank != expr2->rank)
12146 : : return result;
12147 : :
12148 : : /* Compare the size of each dimension. */
12149 : 2795 : for (i=0; i<expr1->rank; i++)
12150 : : {
12151 : 1484 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
12152 : 150 : goto ignore;
12153 : :
12154 : 1334 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
12155 : 0 : goto ignore;
12156 : :
12157 : 1334 : if (mpz_cmp (shape[i], shape2[i]))
12158 : 0 : goto over;
12159 : : }
12160 : :
12161 : : /* When either of the two expression is an assumed size array, we
12162 : : ignore the comparison of dimension sizes. */
12163 : 1311 : ignore:
12164 : : result = true;
12165 : :
12166 : 1461 : over:
12167 : 1461 : gfc_clear_shape (shape, i);
12168 : 1461 : gfc_clear_shape (shape2, i);
12169 : 1461 : return result;
12170 : : }
12171 : :
12172 : :
12173 : : /* Check whether a WHERE assignment target or a WHERE mask expression
12174 : : has the same shape as the outmost WHERE mask expression. */
12175 : :
12176 : : static void
12177 : 506 : resolve_where (gfc_code *code, gfc_expr *mask)
12178 : : {
12179 : 506 : gfc_code *cblock;
12180 : 506 : gfc_code *cnext;
12181 : 506 : gfc_expr *e = NULL;
12182 : :
12183 : 506 : cblock = code->block;
12184 : :
12185 : : /* Store the first WHERE mask-expr of the WHERE statement or construct.
12186 : : In case of nested WHERE, only the outmost one is stored. */
12187 : 506 : if (mask == NULL) /* outmost WHERE */
12188 : 450 : e = cblock->expr1;
12189 : : else /* inner WHERE */
12190 : 506 : e = mask;
12191 : :
12192 : 1381 : while (cblock)
12193 : : {
12194 : 875 : if (cblock->expr1)
12195 : : {
12196 : : /* Check if the mask-expr has a consistent shape with the
12197 : : outmost WHERE mask-expr. */
12198 : 711 : if (!resolve_where_shape (cblock->expr1, e))
12199 : 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
12200 : 0 : &cblock->expr1->where);
12201 : : }
12202 : :
12203 : : /* the assignment statement of a WHERE statement, or the first
12204 : : statement in where-body-construct of a WHERE construct */
12205 : 875 : cnext = cblock->next;
12206 : 1727 : while (cnext)
12207 : : {
12208 : 852 : switch (cnext->op)
12209 : : {
12210 : : /* WHERE assignment statement */
12211 : 750 : case EXEC_ASSIGN:
12212 : :
12213 : : /* Check shape consistent for WHERE assignment target. */
12214 : 750 : if (e && !resolve_where_shape (cnext->expr1, e))
12215 : 0 : gfc_error ("WHERE assignment target at %L has "
12216 : 0 : "inconsistent shape", &cnext->expr1->where);
12217 : :
12218 : 750 : if (cnext->op == EXEC_ASSIGN
12219 : 750 : && gfc_may_be_finalized (cnext->expr1->ts))
12220 : 0 : cnext->expr1->must_finalize = 1;
12221 : :
12222 : : break;
12223 : :
12224 : :
12225 : 46 : case EXEC_ASSIGN_CALL:
12226 : 46 : resolve_call (cnext);
12227 : 46 : if (!cnext->resolved_sym->attr.elemental)
12228 : 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12229 : 2 : &cnext->ext.actual->expr->where);
12230 : : break;
12231 : :
12232 : : /* WHERE or WHERE construct is part of a where-body-construct */
12233 : 56 : case EXEC_WHERE:
12234 : 56 : resolve_where (cnext, e);
12235 : 56 : break;
12236 : :
12237 : 0 : default:
12238 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12239 : : &cnext->loc);
12240 : : }
12241 : : /* the next statement within the same where-body-construct */
12242 : 852 : cnext = cnext->next;
12243 : : }
12244 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12245 : 875 : cblock = cblock->block;
12246 : : }
12247 : 506 : }
12248 : :
12249 : :
12250 : : /* Resolve assignment in FORALL construct.
12251 : : NVAR is the number of FORALL index variables, and VAR_EXPR records the
12252 : : FORALL index variables. */
12253 : :
12254 : : static void
12255 : 2372 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
12256 : : {
12257 : 2372 : int n;
12258 : 2372 : gfc_symbol *forall_index;
12259 : :
12260 : 6762 : for (n = 0; n < nvar; n++)
12261 : : {
12262 : 4390 : forall_index = var_expr[n]->symtree->n.sym;
12263 : :
12264 : : /* Check whether the assignment target is one of the FORALL index
12265 : : variable. */
12266 : 4390 : if ((code->expr1->expr_type == EXPR_VARIABLE)
12267 : 4390 : && (code->expr1->symtree->n.sym == forall_index))
12268 : 0 : gfc_error ("Assignment to a FORALL index variable at %L",
12269 : : &code->expr1->where);
12270 : : else
12271 : : {
12272 : : /* If one of the FORALL index variables doesn't appear in the
12273 : : assignment variable, then there could be a many-to-one
12274 : : assignment. Emit a warning rather than an error because the
12275 : : mask could be resolving this problem.
12276 : : DO NOT emit this warning for DO CONCURRENT - reduction-like
12277 : : many-to-one assignments are semantically valid (formalized with
12278 : : the REDUCE locality-spec in Fortran 2023). */
12279 : 4390 : if (!find_forall_index (code->expr1, forall_index, 0)
12280 : 4390 : && !gfc_do_concurrent_flag)
12281 : 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
12282 : : "left side of the assignment at %L and so might "
12283 : : "cause multiple assignment to this object",
12284 : 0 : var_expr[n]->symtree->name, &code->expr1->where);
12285 : : }
12286 : : }
12287 : 2372 : }
12288 : :
12289 : :
12290 : : /* Resolve WHERE statement in FORALL construct. */
12291 : :
12292 : : static void
12293 : 46 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
12294 : : gfc_expr **var_expr)
12295 : : {
12296 : 46 : gfc_code *cblock;
12297 : 46 : gfc_code *cnext;
12298 : :
12299 : 46 : cblock = code->block;
12300 : 111 : while (cblock)
12301 : : {
12302 : : /* the assignment statement of a WHERE statement, or the first
12303 : : statement in where-body-construct of a WHERE construct */
12304 : 65 : cnext = cblock->next;
12305 : 130 : while (cnext)
12306 : : {
12307 : 65 : switch (cnext->op)
12308 : : {
12309 : : /* WHERE assignment statement */
12310 : 65 : case EXEC_ASSIGN:
12311 : 65 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
12312 : :
12313 : 65 : if (cnext->op == EXEC_ASSIGN
12314 : 65 : && gfc_may_be_finalized (cnext->expr1->ts))
12315 : 0 : cnext->expr1->must_finalize = 1;
12316 : :
12317 : : break;
12318 : :
12319 : : /* WHERE operator assignment statement */
12320 : 0 : case EXEC_ASSIGN_CALL:
12321 : 0 : resolve_call (cnext);
12322 : 0 : if (!cnext->resolved_sym->attr.elemental)
12323 : 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12324 : 0 : &cnext->ext.actual->expr->where);
12325 : : break;
12326 : :
12327 : : /* WHERE or WHERE construct is part of a where-body-construct */
12328 : 0 : case EXEC_WHERE:
12329 : 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12330 : 0 : break;
12331 : :
12332 : 0 : default:
12333 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12334 : : &cnext->loc);
12335 : : }
12336 : : /* the next statement within the same where-body-construct */
12337 : 65 : cnext = cnext->next;
12338 : : }
12339 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12340 : 65 : cblock = cblock->block;
12341 : : }
12342 : 46 : }
12343 : :
12344 : :
12345 : : /* Traverse the FORALL body to check whether the following errors exist:
12346 : : 1. For assignment, check if a many-to-one assignment happens.
12347 : : 2. For WHERE statement, check the WHERE body to see if there is any
12348 : : many-to-one assignment. */
12349 : :
12350 : : static void
12351 : 2190 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12352 : : {
12353 : 2190 : gfc_code *c;
12354 : :
12355 : 2190 : c = code->block->next;
12356 : 4807 : while (c)
12357 : : {
12358 : 2617 : switch (c->op)
12359 : : {
12360 : 2307 : case EXEC_ASSIGN:
12361 : 2307 : case EXEC_POINTER_ASSIGN:
12362 : 2307 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12363 : :
12364 : 2307 : if (c->op == EXEC_ASSIGN
12365 : 2307 : && gfc_may_be_finalized (c->expr1->ts))
12366 : 0 : c->expr1->must_finalize = 1;
12367 : :
12368 : : break;
12369 : :
12370 : 0 : case EXEC_ASSIGN_CALL:
12371 : 0 : resolve_call (c);
12372 : 0 : break;
12373 : :
12374 : : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12375 : : there is no need to handle it here. */
12376 : : case EXEC_FORALL:
12377 : : break;
12378 : 46 : case EXEC_WHERE:
12379 : 46 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12380 : 46 : break;
12381 : : default:
12382 : : break;
12383 : : }
12384 : : /* The next statement in the FORALL body. */
12385 : 2617 : c = c->next;
12386 : : }
12387 : 2190 : }
12388 : :
12389 : :
12390 : : /* Counts the number of iterators needed inside a forall construct, including
12391 : : nested forall constructs. This is used to allocate the needed memory
12392 : : in gfc_resolve_forall. */
12393 : :
12394 : : static int
12395 : 2190 : gfc_count_forall_iterators (gfc_code *code)
12396 : : {
12397 : 2190 : int max_iters, sub_iters, current_iters;
12398 : 2190 : gfc_forall_iterator *fa;
12399 : :
12400 : 2190 : gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
12401 : 2190 : max_iters = 0;
12402 : 2190 : current_iters = 0;
12403 : :
12404 : 6295 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12405 : 4105 : current_iters ++;
12406 : :
12407 : 2190 : code = code->block->next;
12408 : :
12409 : 4807 : while (code)
12410 : : {
12411 : 2617 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
12412 : : {
12413 : 88 : sub_iters = gfc_count_forall_iterators (code);
12414 : 88 : if (sub_iters > max_iters)
12415 : 2617 : max_iters = sub_iters;
12416 : : }
12417 : 2617 : code = code->next;
12418 : : }
12419 : :
12420 : 2190 : return current_iters + max_iters;
12421 : : }
12422 : :
12423 : :
12424 : : /* Given a FORALL construct.
12425 : : 1) Resolve the FORALL iterator.
12426 : : 2) Check for shadow index-name(s) and update code block.
12427 : : 3) call gfc_resolve_forall_body to resolve the FORALL body. */
12428 : :
12429 : : /* Custom recursive expression walker that replaces symbols.
12430 : : This ensures we visit ALL expressions including those in array subscripts. */
12431 : :
12432 : : static void
12433 : 114 : replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st)
12434 : : {
12435 : 144 : if (!expr)
12436 : : return;
12437 : :
12438 : : /* Check if this is a variable reference to replace */
12439 : 108 : if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
12440 : : {
12441 : 18 : expr->symtree = new_st;
12442 : 18 : expr->ts = new_st->n.sym->ts;
12443 : : }
12444 : :
12445 : : /* Walk through reference chain (array subscripts, substrings, etc.) */
12446 : 108 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
12447 : : {
12448 : 0 : if (ref->type == REF_ARRAY)
12449 : : {
12450 : : gfc_array_ref *ar = &ref->u.ar;
12451 : 0 : for (int i = 0; i < ar->dimen; i++)
12452 : : {
12453 : 0 : replace_in_expr_recursive (ar->start[i], old_sym, new_st);
12454 : 0 : replace_in_expr_recursive (ar->end[i], old_sym, new_st);
12455 : 0 : replace_in_expr_recursive (ar->stride[i], old_sym, new_st);
12456 : : }
12457 : : }
12458 : 0 : else if (ref->type == REF_SUBSTRING)
12459 : : {
12460 : 0 : replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st);
12461 : 0 : replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st);
12462 : : }
12463 : : }
12464 : :
12465 : : /* Walk through sub-expressions based on expression type */
12466 : 108 : switch (expr->expr_type)
12467 : : {
12468 : 30 : case EXPR_OP:
12469 : 30 : replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st);
12470 : 30 : replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st);
12471 : 30 : break;
12472 : :
12473 : 6 : case EXPR_FUNCTION:
12474 : 18 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
12475 : 12 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12476 : : break;
12477 : :
12478 : 0 : case EXPR_ARRAY:
12479 : 0 : case EXPR_STRUCTURE:
12480 : 0 : for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
12481 : 0 : c; c = gfc_constructor_next (c))
12482 : : {
12483 : 0 : replace_in_expr_recursive (c->expr, old_sym, new_st);
12484 : 0 : if (c->iterator)
12485 : : {
12486 : 0 : replace_in_expr_recursive (c->iterator->start, old_sym, new_st);
12487 : 0 : replace_in_expr_recursive (c->iterator->end, old_sym, new_st);
12488 : 0 : replace_in_expr_recursive (c->iterator->step, old_sym, new_st);
12489 : : }
12490 : : }
12491 : : break;
12492 : :
12493 : : default:
12494 : : break;
12495 : : }
12496 : : }
12497 : :
12498 : :
12499 : : /* Walk code tree and replace all variable references */
12500 : :
12501 : : static void
12502 : 18 : replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st)
12503 : : {
12504 : 18 : if (!code)
12505 : : return;
12506 : :
12507 : 36 : for (gfc_code *c = code; c; c = c->next)
12508 : : {
12509 : : /* Replace in expressions associated with this code node */
12510 : 18 : replace_in_expr_recursive (c->expr1, old_sym, new_st);
12511 : 18 : replace_in_expr_recursive (c->expr2, old_sym, new_st);
12512 : 18 : replace_in_expr_recursive (c->expr3, old_sym, new_st);
12513 : 18 : replace_in_expr_recursive (c->expr4, old_sym, new_st);
12514 : :
12515 : : /* Handle special code types with additional expressions */
12516 : 18 : switch (c->op)
12517 : : {
12518 : 0 : case EXEC_DO:
12519 : 0 : if (c->ext.iterator)
12520 : : {
12521 : 0 : replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st);
12522 : 0 : replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
12523 : 0 : replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st);
12524 : : }
12525 : : break;
12526 : :
12527 : 0 : case EXEC_CALL:
12528 : 0 : case EXEC_ASSIGN_CALL:
12529 : 0 : for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
12530 : 0 : replace_in_expr_recursive (a->expr, old_sym, new_st);
12531 : : break;
12532 : :
12533 : 0 : case EXEC_SELECT:
12534 : 0 : for (gfc_code *b = c->block; b; b = b->block)
12535 : : {
12536 : 0 : for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
12537 : : {
12538 : 0 : replace_in_expr_recursive (cp->low, old_sym, new_st);
12539 : 0 : replace_in_expr_recursive (cp->high, old_sym, new_st);
12540 : : }
12541 : 0 : replace_in_code_recursive (b->next, old_sym, new_st);
12542 : : }
12543 : : break;
12544 : :
12545 : 0 : case EXEC_FORALL:
12546 : 0 : case EXEC_DO_CONCURRENT:
12547 : 0 : for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
12548 : : {
12549 : 0 : replace_in_expr_recursive (fa->start, old_sym, new_st);
12550 : 0 : replace_in_expr_recursive (fa->end, old_sym, new_st);
12551 : 0 : replace_in_expr_recursive (fa->stride, old_sym, new_st);
12552 : : }
12553 : : /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
12554 : : they'll be handled separately */
12555 : : break;
12556 : :
12557 : : default:
12558 : : break;
12559 : : }
12560 : :
12561 : : /* Recurse into blocks */
12562 : 18 : if (c->block)
12563 : 0 : replace_in_code_recursive (c->block->next, old_sym, new_st);
12564 : : }
12565 : : }
12566 : :
12567 : :
12568 : : /* Replace all references to outer_sym with shadow_st in the given code. */
12569 : :
12570 : : static void
12571 : 18 : gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
12572 : : gfc_symtree *shadow_st)
12573 : : {
12574 : : /* Use custom recursive walker to ensure we visit ALL expressions */
12575 : 0 : replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
12576 : 18 : }
12577 : :
12578 : :
12579 : : static void
12580 : 2190 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12581 : : {
12582 : 2190 : static gfc_expr **var_expr;
12583 : 2190 : static int total_var = 0;
12584 : 2190 : static int nvar = 0;
12585 : 2190 : int i, old_nvar, tmp;
12586 : 2190 : gfc_forall_iterator *fa;
12587 : 2190 : bool shadow = false;
12588 : :
12589 : 2190 : old_nvar = nvar;
12590 : :
12591 : : /* Only warn about obsolescent FORALL, not DO CONCURRENT */
12592 : 2190 : if (code->op == EXEC_FORALL
12593 : 2190 : && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12594 : : return;
12595 : :
12596 : : /* Start to resolve a FORALL construct */
12597 : : /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
12598 : : forall_save==0 means we're not nested in a FORALL in the current scope,
12599 : : but nvar==0 ensures we're not nested in a parent scope either (prevents
12600 : : double allocation when FORALL is nested inside DO CONCURRENT). */
12601 : 2190 : if (forall_save == 0 && nvar == 0)
12602 : : {
12603 : : /* Count the total number of FORALL indices in the nested FORALL
12604 : : construct in order to allocate the VAR_EXPR with proper size. */
12605 : 2102 : total_var = gfc_count_forall_iterators (code);
12606 : :
12607 : : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12608 : 2102 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12609 : : }
12610 : :
12611 : : /* The information about FORALL iterator, including FORALL indices start,
12612 : : end and stride. An outer FORALL indice cannot appear in start, end or
12613 : : stride. Check for a shadow index-name. */
12614 : 6295 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12615 : : {
12616 : : /* Fortran 2008: C738 (R753). */
12617 : 4105 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12618 : : {
12619 : 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12620 : : "of type integer", &fa->var->where);
12621 : 2 : continue;
12622 : : }
12623 : :
12624 : : /* Check if any outer FORALL index name is the same as the current
12625 : : one. Skip this check if the iterator is a shadow variable (from
12626 : : DO CONCURRENT type spec) which may not have a symtree yet. */
12627 : 7105 : for (i = 0; i < nvar; i++)
12628 : : {
12629 : 3002 : if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
12630 : 3002 : && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12631 : 0 : gfc_error ("An outer FORALL construct already has an index "
12632 : : "with this name %L", &fa->var->where);
12633 : : }
12634 : :
12635 : 4103 : if (fa->shadow)
12636 : 18 : shadow = true;
12637 : :
12638 : : /* Record the current FORALL index. */
12639 : 4103 : var_expr[nvar] = gfc_copy_expr (fa->var);
12640 : :
12641 : 4103 : nvar++;
12642 : :
12643 : : /* No memory leak. */
12644 : 4103 : gcc_assert (nvar <= total_var);
12645 : : }
12646 : :
12647 : : /* Need to walk the code and replace references to the index-name with
12648 : : references to the shadow index-name. This must be done BEFORE resolving
12649 : : the body so that resolution uses the correct shadow variables. */
12650 : 2190 : if (shadow)
12651 : : {
12652 : : /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */
12653 : 42 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
12654 : : {
12655 : 24 : if (fa->shadow)
12656 : : {
12657 : 18 : gfc_symtree *shadow_st;
12658 : 18 : const char *shadow_name_str;
12659 : 18 : char *outer_name;
12660 : :
12661 : : /* fa->var now points to the shadow variable "_name". */
12662 : 18 : shadow_name_str = fa->var->symtree->name;
12663 : 18 : shadow_st = fa->var->symtree;
12664 : :
12665 : 18 : if (shadow_name_str[0] != '_')
12666 : 0 : gfc_internal_error ("Expected shadow variable name to start with _");
12667 : :
12668 : 18 : outer_name = (char *) alloca (strlen (shadow_name_str));
12669 : 18 : strcpy (outer_name, shadow_name_str + 1);
12670 : :
12671 : : /* Find the ITERATOR symbol in the current namespace.
12672 : : This is the local DO CONCURRENT variable that body expressions reference. */
12673 : 18 : gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name);
12674 : :
12675 : 18 : if (!iter_st)
12676 : : /* No iterator variable found - this shouldn't happen */
12677 : 0 : continue;
12678 : :
12679 : 18 : gfc_symbol *iter_sym = iter_st->n.sym;
12680 : :
12681 : : /* Walk the FORALL/DO CONCURRENT body and replace all references. */
12682 : 18 : if (code->block && code->block->next)
12683 : 18 : gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st);
12684 : : }
12685 : : }
12686 : : }
12687 : :
12688 : : /* Resolve the FORALL body. */
12689 : 2190 : gfc_resolve_forall_body (code, nvar, var_expr);
12690 : :
12691 : : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
12692 : 2190 : gfc_resolve_blocks (code->block, ns);
12693 : :
12694 : 2190 : tmp = nvar;
12695 : 2190 : nvar = old_nvar;
12696 : : /* Free only the VAR_EXPRs allocated in this frame. */
12697 : 6293 : for (i = nvar; i < tmp; i++)
12698 : 4103 : gfc_free_expr (var_expr[i]);
12699 : :
12700 : 2190 : if (nvar == 0)
12701 : : {
12702 : : /* We are in the outermost FORALL construct. */
12703 : 2102 : gcc_assert (forall_save == 0);
12704 : :
12705 : : /* VAR_EXPR is not needed any more. */
12706 : 2102 : free (var_expr);
12707 : 2102 : total_var = 0;
12708 : : }
12709 : : }
12710 : :
12711 : :
12712 : : /* Resolve a BLOCK construct statement. */
12713 : :
12714 : : static void
12715 : 7782 : resolve_block_construct (gfc_code* code)
12716 : : {
12717 : 7782 : gfc_namespace *ns = code->ext.block.ns;
12718 : :
12719 : : /* For an ASSOCIATE block, the associations (and their targets) will be
12720 : : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
12721 : : namespace. */
12722 : 7782 : gfc_resolve (ns);
12723 : 0 : }
12724 : :
12725 : :
12726 : : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
12727 : : DO code nodes. */
12728 : :
12729 : : void
12730 : 325944 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
12731 : : {
12732 : 325944 : bool t;
12733 : :
12734 : 663134 : for (; b; b = b->block)
12735 : : {
12736 : 337190 : t = gfc_resolve_expr (b->expr1);
12737 : 337190 : if (!gfc_resolve_expr (b->expr2))
12738 : 0 : t = false;
12739 : :
12740 : 337190 : switch (b->op)
12741 : : {
12742 : 232700 : case EXEC_IF:
12743 : 232700 : if (t && b->expr1 != NULL
12744 : 228560 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
12745 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12746 : : &b->expr1->where);
12747 : : break;
12748 : :
12749 : 761 : case EXEC_WHERE:
12750 : 761 : if (t
12751 : 761 : && b->expr1 != NULL
12752 : 628 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
12753 : 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
12754 : : &b->expr1->where);
12755 : : break;
12756 : :
12757 : 76 : case EXEC_GOTO:
12758 : 76 : resolve_branch (b->label1, b);
12759 : 76 : break;
12760 : :
12761 : 0 : case EXEC_BLOCK:
12762 : 0 : resolve_block_construct (b);
12763 : 0 : break;
12764 : :
12765 : : case EXEC_SELECT:
12766 : : case EXEC_SELECT_TYPE:
12767 : : case EXEC_SELECT_RANK:
12768 : : case EXEC_FORALL:
12769 : : case EXEC_DO:
12770 : : case EXEC_DO_WHILE:
12771 : : case EXEC_DO_CONCURRENT:
12772 : : case EXEC_CRITICAL:
12773 : : case EXEC_READ:
12774 : : case EXEC_WRITE:
12775 : : case EXEC_IOLENGTH:
12776 : : case EXEC_WAIT:
12777 : : break;
12778 : :
12779 : 2697 : case EXEC_OMP_ATOMIC:
12780 : 2697 : case EXEC_OACC_ATOMIC:
12781 : 2697 : {
12782 : : /* Verify this before calling gfc_resolve_code, which might
12783 : : change it. */
12784 : 2697 : gcc_assert (b->op == EXEC_OMP_ATOMIC
12785 : : || (b->next && b->next->op == EXEC_ASSIGN));
12786 : : }
12787 : : break;
12788 : :
12789 : : case EXEC_OACC_PARALLEL_LOOP:
12790 : : case EXEC_OACC_PARALLEL:
12791 : : case EXEC_OACC_KERNELS_LOOP:
12792 : : case EXEC_OACC_KERNELS:
12793 : : case EXEC_OACC_SERIAL_LOOP:
12794 : : case EXEC_OACC_SERIAL:
12795 : : case EXEC_OACC_DATA:
12796 : : case EXEC_OACC_HOST_DATA:
12797 : : case EXEC_OACC_LOOP:
12798 : : case EXEC_OACC_UPDATE:
12799 : : case EXEC_OACC_WAIT:
12800 : : case EXEC_OACC_CACHE:
12801 : : case EXEC_OACC_ENTER_DATA:
12802 : : case EXEC_OACC_EXIT_DATA:
12803 : : case EXEC_OACC_ROUTINE:
12804 : : case EXEC_OMP_ALLOCATE:
12805 : : case EXEC_OMP_ALLOCATORS:
12806 : : case EXEC_OMP_ASSUME:
12807 : : case EXEC_OMP_CRITICAL:
12808 : : case EXEC_OMP_DISPATCH:
12809 : : case EXEC_OMP_DISTRIBUTE:
12810 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12811 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12812 : : case EXEC_OMP_DISTRIBUTE_SIMD:
12813 : : case EXEC_OMP_DO:
12814 : : case EXEC_OMP_DO_SIMD:
12815 : : case EXEC_OMP_ERROR:
12816 : : case EXEC_OMP_LOOP:
12817 : : case EXEC_OMP_MASKED:
12818 : : case EXEC_OMP_MASKED_TASKLOOP:
12819 : : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12820 : : case EXEC_OMP_MASTER:
12821 : : case EXEC_OMP_MASTER_TASKLOOP:
12822 : : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12823 : : case EXEC_OMP_ORDERED:
12824 : : case EXEC_OMP_PARALLEL:
12825 : : case EXEC_OMP_PARALLEL_DO:
12826 : : case EXEC_OMP_PARALLEL_DO_SIMD:
12827 : : case EXEC_OMP_PARALLEL_LOOP:
12828 : : case EXEC_OMP_PARALLEL_MASKED:
12829 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12830 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12831 : : case EXEC_OMP_PARALLEL_MASTER:
12832 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12833 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12834 : : case EXEC_OMP_PARALLEL_SECTIONS:
12835 : : case EXEC_OMP_PARALLEL_WORKSHARE:
12836 : : case EXEC_OMP_SECTIONS:
12837 : : case EXEC_OMP_SIMD:
12838 : : case EXEC_OMP_SCOPE:
12839 : : case EXEC_OMP_SINGLE:
12840 : : case EXEC_OMP_TARGET:
12841 : : case EXEC_OMP_TARGET_DATA:
12842 : : case EXEC_OMP_TARGET_ENTER_DATA:
12843 : : case EXEC_OMP_TARGET_EXIT_DATA:
12844 : : case EXEC_OMP_TARGET_PARALLEL:
12845 : : case EXEC_OMP_TARGET_PARALLEL_DO:
12846 : : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12847 : : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12848 : : case EXEC_OMP_TARGET_SIMD:
12849 : : case EXEC_OMP_TARGET_TEAMS:
12850 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12851 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12852 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12853 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12854 : : case EXEC_OMP_TARGET_TEAMS_LOOP:
12855 : : case EXEC_OMP_TARGET_UPDATE:
12856 : : case EXEC_OMP_TASK:
12857 : : case EXEC_OMP_TASKGROUP:
12858 : : case EXEC_OMP_TASKLOOP:
12859 : : case EXEC_OMP_TASKLOOP_SIMD:
12860 : : case EXEC_OMP_TASKWAIT:
12861 : : case EXEC_OMP_TASKYIELD:
12862 : : case EXEC_OMP_TEAMS:
12863 : : case EXEC_OMP_TEAMS_DISTRIBUTE:
12864 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12865 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12866 : : case EXEC_OMP_TEAMS_LOOP:
12867 : : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12868 : : case EXEC_OMP_TILE:
12869 : : case EXEC_OMP_UNROLL:
12870 : : case EXEC_OMP_WORKSHARE:
12871 : : break;
12872 : :
12873 : 0 : default:
12874 : 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
12875 : : }
12876 : :
12877 : 337190 : gfc_resolve_code (b->next, ns);
12878 : : }
12879 : 325944 : }
12880 : :
12881 : : bool
12882 : 0 : caf_possible_reallocate (gfc_expr *e)
12883 : : {
12884 : 0 : symbol_attribute caf_attr;
12885 : 0 : gfc_ref *last_arr_ref = nullptr;
12886 : :
12887 : 0 : caf_attr = gfc_caf_attr (e);
12888 : 0 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
12889 : : return false;
12890 : :
12891 : : /* Only full array refs can indicate a needed reallocation. */
12892 : 0 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
12893 : 0 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
12894 : 0 : last_arr_ref = ref;
12895 : :
12896 : 0 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
12897 : : }
12898 : :
12899 : : /* Does everything to resolve an ordinary assignment. Returns true
12900 : : if this is an interface assignment. */
12901 : : static bool
12902 : 280924 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
12903 : : {
12904 : 280924 : bool rval = false;
12905 : 280924 : gfc_expr *lhs;
12906 : 280924 : gfc_expr *rhs;
12907 : 280924 : int n;
12908 : 280924 : gfc_ref *ref;
12909 : 280924 : symbol_attribute attr;
12910 : :
12911 : 280924 : if (gfc_extend_assign (code, ns))
12912 : : {
12913 : 776 : gfc_expr** rhsptr;
12914 : :
12915 : 776 : if (code->op == EXEC_ASSIGN_CALL)
12916 : : {
12917 : 360 : lhs = code->ext.actual->expr;
12918 : 360 : rhsptr = &code->ext.actual->next->expr;
12919 : : }
12920 : : else
12921 : : {
12922 : 416 : gfc_actual_arglist* args;
12923 : 416 : gfc_typebound_proc* tbp;
12924 : :
12925 : 416 : gcc_assert (code->op == EXEC_COMPCALL);
12926 : :
12927 : 416 : args = code->expr1->value.compcall.actual;
12928 : 416 : lhs = args->expr;
12929 : 416 : rhsptr = &args->next->expr;
12930 : :
12931 : 416 : tbp = code->expr1->value.compcall.tbp;
12932 : 416 : gcc_assert (!tbp->is_generic);
12933 : : }
12934 : :
12935 : : /* Make a temporary rhs when there is a default initializer
12936 : : and rhs is the same symbol as the lhs. */
12937 : 776 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
12938 : 392 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
12939 : 339 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
12940 : 967 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
12941 : 24 : *rhsptr = gfc_get_parentheses (*rhsptr);
12942 : :
12943 : 776 : return true;
12944 : : }
12945 : :
12946 : 280148 : lhs = code->expr1;
12947 : 280148 : rhs = code->expr2;
12948 : :
12949 : 280148 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
12950 : 261189 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
12951 : 21394 : && !lhs->symtree->n.sym->attr.proc_pointer
12952 : 301542 : && gfc_expr_attr (lhs).proc_pointer)
12953 : : {
12954 : 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
12955 : : "pointer component",
12956 : : &lhs->where);
12957 : 1 : return false;
12958 : : }
12959 : :
12960 : 329145 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
12961 : 246479 : && rhs->ts.type == BT_CHARACTER
12962 : 280540 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
12963 : : {
12964 : : /* Use of -fdec-char-conversions allows assignment of character data
12965 : : to non-character variables. This not permitted for nonconstant
12966 : : strings. */
12967 : 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
12968 : : gfc_typename (lhs), &rhs->where);
12969 : 29 : return false;
12970 : : }
12971 : :
12972 : 280118 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
12973 : : {
12974 : 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
12975 : : gfc_typename (lhs), &rhs->where);
12976 : 0 : return false;
12977 : : }
12978 : :
12979 : : /* Handle the case of a BOZ literal on the RHS. */
12980 : 280118 : if (rhs->ts.type == BT_BOZ)
12981 : : {
12982 : 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
12983 : : "statement value nor an actual argument of "
12984 : : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
12985 : : &rhs->where))
12986 : : return false;
12987 : :
12988 : 1 : switch (lhs->ts.type)
12989 : : {
12990 : 0 : case BT_INTEGER:
12991 : 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
12992 : : return false;
12993 : : break;
12994 : 1 : case BT_REAL:
12995 : 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
12996 : : return false;
12997 : : break;
12998 : 0 : default:
12999 : 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
13000 : 0 : return false;
13001 : : }
13002 : : }
13003 : :
13004 : 280116 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
13005 : : {
13006 : 64 : HOST_WIDE_INT llen = 0, rlen = 0;
13007 : 64 : if (lhs->ts.u.cl != NULL
13008 : 64 : && lhs->ts.u.cl->length != NULL
13009 : 53 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13010 : 53 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
13011 : :
13012 : 64 : if (rhs->expr_type == EXPR_CONSTANT)
13013 : 26 : rlen = rhs->value.character.length;
13014 : :
13015 : 38 : else if (rhs->ts.u.cl != NULL
13016 : 38 : && rhs->ts.u.cl->length != NULL
13017 : 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
13018 : 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
13019 : :
13020 : 64 : if (rlen && llen && rlen > llen)
13021 : 28 : gfc_warning_now (OPT_Wcharacter_truncation,
13022 : : "CHARACTER expression will be truncated "
13023 : : "in assignment (%wd/%wd) at %L",
13024 : : llen, rlen, &code->loc);
13025 : : }
13026 : :
13027 : : /* Ensure that a vector index expression for the lvalue is evaluated
13028 : : to a temporary if the lvalue symbol is referenced in it. */
13029 : 280116 : if (lhs->rank)
13030 : : {
13031 : 107350 : for (ref = lhs->ref; ref; ref= ref->next)
13032 : 56939 : if (ref->type == REF_ARRAY)
13033 : : {
13034 : 127571 : for (n = 0; n < ref->u.ar.dimen; n++)
13035 : 75675 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
13036 : 75900 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
13037 : 225 : ref->u.ar.start[n]))
13038 : 14 : ref->u.ar.start[n]
13039 : 14 : = gfc_get_parentheses (ref->u.ar.start[n]);
13040 : : }
13041 : : }
13042 : :
13043 : 280116 : if (gfc_pure (NULL))
13044 : : {
13045 : 3280 : if (lhs->ts.type == BT_DERIVED
13046 : 87 : && lhs->expr_type == EXPR_VARIABLE
13047 : 87 : && lhs->ts.u.derived->attr.pointer_comp
13048 : 4 : && rhs->expr_type == EXPR_VARIABLE
13049 : 3283 : && (gfc_impure_variable (rhs->symtree->n.sym)
13050 : 2 : || gfc_is_coindexed (rhs)))
13051 : : {
13052 : : /* F2008, C1283. */
13053 : 2 : if (gfc_is_coindexed (rhs))
13054 : 1 : gfc_error ("Coindexed expression at %L is assigned to "
13055 : : "a derived type variable with a POINTER "
13056 : : "component in a PURE procedure",
13057 : : &rhs->where);
13058 : : else
13059 : : /* F2008, C1283 (4). */
13060 : 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
13061 : : "shall not be used as the expr at %L of an intrinsic "
13062 : : "assignment statement in which the variable is of a "
13063 : : "derived type if the derived type has a pointer "
13064 : : "component at any level of component selection.",
13065 : : &rhs->where);
13066 : 2 : return rval;
13067 : : }
13068 : :
13069 : : /* Fortran 2008, C1283. */
13070 : 3278 : if (gfc_is_coindexed (lhs))
13071 : : {
13072 : 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
13073 : : "procedure", &rhs->where);
13074 : 1 : return rval;
13075 : : }
13076 : : }
13077 : :
13078 : 280113 : if (gfc_implicit_pure (NULL))
13079 : : {
13080 : 7108 : if (lhs->expr_type == EXPR_VARIABLE
13081 : 7108 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
13082 : 5052 : && lhs->symtree->n.sym->ns != gfc_current_ns)
13083 : 243 : gfc_unset_implicit_pure (NULL);
13084 : :
13085 : 7108 : if (lhs->ts.type == BT_DERIVED
13086 : 305 : && lhs->expr_type == EXPR_VARIABLE
13087 : 305 : && lhs->ts.u.derived->attr.pointer_comp
13088 : 7 : && rhs->expr_type == EXPR_VARIABLE
13089 : 7115 : && (gfc_impure_variable (rhs->symtree->n.sym)
13090 : 7 : || gfc_is_coindexed (rhs)))
13091 : 0 : gfc_unset_implicit_pure (NULL);
13092 : :
13093 : : /* Fortran 2008, C1283. */
13094 : 7108 : if (gfc_is_coindexed (lhs))
13095 : 0 : gfc_unset_implicit_pure (NULL);
13096 : : }
13097 : :
13098 : : /* F2008, 7.2.1.2. */
13099 : 280113 : attr = gfc_expr_attr (lhs);
13100 : 280113 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
13101 : : {
13102 : 904 : if (attr.codimension)
13103 : : {
13104 : 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
13105 : : "permitted", &lhs->where);
13106 : 1 : return false;
13107 : : }
13108 : 903 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
13109 : : "polymorphic variable at %L", &lhs->where))
13110 : : return false;
13111 : 902 : if (!flag_realloc_lhs)
13112 : : {
13113 : 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
13114 : : "requires %<-frealloc-lhs%>", &lhs->where);
13115 : 1 : return false;
13116 : : }
13117 : : }
13118 : 279209 : else if (lhs->ts.type == BT_CLASS)
13119 : : {
13120 : 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
13121 : : "assignment at %L - check that there is a matching specific "
13122 : : "subroutine for %<=%> operator", &lhs->where);
13123 : 9 : return false;
13124 : : }
13125 : :
13126 : 280101 : bool lhs_coindexed = gfc_is_coindexed (lhs);
13127 : :
13128 : : /* F2008, Section 7.2.1.2. */
13129 : 280101 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
13130 : : {
13131 : 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
13132 : : "component in assignment at %L", &lhs->where);
13133 : 1 : return false;
13134 : : }
13135 : :
13136 : : /* Assign the 'data' of a class object to a derived type. */
13137 : 280100 : if (lhs->ts.type == BT_DERIVED
13138 : 6864 : && rhs->ts.type == BT_CLASS
13139 : 137 : && rhs->expr_type != EXPR_ARRAY)
13140 : 131 : gfc_add_data_component (rhs);
13141 : :
13142 : : /* Make sure there is a vtable and, in particular, a _copy for the
13143 : : rhs type. */
13144 : 280100 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
13145 : 544 : gfc_find_vtab (&rhs->ts);
13146 : :
13147 : 280100 : gfc_check_assign (lhs, rhs, 1);
13148 : :
13149 : 280100 : return false;
13150 : : }
13151 : :
13152 : :
13153 : : /* Add a component reference onto an expression. */
13154 : :
13155 : : static void
13156 : 665 : add_comp_ref (gfc_expr *e, gfc_component *c)
13157 : : {
13158 : 665 : gfc_ref **ref;
13159 : 665 : ref = &(e->ref);
13160 : 889 : while (*ref)
13161 : 224 : ref = &((*ref)->next);
13162 : 665 : *ref = gfc_get_ref ();
13163 : 665 : (*ref)->type = REF_COMPONENT;
13164 : 665 : (*ref)->u.c.sym = e->ts.u.derived;
13165 : 665 : (*ref)->u.c.component = c;
13166 : 665 : e->ts = c->ts;
13167 : :
13168 : : /* Add a full array ref, as necessary. */
13169 : 665 : if (c->as)
13170 : : {
13171 : 84 : gfc_add_full_array_ref (e, c->as);
13172 : 84 : e->rank = c->as->rank;
13173 : 84 : e->corank = c->as->corank;
13174 : : }
13175 : 665 : }
13176 : :
13177 : :
13178 : : /* Build an assignment. Keep the argument 'op' for future use, so that
13179 : : pointer assignments can be made. */
13180 : :
13181 : : static gfc_code *
13182 : 898 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
13183 : : gfc_component *comp1, gfc_component *comp2, locus loc)
13184 : : {
13185 : 898 : gfc_code *this_code;
13186 : :
13187 : 898 : this_code = gfc_get_code (op);
13188 : 898 : this_code->next = NULL;
13189 : 898 : this_code->expr1 = gfc_copy_expr (expr1);
13190 : 898 : this_code->expr2 = gfc_copy_expr (expr2);
13191 : 898 : this_code->loc = loc;
13192 : 898 : if (comp1 && comp2)
13193 : : {
13194 : 288 : add_comp_ref (this_code->expr1, comp1);
13195 : 288 : add_comp_ref (this_code->expr2, comp2);
13196 : : }
13197 : :
13198 : 898 : return this_code;
13199 : : }
13200 : :
13201 : :
13202 : : /* Makes a temporary variable expression based on the characteristics of
13203 : : a given variable expression. */
13204 : :
13205 : : static gfc_expr*
13206 : 392 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
13207 : : {
13208 : 392 : static int serial = 0;
13209 : 392 : char name[GFC_MAX_SYMBOL_LEN];
13210 : 392 : gfc_symtree *tmp;
13211 : 392 : gfc_array_spec *as;
13212 : 392 : gfc_array_ref *aref;
13213 : 392 : gfc_ref *ref;
13214 : :
13215 : 392 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
13216 : 392 : gfc_get_sym_tree (name, ns, &tmp, false);
13217 : 392 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
13218 : :
13219 : 392 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
13220 : 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
13221 : : NULL,
13222 : 0 : e->value.character.length);
13223 : :
13224 : 392 : as = NULL;
13225 : 392 : ref = NULL;
13226 : 392 : aref = NULL;
13227 : :
13228 : : /* Obtain the arrayspec for the temporary. */
13229 : 392 : if (e->rank && e->expr_type != EXPR_ARRAY
13230 : : && e->expr_type != EXPR_FUNCTION
13231 : : && e->expr_type != EXPR_OP)
13232 : : {
13233 : 52 : aref = gfc_find_array_ref (e);
13234 : 52 : if (e->expr_type == EXPR_VARIABLE
13235 : 52 : && e->symtree->n.sym->as == aref->as)
13236 : : as = aref->as;
13237 : : else
13238 : : {
13239 : 0 : for (ref = e->ref; ref; ref = ref->next)
13240 : 0 : if (ref->type == REF_COMPONENT
13241 : 0 : && ref->u.c.component->as == aref->as)
13242 : : {
13243 : : as = aref->as;
13244 : : break;
13245 : : }
13246 : : }
13247 : : }
13248 : :
13249 : : /* Add the attributes and the arrayspec to the temporary. */
13250 : 392 : tmp->n.sym->attr = gfc_expr_attr (e);
13251 : 392 : tmp->n.sym->attr.function = 0;
13252 : 392 : tmp->n.sym->attr.proc_pointer = 0;
13253 : 392 : tmp->n.sym->attr.result = 0;
13254 : 392 : tmp->n.sym->attr.flavor = FL_VARIABLE;
13255 : 392 : tmp->n.sym->attr.dummy = 0;
13256 : 392 : tmp->n.sym->attr.use_assoc = 0;
13257 : 392 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
13258 : :
13259 : :
13260 : 392 : if (as)
13261 : : {
13262 : 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
13263 : 52 : if (!ref)
13264 : 52 : ref = e->ref;
13265 : 52 : if (as->type == AS_DEFERRED)
13266 : 46 : tmp->n.sym->attr.allocatable = 1;
13267 : : }
13268 : 340 : else if ((e->rank || e->corank)
13269 : 48 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
13270 : 0 : || e->expr_type == EXPR_OP))
13271 : : {
13272 : 48 : tmp->n.sym->as = gfc_get_array_spec ();
13273 : 48 : tmp->n.sym->as->type = AS_DEFERRED;
13274 : 48 : tmp->n.sym->as->rank = e->rank;
13275 : 48 : tmp->n.sym->as->corank = e->corank;
13276 : 48 : tmp->n.sym->attr.allocatable = 1;
13277 : 48 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
13278 : 96 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
13279 : : }
13280 : : else
13281 : 292 : tmp->n.sym->attr.dimension = 0;
13282 : :
13283 : 392 : gfc_set_sym_referenced (tmp->n.sym);
13284 : 392 : gfc_commit_symbol (tmp->n.sym);
13285 : 392 : e = gfc_lval_expr_from_sym (tmp->n.sym);
13286 : :
13287 : : /* Should the lhs be a section, use its array ref for the
13288 : : temporary expression. */
13289 : 392 : if (aref && aref->type != AR_FULL)
13290 : : {
13291 : 6 : gfc_free_ref_list (e->ref);
13292 : 6 : e->ref = gfc_copy_ref (ref);
13293 : : }
13294 : 392 : return e;
13295 : : }
13296 : :
13297 : :
13298 : : /* Add one line of code to the code chain, making sure that 'head' and
13299 : : 'tail' are appropriately updated. */
13300 : :
13301 : : static void
13302 : 656 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
13303 : : {
13304 : 656 : gcc_assert (this_code);
13305 : 656 : if (*head == NULL)
13306 : 308 : *head = *tail = *this_code;
13307 : : else
13308 : 348 : *tail = gfc_append_code (*tail, *this_code);
13309 : 656 : *this_code = NULL;
13310 : 656 : }
13311 : :
13312 : :
13313 : : /* Generate a final call from a variable expression */
13314 : :
13315 : : static void
13316 : 81 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
13317 : : {
13318 : 81 : gfc_code *this_code;
13319 : 81 : gfc_expr *final_expr = NULL;
13320 : 81 : gfc_expr *size_expr;
13321 : 81 : gfc_expr *fini_coarray;
13322 : :
13323 : 81 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
13324 : 81 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
13325 : 75 : return;
13326 : :
13327 : : /* Now generate the finalizer call. */
13328 : 6 : this_code = gfc_get_code (EXEC_CALL);
13329 : 6 : this_code->symtree = final_expr->symtree;
13330 : 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
13331 : :
13332 : : //* Expression to be finalized */
13333 : 6 : this_code->ext.actual = gfc_get_actual_arglist ();
13334 : 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
13335 : :
13336 : : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
13337 : 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
13338 : 6 : size_expr = gfc_get_expr ();
13339 : 6 : size_expr->where = gfc_current_locus;
13340 : 6 : size_expr->expr_type = EXPR_OP;
13341 : 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
13342 : 6 : size_expr->value.op.op1
13343 : 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
13344 : : "storage_size", gfc_current_locus, 2,
13345 : 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
13346 : : gfc_get_int_expr (gfc_index_integer_kind,
13347 : : NULL, 0));
13348 : 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
13349 : : gfc_character_storage_size);
13350 : 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
13351 : 6 : size_expr->ts = size_expr->value.op.op1->ts;
13352 : 6 : this_code->ext.actual->next->expr = size_expr;
13353 : :
13354 : : /* fini_coarray */
13355 : 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
13356 : 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
13357 : : &tmp_expr->where);
13358 : 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
13359 : 6 : this_code->ext.actual->next->next->expr = fini_coarray;
13360 : :
13361 : 6 : add_code_to_chain (&this_code, head, tail);
13362 : :
13363 : : }
13364 : :
13365 : : /* Counts the potential number of part array references that would
13366 : : result from resolution of typebound defined assignments. */
13367 : :
13368 : :
13369 : : static int
13370 : 243 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
13371 : : {
13372 : 243 : gfc_component *c;
13373 : 243 : int c_depth = 0, t_depth;
13374 : :
13375 : 584 : for (c= derived->components; c; c = c->next)
13376 : : {
13377 : 341 : if ((!gfc_bt_struct (c->ts.type)
13378 : 261 : || c->attr.pointer
13379 : 261 : || c->attr.allocatable
13380 : 260 : || c->attr.proc_pointer_comp
13381 : 260 : || c->attr.class_pointer
13382 : 260 : || c->attr.proc_pointer)
13383 : 81 : && !c->attr.defined_assign_comp)
13384 : 81 : continue;
13385 : :
13386 : 260 : if (c->as && c_depth == 0)
13387 : 260 : c_depth = 1;
13388 : :
13389 : 260 : if (c->ts.u.derived->attr.defined_assign_comp)
13390 : 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
13391 : : c->as ? 1 : 0);
13392 : : else
13393 : : t_depth = 0;
13394 : :
13395 : 260 : c_depth = t_depth > c_depth ? t_depth : c_depth;
13396 : : }
13397 : 243 : return depth + c_depth;
13398 : : }
13399 : :
13400 : :
13401 : : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
13402 : : "An intrinsic assignment where the variable is of derived type is performed
13403 : : as if each component of the variable were assigned from the corresponding
13404 : : component of expr using pointer assignment (10.2.2) for each pointer
13405 : : component, defined assignment for each nonpointer nonallocatable component
13406 : : of a type that has a type-bound defined assignment consistent with the
13407 : : component, intrinsic assignment for each other nonpointer nonallocatable
13408 : : component, and intrinsic assignment for each allocated coarray component.
13409 : : For unallocated coarray components, the corresponding component of the
13410 : : variable shall be unallocated. For a noncoarray allocatable component the
13411 : : following sequence of operations is applied.
13412 : : (1) If the component of the variable is allocated, it is deallocated.
13413 : : (2) If the component of the value of expr is allocated, the
13414 : : corresponding component of the variable is allocated with the same
13415 : : dynamic type and type parameters as the component of the value of
13416 : : expr. If it is an array, it is allocated with the same bounds. The
13417 : : value of the component of the value of expr is then assigned to the
13418 : : corresponding component of the variable using defined assignment if
13419 : : the declared type of the component has a type-bound defined
13420 : : assignment consistent with the component, and intrinsic assignment
13421 : : for the dynamic type of that component otherwise."
13422 : :
13423 : : The pointer assignments are taken care of by the intrinsic assignment of the
13424 : : structure itself. This function recursively adds defined assignments where
13425 : : required. The recursion is accomplished by calling gfc_resolve_code.
13426 : :
13427 : : When the lhs in a defined assignment has intent INOUT or is intent OUT
13428 : : and the component of 'var' is finalizable, we need a temporary for the
13429 : : lhs. In pseudo-code for an assignment var = expr:
13430 : :
13431 : : ! Confine finalization of temporaries, as far as possible.
13432 : : Enclose the code for the assignment in a block
13433 : : ! Only call function 'expr' once.
13434 : : #if ('expr is not a constant or an variable)
13435 : : temp_expr = expr
13436 : : expr = temp_x
13437 : : ! Do the intrinsic assignment
13438 : : #if typeof ('var') has a typebound final subroutine
13439 : : finalize (var)
13440 : : var = expr
13441 : : ! Now do the component assignments
13442 : : #do over derived type components [%cmp]
13443 : : #if (cmp is a pointer of any kind)
13444 : : continue
13445 : : build the assignment
13446 : : resolve the code
13447 : : #if the code is a typebound assignment
13448 : : #if (arg1 is INOUT or finalizable OUT && !t1)
13449 : : t1 = var
13450 : : arg1 = t1
13451 : : deal with allocatation or not of var and this component
13452 : : #elseif the code is an assignment by itself
13453 : : #if this component does not need finalization
13454 : : delete code and continue
13455 : : #else
13456 : : remove the leading assignment
13457 : : #endif
13458 : : commit the code
13459 : : #if (t1 and (arg1 is INOUT or finalizable OUT))
13460 : : var%cmp = t1%cmp
13461 : : #enddo
13462 : : put all code chunks involving t1 to the top of the generated code
13463 : : insert the generated block in place of the original code
13464 : : */
13465 : :
13466 : : static bool
13467 : 381 : is_finalizable_type (gfc_typespec ts)
13468 : : {
13469 : 381 : gfc_component *c;
13470 : :
13471 : 381 : if (ts.type != BT_DERIVED)
13472 : : return false;
13473 : :
13474 : : /* (1) Check for FINAL subroutines. */
13475 : 381 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
13476 : : return true;
13477 : :
13478 : : /* (2) Check for components of finalizable type. */
13479 : 809 : for (c = ts.u.derived->components; c; c = c->next)
13480 : 470 : if (c->ts.type == BT_DERIVED
13481 : 243 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
13482 : 242 : && c->ts.u.derived->f2k_derived
13483 : 242 : && c->ts.u.derived->f2k_derived->finalizers)
13484 : : return true;
13485 : :
13486 : : return false;
13487 : : }
13488 : :
13489 : : /* The temporary assignments have to be put on top of the additional
13490 : : code to avoid the result being changed by the intrinsic assignment.
13491 : : */
13492 : : static int component_assignment_level = 0;
13493 : : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
13494 : : static bool finalizable_comp;
13495 : :
13496 : : static void
13497 : 188 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
13498 : : {
13499 : 188 : gfc_component *comp1, *comp2;
13500 : 188 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
13501 : 188 : gfc_code *tmp_code = NULL;
13502 : 188 : gfc_expr *t1 = NULL;
13503 : 188 : gfc_expr *tmp_expr = NULL;
13504 : 188 : int error_count, depth;
13505 : 188 : bool finalizable_lhs;
13506 : :
13507 : 188 : gfc_get_errors (NULL, &error_count);
13508 : :
13509 : : /* Filter out continuing processing after an error. */
13510 : 188 : if (error_count
13511 : 188 : || (*code)->expr1->ts.type != BT_DERIVED
13512 : 188 : || (*code)->expr2->ts.type != BT_DERIVED)
13513 : 140 : return;
13514 : :
13515 : : /* TODO: Handle more than one part array reference in assignments. */
13516 : 188 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
13517 : 188 : (*code)->expr1->rank ? 1 : 0);
13518 : 188 : if (depth > 1)
13519 : : {
13520 : 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
13521 : : "done because multiple part array references would "
13522 : : "occur in intermediate expressions.", &(*code)->loc);
13523 : 6 : return;
13524 : : }
13525 : :
13526 : 182 : if (!component_assignment_level)
13527 : 134 : finalizable_comp = true;
13528 : :
13529 : : /* Build a block so that function result temporaries are finalized
13530 : : locally on exiting the rather than enclosing scope. */
13531 : 182 : if (!component_assignment_level)
13532 : : {
13533 : 134 : ns = gfc_build_block_ns (ns);
13534 : 134 : tmp_code = gfc_get_code (EXEC_NOP);
13535 : 134 : *tmp_code = **code;
13536 : 134 : tmp_code->next = NULL;
13537 : 134 : (*code)->op = EXEC_BLOCK;
13538 : 134 : (*code)->ext.block.ns = ns;
13539 : 134 : (*code)->ext.block.assoc = NULL;
13540 : 134 : (*code)->expr1 = (*code)->expr2 = NULL;
13541 : 134 : ns->code = tmp_code;
13542 : 134 : code = &ns->code;
13543 : : }
13544 : :
13545 : 182 : component_assignment_level++;
13546 : :
13547 : 182 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13548 : :
13549 : : /* Create a temporary so that functions get called only once. */
13550 : 182 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13551 : 182 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13552 : : {
13553 : : /* Assign the rhs to the temporary. */
13554 : 81 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13555 : 81 : if (tmp_expr->symtree->n.sym->attr.pointer)
13556 : : {
13557 : : /* Use allocate on assignment for the sake of simplicity. The
13558 : : temporary must not take on the optional attribute. Assume
13559 : : that the assignment is guarded by a PRESENT condition if the
13560 : : lhs is optional. */
13561 : 25 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13562 : 25 : tmp_expr->symtree->n.sym->attr.optional = 0;
13563 : 25 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13564 : : }
13565 : 162 : this_code = build_assignment (EXEC_ASSIGN,
13566 : : tmp_expr, (*code)->expr2,
13567 : 81 : NULL, NULL, (*code)->loc);
13568 : 81 : this_code->expr2->must_finalize = 1;
13569 : : /* Add the code and substitute the rhs expression. */
13570 : 81 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13571 : 81 : gfc_free_expr ((*code)->expr2);
13572 : 81 : (*code)->expr2 = tmp_expr;
13573 : : }
13574 : :
13575 : : /* Do the intrinsic assignment. This is not needed if the lhs is one
13576 : : of the temporaries generated here, since the intrinsic assignment
13577 : : to the final result already does this. */
13578 : 182 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
13579 : : {
13580 : 182 : if (finalizable_lhs)
13581 : 18 : (*code)->expr1->must_finalize = 1;
13582 : 182 : this_code = build_assignment (EXEC_ASSIGN,
13583 : : (*code)->expr1, (*code)->expr2,
13584 : : NULL, NULL, (*code)->loc);
13585 : 182 : add_code_to_chain (&this_code, &head, &tail);
13586 : : }
13587 : :
13588 : 182 : comp1 = (*code)->expr1->ts.u.derived->components;
13589 : 182 : comp2 = (*code)->expr2->ts.u.derived->components;
13590 : :
13591 : 449 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
13592 : : {
13593 : 267 : bool inout = false;
13594 : 267 : bool finalizable_out = false;
13595 : :
13596 : : /* The intrinsic assignment does the right thing for pointers
13597 : : of all kinds and allocatable components. */
13598 : 267 : if (!gfc_bt_struct (comp1->ts.type)
13599 : 200 : || comp1->attr.pointer
13600 : 200 : || comp1->attr.allocatable
13601 : 199 : || comp1->attr.proc_pointer_comp
13602 : 199 : || comp1->attr.class_pointer
13603 : 199 : || comp1->attr.proc_pointer)
13604 : 68 : continue;
13605 : :
13606 : 398 : finalizable_comp = is_finalizable_type (comp1->ts)
13607 : 199 : && !finalizable_lhs;
13608 : :
13609 : : /* Make an assignment for this component. */
13610 : 398 : this_code = build_assignment (EXEC_ASSIGN,
13611 : : (*code)->expr1, (*code)->expr2,
13612 : 199 : comp1, comp2, (*code)->loc);
13613 : :
13614 : : /* Convert the assignment if there is a defined assignment for
13615 : : this type. Otherwise, using the call from gfc_resolve_code,
13616 : : recurse into its components. */
13617 : 199 : gfc_resolve_code (this_code, ns);
13618 : :
13619 : 199 : if (this_code->op == EXEC_ASSIGN_CALL)
13620 : : {
13621 : 144 : gfc_formal_arglist *dummy_args;
13622 : 144 : gfc_symbol *rsym;
13623 : : /* Check that there is a typebound defined assignment. If not,
13624 : : then this must be a module defined assignment. We cannot
13625 : : use the defined_assign_comp attribute here because it must
13626 : : be this derived type that has the defined assignment and not
13627 : : a parent type. */
13628 : 144 : if (!(comp1->ts.u.derived->f2k_derived
13629 : : && comp1->ts.u.derived->f2k_derived
13630 : 144 : ->tb_op[INTRINSIC_ASSIGN]))
13631 : : {
13632 : 1 : gfc_free_statements (this_code);
13633 : 1 : this_code = NULL;
13634 : 1 : continue;
13635 : : }
13636 : :
13637 : : /* If the first argument of the subroutine has intent INOUT
13638 : : a temporary must be generated and used instead. */
13639 : 143 : rsym = this_code->resolved_sym;
13640 : 143 : dummy_args = gfc_sym_get_dummy_args (rsym);
13641 : 268 : finalizable_out = gfc_may_be_finalized (comp1->ts)
13642 : 18 : && dummy_args
13643 : 161 : && dummy_args->sym->attr.intent == INTENT_OUT;
13644 : 286 : inout = dummy_args
13645 : 268 : && dummy_args->sym->attr.intent == INTENT_INOUT;
13646 : 72 : if ((inout || finalizable_out)
13647 : 89 : && !comp1->attr.allocatable)
13648 : : {
13649 : 89 : gfc_code *temp_code;
13650 : 89 : inout = true;
13651 : :
13652 : : /* Build the temporary required for the assignment and put
13653 : : it at the head of the generated code. */
13654 : 89 : if (!t1)
13655 : : {
13656 : 89 : gfc_namespace *tmp_ns = ns;
13657 : 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
13658 : 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
13659 : 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
13660 : 89 : t1->symtree->n.sym->attr.artificial = 1;
13661 : 178 : temp_code = build_assignment (EXEC_ASSIGN,
13662 : : t1, (*code)->expr1,
13663 : 89 : NULL, NULL, (*code)->loc);
13664 : :
13665 : : /* For allocatable LHS, check whether it is allocated. Note
13666 : : that allocatable components with defined assignment are
13667 : : not yet support. See PR 57696. */
13668 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
13669 : : {
13670 : 24 : gfc_code *block;
13671 : 24 : gfc_expr *e =
13672 : 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13673 : 24 : block = gfc_get_code (EXEC_IF);
13674 : 24 : block->block = gfc_get_code (EXEC_IF);
13675 : 24 : block->block->expr1
13676 : 48 : = gfc_build_intrinsic_call (ns,
13677 : : GFC_ISYM_ALLOCATED, "allocated",
13678 : 24 : (*code)->loc, 1, e);
13679 : 24 : block->block->next = temp_code;
13680 : 24 : temp_code = block;
13681 : : }
13682 : 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
13683 : : }
13684 : :
13685 : : /* Replace the first actual arg with the component of the
13686 : : temporary. */
13687 : 89 : gfc_free_expr (this_code->ext.actual->expr);
13688 : 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
13689 : 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
13690 : :
13691 : : /* If the LHS variable is allocatable and wasn't allocated and
13692 : : the temporary is allocatable, pointer assign the address of
13693 : : the freshly allocated LHS to the temporary. */
13694 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
13695 : 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
13696 : : {
13697 : 18 : gfc_code *block;
13698 : 18 : gfc_expr *cond;
13699 : :
13700 : 18 : cond = gfc_get_expr ();
13701 : 18 : cond->ts.type = BT_LOGICAL;
13702 : 18 : cond->ts.kind = gfc_default_logical_kind;
13703 : 18 : cond->expr_type = EXPR_OP;
13704 : 18 : cond->where = (*code)->loc;
13705 : 18 : cond->value.op.op = INTRINSIC_NOT;
13706 : 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
13707 : : GFC_ISYM_ALLOCATED, "allocated",
13708 : 18 : (*code)->loc, 1, gfc_copy_expr (t1));
13709 : 18 : block = gfc_get_code (EXEC_IF);
13710 : 18 : block->block = gfc_get_code (EXEC_IF);
13711 : 18 : block->block->expr1 = cond;
13712 : 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13713 : : t1, (*code)->expr1,
13714 : 18 : NULL, NULL, (*code)->loc);
13715 : 18 : add_code_to_chain (&block, &head, &tail);
13716 : : }
13717 : : }
13718 : : }
13719 : 55 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
13720 : : {
13721 : : /* Don't add intrinsic assignments since they are already
13722 : : effected by the intrinsic assignment of the structure, unless
13723 : : finalization is required. */
13724 : 7 : if (finalizable_comp)
13725 : 0 : this_code->expr1->must_finalize = 1;
13726 : : else
13727 : : {
13728 : 7 : gfc_free_statements (this_code);
13729 : 7 : this_code = NULL;
13730 : 7 : continue;
13731 : : }
13732 : : }
13733 : : else
13734 : : {
13735 : : /* Resolution has expanded an assignment of a derived type with
13736 : : defined assigned components. Remove the redundant, leading
13737 : : assignment. */
13738 : 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
13739 : 48 : gfc_code *tmp = this_code;
13740 : 48 : this_code = this_code->next;
13741 : 48 : tmp->next = NULL;
13742 : 48 : gfc_free_statements (tmp);
13743 : : }
13744 : :
13745 : 191 : add_code_to_chain (&this_code, &head, &tail);
13746 : :
13747 : 191 : if (t1 && (inout || finalizable_out))
13748 : : {
13749 : : /* Transfer the value to the final result. */
13750 : 178 : this_code = build_assignment (EXEC_ASSIGN,
13751 : : (*code)->expr1, t1,
13752 : 89 : comp1, comp2, (*code)->loc);
13753 : 89 : this_code->expr1->must_finalize = 0;
13754 : 89 : add_code_to_chain (&this_code, &head, &tail);
13755 : : }
13756 : : }
13757 : :
13758 : : /* Put the temporary assignments at the top of the generated code. */
13759 : 182 : if (tmp_head && component_assignment_level == 1)
13760 : : {
13761 : 126 : gfc_append_code (tmp_head, head);
13762 : 126 : head = tmp_head;
13763 : 126 : tmp_head = tmp_tail = NULL;
13764 : : }
13765 : :
13766 : : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
13767 : : not accidentally deallocated. Hence, nullify t1. */
13768 : 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
13769 : 271 : && gfc_expr_attr ((*code)->expr1).allocatable)
13770 : : {
13771 : 18 : gfc_code *block;
13772 : 18 : gfc_expr *cond;
13773 : 18 : gfc_expr *e;
13774 : :
13775 : 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13776 : 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
13777 : 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
13778 : 18 : block = gfc_get_code (EXEC_IF);
13779 : 18 : block->block = gfc_get_code (EXEC_IF);
13780 : 18 : block->block->expr1 = cond;
13781 : 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13782 : : t1, gfc_get_null_expr (&(*code)->loc),
13783 : 18 : NULL, NULL, (*code)->loc);
13784 : 18 : gfc_append_code (tail, block);
13785 : 18 : tail = block;
13786 : : }
13787 : :
13788 : 182 : component_assignment_level--;
13789 : :
13790 : : /* Make an explicit final call for the function result. */
13791 : 182 : if (tmp_expr)
13792 : 81 : generate_final_call (tmp_expr, &head, &tail);
13793 : :
13794 : 182 : if (tmp_code)
13795 : : {
13796 : 134 : ns->code = head;
13797 : 134 : return;
13798 : : }
13799 : :
13800 : : /* Now attach the remaining code chain to the input code. Step on
13801 : : to the end of the new code since resolution is complete. */
13802 : 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
13803 : 48 : tail->next = (*code)->next;
13804 : : /* Overwrite 'code' because this would place the intrinsic assignment
13805 : : before the temporary for the lhs is created. */
13806 : 48 : gfc_free_expr ((*code)->expr1);
13807 : 48 : gfc_free_expr ((*code)->expr2);
13808 : 48 : **code = *head;
13809 : 48 : if (head != tail)
13810 : 48 : free (head);
13811 : 48 : *code = tail;
13812 : : }
13813 : :
13814 : :
13815 : : /* F2008: Pointer function assignments are of the form:
13816 : : ptr_fcn (args) = expr
13817 : : This function breaks these assignments into two statements:
13818 : : temporary_pointer => ptr_fcn(args)
13819 : : temporary_pointer = expr */
13820 : :
13821 : : static bool
13822 : 281167 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
13823 : : {
13824 : 281167 : gfc_expr *tmp_ptr_expr;
13825 : 281167 : gfc_code *this_code;
13826 : 281167 : gfc_component *comp;
13827 : 281167 : gfc_symbol *s;
13828 : :
13829 : 281167 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
13830 : : return false;
13831 : :
13832 : : /* Even if standard does not support this feature, continue to build
13833 : : the two statements to avoid upsetting frontend_passes.c. */
13834 : 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
13835 : : "%L", &(*code)->loc);
13836 : :
13837 : 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
13838 : :
13839 : 205 : if (comp)
13840 : 6 : s = comp->ts.interface;
13841 : : else
13842 : 199 : s = (*code)->expr1->symtree->n.sym;
13843 : :
13844 : 205 : if (s == NULL || !s->result->attr.pointer)
13845 : : {
13846 : 5 : gfc_error ("The function result on the lhs of the assignment at "
13847 : : "%L must have the pointer attribute.",
13848 : 5 : &(*code)->expr1->where);
13849 : 5 : (*code)->op = EXEC_NOP;
13850 : 5 : return false;
13851 : : }
13852 : :
13853 : 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
13854 : :
13855 : : /* get_temp_from_expression is set up for ordinary assignments. To that
13856 : : end, where array bounds are not known, arrays are made allocatable.
13857 : : Change the temporary to a pointer here. */
13858 : 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
13859 : 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
13860 : 200 : tmp_ptr_expr->where = (*code)->loc;
13861 : :
13862 : : /* A new charlen is required to ensure that the variable string length
13863 : : is different to that of the original lhs for deferred results. */
13864 : 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
13865 : : {
13866 : 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
13867 : 60 : tmp_ptr_expr->ts.deferred = 1;
13868 : 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
13869 : 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
13870 : 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
13871 : : }
13872 : :
13873 : 400 : this_code = build_assignment (EXEC_ASSIGN,
13874 : : tmp_ptr_expr, (*code)->expr2,
13875 : 200 : NULL, NULL, (*code)->loc);
13876 : 200 : this_code->next = (*code)->next;
13877 : 200 : (*code)->next = this_code;
13878 : 200 : (*code)->op = EXEC_POINTER_ASSIGN;
13879 : 200 : (*code)->expr2 = (*code)->expr1;
13880 : 200 : (*code)->expr1 = tmp_ptr_expr;
13881 : :
13882 : 200 : return true;
13883 : : }
13884 : :
13885 : :
13886 : : /* Deferred character length assignments from an operator expression
13887 : : require a temporary because the character length of the lhs can
13888 : : change in the course of the assignment. */
13889 : :
13890 : : static bool
13891 : 280148 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
13892 : : {
13893 : 280148 : gfc_expr *tmp_expr;
13894 : 280148 : gfc_code *this_code;
13895 : :
13896 : 280148 : if (!((*code)->expr1->ts.type == BT_CHARACTER
13897 : 25889 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
13898 : 752 : && (*code)->expr2->ts.type == BT_CHARACTER
13899 : 751 : && (*code)->expr2->expr_type == EXPR_OP))
13900 : : return false;
13901 : :
13902 : 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
13903 : : return false;
13904 : :
13905 : 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
13906 : : return false;
13907 : :
13908 : 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13909 : 22 : tmp_expr->where = (*code)->loc;
13910 : :
13911 : : /* A new charlen is required to ensure that the variable string
13912 : : length is different to that of the original lhs. */
13913 : 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
13914 : 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
13915 : 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
13916 : 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
13917 : :
13918 : 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
13919 : :
13920 : 22 : this_code = build_assignment (EXEC_ASSIGN,
13921 : 22 : (*code)->expr1,
13922 : : gfc_copy_expr (tmp_expr),
13923 : : NULL, NULL, (*code)->loc);
13924 : :
13925 : 22 : (*code)->expr1 = tmp_expr;
13926 : :
13927 : 22 : this_code->next = (*code)->next;
13928 : 22 : (*code)->next = this_code;
13929 : :
13930 : 22 : return true;
13931 : : }
13932 : :
13933 : :
13934 : : /* Given a block of code, recursively resolve everything pointed to by this
13935 : : code block. */
13936 : :
13937 : : void
13938 : 664527 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
13939 : : {
13940 : 664527 : int omp_workshare_save;
13941 : 664527 : int forall_save, do_concurrent_save;
13942 : 664527 : code_stack frame;
13943 : 664527 : bool t;
13944 : :
13945 : 664527 : frame.prev = cs_base;
13946 : 664527 : frame.head = code;
13947 : 664527 : cs_base = &frame;
13948 : :
13949 : 664527 : find_reachable_labels (code);
13950 : :
13951 : 1777900 : for (; code; code = code->next)
13952 : : {
13953 : 1113374 : frame.current = code;
13954 : 1113374 : forall_save = forall_flag;
13955 : 1113374 : do_concurrent_save = gfc_do_concurrent_flag;
13956 : :
13957 : 1113374 : if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
13958 : : {
13959 : 2190 : if (code->op == EXEC_FORALL)
13960 : 1990 : forall_flag = 1;
13961 : 200 : else if (code->op == EXEC_DO_CONCURRENT)
13962 : 200 : gfc_do_concurrent_flag = 1;
13963 : 2190 : gfc_resolve_forall (code, ns, forall_save);
13964 : 2190 : if (code->op == EXEC_FORALL)
13965 : 1990 : forall_flag = 2;
13966 : 200 : else if (code->op == EXEC_DO_CONCURRENT)
13967 : 200 : gfc_do_concurrent_flag = 2;
13968 : : }
13969 : 1111184 : else if (code->op == EXEC_OMP_METADIRECTIVE)
13970 : 138 : for (gfc_omp_variant *variant
13971 : : = code->ext.omp_variants;
13972 : 448 : variant; variant = variant->next)
13973 : 310 : gfc_resolve_code (variant->code, ns);
13974 : 1111046 : else if (code->block)
13975 : : {
13976 : 323757 : omp_workshare_save = -1;
13977 : 323757 : switch (code->op)
13978 : : {
13979 : 10115 : case EXEC_OACC_PARALLEL_LOOP:
13980 : 10115 : case EXEC_OACC_PARALLEL:
13981 : 10115 : case EXEC_OACC_KERNELS_LOOP:
13982 : 10115 : case EXEC_OACC_KERNELS:
13983 : 10115 : case EXEC_OACC_SERIAL_LOOP:
13984 : 10115 : case EXEC_OACC_SERIAL:
13985 : 10115 : case EXEC_OACC_DATA:
13986 : 10115 : case EXEC_OACC_HOST_DATA:
13987 : 10115 : case EXEC_OACC_LOOP:
13988 : 10115 : gfc_resolve_oacc_blocks (code, ns);
13989 : 10115 : break;
13990 : 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
13991 : 54 : omp_workshare_save = omp_workshare_flag;
13992 : 54 : omp_workshare_flag = 1;
13993 : 54 : gfc_resolve_omp_parallel_blocks (code, ns);
13994 : 54 : break;
13995 : 5955 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13996 : 5955 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13997 : 5955 : case EXEC_OMP_MASKED_TASKLOOP:
13998 : 5955 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13999 : 5955 : case EXEC_OMP_MASTER_TASKLOOP:
14000 : 5955 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14001 : 5955 : case EXEC_OMP_PARALLEL:
14002 : 5955 : case EXEC_OMP_PARALLEL_DO:
14003 : 5955 : case EXEC_OMP_PARALLEL_DO_SIMD:
14004 : 5955 : case EXEC_OMP_PARALLEL_LOOP:
14005 : 5955 : case EXEC_OMP_PARALLEL_MASKED:
14006 : 5955 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14007 : 5955 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14008 : 5955 : case EXEC_OMP_PARALLEL_MASTER:
14009 : 5955 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14010 : 5955 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14011 : 5955 : case EXEC_OMP_PARALLEL_SECTIONS:
14012 : 5955 : case EXEC_OMP_TARGET_PARALLEL:
14013 : 5955 : case EXEC_OMP_TARGET_PARALLEL_DO:
14014 : 5955 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14015 : 5955 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14016 : 5955 : case EXEC_OMP_TARGET_TEAMS:
14017 : 5955 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14018 : 5955 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14019 : 5955 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14020 : 5955 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14021 : 5955 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14022 : 5955 : case EXEC_OMP_TASK:
14023 : 5955 : case EXEC_OMP_TASKLOOP:
14024 : 5955 : case EXEC_OMP_TASKLOOP_SIMD:
14025 : 5955 : case EXEC_OMP_TEAMS:
14026 : 5955 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14027 : 5955 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14028 : 5955 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14029 : 5955 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14030 : 5955 : case EXEC_OMP_TEAMS_LOOP:
14031 : 5955 : omp_workshare_save = omp_workshare_flag;
14032 : 5955 : omp_workshare_flag = 0;
14033 : 5955 : gfc_resolve_omp_parallel_blocks (code, ns);
14034 : 5955 : break;
14035 : 3062 : case EXEC_OMP_DISTRIBUTE:
14036 : 3062 : case EXEC_OMP_DISTRIBUTE_SIMD:
14037 : 3062 : case EXEC_OMP_DO:
14038 : 3062 : case EXEC_OMP_DO_SIMD:
14039 : 3062 : case EXEC_OMP_LOOP:
14040 : 3062 : case EXEC_OMP_SIMD:
14041 : 3062 : case EXEC_OMP_TARGET_SIMD:
14042 : 3062 : case EXEC_OMP_TILE:
14043 : 3062 : case EXEC_OMP_UNROLL:
14044 : 3062 : gfc_resolve_omp_do_blocks (code, ns);
14045 : 3062 : break;
14046 : : case EXEC_SELECT_TYPE:
14047 : : case EXEC_SELECT_RANK:
14048 : : /* Blocks are handled in resolve_select_type/rank because we
14049 : : have to transform the SELECT TYPE into ASSOCIATE first. */
14050 : : break;
14051 : : case EXEC_DO_CONCURRENT:
14052 : : gfc_do_concurrent_flag = 1;
14053 : : gfc_resolve_blocks (code->block, ns);
14054 : : gfc_do_concurrent_flag = 2;
14055 : : break;
14056 : 39 : case EXEC_OMP_WORKSHARE:
14057 : 39 : omp_workshare_save = omp_workshare_flag;
14058 : 39 : omp_workshare_flag = 1;
14059 : : /* FALL THROUGH */
14060 : 300647 : default:
14061 : 300647 : gfc_resolve_blocks (code->block, ns);
14062 : 300647 : break;
14063 : : }
14064 : :
14065 : 319833 : if (omp_workshare_save != -1)
14066 : 6048 : omp_workshare_flag = omp_workshare_save;
14067 : : }
14068 : 787289 : start:
14069 : 1113579 : t = true;
14070 : 1113579 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
14071 : 1112196 : t = gfc_resolve_expr (code->expr1);
14072 : :
14073 : 1113579 : forall_flag = forall_save;
14074 : 1113579 : gfc_do_concurrent_flag = do_concurrent_save;
14075 : :
14076 : 1113579 : if (!gfc_resolve_expr (code->expr2))
14077 : 609 : t = false;
14078 : :
14079 : 1113579 : if (code->op == EXEC_ALLOCATE
14080 : 1113579 : && !gfc_resolve_expr (code->expr3))
14081 : : t = false;
14082 : :
14083 : 1113579 : switch (code->op)
14084 : : {
14085 : : case EXEC_NOP:
14086 : : case EXEC_END_BLOCK:
14087 : : case EXEC_END_NESTED_BLOCK:
14088 : : case EXEC_CYCLE:
14089 : : case EXEC_PAUSE:
14090 : : break;
14091 : :
14092 : 213758 : case EXEC_STOP:
14093 : 213758 : case EXEC_ERROR_STOP:
14094 : 213758 : if (code->expr2 != NULL
14095 : 37 : && (code->expr2->ts.type != BT_LOGICAL
14096 : 37 : || code->expr2->rank != 0))
14097 : 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
14098 : : &code->expr2->where);
14099 : : break;
14100 : :
14101 : : case EXEC_EXIT:
14102 : : case EXEC_CONTINUE:
14103 : : case EXEC_DT_END:
14104 : : case EXEC_ASSIGN_CALL:
14105 : : break;
14106 : :
14107 : 50 : case EXEC_CRITICAL:
14108 : 50 : resolve_critical (code);
14109 : 50 : break;
14110 : :
14111 : 747 : case EXEC_SYNC_ALL:
14112 : 747 : case EXEC_SYNC_IMAGES:
14113 : 747 : case EXEC_SYNC_MEMORY:
14114 : 747 : resolve_sync (code);
14115 : 747 : break;
14116 : :
14117 : 136 : case EXEC_LOCK:
14118 : 136 : case EXEC_UNLOCK:
14119 : 136 : case EXEC_EVENT_POST:
14120 : 136 : case EXEC_EVENT_WAIT:
14121 : 136 : resolve_lock_unlock_event (code);
14122 : 136 : break;
14123 : :
14124 : : case EXEC_FAIL_IMAGE:
14125 : : break;
14126 : :
14127 : 107 : case EXEC_FORM_TEAM:
14128 : 107 : resolve_form_team (code);
14129 : 107 : break;
14130 : :
14131 : 66 : case EXEC_CHANGE_TEAM:
14132 : 66 : resolve_change_team (code);
14133 : 66 : break;
14134 : :
14135 : 64 : case EXEC_END_TEAM:
14136 : 64 : resolve_end_team (code);
14137 : 64 : break;
14138 : :
14139 : 22 : case EXEC_SYNC_TEAM:
14140 : 22 : resolve_sync_team (code);
14141 : 22 : break;
14142 : :
14143 : 1420 : case EXEC_ENTRY:
14144 : : /* Keep track of which entry we are up to. */
14145 : 1420 : current_entry_id = code->ext.entry->id;
14146 : 1420 : break;
14147 : :
14148 : 450 : case EXEC_WHERE:
14149 : 450 : resolve_where (code, NULL);
14150 : 450 : break;
14151 : :
14152 : 1250 : case EXEC_GOTO:
14153 : 1250 : if (code->expr1 != NULL)
14154 : : {
14155 : 78 : if (code->expr1->expr_type != EXPR_VARIABLE
14156 : 76 : || code->expr1->ts.type != BT_INTEGER
14157 : 76 : || (code->expr1->ref
14158 : 1 : && code->expr1->ref->type == REF_ARRAY)
14159 : 75 : || code->expr1->symtree == NULL
14160 : 75 : || (code->expr1->symtree->n.sym
14161 : 75 : && (code->expr1->symtree->n.sym->attr.flavor
14162 : 75 : == FL_PARAMETER)))
14163 : 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
14164 : : "scalar INTEGER variable", &code->expr1->where);
14165 : 74 : else if (code->expr1->symtree->n.sym
14166 : 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
14167 : 1 : gfc_error ("Variable %qs has not been assigned a target "
14168 : : "label at %L", code->expr1->symtree->n.sym->name,
14169 : : &code->expr1->where);
14170 : : }
14171 : : else
14172 : 1172 : resolve_branch (code->label1, code);
14173 : : break;
14174 : :
14175 : 3124 : case EXEC_RETURN:
14176 : 3124 : if (code->expr1 != NULL
14177 : 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
14178 : 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
14179 : : "INTEGER return specifier", &code->expr1->where);
14180 : : break;
14181 : :
14182 : : case EXEC_INIT_ASSIGN:
14183 : : case EXEC_END_PROCEDURE:
14184 : : break;
14185 : :
14186 : 282204 : case EXEC_ASSIGN:
14187 : 282204 : if (!t)
14188 : : break;
14189 : :
14190 : 281557 : if (flag_coarray == GFC_FCOARRAY_LIB
14191 : 281557 : && gfc_is_coindexed (code->expr1))
14192 : : {
14193 : : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
14194 : : coindexed variable. */
14195 : 390 : code->op = EXEC_CALL;
14196 : 390 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
14197 : : true);
14198 : 390 : code->resolved_sym = code->symtree->n.sym;
14199 : 390 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
14200 : 390 : code->resolved_sym->attr.intrinsic = 1;
14201 : 390 : code->resolved_sym->attr.subroutine = 1;
14202 : 390 : code->resolved_isym
14203 : 390 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
14204 : 390 : gfc_commit_symbol (code->resolved_sym);
14205 : 390 : code->ext.actual = gfc_get_actual_arglist ();
14206 : 390 : code->ext.actual->expr = code->expr1;
14207 : 390 : code->ext.actual->next = gfc_get_actual_arglist ();
14208 : 390 : code->ext.actual->next->expr = code->expr2;
14209 : :
14210 : 390 : code->expr1 = NULL;
14211 : 390 : code->expr2 = NULL;
14212 : 390 : break;
14213 : : }
14214 : :
14215 : 281167 : if (code->expr1->ts.type == BT_CLASS)
14216 : 1019 : gfc_find_vtab (&code->expr2->ts);
14217 : :
14218 : : /* If this is a pointer function in an lvalue variable context,
14219 : : the new code will have to be resolved afresh. This is also the
14220 : : case with an error, where the code is transformed into NOP to
14221 : : prevent ICEs downstream. */
14222 : 281167 : if (resolve_ptr_fcn_assign (&code, ns)
14223 : 281167 : || code->op == EXEC_NOP)
14224 : 205 : goto start;
14225 : :
14226 : 280962 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
14227 : 280962 : _("assignment")))
14228 : : break;
14229 : :
14230 : 280924 : if (resolve_ordinary_assign (code, ns))
14231 : : {
14232 : 776 : if (omp_workshare_flag)
14233 : : {
14234 : 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
14235 : 1 : "at %L", &code->loc);
14236 : 1 : break;
14237 : : }
14238 : 775 : if (code->op == EXEC_COMPCALL)
14239 : 416 : goto compcall;
14240 : : else
14241 : 359 : goto call;
14242 : : }
14243 : :
14244 : : /* Check for dependencies in deferred character length array
14245 : : assignments and generate a temporary, if necessary. */
14246 : 280148 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
14247 : : break;
14248 : :
14249 : : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
14250 : 280126 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
14251 : 6867 : && code->expr1->ts.u.derived
14252 : 6867 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
14253 : 188 : generate_component_assignments (&code, ns);
14254 : 279938 : else if (code->op == EXEC_ASSIGN)
14255 : : {
14256 : 279938 : if (gfc_may_be_finalized (code->expr1->ts))
14257 : 1163 : code->expr1->must_finalize = 1;
14258 : 279938 : if (code->expr2->expr_type == EXPR_ARRAY
14259 : 279938 : && gfc_may_be_finalized (code->expr2->ts))
14260 : 43 : code->expr2->must_finalize = 1;
14261 : : }
14262 : :
14263 : : break;
14264 : :
14265 : 126 : case EXEC_LABEL_ASSIGN:
14266 : 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
14267 : 0 : gfc_error ("Label %d referenced at %L is never defined",
14268 : : code->label1->value, &code->label1->where);
14269 : 126 : if (t
14270 : 126 : && (code->expr1->expr_type != EXPR_VARIABLE
14271 : 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
14272 : 126 : || code->expr1->symtree->n.sym->ts.kind
14273 : 126 : != gfc_default_integer_kind
14274 : 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
14275 : 125 : || code->expr1->symtree->n.sym->as != NULL))
14276 : 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
14277 : : "default INTEGER variable", &code->expr1->where);
14278 : : break;
14279 : :
14280 : 10360 : case EXEC_POINTER_ASSIGN:
14281 : 10360 : {
14282 : 10360 : gfc_expr* e;
14283 : :
14284 : 10360 : if (!t)
14285 : : break;
14286 : :
14287 : : /* This is both a variable definition and pointer assignment
14288 : : context, so check both of them. For rank remapping, a final
14289 : : array ref may be present on the LHS and fool gfc_expr_attr
14290 : : used in gfc_check_vardef_context. Remove it. */
14291 : 10355 : e = remove_last_array_ref (code->expr1);
14292 : 20710 : t = gfc_check_vardef_context (e, true, false, false,
14293 : 10355 : _("pointer assignment"));
14294 : 10355 : if (t)
14295 : 10334 : t = gfc_check_vardef_context (e, false, false, false,
14296 : 10334 : _("pointer assignment"));
14297 : 10355 : gfc_free_expr (e);
14298 : :
14299 : 1123594 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
14300 : :
14301 : 10221 : if (!t)
14302 : : break;
14303 : :
14304 : : /* Assigning a class object always is a regular assign. */
14305 : 10221 : if (code->expr2->ts.type == BT_CLASS
14306 : 565 : && code->expr1->ts.type == BT_CLASS
14307 : 474 : && CLASS_DATA (code->expr2)
14308 : 473 : && !CLASS_DATA (code->expr2)->attr.dimension
14309 : 10840 : && !(gfc_expr_attr (code->expr1).proc_pointer
14310 : 54 : && code->expr2->expr_type == EXPR_VARIABLE
14311 : 42 : && code->expr2->symtree->n.sym->attr.flavor
14312 : 42 : == FL_PROCEDURE))
14313 : 324 : code->op = EXEC_ASSIGN;
14314 : : break;
14315 : : }
14316 : :
14317 : 72 : case EXEC_ARITHMETIC_IF:
14318 : 72 : {
14319 : 72 : gfc_expr *e = code->expr1;
14320 : :
14321 : 72 : gfc_resolve_expr (e);
14322 : 72 : if (e->expr_type == EXPR_NULL)
14323 : 1 : gfc_error ("Invalid NULL at %L", &e->where);
14324 : :
14325 : 72 : if (t && (e->rank > 0
14326 : 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
14327 : 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
14328 : : "REAL or INTEGER expression", &e->where);
14329 : :
14330 : 72 : resolve_branch (code->label1, code);
14331 : 72 : resolve_branch (code->label2, code);
14332 : 72 : resolve_branch (code->label3, code);
14333 : : }
14334 : 72 : break;
14335 : :
14336 : 226686 : case EXEC_IF:
14337 : 226686 : if (t && code->expr1 != NULL
14338 : 0 : && (code->expr1->ts.type != BT_LOGICAL
14339 : 0 : || code->expr1->rank != 0))
14340 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
14341 : : &code->expr1->where);
14342 : : break;
14343 : :
14344 : 77821 : case EXEC_CALL:
14345 : 77821 : call:
14346 : 77821 : resolve_call (code);
14347 : 77821 : break;
14348 : :
14349 : 1676 : case EXEC_COMPCALL:
14350 : 1676 : compcall:
14351 : 1676 : resolve_typebound_subroutine (code);
14352 : 1676 : break;
14353 : :
14354 : 123 : case EXEC_CALL_PPC:
14355 : 123 : resolve_ppc_call (code);
14356 : 123 : break;
14357 : :
14358 : 683 : case EXEC_SELECT:
14359 : : /* Select is complicated. Also, a SELECT construct could be
14360 : : a transformed computed GOTO. */
14361 : 683 : resolve_select (code, false);
14362 : 683 : break;
14363 : :
14364 : 2931 : case EXEC_SELECT_TYPE:
14365 : 2931 : resolve_select_type (code, ns);
14366 : 2931 : break;
14367 : :
14368 : 1018 : case EXEC_SELECT_RANK:
14369 : 1018 : resolve_select_rank (code, ns);
14370 : 1018 : break;
14371 : :
14372 : 7716 : case EXEC_BLOCK:
14373 : 7716 : resolve_block_construct (code);
14374 : 7716 : break;
14375 : :
14376 : 32440 : case EXEC_DO:
14377 : 32440 : if (code->ext.iterator != NULL)
14378 : : {
14379 : 32440 : gfc_iterator *iter = code->ext.iterator;
14380 : 32440 : if (gfc_resolve_iterator (iter, true, false))
14381 : 32426 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
14382 : : true);
14383 : : }
14384 : : break;
14385 : :
14386 : 527 : case EXEC_DO_WHILE:
14387 : 527 : if (code->expr1 == NULL)
14388 : 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
14389 : : "DO WHILE");
14390 : 527 : if (t
14391 : 527 : && (code->expr1->rank != 0
14392 : 527 : || code->expr1->ts.type != BT_LOGICAL))
14393 : 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
14394 : : "a scalar LOGICAL expression", &code->expr1->where);
14395 : : break;
14396 : :
14397 : 13866 : case EXEC_ALLOCATE:
14398 : 13866 : if (t)
14399 : 13864 : resolve_allocate_deallocate (code, "ALLOCATE");
14400 : :
14401 : : break;
14402 : :
14403 : 5815 : case EXEC_DEALLOCATE:
14404 : 5815 : if (t)
14405 : 5815 : resolve_allocate_deallocate (code, "DEALLOCATE");
14406 : :
14407 : : break;
14408 : :
14409 : 3879 : case EXEC_OPEN:
14410 : 3879 : if (!gfc_resolve_open (code->ext.open, &code->loc))
14411 : : break;
14412 : :
14413 : 3652 : resolve_branch (code->ext.open->err, code);
14414 : 3652 : break;
14415 : :
14416 : 3067 : case EXEC_CLOSE:
14417 : 3067 : if (!gfc_resolve_close (code->ext.close, &code->loc))
14418 : : break;
14419 : :
14420 : 3033 : resolve_branch (code->ext.close->err, code);
14421 : 3033 : break;
14422 : :
14423 : 2779 : case EXEC_BACKSPACE:
14424 : 2779 : case EXEC_ENDFILE:
14425 : 2779 : case EXEC_REWIND:
14426 : 2779 : case EXEC_FLUSH:
14427 : 2779 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
14428 : : break;
14429 : :
14430 : 2713 : resolve_branch (code->ext.filepos->err, code);
14431 : 2713 : break;
14432 : :
14433 : 817 : case EXEC_INQUIRE:
14434 : 817 : if (!gfc_resolve_inquire (code->ext.inquire))
14435 : : break;
14436 : :
14437 : 769 : resolve_branch (code->ext.inquire->err, code);
14438 : 769 : break;
14439 : :
14440 : 92 : case EXEC_IOLENGTH:
14441 : 92 : gcc_assert (code->ext.inquire != NULL);
14442 : 92 : if (!gfc_resolve_inquire (code->ext.inquire))
14443 : : break;
14444 : :
14445 : 90 : resolve_branch (code->ext.inquire->err, code);
14446 : 90 : break;
14447 : :
14448 : 89 : case EXEC_WAIT:
14449 : 89 : if (!gfc_resolve_wait (code->ext.wait))
14450 : : break;
14451 : :
14452 : 74 : resolve_branch (code->ext.wait->err, code);
14453 : 74 : resolve_branch (code->ext.wait->end, code);
14454 : 74 : resolve_branch (code->ext.wait->eor, code);
14455 : 74 : break;
14456 : :
14457 : 32093 : case EXEC_READ:
14458 : 32093 : case EXEC_WRITE:
14459 : 32093 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
14460 : : break;
14461 : :
14462 : 31785 : resolve_branch (code->ext.dt->err, code);
14463 : 31785 : resolve_branch (code->ext.dt->end, code);
14464 : 31785 : resolve_branch (code->ext.dt->eor, code);
14465 : 31785 : break;
14466 : :
14467 : 45886 : case EXEC_TRANSFER:
14468 : 45886 : resolve_transfer (code);
14469 : 45886 : break;
14470 : :
14471 : 2190 : case EXEC_DO_CONCURRENT:
14472 : 2190 : case EXEC_FORALL:
14473 : 2190 : resolve_forall_iterators (code->ext.concur.forall_iterator);
14474 : :
14475 : 2190 : if (code->expr1 != NULL
14476 : 730 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
14477 : 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
14478 : : "expression", &code->expr1->where);
14479 : :
14480 : 2190 : if (code->op == EXEC_DO_CONCURRENT)
14481 : 200 : resolve_locality_spec (code, ns);
14482 : : break;
14483 : :
14484 : 13160 : case EXEC_OACC_PARALLEL_LOOP:
14485 : 13160 : case EXEC_OACC_PARALLEL:
14486 : 13160 : case EXEC_OACC_KERNELS_LOOP:
14487 : 13160 : case EXEC_OACC_KERNELS:
14488 : 13160 : case EXEC_OACC_SERIAL_LOOP:
14489 : 13160 : case EXEC_OACC_SERIAL:
14490 : 13160 : case EXEC_OACC_DATA:
14491 : 13160 : case EXEC_OACC_HOST_DATA:
14492 : 13160 : case EXEC_OACC_LOOP:
14493 : 13160 : case EXEC_OACC_UPDATE:
14494 : 13160 : case EXEC_OACC_WAIT:
14495 : 13160 : case EXEC_OACC_CACHE:
14496 : 13160 : case EXEC_OACC_ENTER_DATA:
14497 : 13160 : case EXEC_OACC_EXIT_DATA:
14498 : 13160 : case EXEC_OACC_ATOMIC:
14499 : 13160 : case EXEC_OACC_DECLARE:
14500 : 13160 : gfc_resolve_oacc_directive (code, ns);
14501 : 13160 : break;
14502 : :
14503 : 16654 : case EXEC_OMP_ALLOCATE:
14504 : 16654 : case EXEC_OMP_ALLOCATORS:
14505 : 16654 : case EXEC_OMP_ASSUME:
14506 : 16654 : case EXEC_OMP_ATOMIC:
14507 : 16654 : case EXEC_OMP_BARRIER:
14508 : 16654 : case EXEC_OMP_CANCEL:
14509 : 16654 : case EXEC_OMP_CANCELLATION_POINT:
14510 : 16654 : case EXEC_OMP_CRITICAL:
14511 : 16654 : case EXEC_OMP_FLUSH:
14512 : 16654 : case EXEC_OMP_DEPOBJ:
14513 : 16654 : case EXEC_OMP_DISPATCH:
14514 : 16654 : case EXEC_OMP_DISTRIBUTE:
14515 : 16654 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14516 : 16654 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14517 : 16654 : case EXEC_OMP_DISTRIBUTE_SIMD:
14518 : 16654 : case EXEC_OMP_DO:
14519 : 16654 : case EXEC_OMP_DO_SIMD:
14520 : 16654 : case EXEC_OMP_ERROR:
14521 : 16654 : case EXEC_OMP_INTEROP:
14522 : 16654 : case EXEC_OMP_LOOP:
14523 : 16654 : case EXEC_OMP_MASTER:
14524 : 16654 : case EXEC_OMP_MASTER_TASKLOOP:
14525 : 16654 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14526 : 16654 : case EXEC_OMP_MASKED:
14527 : 16654 : case EXEC_OMP_MASKED_TASKLOOP:
14528 : 16654 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14529 : 16654 : case EXEC_OMP_METADIRECTIVE:
14530 : 16654 : case EXEC_OMP_ORDERED:
14531 : 16654 : case EXEC_OMP_SCAN:
14532 : 16654 : case EXEC_OMP_SCOPE:
14533 : 16654 : case EXEC_OMP_SECTIONS:
14534 : 16654 : case EXEC_OMP_SIMD:
14535 : 16654 : case EXEC_OMP_SINGLE:
14536 : 16654 : case EXEC_OMP_TARGET:
14537 : 16654 : case EXEC_OMP_TARGET_DATA:
14538 : 16654 : case EXEC_OMP_TARGET_ENTER_DATA:
14539 : 16654 : case EXEC_OMP_TARGET_EXIT_DATA:
14540 : 16654 : case EXEC_OMP_TARGET_PARALLEL:
14541 : 16654 : case EXEC_OMP_TARGET_PARALLEL_DO:
14542 : 16654 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14543 : 16654 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14544 : 16654 : case EXEC_OMP_TARGET_SIMD:
14545 : 16654 : case EXEC_OMP_TARGET_TEAMS:
14546 : 16654 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14547 : 16654 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14548 : 16654 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14549 : 16654 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14550 : 16654 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14551 : 16654 : case EXEC_OMP_TARGET_UPDATE:
14552 : 16654 : case EXEC_OMP_TASK:
14553 : 16654 : case EXEC_OMP_TASKGROUP:
14554 : 16654 : case EXEC_OMP_TASKLOOP:
14555 : 16654 : case EXEC_OMP_TASKLOOP_SIMD:
14556 : 16654 : case EXEC_OMP_TASKWAIT:
14557 : 16654 : case EXEC_OMP_TASKYIELD:
14558 : 16654 : case EXEC_OMP_TEAMS:
14559 : 16654 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14560 : 16654 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14561 : 16654 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14562 : 16654 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14563 : 16654 : case EXEC_OMP_TEAMS_LOOP:
14564 : 16654 : case EXEC_OMP_TILE:
14565 : 16654 : case EXEC_OMP_UNROLL:
14566 : 16654 : case EXEC_OMP_WORKSHARE:
14567 : 16654 : gfc_resolve_omp_directive (code, ns);
14568 : 16654 : break;
14569 : :
14570 : 3869 : case EXEC_OMP_PARALLEL:
14571 : 3869 : case EXEC_OMP_PARALLEL_DO:
14572 : 3869 : case EXEC_OMP_PARALLEL_DO_SIMD:
14573 : 3869 : case EXEC_OMP_PARALLEL_LOOP:
14574 : 3869 : case EXEC_OMP_PARALLEL_MASKED:
14575 : 3869 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14576 : 3869 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14577 : 3869 : case EXEC_OMP_PARALLEL_MASTER:
14578 : 3869 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14579 : 3869 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14580 : 3869 : case EXEC_OMP_PARALLEL_SECTIONS:
14581 : 3869 : case EXEC_OMP_PARALLEL_WORKSHARE:
14582 : 3869 : omp_workshare_save = omp_workshare_flag;
14583 : 3869 : omp_workshare_flag = 0;
14584 : 3869 : gfc_resolve_omp_directive (code, ns);
14585 : 3869 : omp_workshare_flag = omp_workshare_save;
14586 : 3869 : break;
14587 : :
14588 : 0 : default:
14589 : 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
14590 : : }
14591 : : }
14592 : :
14593 : 664526 : cs_base = frame.prev;
14594 : 664526 : }
14595 : :
14596 : :
14597 : : /* Resolve initial values and make sure they are compatible with
14598 : : the variable. */
14599 : :
14600 : : static void
14601 : 1808137 : resolve_values (gfc_symbol *sym)
14602 : : {
14603 : 1808137 : bool t;
14604 : :
14605 : 1808137 : if (sym->value == NULL)
14606 : : return;
14607 : :
14608 : 408592 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
14609 : 4 : gfc_warning (OPT_Wdeprecated_declarations,
14610 : : "Using parameter %qs declared at %L is deprecated",
14611 : : sym->name, &sym->declared_at);
14612 : :
14613 : 408592 : if (sym->value->expr_type == EXPR_STRUCTURE)
14614 : 38497 : t= resolve_structure_cons (sym->value, 1);
14615 : : else
14616 : 370095 : t = gfc_resolve_expr (sym->value);
14617 : :
14618 : 408592 : if (!t)
14619 : : return;
14620 : :
14621 : 408590 : gfc_check_assign_symbol (sym, NULL, sym->value);
14622 : : }
14623 : :
14624 : :
14625 : : /* Verify any BIND(C) derived types in the namespace so we can report errors
14626 : : for them once, rather than for each variable declared of that type. */
14627 : :
14628 : : static void
14629 : 1780395 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
14630 : : {
14631 : 1780395 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
14632 : 80314 : && derived_sym->attr.is_bind_c == 1)
14633 : 26412 : verify_bind_c_derived_type (derived_sym);
14634 : :
14635 : 1780395 : return;
14636 : : }
14637 : :
14638 : :
14639 : : /* Check the interfaces of DTIO procedures associated with derived
14640 : : type 'sym'. These procedures can either have typebound bindings or
14641 : : can appear in DTIO generic interfaces. */
14642 : :
14643 : : static void
14644 : 1809105 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
14645 : : {
14646 : 1809105 : if (!sym || sym->attr.flavor != FL_DERIVED)
14647 : : return;
14648 : :
14649 : 89153 : gfc_check_dtio_interfaces (sym);
14650 : :
14651 : 89153 : return;
14652 : : }
14653 : :
14654 : : /* Verify that any binding labels used in a given namespace do not collide
14655 : : with the names or binding labels of any global symbols. Multiple INTERFACE
14656 : : for the same procedure are permitted. Abstract interfaces and dummy
14657 : : arguments are not checked. */
14658 : :
14659 : : static void
14660 : 1809105 : gfc_verify_binding_labels (gfc_symbol *sym)
14661 : : {
14662 : 1809105 : gfc_gsymbol *gsym;
14663 : 1809105 : const char *module;
14664 : :
14665 : 1809105 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
14666 : 60477 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label
14667 : 33149 : || sym->attr.abstract || sym->attr.dummy)
14668 : : return;
14669 : :
14670 : 33049 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
14671 : :
14672 : 33049 : if (sym->module)
14673 : : module = sym->module;
14674 : 11956 : else if (sym->ns && sym->ns->proc_name
14675 : 11956 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
14676 : 4502 : module = sym->ns->proc_name->name;
14677 : 7454 : else if (sym->ns && sym->ns->parent
14678 : 358 : && sym->ns && sym->ns->parent->proc_name
14679 : 358 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
14680 : 272 : module = sym->ns->parent->proc_name->name;
14681 : : else
14682 : : module = NULL;
14683 : :
14684 : 33049 : if (!gsym
14685 : 11323 : || (!gsym->defined
14686 : 8487 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
14687 : : {
14688 : 21726 : if (!gsym)
14689 : 21726 : gsym = gfc_get_gsymbol (sym->binding_label, true);
14690 : 30213 : gsym->where = sym->declared_at;
14691 : 30213 : gsym->sym_name = sym->name;
14692 : 30213 : gsym->binding_label = sym->binding_label;
14693 : 30213 : gsym->ns = sym->ns;
14694 : 30213 : gsym->mod_name = module;
14695 : 30213 : if (sym->attr.function)
14696 : 19382 : gsym->type = GSYM_FUNCTION;
14697 : 10831 : else if (sym->attr.subroutine)
14698 : 10692 : gsym->type = GSYM_SUBROUTINE;
14699 : : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
14700 : 30213 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
14701 : 30213 : return;
14702 : : }
14703 : :
14704 : 2836 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
14705 : : {
14706 : 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
14707 : : "identifier as entity at %L", sym->name,
14708 : : sym->binding_label, &sym->declared_at, &gsym->where);
14709 : : /* Clear the binding label to prevent checking multiple times. */
14710 : 1 : sym->binding_label = NULL;
14711 : 1 : return;
14712 : : }
14713 : :
14714 : 2835 : if (sym->attr.flavor == FL_VARIABLE && module
14715 : 37 : && (strcmp (module, gsym->mod_name) != 0
14716 : 35 : || strcmp (sym->name, gsym->sym_name) != 0))
14717 : : {
14718 : : /* This can only happen if the variable is defined in a module - if it
14719 : : isn't the same module, reject it. */
14720 : 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
14721 : : "uses the same global identifier as entity at %L from module %qs",
14722 : : sym->name, module, sym->binding_label,
14723 : : &sym->declared_at, &gsym->where, gsym->mod_name);
14724 : 3 : sym->binding_label = NULL;
14725 : 3 : return;
14726 : : }
14727 : :
14728 : 2832 : if ((sym->attr.function || sym->attr.subroutine)
14729 : 2796 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
14730 : 2794 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
14731 : 2481 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
14732 : 2087 : && (module != gsym->mod_name
14733 : 2083 : || strcmp (gsym->sym_name, sym->name) != 0
14734 : 2083 : || (module && strcmp (module, gsym->mod_name) != 0)))
14735 : : {
14736 : : /* Print an error if the procedure is defined multiple times; we have to
14737 : : exclude references to the same procedure via module association or
14738 : : multiple checks for the same procedure. */
14739 : 4 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
14740 : : "global identifier as entity at %L", sym->name,
14741 : : sym->binding_label, &sym->declared_at, &gsym->where);
14742 : 4 : sym->binding_label = NULL;
14743 : : }
14744 : : }
14745 : :
14746 : :
14747 : : /* Resolve an index expression. */
14748 : :
14749 : : static bool
14750 : 262009 : resolve_index_expr (gfc_expr *e)
14751 : : {
14752 : 262009 : if (!gfc_resolve_expr (e))
14753 : : return false;
14754 : :
14755 : 261999 : if (!gfc_simplify_expr (e, 0))
14756 : : return false;
14757 : :
14758 : 261997 : if (!gfc_specification_expr (e))
14759 : : return false;
14760 : :
14761 : : return true;
14762 : : }
14763 : :
14764 : :
14765 : : /* Resolve a charlen structure. */
14766 : :
14767 : : static bool
14768 : 100911 : resolve_charlen (gfc_charlen *cl)
14769 : : {
14770 : 100911 : int k;
14771 : 100911 : bool saved_specification_expr;
14772 : :
14773 : 100911 : if (cl->resolved)
14774 : : return true;
14775 : :
14776 : 92619 : cl->resolved = 1;
14777 : 92619 : saved_specification_expr = specification_expr;
14778 : 92619 : specification_expr = true;
14779 : :
14780 : 92619 : if (cl->length_from_typespec)
14781 : : {
14782 : 1102 : if (!gfc_resolve_expr (cl->length))
14783 : : {
14784 : 1 : specification_expr = saved_specification_expr;
14785 : 1 : return false;
14786 : : }
14787 : :
14788 : 1101 : if (!gfc_simplify_expr (cl->length, 0))
14789 : : {
14790 : 0 : specification_expr = saved_specification_expr;
14791 : 0 : return false;
14792 : : }
14793 : :
14794 : : /* cl->length has been resolved. It should have an integer type. */
14795 : 1101 : if (cl->length
14796 : 1100 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
14797 : : {
14798 : 4 : gfc_error ("Scalar INTEGER expression expected at %L",
14799 : : &cl->length->where);
14800 : 4 : return false;
14801 : : }
14802 : : }
14803 : : else
14804 : : {
14805 : 91517 : if (!resolve_index_expr (cl->length))
14806 : : {
14807 : 19 : specification_expr = saved_specification_expr;
14808 : 19 : return false;
14809 : : }
14810 : : }
14811 : :
14812 : : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
14813 : : a negative value, the length of character entities declared is zero. */
14814 : 92595 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14815 : 55335 : && mpz_sgn (cl->length->value.integer) < 0)
14816 : 0 : gfc_replace_expr (cl->length,
14817 : : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
14818 : :
14819 : : /* Check that the character length is not too large. */
14820 : 92595 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
14821 : 92595 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14822 : 55335 : && cl->length->ts.type == BT_INTEGER
14823 : 55335 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
14824 : : {
14825 : 4 : gfc_error ("String length at %L is too large", &cl->length->where);
14826 : 4 : specification_expr = saved_specification_expr;
14827 : 4 : return false;
14828 : : }
14829 : :
14830 : 92591 : specification_expr = saved_specification_expr;
14831 : 92591 : return true;
14832 : : }
14833 : :
14834 : :
14835 : : /* Test for non-constant shape arrays. */
14836 : :
14837 : : static bool
14838 : 115753 : is_non_constant_shape_array (gfc_symbol *sym)
14839 : : {
14840 : 115753 : gfc_expr *e;
14841 : 115753 : int i;
14842 : 115753 : bool not_constant;
14843 : :
14844 : 115753 : not_constant = false;
14845 : 115753 : if (sym->as != NULL)
14846 : : {
14847 : : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
14848 : : has not been simplified; parameter array references. Do the
14849 : : simplification now. */
14850 : 153299 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
14851 : : {
14852 : 88531 : if (i == GFC_MAX_DIMENSIONS)
14853 : : break;
14854 : :
14855 : 88529 : e = sym->as->lower[i];
14856 : 88529 : if (e && (!resolve_index_expr(e)
14857 : 85752 : || !gfc_is_constant_expr (e)))
14858 : : not_constant = true;
14859 : 88529 : e = sym->as->upper[i];
14860 : 88529 : if (e && (!resolve_index_expr(e)
14861 : 84712 : || !gfc_is_constant_expr (e)))
14862 : : not_constant = true;
14863 : : }
14864 : : }
14865 : 115753 : return not_constant;
14866 : : }
14867 : :
14868 : : /* Given a symbol and an initialization expression, add code to initialize
14869 : : the symbol to the function entry. */
14870 : : static void
14871 : 1972 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
14872 : : {
14873 : 1972 : gfc_expr *lval;
14874 : 1972 : gfc_code *init_st;
14875 : 1972 : gfc_namespace *ns = sym->ns;
14876 : :
14877 : 1972 : if (sym->attr.function && sym->result == sym
14878 : 322 : && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
14879 : : {
14880 : 19 : gfc_free_expr (init);
14881 : 19 : return;
14882 : : }
14883 : :
14884 : : /* Search for the function namespace if this is a contained
14885 : : function without an explicit result. */
14886 : 1953 : if (sym->attr.function && sym == sym->result
14887 : 303 : && sym->name != sym->ns->proc_name->name)
14888 : : {
14889 : 302 : ns = ns->contained;
14890 : 1365 : for (;ns; ns = ns->sibling)
14891 : 1299 : if (strcmp (ns->proc_name->name, sym->name) == 0)
14892 : : break;
14893 : : }
14894 : :
14895 : 1953 : if (ns == NULL)
14896 : : {
14897 : 66 : gfc_free_expr (init);
14898 : 66 : return;
14899 : : }
14900 : :
14901 : : /* Build an l-value expression for the result. */
14902 : 1887 : lval = gfc_lval_expr_from_sym (sym);
14903 : :
14904 : : /* Add the code at scope entry. */
14905 : 1887 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
14906 : 1887 : init_st->next = ns->code;
14907 : 1887 : ns->code = init_st;
14908 : :
14909 : : /* Assign the default initializer to the l-value. */
14910 : 1887 : init_st->loc = sym->declared_at;
14911 : 1887 : init_st->expr1 = lval;
14912 : 1887 : init_st->expr2 = init;
14913 : : }
14914 : :
14915 : :
14916 : : /* Whether or not we can generate a default initializer for a symbol. */
14917 : :
14918 : : static bool
14919 : 29192 : can_generate_init (gfc_symbol *sym)
14920 : : {
14921 : 29192 : symbol_attribute *a;
14922 : 29192 : if (!sym)
14923 : : return false;
14924 : 29192 : a = &sym->attr;
14925 : :
14926 : : /* These symbols should never have a default initialization. */
14927 : 47942 : return !(
14928 : 29192 : a->allocatable
14929 : 29192 : || a->external
14930 : 28043 : || a->pointer
14931 : 28043 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
14932 : 5538 : && (CLASS_DATA (sym)->attr.class_pointer
14933 : 3610 : || CLASS_DATA (sym)->attr.proc_pointer))
14934 : 26115 : || a->in_equivalence
14935 : 25994 : || a->in_common
14936 : 25947 : || a->data
14937 : 25769 : || sym->module
14938 : 22017 : || a->cray_pointee
14939 : 21955 : || a->cray_pointer
14940 : 21955 : || sym->assoc
14941 : 19377 : || (!a->referenced && !a->result)
14942 : 18750 : || (a->dummy && (a->intent != INTENT_OUT
14943 : 1061 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
14944 : 18750 : || (a->function && sym != sym->result)
14945 : : );
14946 : : }
14947 : :
14948 : :
14949 : : /* Assign the default initializer to a derived type variable or result. */
14950 : :
14951 : : static void
14952 : 11169 : apply_default_init (gfc_symbol *sym)
14953 : : {
14954 : 11169 : gfc_expr *init = NULL;
14955 : :
14956 : 11169 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
14957 : : return;
14958 : :
14959 : 10961 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
14960 : 10154 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
14961 : :
14962 : 10961 : if (init == NULL && sym->ts.type != BT_CLASS)
14963 : : return;
14964 : :
14965 : 1590 : build_init_assign (sym, init);
14966 : 1590 : sym->attr.referenced = 1;
14967 : : }
14968 : :
14969 : :
14970 : : /* Build an initializer for a local. Returns null if the symbol should not have
14971 : : a default initialization. */
14972 : :
14973 : : static gfc_expr *
14974 : 201014 : build_default_init_expr (gfc_symbol *sym)
14975 : : {
14976 : : /* These symbols should never have a default initialization. */
14977 : 201014 : if (sym->attr.allocatable
14978 : 187587 : || sym->attr.external
14979 : 187587 : || sym->attr.dummy
14980 : 123321 : || sym->attr.pointer
14981 : 115264 : || sym->attr.in_equivalence
14982 : 112888 : || sym->attr.in_common
14983 : 109835 : || sym->attr.data
14984 : 107539 : || sym->module
14985 : 105166 : || sym->attr.cray_pointee
14986 : 104865 : || sym->attr.cray_pointer
14987 : 104563 : || sym->assoc)
14988 : : return NULL;
14989 : :
14990 : : /* Get the appropriate init expression. */
14991 : 99998 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
14992 : : }
14993 : :
14994 : : /* Add an initialization expression to a local variable. */
14995 : : static void
14996 : 201014 : apply_default_init_local (gfc_symbol *sym)
14997 : : {
14998 : 201014 : gfc_expr *init = NULL;
14999 : :
15000 : : /* The symbol should be a variable or a function return value. */
15001 : 201014 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
15002 : 201014 : || (sym->attr.function && sym->result != sym))
15003 : : return;
15004 : :
15005 : : /* Try to build the initializer expression. If we can't initialize
15006 : : this symbol, then init will be NULL. */
15007 : 201014 : init = build_default_init_expr (sym);
15008 : 201014 : if (init == NULL)
15009 : : return;
15010 : :
15011 : : /* For saved variables, we don't want to add an initializer at function
15012 : : entry, so we just add a static initializer. Note that automatic variables
15013 : : are stack allocated even with -fno-automatic; we have also to exclude
15014 : : result variable, which are also nonstatic. */
15015 : 419 : if (!sym->attr.automatic
15016 : 419 : && (sym->attr.save || sym->ns->save_all
15017 : 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
15018 : 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
15019 : 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
15020 : : {
15021 : : /* Don't clobber an existing initializer! */
15022 : 37 : gcc_assert (sym->value == NULL);
15023 : 37 : sym->value = init;
15024 : 37 : return;
15025 : : }
15026 : :
15027 : 382 : build_init_assign (sym, init);
15028 : : }
15029 : :
15030 : :
15031 : : /* Resolution of common features of flavors variable and procedure. */
15032 : :
15033 : : static bool
15034 : 949767 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
15035 : : {
15036 : 949767 : gfc_array_spec *as;
15037 : :
15038 : 949767 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15039 : 18803 : && sym->ts.u.derived && CLASS_DATA (sym))
15040 : 18797 : as = CLASS_DATA (sym)->as;
15041 : : else
15042 : 930970 : as = sym->as;
15043 : :
15044 : : /* Constraints on deferred shape variable. */
15045 : 949767 : if (as == NULL || as->type != AS_DEFERRED)
15046 : : {
15047 : 925903 : bool pointer, allocatable, dimension;
15048 : :
15049 : 925903 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
15050 : 15675 : && sym->ts.u.derived && CLASS_DATA (sym))
15051 : : {
15052 : 15669 : pointer = CLASS_DATA (sym)->attr.class_pointer;
15053 : 15669 : allocatable = CLASS_DATA (sym)->attr.allocatable;
15054 : 15669 : dimension = CLASS_DATA (sym)->attr.dimension;
15055 : : }
15056 : : else
15057 : : {
15058 : 910234 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
15059 : 910234 : allocatable = sym->attr.allocatable;
15060 : 910234 : dimension = sym->attr.dimension;
15061 : : }
15062 : :
15063 : 925903 : if (allocatable)
15064 : : {
15065 : 7941 : if (dimension
15066 : 7941 : && as
15067 : 524 : && as->type != AS_ASSUMED_RANK
15068 : 5 : && !sym->attr.select_rank_temporary)
15069 : : {
15070 : 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
15071 : : "shape or assumed rank", sym->name, &sym->declared_at);
15072 : 3 : return false;
15073 : : }
15074 : 7938 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
15075 : : "%qs at %L may not be ALLOCATABLE",
15076 : : sym->name, &sym->declared_at))
15077 : : return false;
15078 : : }
15079 : :
15080 : 925899 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
15081 : : {
15082 : 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
15083 : : "assumed rank", sym->name, &sym->declared_at);
15084 : 4 : sym->error = 1;
15085 : 4 : return false;
15086 : : }
15087 : : }
15088 : : else
15089 : : {
15090 : 23864 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
15091 : 4558 : && sym->ts.type != BT_CLASS && !sym->assoc)
15092 : : {
15093 : 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
15094 : : sym->name, &sym->declared_at);
15095 : 3 : return false;
15096 : : }
15097 : : }
15098 : :
15099 : : /* Constraints on polymorphic variables. */
15100 : 949756 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
15101 : : {
15102 : : /* F03:C502. */
15103 : 18141 : if (sym->attr.class_ok
15104 : 18085 : && sym->ts.u.derived
15105 : 18080 : && !sym->attr.select_type_temporary
15106 : 17019 : && !UNLIMITED_POLY (sym)
15107 : 14543 : && CLASS_DATA (sym)
15108 : 14542 : && CLASS_DATA (sym)->ts.u.derived
15109 : 32682 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
15110 : : {
15111 : 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
15112 : 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
15113 : : &sym->declared_at);
15114 : 5 : return false;
15115 : : }
15116 : :
15117 : : /* F03:C509. */
15118 : : /* Assume that use associated symbols were checked in the module ns.
15119 : : Class-variables that are associate-names are also something special
15120 : : and excepted from the test. */
15121 : 18136 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
15122 : 54 : && !sym->attr.select_type_temporary
15123 : 54 : && !sym->attr.select_rank_temporary)
15124 : : {
15125 : 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
15126 : : "or pointer", sym->name, &sym->declared_at);
15127 : 54 : return false;
15128 : : }
15129 : : }
15130 : :
15131 : : return true;
15132 : : }
15133 : :
15134 : :
15135 : : /* Additional checks for symbols with flavor variable and derived
15136 : : type. To be called from resolve_fl_variable. */
15137 : :
15138 : : static bool
15139 : 79826 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
15140 : : {
15141 : 79826 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
15142 : :
15143 : : /* Check to see if a derived type is blocked from being host
15144 : : associated by the presence of another class I symbol in the same
15145 : : namespace. 14.6.1.3 of the standard and the discussion on
15146 : : comp.lang.fortran. */
15147 : 79826 : if (sym->ts.u.derived
15148 : 79821 : && sym->ns != sym->ts.u.derived->ns
15149 : 45910 : && !sym->ts.u.derived->attr.use_assoc
15150 : 16839 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
15151 : : {
15152 : 15891 : gfc_symbol *s;
15153 : 15891 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
15154 : 15891 : if (s && s->attr.generic)
15155 : 2 : s = gfc_find_dt_in_generic (s);
15156 : 15891 : if (s && !gfc_fl_struct (s->attr.flavor))
15157 : : {
15158 : 2 : gfc_error ("The type %qs cannot be host associated at %L "
15159 : : "because it is blocked by an incompatible object "
15160 : : "of the same name declared at %L",
15161 : 2 : sym->ts.u.derived->name, &sym->declared_at,
15162 : : &s->declared_at);
15163 : 2 : return false;
15164 : : }
15165 : : }
15166 : :
15167 : : /* 4th constraint in section 11.3: "If an object of a type for which
15168 : : component-initialization is specified (R429) appears in the
15169 : : specification-part of a module and does not have the ALLOCATABLE
15170 : : or POINTER attribute, the object shall have the SAVE attribute."
15171 : :
15172 : : The check for initializers is performed with
15173 : : gfc_has_default_initializer because gfc_default_initializer generates
15174 : : a hidden default for allocatable components. */
15175 : 79187 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
15176 : 17813 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15177 : 356 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
15178 : 20 : && !sym->attr.pointer && !sym->attr.allocatable
15179 : 20 : && gfc_has_default_initializer (sym->ts.u.derived)
15180 : 79833 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
15181 : : "%qs at %L, needed due to the default "
15182 : : "initialization", sym->name, &sym->declared_at))
15183 : : return false;
15184 : :
15185 : : /* Assign default initializer. */
15186 : 79822 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
15187 : 73766 : && (!no_init_flag
15188 : 57733 : || (sym->attr.intent == INTENT_OUT
15189 : 3179 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
15190 : 19038 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
15191 : :
15192 : : return true;
15193 : : }
15194 : :
15195 : :
15196 : : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
15197 : : except in the declaration of an entity or component that has the POINTER
15198 : : or ALLOCATABLE attribute. */
15199 : :
15200 : : static bool
15201 : 1479312 : deferred_requirements (gfc_symbol *sym)
15202 : : {
15203 : 1479312 : if (sym->ts.deferred
15204 : 7686 : && !(sym->attr.pointer
15205 : 2326 : || sym->attr.allocatable
15206 : 92 : || sym->attr.associate_var
15207 : 7 : || sym->attr.omp_udr_artificial_var))
15208 : : {
15209 : : /* If a function has a result variable, only check the variable. */
15210 : 7 : if (sym->result && sym->name != sym->result->name)
15211 : : return true;
15212 : :
15213 : 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
15214 : : "requires either the POINTER or ALLOCATABLE attribute",
15215 : : sym->name, &sym->declared_at);
15216 : 6 : return false;
15217 : : }
15218 : : return true;
15219 : : }
15220 : :
15221 : :
15222 : : /* Resolve symbols with flavor variable. */
15223 : :
15224 : : static bool
15225 : 637866 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
15226 : : {
15227 : 637866 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
15228 : : "SAVE attribute");
15229 : :
15230 : 637866 : if (!resolve_fl_var_and_proc (sym, mp_flag))
15231 : : return false;
15232 : :
15233 : : /* Set this flag to check that variables are parameters of all entries.
15234 : : This check is effected by the call to gfc_resolve_expr through
15235 : : is_non_constant_shape_array. */
15236 : 637806 : bool saved_specification_expr = specification_expr;
15237 : 637806 : specification_expr = true;
15238 : :
15239 : 637806 : if (sym->ns->proc_name
15240 : 637719 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15241 : 632892 : || sym->ns->proc_name->attr.is_main_program)
15242 : 80964 : && !sym->attr.use_assoc
15243 : 77918 : && !sym->attr.allocatable
15244 : 72382 : && !sym->attr.pointer
15245 : 706559 : && is_non_constant_shape_array (sym))
15246 : : {
15247 : : /* F08:C541. The shape of an array defined in a main program or module
15248 : : * needs to be constant. */
15249 : 3 : gfc_error ("The module or main program array %qs at %L must "
15250 : : "have constant shape", sym->name, &sym->declared_at);
15251 : 3 : specification_expr = saved_specification_expr;
15252 : 3 : return false;
15253 : : }
15254 : :
15255 : : /* Constraints on deferred type parameter. */
15256 : 637803 : if (!deferred_requirements (sym))
15257 : : return false;
15258 : :
15259 : 637799 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
15260 : : {
15261 : : /* Make sure that character string variables with assumed length are
15262 : : dummy arguments. */
15263 : 35415 : gfc_expr *e = NULL;
15264 : :
15265 : 35415 : if (sym->ts.u.cl)
15266 : 35415 : e = sym->ts.u.cl->length;
15267 : : else
15268 : : return false;
15269 : :
15270 : 35415 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
15271 : 2550 : && !sym->ts.deferred && !sym->attr.select_type_temporary
15272 : 2 : && !sym->attr.omp_udr_artificial_var)
15273 : : {
15274 : 2 : gfc_error ("Entity with assumed character length at %L must be a "
15275 : : "dummy argument or a PARAMETER", &sym->declared_at);
15276 : 2 : specification_expr = saved_specification_expr;
15277 : 2 : return false;
15278 : : }
15279 : :
15280 : 20545 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
15281 : : {
15282 : 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15283 : 1 : specification_expr = saved_specification_expr;
15284 : 1 : return false;
15285 : : }
15286 : :
15287 : 35412 : if (!gfc_is_constant_expr (e)
15288 : 35412 : && !(e->expr_type == EXPR_VARIABLE
15289 : 1388 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
15290 : : {
15291 : 2184 : if (!sym->attr.use_assoc && sym->ns->proc_name
15292 : 1680 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
15293 : 1679 : || sym->ns->proc_name->attr.is_main_program))
15294 : : {
15295 : 3 : gfc_error ("%qs at %L must have constant character length "
15296 : : "in this context", sym->name, &sym->declared_at);
15297 : 3 : specification_expr = saved_specification_expr;
15298 : 3 : return false;
15299 : : }
15300 : 2181 : if (sym->attr.in_common)
15301 : : {
15302 : 1 : gfc_error ("COMMON variable %qs at %L must have constant "
15303 : : "character length", sym->name, &sym->declared_at);
15304 : 1 : specification_expr = saved_specification_expr;
15305 : 1 : return false;
15306 : : }
15307 : : }
15308 : : }
15309 : :
15310 : 637792 : if (sym->value == NULL && sym->attr.referenced
15311 : 202893 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
15312 : 201014 : apply_default_init_local (sym); /* Try to apply a default initialization. */
15313 : :
15314 : : /* Determine if the symbol may not have an initializer. */
15315 : 637792 : int no_init_flag = 0, automatic_flag = 0;
15316 : 637792 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
15317 : 168026 : || sym->attr.intrinsic || sym->attr.result)
15318 : : no_init_flag = 1;
15319 : 135931 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
15320 : 170096 : && is_non_constant_shape_array (sym))
15321 : : {
15322 : 1331 : no_init_flag = automatic_flag = 1;
15323 : :
15324 : : /* Also, they must not have the SAVE attribute.
15325 : : SAVE_IMPLICIT is checked below. */
15326 : 1331 : if (sym->as && sym->attr.codimension)
15327 : : {
15328 : 7 : int corank = sym->as->corank;
15329 : 7 : sym->as->corank = 0;
15330 : 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
15331 : 7 : sym->as->corank = corank;
15332 : : }
15333 : 1331 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
15334 : : {
15335 : 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
15336 : 2 : specification_expr = saved_specification_expr;
15337 : 2 : return false;
15338 : : }
15339 : : }
15340 : :
15341 : : /* Ensure that any initializer is simplified. */
15342 : 637790 : if (sym->value)
15343 : 7788 : gfc_simplify_expr (sym->value, 1);
15344 : :
15345 : : /* Reject illegal initializers. */
15346 : 637790 : if (!sym->mark && sym->value)
15347 : : {
15348 : 7788 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
15349 : 67 : && CLASS_DATA (sym)->attr.allocatable))
15350 : 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
15351 : : sym->name, &sym->declared_at);
15352 : 7787 : else if (sym->attr.external)
15353 : 0 : gfc_error ("External %qs at %L cannot have an initializer",
15354 : : sym->name, &sym->declared_at);
15355 : 7787 : else if (sym->attr.dummy)
15356 : 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
15357 : : sym->name, &sym->declared_at);
15358 : 7784 : else if (sym->attr.intrinsic)
15359 : 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
15360 : : sym->name, &sym->declared_at);
15361 : 7784 : else if (sym->attr.result)
15362 : 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
15363 : : sym->name, &sym->declared_at);
15364 : 7783 : else if (automatic_flag)
15365 : 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
15366 : : sym->name, &sym->declared_at);
15367 : : else
15368 : 7778 : goto no_init_error;
15369 : 10 : specification_expr = saved_specification_expr;
15370 : 10 : return false;
15371 : : }
15372 : :
15373 : 630002 : no_init_error:
15374 : 637780 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
15375 : : {
15376 : 79826 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
15377 : 79826 : specification_expr = saved_specification_expr;
15378 : 79826 : return res;
15379 : : }
15380 : :
15381 : 557954 : specification_expr = saved_specification_expr;
15382 : 557954 : return true;
15383 : : }
15384 : :
15385 : :
15386 : : /* Compare the dummy characteristics of a module procedure interface
15387 : : declaration with the corresponding declaration in a submodule. */
15388 : : static gfc_formal_arglist *new_formal;
15389 : : static char errmsg[200];
15390 : :
15391 : : static void
15392 : 1291 : compare_fsyms (gfc_symbol *sym)
15393 : : {
15394 : 1291 : gfc_symbol *fsym;
15395 : :
15396 : 1291 : if (sym == NULL || new_formal == NULL)
15397 : : return;
15398 : :
15399 : 1291 : fsym = new_formal->sym;
15400 : :
15401 : 1291 : if (sym == fsym)
15402 : : return;
15403 : :
15404 : 1267 : if (strcmp (sym->name, fsym->name) == 0)
15405 : : {
15406 : 482 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
15407 : 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
15408 : : }
15409 : : }
15410 : :
15411 : :
15412 : : /* Resolve a procedure. */
15413 : :
15414 : : static bool
15415 : 465619 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
15416 : : {
15417 : 465619 : gfc_formal_arglist *arg;
15418 : 465619 : bool allocatable_or_pointer = false;
15419 : :
15420 : 465619 : if (sym->attr.function
15421 : 465619 : && !resolve_fl_var_and_proc (sym, mp_flag))
15422 : : return false;
15423 : :
15424 : : /* Constraints on deferred type parameter. */
15425 : 465609 : if (!deferred_requirements (sym))
15426 : : return false;
15427 : :
15428 : 465608 : if (sym->ts.type == BT_CHARACTER)
15429 : : {
15430 : 11337 : gfc_charlen *cl = sym->ts.u.cl;
15431 : :
15432 : 7291 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
15433 : 12501 : && !resolve_charlen (cl))
15434 : : return false;
15435 : :
15436 : 11336 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
15437 : 10173 : && sym->attr.proc == PROC_ST_FUNCTION)
15438 : : {
15439 : 0 : gfc_error ("Character-valued statement function %qs at %L must "
15440 : : "have constant length", sym->name, &sym->declared_at);
15441 : 0 : return false;
15442 : : }
15443 : : }
15444 : :
15445 : : /* Ensure that derived type for are not of a private type. Internal
15446 : : module procedures are excluded by 2.2.3.3 - i.e., they are not
15447 : : externally accessible and can access all the objects accessible in
15448 : : the host. */
15449 : 107580 : if (!(sym->ns->parent && sym->ns->parent->proc_name
15450 : 107580 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
15451 : 549888 : && gfc_check_symbol_access (sym))
15452 : : {
15453 : 435473 : gfc_interface *iface;
15454 : :
15455 : 919454 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
15456 : : {
15457 : 483982 : if (arg->sym
15458 : 483841 : && arg->sym->ts.type == BT_DERIVED
15459 : 42003 : && arg->sym->ts.u.derived
15460 : 42003 : && !arg->sym->ts.u.derived->attr.use_assoc
15461 : 4293 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15462 : 483991 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
15463 : : "and cannot be a dummy argument"
15464 : : " of %qs, which is PUBLIC at %L",
15465 : 9 : arg->sym->name, sym->name,
15466 : : &sym->declared_at))
15467 : : {
15468 : : /* Stop this message from recurring. */
15469 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15470 : 1 : return false;
15471 : : }
15472 : : }
15473 : :
15474 : : /* PUBLIC interfaces may expose PRIVATE procedures that take types
15475 : : PRIVATE to the containing module. */
15476 : 620462 : for (iface = sym->generic; iface; iface = iface->next)
15477 : : {
15478 : 432887 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
15479 : : {
15480 : 247897 : if (arg->sym
15481 : 247865 : && arg->sym->ts.type == BT_DERIVED
15482 : 7916 : && !arg->sym->ts.u.derived->attr.use_assoc
15483 : 234 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
15484 : 247901 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
15485 : : "PUBLIC interface %qs at %L "
15486 : : "takes dummy arguments of %qs which "
15487 : : "is PRIVATE", iface->sym->name,
15488 : 4 : sym->name, &iface->sym->declared_at,
15489 : 4 : gfc_typename(&arg->sym->ts)))
15490 : : {
15491 : : /* Stop this message from recurring. */
15492 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
15493 : 1 : return false;
15494 : : }
15495 : : }
15496 : : }
15497 : : }
15498 : :
15499 : 465605 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
15500 : 67 : && !sym->attr.proc_pointer)
15501 : : {
15502 : 2 : gfc_error ("Function %qs at %L cannot have an initializer",
15503 : : sym->name, &sym->declared_at);
15504 : :
15505 : : /* Make sure no second error is issued for this. */
15506 : 2 : sym->value->error = 1;
15507 : 2 : return false;
15508 : : }
15509 : :
15510 : : /* An external symbol may not have an initializer because it is taken to be
15511 : : a procedure. Exception: Procedure Pointers. */
15512 : 465603 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
15513 : : {
15514 : 0 : gfc_error ("External object %qs at %L may not have an initializer",
15515 : : sym->name, &sym->declared_at);
15516 : 0 : return false;
15517 : : }
15518 : :
15519 : : /* An elemental function is required to return a scalar 12.7.1 */
15520 : 465603 : if (sym->attr.elemental && sym->attr.function
15521 : 86137 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15522 : 2 : && CLASS_DATA (sym)->as)))
15523 : : {
15524 : 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
15525 : : "result", sym->name, &sym->declared_at);
15526 : : /* Reset so that the error only occurs once. */
15527 : 3 : sym->attr.elemental = 0;
15528 : 3 : return false;
15529 : : }
15530 : :
15531 : 465600 : if (sym->attr.proc == PROC_ST_FUNCTION
15532 : 220 : && (sym->attr.allocatable || sym->attr.pointer))
15533 : : {
15534 : 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
15535 : : "allocatable attribute", sym->name, &sym->declared_at);
15536 : 2 : return false;
15537 : : }
15538 : :
15539 : : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
15540 : : char-len-param shall not be array-valued, pointer-valued, recursive
15541 : : or pure. ....snip... A character value of * may only be used in the
15542 : : following ways: (i) Dummy arg of procedure - dummy associates with
15543 : : actual length; (ii) To declare a named constant; or (iii) External
15544 : : function - but length must be declared in calling scoping unit. */
15545 : 465598 : if (sym->attr.function
15546 : 311882 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
15547 : 6502 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
15548 : : {
15549 : 180 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
15550 : 178 : || (sym->attr.recursive) || (sym->attr.pure))
15551 : : {
15552 : 4 : if (sym->as && sym->as->rank)
15553 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15554 : : "array-valued", sym->name, &sym->declared_at);
15555 : :
15556 : 4 : if (sym->attr.pointer)
15557 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15558 : : "pointer-valued", sym->name, &sym->declared_at);
15559 : :
15560 : 4 : if (sym->attr.pure)
15561 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15562 : : "pure", sym->name, &sym->declared_at);
15563 : :
15564 : 4 : if (sym->attr.recursive)
15565 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15566 : : "recursive", sym->name, &sym->declared_at);
15567 : :
15568 : 4 : return false;
15569 : : }
15570 : :
15571 : : /* Appendix B.2 of the standard. Contained functions give an
15572 : : error anyway. Deferred character length is an F2003 feature.
15573 : : Don't warn on intrinsic conversion functions, which start
15574 : : with two underscores. */
15575 : 176 : if (!sym->attr.contained && !sym->ts.deferred
15576 : 172 : && (sym->name[0] != '_' || sym->name[1] != '_'))
15577 : 172 : gfc_notify_std (GFC_STD_F95_OBS,
15578 : : "CHARACTER(*) function %qs at %L",
15579 : : sym->name, &sym->declared_at);
15580 : : }
15581 : :
15582 : : /* F2008, C1218. */
15583 : 465594 : if (sym->attr.elemental)
15584 : : {
15585 : 89307 : if (sym->attr.proc_pointer)
15586 : : {
15587 : 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
15588 : : : sym->name);
15589 : 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
15590 : : name, &sym->declared_at);
15591 : 7 : return false;
15592 : : }
15593 : 89300 : if (sym->attr.dummy)
15594 : : {
15595 : 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
15596 : : sym->name, &sym->declared_at);
15597 : 3 : return false;
15598 : : }
15599 : : }
15600 : :
15601 : : /* F2018, C15100: "The result of an elemental function shall be scalar,
15602 : : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
15603 : : pointer is tested and caught elsewhere. */
15604 : 465584 : if (sym->result)
15605 : 262049 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
15606 : 262049 : && CLASS_DATA (sym->result) ?
15607 : 1657 : (CLASS_DATA (sym->result)->attr.allocatable
15608 : 1657 : || CLASS_DATA (sym->result)->attr.pointer) :
15609 : 260392 : (sym->result->attr.allocatable
15610 : 260392 : || sym->result->attr.pointer);
15611 : :
15612 : 465584 : if (sym->attr.elemental && sym->result
15613 : 85762 : && allocatable_or_pointer)
15614 : : {
15615 : 4 : gfc_error ("Function result variable %qs at %L of elemental "
15616 : : "function %qs shall not have an ALLOCATABLE or POINTER "
15617 : : "attribute", sym->result->name,
15618 : : &sym->result->declared_at, sym->name);
15619 : 4 : return false;
15620 : : }
15621 : :
15622 : : /* F2018:C1585: "The function result of a pure function shall not be both
15623 : : polymorphic and allocatable, or have a polymorphic allocatable ultimate
15624 : : component." */
15625 : 465580 : if (sym->attr.pure && sym->result && sym->ts.u.derived)
15626 : : {
15627 : 2378 : if (sym->ts.type == BT_CLASS
15628 : 5 : && sym->attr.class_ok
15629 : 4 : && CLASS_DATA (sym->result)
15630 : 4 : && CLASS_DATA (sym->result)->attr.allocatable)
15631 : : {
15632 : 4 : gfc_error ("Result variable %qs of pure function at %L is "
15633 : : "polymorphic allocatable",
15634 : : sym->result->name, &sym->result->declared_at);
15635 : 4 : return false;
15636 : : }
15637 : :
15638 : 2374 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
15639 : : {
15640 : : gfc_component *c = sym->ts.u.derived->components;
15641 : 4242 : for (; c; c = c->next)
15642 : 2171 : if (c->ts.type == BT_CLASS
15643 : 2 : && CLASS_DATA (c)
15644 : 2 : && CLASS_DATA (c)->attr.allocatable)
15645 : : {
15646 : 2 : gfc_error ("Result variable %qs of pure function at %L has "
15647 : : "polymorphic allocatable component %qs",
15648 : : sym->result->name, &sym->result->declared_at,
15649 : : c->name);
15650 : 2 : return false;
15651 : : }
15652 : : }
15653 : : }
15654 : :
15655 : 465574 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
15656 : : {
15657 : 6583 : gfc_formal_arglist *curr_arg;
15658 : 6583 : int has_non_interop_arg = 0;
15659 : :
15660 : 6583 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15661 : 6583 : sym->common_block))
15662 : : {
15663 : : /* Clear these to prevent looking at them again if there was an
15664 : : error. */
15665 : 2 : sym->attr.is_bind_c = 0;
15666 : 2 : sym->attr.is_c_interop = 0;
15667 : 2 : sym->ts.is_c_interop = 0;
15668 : : }
15669 : : else
15670 : : {
15671 : : /* So far, no errors have been found. */
15672 : 6581 : sym->attr.is_c_interop = 1;
15673 : 6581 : sym->ts.is_c_interop = 1;
15674 : : }
15675 : :
15676 : 6583 : curr_arg = gfc_sym_get_dummy_args (sym);
15677 : 29583 : while (curr_arg != NULL)
15678 : : {
15679 : : /* Skip implicitly typed dummy args here. */
15680 : 16417 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
15681 : 16361 : if (!gfc_verify_c_interop_param (curr_arg->sym))
15682 : : /* If something is found to fail, record the fact so we
15683 : : can mark the symbol for the procedure as not being
15684 : : BIND(C) to try and prevent multiple errors being
15685 : : reported. */
15686 : 16417 : has_non_interop_arg = 1;
15687 : :
15688 : 16417 : curr_arg = curr_arg->next;
15689 : : }
15690 : :
15691 : : /* See if any of the arguments were not interoperable and if so, clear
15692 : : the procedure symbol to prevent duplicate error messages. */
15693 : 6583 : if (has_non_interop_arg != 0)
15694 : : {
15695 : 128 : sym->attr.is_c_interop = 0;
15696 : 128 : sym->ts.is_c_interop = 0;
15697 : 128 : sym->attr.is_bind_c = 0;
15698 : : }
15699 : : }
15700 : :
15701 : 465574 : if (!sym->attr.proc_pointer)
15702 : : {
15703 : 464530 : if (sym->attr.save == SAVE_EXPLICIT)
15704 : : {
15705 : 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
15706 : : "in %qs at %L", sym->name, &sym->declared_at);
15707 : 5 : return false;
15708 : : }
15709 : 464525 : if (sym->attr.intent)
15710 : : {
15711 : 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
15712 : : "in %qs at %L", sym->name, &sym->declared_at);
15713 : 1 : return false;
15714 : : }
15715 : 464524 : if (sym->attr.subroutine && sym->attr.result)
15716 : : {
15717 : 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
15718 : 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
15719 : 2 : return false;
15720 : : }
15721 : 464522 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
15722 : 132560 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
15723 : 132557 : || sym->attr.contained))
15724 : : {
15725 : 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
15726 : : "in %qs at %L", sym->name, &sym->declared_at);
15727 : 3 : return false;
15728 : : }
15729 : 464519 : if (strcmp ("ppr@", sym->name) == 0)
15730 : : {
15731 : 0 : gfc_error ("Procedure pointer result %qs at %L "
15732 : : "is missing the pointer attribute",
15733 : 0 : sym->ns->proc_name->name, &sym->declared_at);
15734 : 0 : return false;
15735 : : }
15736 : : }
15737 : :
15738 : : /* Assume that a procedure whose body is not known has references
15739 : : to external arrays. */
15740 : 465563 : if (sym->attr.if_source != IFSRC_DECL)
15741 : 320673 : sym->attr.array_outer_dependency = 1;
15742 : :
15743 : : /* Compare the characteristics of a module procedure with the
15744 : : interface declaration. Ideally this would be done with
15745 : : gfc_compare_interfaces but, at present, the formal interface
15746 : : cannot be copied to the ts.interface. */
15747 : 465563 : if (sym->attr.module_procedure
15748 : 1476 : && sym->attr.if_source == IFSRC_DECL)
15749 : : {
15750 : 618 : gfc_symbol *iface;
15751 : 618 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
15752 : 618 : char *module_name;
15753 : 618 : char *submodule_name;
15754 : 618 : strcpy (name, sym->ns->proc_name->name);
15755 : 618 : module_name = strtok (name, ".");
15756 : 618 : submodule_name = strtok (NULL, ".");
15757 : :
15758 : 618 : iface = sym->tlink;
15759 : 618 : sym->tlink = NULL;
15760 : :
15761 : : /* Make sure that the result uses the correct charlen for deferred
15762 : : length results. */
15763 : 618 : if (iface && sym->result
15764 : 180 : && iface->ts.type == BT_CHARACTER
15765 : 19 : && iface->ts.deferred)
15766 : 6 : sym->result->ts.u.cl = iface->ts.u.cl;
15767 : :
15768 : 6 : if (iface == NULL)
15769 : 195 : goto check_formal;
15770 : :
15771 : : /* Check the procedure characteristics. */
15772 : 423 : if (sym->attr.elemental != iface->attr.elemental)
15773 : : {
15774 : 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
15775 : : "PROCEDURE at %L and its interface in %s",
15776 : : &sym->declared_at, module_name);
15777 : 10 : return false;
15778 : : }
15779 : :
15780 : 422 : if (sym->attr.pure != iface->attr.pure)
15781 : : {
15782 : 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
15783 : : "PROCEDURE at %L and its interface in %s",
15784 : : &sym->declared_at, module_name);
15785 : 2 : return false;
15786 : : }
15787 : :
15788 : 420 : if (sym->attr.recursive != iface->attr.recursive)
15789 : : {
15790 : 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
15791 : : "PROCEDURE at %L and its interface in %s",
15792 : : &sym->declared_at, module_name);
15793 : 2 : return false;
15794 : : }
15795 : :
15796 : : /* Check the result characteristics. */
15797 : 418 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
15798 : : {
15799 : 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
15800 : : "in MODULE %qs and the declaration at %L in "
15801 : : "(SUB)MODULE %qs",
15802 : : errmsg, module_name, &sym->declared_at,
15803 : : submodule_name ? submodule_name : module_name);
15804 : 5 : return false;
15805 : : }
15806 : :
15807 : 413 : check_formal:
15808 : : /* Check the characteristics of the formal arguments. */
15809 : 608 : if (sym->formal && sym->formal_ns)
15810 : : {
15811 : 1185 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
15812 : : {
15813 : 680 : new_formal = arg;
15814 : 680 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
15815 : : }
15816 : : }
15817 : : }
15818 : :
15819 : : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
15820 : : BIND(C) attribute. */
15821 : 465553 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
15822 : : {
15823 : 1 : gfc_error ("Interface of %qs at %L must be explicit",
15824 : : sym->name, &sym->declared_at);
15825 : 1 : return false;
15826 : : }
15827 : :
15828 : : return true;
15829 : : }
15830 : :
15831 : :
15832 : : /* Resolve a list of finalizer procedures. That is, after they have hopefully
15833 : : been defined and we now know their defined arguments, check that they fulfill
15834 : : the requirements of the standard for procedures used as finalizers. */
15835 : :
15836 : : static bool
15837 : 107700 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
15838 : : {
15839 : 107700 : gfc_finalizer* list;
15840 : 107700 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
15841 : 107700 : bool result = true;
15842 : 107700 : bool seen_scalar = false;
15843 : 107700 : gfc_symbol *vtab;
15844 : 107700 : gfc_component *c;
15845 : 107700 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
15846 : :
15847 : 107700 : if (parent)
15848 : 14915 : gfc_resolve_finalizers (parent, finalizable);
15849 : :
15850 : : /* Ensure that derived-type components have a their finalizers resolved. */
15851 : 107700 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
15852 : 339380 : for (c = derived->components; c; c = c->next)
15853 : 231680 : if (c->ts.type == BT_DERIVED
15854 : 64720 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
15855 : : {
15856 : 7879 : bool has_final2 = false;
15857 : 7879 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
15858 : 0 : return false; /* Error. */
15859 : 7879 : has_final = has_final || has_final2;
15860 : : }
15861 : : /* Return early if not finalizable. */
15862 : 107700 : if (!has_final)
15863 : : {
15864 : 105411 : if (finalizable)
15865 : 7841 : *finalizable = false;
15866 : 105411 : return true;
15867 : : }
15868 : :
15869 : : /* Walk over the list of finalizer-procedures, check them, and if any one
15870 : : does not fit in with the standard's definition, print an error and remove
15871 : : it from the list. */
15872 : 2289 : prev_link = &derived->f2k_derived->finalizers;
15873 : 4722 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
15874 : : {
15875 : 2433 : gfc_formal_arglist *dummy_args;
15876 : 2433 : gfc_symbol* arg;
15877 : 2433 : gfc_finalizer* i;
15878 : 2433 : int my_rank;
15879 : :
15880 : : /* Skip this finalizer if we already resolved it. */
15881 : 2433 : if (list->proc_tree)
15882 : : {
15883 : 1951 : if (list->proc_tree->n.sym->formal->sym->as == NULL
15884 : 566 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
15885 : 1385 : seen_scalar = true;
15886 : 1951 : prev_link = &(list->next);
15887 : 1951 : continue;
15888 : : }
15889 : :
15890 : : /* Check this exists and is a SUBROUTINE. */
15891 : 482 : if (!list->proc_sym->attr.subroutine)
15892 : : {
15893 : 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
15894 : : list->proc_sym->name, &list->where);
15895 : 3 : goto error;
15896 : : }
15897 : :
15898 : : /* We should have exactly one argument. */
15899 : 479 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
15900 : 479 : if (!dummy_args || dummy_args->next)
15901 : : {
15902 : 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
15903 : : &list->where);
15904 : 2 : goto error;
15905 : : }
15906 : 477 : arg = dummy_args->sym;
15907 : :
15908 : 477 : if (!arg)
15909 : : {
15910 : 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
15911 : 1 : &list->proc_sym->declared_at, derived->name);
15912 : 1 : goto error;
15913 : : }
15914 : :
15915 : 476 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
15916 : 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
15917 : : {
15918 : 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
15919 : : "be the only finalizer with the same kind/type "
15920 : : "(F2018: C790)", &list->where);
15921 : 0 : goto error;
15922 : : }
15923 : :
15924 : : /* This argument must be of our type. */
15925 : 476 : if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
15926 : : {
15927 : 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
15928 : : &arg->declared_at, derived->name);
15929 : 2 : goto error;
15930 : : }
15931 : :
15932 : : /* It must neither be a pointer nor allocatable nor optional. */
15933 : 474 : if (arg->attr.pointer)
15934 : : {
15935 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
15936 : : &arg->declared_at);
15937 : 1 : goto error;
15938 : : }
15939 : 473 : if (arg->attr.allocatable)
15940 : : {
15941 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
15942 : : " ALLOCATABLE", &arg->declared_at);
15943 : 1 : goto error;
15944 : : }
15945 : 472 : if (arg->attr.optional)
15946 : : {
15947 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
15948 : : &arg->declared_at);
15949 : 1 : goto error;
15950 : : }
15951 : :
15952 : : /* It must not be INTENT(OUT). */
15953 : 471 : if (arg->attr.intent == INTENT_OUT)
15954 : : {
15955 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
15956 : : " INTENT(OUT)", &arg->declared_at);
15957 : 1 : goto error;
15958 : : }
15959 : :
15960 : : /* Warn if the procedure is non-scalar and not assumed shape. */
15961 : 470 : if (warn_surprising && arg->as && arg->as->rank != 0
15962 : 3 : && arg->as->type != AS_ASSUMED_SHAPE)
15963 : 2 : gfc_warning (OPT_Wsurprising,
15964 : : "Non-scalar FINAL procedure at %L should have assumed"
15965 : : " shape argument", &arg->declared_at);
15966 : :
15967 : : /* Check that it does not match in kind and rank with a FINAL procedure
15968 : : defined earlier. To really loop over the *earlier* declarations,
15969 : : we need to walk the tail of the list as new ones were pushed at the
15970 : : front. */
15971 : : /* TODO: Handle kind parameters once they are implemented. */
15972 : 470 : my_rank = (arg->as ? arg->as->rank : 0);
15973 : 559 : for (i = list->next; i; i = i->next)
15974 : : {
15975 : 91 : gfc_formal_arglist *dummy_args;
15976 : :
15977 : : /* Argument list might be empty; that is an error signalled earlier,
15978 : : but we nevertheless continued resolving. */
15979 : 91 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
15980 : 91 : if (dummy_args)
15981 : : {
15982 : 89 : gfc_symbol* i_arg = dummy_args->sym;
15983 : 89 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
15984 : 89 : if (i_rank == my_rank)
15985 : : {
15986 : 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
15987 : : " rank (%d) as %qs",
15988 : 2 : list->proc_sym->name, &list->where, my_rank,
15989 : 2 : i->proc_sym->name);
15990 : 2 : goto error;
15991 : : }
15992 : : }
15993 : : }
15994 : :
15995 : : /* Is this the/a scalar finalizer procedure? */
15996 : 468 : if (my_rank == 0)
15997 : 348 : seen_scalar = true;
15998 : :
15999 : : /* Find the symtree for this procedure. */
16000 : 468 : gcc_assert (!list->proc_tree);
16001 : 468 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
16002 : :
16003 : 468 : prev_link = &list->next;
16004 : 468 : continue;
16005 : :
16006 : : /* Remove wrong nodes immediately from the list so we don't risk any
16007 : : troubles in the future when they might fail later expectations. */
16008 : 14 : error:
16009 : 14 : i = list;
16010 : 14 : *prev_link = list->next;
16011 : 14 : gfc_free_finalizer (i);
16012 : 14 : result = false;
16013 : 468 : }
16014 : :
16015 : 2289 : if (result == false)
16016 : : return false;
16017 : :
16018 : : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
16019 : : were nodes in the list, must have been for arrays. It is surely a good
16020 : : idea to have a scalar version there if there's something to finalize. */
16021 : 2285 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
16022 : 1 : gfc_warning (OPT_Wsurprising,
16023 : : "Only array FINAL procedures declared for derived type %qs"
16024 : : " defined at %L, suggest also scalar one unless an assumed"
16025 : : " rank finalizer has been declared",
16026 : : derived->name, &derived->declared_at);
16027 : :
16028 : 2285 : vtab = gfc_find_derived_vtab (derived);
16029 : 2285 : c = vtab->ts.u.derived->components->next->next->next->next->next;
16030 : 2285 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
16031 : :
16032 : 2285 : if (finalizable)
16033 : 590 : *finalizable = true;
16034 : :
16035 : : return true;
16036 : : }
16037 : :
16038 : :
16039 : : static gfc_symbol * containing_dt;
16040 : :
16041 : : /* Helper function for check_generic_tbp_ambiguity, which ensures that passed
16042 : : arguments whose declared types are PDT instances only transmit the PASS arg
16043 : : if they match the enclosing derived type. */
16044 : :
16045 : : static bool
16046 : 1460 : check_pdt_args (gfc_tbp_generic* t, const char *pass)
16047 : : {
16048 : 1460 : gfc_formal_arglist *dummy_args;
16049 : 1460 : if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
16050 : : {
16051 : 532 : dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
16052 : 1190 : while (dummy_args && strcmp (pass, dummy_args->sym->name))
16053 : 126 : dummy_args = dummy_args->next;
16054 : 532 : gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
16055 : 532 : if (dummy_args->sym->ts.type == BT_CLASS
16056 : 532 : && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
16057 : : containing_dt->name))
16058 : : return true;
16059 : : }
16060 : : return false;
16061 : : }
16062 : :
16063 : :
16064 : : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
16065 : :
16066 : : static bool
16067 : 732 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
16068 : : const char* generic_name, locus where)
16069 : : {
16070 : 732 : gfc_symbol *sym1, *sym2;
16071 : 732 : const char *pass1, *pass2;
16072 : 732 : gfc_formal_arglist *dummy_args;
16073 : :
16074 : 732 : gcc_assert (t1->specific && t2->specific);
16075 : 732 : gcc_assert (!t1->specific->is_generic);
16076 : 732 : gcc_assert (!t2->specific->is_generic);
16077 : 732 : gcc_assert (t1->is_operator == t2->is_operator);
16078 : :
16079 : 732 : sym1 = t1->specific->u.specific->n.sym;
16080 : 732 : sym2 = t2->specific->u.specific->n.sym;
16081 : :
16082 : 732 : if (sym1 == sym2)
16083 : : return true;
16084 : :
16085 : : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
16086 : 732 : if (sym1->attr.subroutine != sym2->attr.subroutine
16087 : 730 : || sym1->attr.function != sym2->attr.function)
16088 : : {
16089 : 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
16090 : : " GENERIC %qs at %L",
16091 : : sym1->name, sym2->name, generic_name, &where);
16092 : 2 : return false;
16093 : : }
16094 : :
16095 : : /* Determine PASS arguments. */
16096 : 730 : if (t1->specific->nopass)
16097 : : pass1 = NULL;
16098 : 679 : else if (t1->specific->pass_arg)
16099 : : pass1 = t1->specific->pass_arg;
16100 : : else
16101 : : {
16102 : 420 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
16103 : 420 : if (dummy_args)
16104 : 419 : pass1 = dummy_args->sym->name;
16105 : : else
16106 : : pass1 = NULL;
16107 : : }
16108 : 730 : if (t2->specific->nopass)
16109 : : pass2 = NULL;
16110 : 678 : else if (t2->specific->pass_arg)
16111 : : pass2 = t2->specific->pass_arg;
16112 : : else
16113 : : {
16114 : 541 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
16115 : 541 : if (dummy_args)
16116 : 540 : pass2 = dummy_args->sym->name;
16117 : : else
16118 : : pass2 = NULL;
16119 : : }
16120 : :
16121 : : /* Care must be taken with pdt types and templates because the declared type
16122 : : of the argument that is not 'no_pass' need not be the same as the
16123 : : containing derived type. If this is the case, subject the argument to
16124 : : the full interface check, even though it cannot be used in the type
16125 : : bound context. */
16126 : 730 : pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
16127 : 730 : pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
16128 : :
16129 : 730 : if (containing_dt != NULL && containing_dt->attr.pdt_template)
16130 : 730 : pass1 = pass2 = NULL;
16131 : :
16132 : : /* Compare the interfaces. */
16133 : 730 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
16134 : : NULL, 0, pass1, pass2))
16135 : : {
16136 : 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
16137 : : sym1->name, sym2->name, generic_name, &where);
16138 : 8 : return false;
16139 : : }
16140 : :
16141 : : return true;
16142 : : }
16143 : :
16144 : :
16145 : : /* Worker function for resolving a generic procedure binding; this is used to
16146 : : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
16147 : :
16148 : : The difference between those cases is finding possible inherited bindings
16149 : : that are overridden, as one has to look for them in tb_sym_root,
16150 : : tb_uop_root or tb_op, respectively. Thus the caller must already find
16151 : : the super-type and set p->overridden correctly. */
16152 : :
16153 : : static bool
16154 : 2223 : resolve_tb_generic_targets (gfc_symbol* super_type,
16155 : : gfc_typebound_proc* p, const char* name)
16156 : : {
16157 : 2223 : gfc_tbp_generic* target;
16158 : 2223 : gfc_symtree* first_target;
16159 : 2223 : gfc_symtree* inherited;
16160 : :
16161 : 2223 : gcc_assert (p && p->is_generic);
16162 : :
16163 : : /* Try to find the specific bindings for the symtrees in our target-list. */
16164 : 2223 : gcc_assert (p->u.generic);
16165 : 5030 : for (target = p->u.generic; target; target = target->next)
16166 : 2824 : if (!target->specific)
16167 : : {
16168 : 2463 : gfc_typebound_proc* overridden_tbp;
16169 : 2463 : gfc_tbp_generic* g;
16170 : 2463 : const char* target_name;
16171 : :
16172 : 2463 : target_name = target->specific_st->name;
16173 : :
16174 : : /* Defined for this type directly. */
16175 : 2463 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
16176 : : {
16177 : 2454 : target->specific = target->specific_st->n.tb;
16178 : 2454 : goto specific_found;
16179 : : }
16180 : :
16181 : : /* Look for an inherited specific binding. */
16182 : 9 : if (super_type)
16183 : : {
16184 : 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
16185 : : true, NULL);
16186 : :
16187 : 5 : if (inherited)
16188 : : {
16189 : 5 : gcc_assert (inherited->n.tb);
16190 : 5 : target->specific = inherited->n.tb;
16191 : 5 : goto specific_found;
16192 : : }
16193 : : }
16194 : :
16195 : 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
16196 : : " at %L", target_name, name, &p->where);
16197 : 4 : return false;
16198 : :
16199 : : /* Once we've found the specific binding, check it is not ambiguous with
16200 : : other specifics already found or inherited for the same GENERIC. */
16201 : 2459 : specific_found:
16202 : 2459 : gcc_assert (target->specific);
16203 : :
16204 : : /* This must really be a specific binding! */
16205 : 2459 : if (target->specific->is_generic)
16206 : : {
16207 : 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
16208 : : " %qs is GENERIC, too", name, &p->where, target_name);
16209 : 3 : return false;
16210 : : }
16211 : :
16212 : : /* Check those already resolved on this type directly. */
16213 : 6326 : for (g = p->u.generic; g; g = g->next)
16214 : 1428 : if (g != target && g->specific
16215 : 4591 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
16216 : : return false;
16217 : :
16218 : : /* Check for ambiguity with inherited specific targets. */
16219 : 2465 : for (overridden_tbp = p->overridden; overridden_tbp;
16220 : 16 : overridden_tbp = overridden_tbp->overridden)
16221 : 19 : if (overridden_tbp->is_generic)
16222 : : {
16223 : 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
16224 : : {
16225 : 18 : gcc_assert (g->specific);
16226 : 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
16227 : : return false;
16228 : : }
16229 : : }
16230 : : }
16231 : :
16232 : : /* If we attempt to "overwrite" a specific binding, this is an error. */
16233 : 2206 : if (p->overridden && !p->overridden->is_generic)
16234 : : {
16235 : 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
16236 : : " the same name", name, &p->where);
16237 : 1 : return false;
16238 : : }
16239 : :
16240 : : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
16241 : : all must have the same attributes here. */
16242 : 2205 : first_target = p->u.generic->specific->u.specific;
16243 : 2205 : gcc_assert (first_target);
16244 : 2205 : p->subroutine = first_target->n.sym->attr.subroutine;
16245 : 2205 : p->function = first_target->n.sym->attr.function;
16246 : :
16247 : 2205 : return true;
16248 : : }
16249 : :
16250 : :
16251 : : /* Resolve a GENERIC procedure binding for a derived type. */
16252 : :
16253 : : static bool
16254 : 1198 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
16255 : : {
16256 : 1198 : gfc_symbol* super_type;
16257 : :
16258 : : /* Find the overridden binding if any. */
16259 : 1198 : st->n.tb->overridden = NULL;
16260 : 1198 : super_type = gfc_get_derived_super_type (derived);
16261 : 1198 : if (super_type)
16262 : : {
16263 : 40 : gfc_symtree* overridden;
16264 : 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
16265 : : true, NULL);
16266 : :
16267 : 40 : if (overridden && overridden->n.tb)
16268 : 21 : st->n.tb->overridden = overridden->n.tb;
16269 : : }
16270 : :
16271 : : /* Resolve using worker function. */
16272 : 1198 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
16273 : : }
16274 : :
16275 : :
16276 : : /* Retrieve the target-procedure of an operator binding and do some checks in
16277 : : common for intrinsic and user-defined type-bound operators. */
16278 : :
16279 : : static gfc_symbol*
16280 : 1097 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
16281 : : {
16282 : 1097 : gfc_symbol* target_proc;
16283 : :
16284 : 1097 : gcc_assert (target->specific && !target->specific->is_generic);
16285 : 1097 : target_proc = target->specific->u.specific->n.sym;
16286 : 1097 : gcc_assert (target_proc);
16287 : :
16288 : : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
16289 : 1097 : if (target->specific->nopass)
16290 : : {
16291 : 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
16292 : 2 : return NULL;
16293 : : }
16294 : :
16295 : : return target_proc;
16296 : : }
16297 : :
16298 : :
16299 : : /* Resolve a type-bound intrinsic operator. */
16300 : :
16301 : : static bool
16302 : 971 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
16303 : : gfc_typebound_proc* p)
16304 : : {
16305 : 971 : gfc_symbol* super_type;
16306 : 971 : gfc_tbp_generic* target;
16307 : :
16308 : : /* If there's already an error here, do nothing (but don't fail again). */
16309 : 971 : if (p->error)
16310 : : return true;
16311 : :
16312 : : /* Operators should always be GENERIC bindings. */
16313 : 971 : gcc_assert (p->is_generic);
16314 : :
16315 : : /* Look for an overridden binding. */
16316 : 971 : super_type = gfc_get_derived_super_type (derived);
16317 : 971 : if (super_type && super_type->f2k_derived)
16318 : 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
16319 : : op, true, NULL);
16320 : : else
16321 : 970 : p->overridden = NULL;
16322 : :
16323 : : /* Resolve general GENERIC properties using worker function. */
16324 : 971 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
16325 : 1 : goto error;
16326 : :
16327 : : /* Check the targets to be procedures of correct interface. */
16328 : 1987 : for (target = p->u.generic; target; target = target->next)
16329 : : {
16330 : 1042 : gfc_symbol* target_proc;
16331 : :
16332 : 1042 : target_proc = get_checked_tb_operator_target (target, p->where);
16333 : 1042 : if (!target_proc)
16334 : 1 : goto error;
16335 : :
16336 : 1041 : if (!gfc_check_operator_interface (target_proc, op, p->where))
16337 : 3 : goto error;
16338 : :
16339 : : /* Add target to non-typebound operator list. */
16340 : 1038 : if (!target->specific->deferred && !derived->attr.use_assoc
16341 : 365 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
16342 : : {
16343 : 363 : gfc_interface *head, *intr;
16344 : :
16345 : : /* Preempt 'gfc_check_new_interface' for submodules, where the
16346 : : mechanism for handling module procedures winds up resolving
16347 : : operator interfaces twice and would otherwise cause an error.
16348 : : Likewise, new instances of PDTs can cause the operator inter-
16349 : : faces to be resolved multiple times. */
16350 : 434 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
16351 : 90 : if (intr->sym == target_proc
16352 : 21 : && (target_proc->attr.used_in_submodule
16353 : 4 : || derived->attr.pdt_type
16354 : 2 : || derived->attr.pdt_template))
16355 : : return true;
16356 : :
16357 : 344 : if (!gfc_check_new_interface (derived->ns->op[op],
16358 : : target_proc, p->where))
16359 : : return false;
16360 : 342 : head = derived->ns->op[op];
16361 : 342 : intr = gfc_get_interface ();
16362 : 342 : intr->sym = target_proc;
16363 : 342 : intr->where = p->where;
16364 : 342 : intr->next = head;
16365 : 342 : derived->ns->op[op] = intr;
16366 : : }
16367 : : }
16368 : :
16369 : : return true;
16370 : :
16371 : 5 : error:
16372 : 5 : p->error = 1;
16373 : 5 : return false;
16374 : : }
16375 : :
16376 : :
16377 : : /* Resolve a type-bound user operator (tree-walker callback). */
16378 : :
16379 : : static gfc_symbol* resolve_bindings_derived;
16380 : : static bool resolve_bindings_result;
16381 : :
16382 : : static bool check_uop_procedure (gfc_symbol* sym, locus where);
16383 : :
16384 : : static void
16385 : 54 : resolve_typebound_user_op (gfc_symtree* stree)
16386 : : {
16387 : 54 : gfc_symbol* super_type;
16388 : 54 : gfc_tbp_generic* target;
16389 : :
16390 : 54 : gcc_assert (stree && stree->n.tb);
16391 : :
16392 : 54 : if (stree->n.tb->error)
16393 : : return;
16394 : :
16395 : : /* Operators should always be GENERIC bindings. */
16396 : 54 : gcc_assert (stree->n.tb->is_generic);
16397 : :
16398 : : /* Find overridden procedure, if any. */
16399 : 54 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16400 : 54 : if (super_type && super_type->f2k_derived)
16401 : : {
16402 : 0 : gfc_symtree* overridden;
16403 : 0 : overridden = gfc_find_typebound_user_op (super_type, NULL,
16404 : : stree->name, true, NULL);
16405 : :
16406 : 0 : if (overridden && overridden->n.tb)
16407 : 0 : stree->n.tb->overridden = overridden->n.tb;
16408 : : }
16409 : : else
16410 : 54 : stree->n.tb->overridden = NULL;
16411 : :
16412 : : /* Resolve basically using worker function. */
16413 : 54 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
16414 : 0 : goto error;
16415 : :
16416 : : /* Check the targets to be functions of correct interface. */
16417 : 106 : for (target = stree->n.tb->u.generic; target; target = target->next)
16418 : : {
16419 : 55 : gfc_symbol* target_proc;
16420 : :
16421 : 55 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
16422 : 55 : if (!target_proc)
16423 : 1 : goto error;
16424 : :
16425 : 54 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
16426 : 2 : goto error;
16427 : : }
16428 : :
16429 : : return;
16430 : :
16431 : 3 : error:
16432 : 3 : resolve_bindings_result = false;
16433 : 3 : stree->n.tb->error = 1;
16434 : : }
16435 : :
16436 : :
16437 : : /* Resolve the type-bound procedures for a derived type. */
16438 : :
16439 : : static void
16440 : 9745 : resolve_typebound_procedure (gfc_symtree* stree)
16441 : : {
16442 : 9745 : gfc_symbol* proc;
16443 : 9745 : locus where;
16444 : 9745 : gfc_symbol* me_arg;
16445 : 9745 : gfc_symbol* super_type;
16446 : 9745 : gfc_component* comp;
16447 : :
16448 : 9745 : gcc_assert (stree);
16449 : :
16450 : : /* Undefined specific symbol from GENERIC target definition. */
16451 : 9745 : if (!stree->n.tb)
16452 : 9663 : return;
16453 : :
16454 : 9739 : if (stree->n.tb->error)
16455 : : return;
16456 : :
16457 : : /* If this is a GENERIC binding, use that routine. */
16458 : 9723 : if (stree->n.tb->is_generic)
16459 : : {
16460 : 1198 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
16461 : 17 : goto error;
16462 : : return;
16463 : : }
16464 : :
16465 : : /* Get the target-procedure to check it. */
16466 : 8525 : gcc_assert (!stree->n.tb->is_generic);
16467 : 8525 : gcc_assert (stree->n.tb->u.specific);
16468 : 8525 : proc = stree->n.tb->u.specific->n.sym;
16469 : 8525 : where = stree->n.tb->where;
16470 : :
16471 : : /* Default access should already be resolved from the parser. */
16472 : 8525 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
16473 : :
16474 : 8525 : if (stree->n.tb->deferred)
16475 : : {
16476 : 671 : if (!check_proc_interface (proc, &where))
16477 : 5 : goto error;
16478 : : }
16479 : : else
16480 : : {
16481 : : /* If proc has not been resolved at this point, proc->name may
16482 : : actually be a USE associated entity. See PR fortran/89647. */
16483 : 7854 : if (!proc->resolve_symbol_called
16484 : 5240 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
16485 : : {
16486 : 11 : gfc_symbol *tmp;
16487 : 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
16488 : 11 : if (tmp && tmp->attr.use_assoc)
16489 : : {
16490 : 1 : proc->module = tmp->module;
16491 : 1 : proc->attr.proc = tmp->attr.proc;
16492 : 1 : proc->attr.function = tmp->attr.function;
16493 : 1 : proc->attr.subroutine = tmp->attr.subroutine;
16494 : 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
16495 : 1 : proc->ts = tmp->ts;
16496 : 1 : proc->result = tmp->result;
16497 : : }
16498 : : }
16499 : :
16500 : : /* Check for F08:C465. */
16501 : 7854 : if ((!proc->attr.subroutine && !proc->attr.function)
16502 : 7844 : || (proc->attr.proc != PROC_MODULE
16503 : 71 : && proc->attr.if_source != IFSRC_IFBODY
16504 : 7 : && !proc->attr.module_procedure)
16505 : 7843 : || proc->attr.abstract)
16506 : : {
16507 : 12 : gfc_error ("%qs must be a module procedure or an external "
16508 : : "procedure with an explicit interface at %L",
16509 : : proc->name, &where);
16510 : 12 : goto error;
16511 : : }
16512 : : }
16513 : :
16514 : 8508 : stree->n.tb->subroutine = proc->attr.subroutine;
16515 : 8508 : stree->n.tb->function = proc->attr.function;
16516 : :
16517 : : /* Find the super-type of the current derived type. We could do this once and
16518 : : store in a global if speed is needed, but as long as not I believe this is
16519 : : more readable and clearer. */
16520 : 8508 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
16521 : :
16522 : : /* If PASS, resolve and check arguments if not already resolved / loaded
16523 : : from a .mod file. */
16524 : 8508 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
16525 : : {
16526 : 2696 : gfc_formal_arglist *dummy_args;
16527 : :
16528 : 2696 : dummy_args = gfc_sym_get_dummy_args (proc);
16529 : 2696 : if (stree->n.tb->pass_arg)
16530 : : {
16531 : 459 : gfc_formal_arglist *i;
16532 : :
16533 : : /* If an explicit passing argument name is given, walk the arg-list
16534 : : and look for it. */
16535 : :
16536 : 459 : me_arg = NULL;
16537 : 459 : stree->n.tb->pass_arg_num = 1;
16538 : 585 : for (i = dummy_args; i; i = i->next)
16539 : : {
16540 : 583 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
16541 : : {
16542 : : me_arg = i->sym;
16543 : : break;
16544 : : }
16545 : 126 : ++stree->n.tb->pass_arg_num;
16546 : : }
16547 : :
16548 : 459 : if (!me_arg)
16549 : : {
16550 : 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
16551 : : " argument %qs",
16552 : : proc->name, stree->n.tb->pass_arg, &where,
16553 : : stree->n.tb->pass_arg);
16554 : 2 : goto error;
16555 : : }
16556 : : }
16557 : : else
16558 : : {
16559 : : /* Otherwise, take the first one; there should in fact be at least
16560 : : one. */
16561 : 2237 : stree->n.tb->pass_arg_num = 1;
16562 : 2237 : if (!dummy_args)
16563 : : {
16564 : 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
16565 : : " least one argument", proc->name, &where);
16566 : 2 : goto error;
16567 : : }
16568 : 2235 : me_arg = dummy_args->sym;
16569 : : }
16570 : :
16571 : : /* Now check that the argument-type matches and the passed-object
16572 : : dummy argument is generally fine. */
16573 : :
16574 : 2235 : gcc_assert (me_arg);
16575 : :
16576 : 2692 : if (me_arg->ts.type != BT_CLASS)
16577 : : {
16578 : 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
16579 : : " at %L", proc->name, &where);
16580 : 5 : goto error;
16581 : : }
16582 : :
16583 : : /* The derived type is not a PDT template or type. Resolve as usual. */
16584 : 2687 : if (!resolve_bindings_derived->attr.pdt_template
16585 : 2670 : && !(containing_dt && containing_dt->attr.pdt_type
16586 : 48 : && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
16587 : 2650 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
16588 : : {
16589 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16590 : : "the derived-type %qs", me_arg->name, proc->name,
16591 : : me_arg->name, &where, resolve_bindings_derived->name);
16592 : 0 : goto error;
16593 : : }
16594 : :
16595 : 2687 : if (resolve_bindings_derived->attr.pdt_template
16596 : 2704 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
16597 : 17 : CLASS_DATA (me_arg)->ts.u.derived))
16598 : : {
16599 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16600 : : "the parametric derived-type %qs", me_arg->name,
16601 : : proc->name, me_arg->name, &where,
16602 : : resolve_bindings_derived->name);
16603 : 0 : goto error;
16604 : : }
16605 : :
16606 : 2687 : if (resolve_bindings_derived->attr.pdt_template
16607 : 17 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
16608 : 17 : CLASS_DATA (me_arg)->ts.u.derived)
16609 : 17 : && (me_arg->param_list != NULL)
16610 : 2704 : && (gfc_spec_list_type (me_arg->param_list,
16611 : 17 : CLASS_DATA(me_arg)->ts.u.derived)
16612 : : != SPEC_ASSUMED))
16613 : : {
16614 : :
16615 : : /* Add a check to verify if there are any LEN parameters in the
16616 : : first place. If there are LEN parameters, throw this error.
16617 : : If there are only KIND parameters, then don't trigger
16618 : : this error. */
16619 : 6 : gfc_component *c;
16620 : 6 : bool seen_len_param = false;
16621 : 6 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
16622 : :
16623 : 6 : for (; me_arg_param; me_arg_param = me_arg_param->next)
16624 : : {
16625 : 6 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
16626 : : me_arg_param->name, true, true, NULL);
16627 : :
16628 : 6 : gcc_assert (c != NULL);
16629 : :
16630 : 6 : if (c->attr.pdt_kind)
16631 : 0 : continue;
16632 : :
16633 : : /* Getting here implies that there is a pdt_len parameter
16634 : : in the list. */
16635 : : seen_len_param = true;
16636 : : break;
16637 : : }
16638 : :
16639 : 6 : if (seen_len_param)
16640 : : {
16641 : 6 : gfc_error ("All LEN type parameters of the passed dummy "
16642 : : "argument %qs of %qs at %L must be ASSUMED.",
16643 : : me_arg->name, proc->name, &where);
16644 : 6 : goto error;
16645 : : }
16646 : : }
16647 : :
16648 : 2681 : gcc_assert (me_arg->ts.type == BT_CLASS);
16649 : 2681 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
16650 : : {
16651 : 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
16652 : : " scalar", proc->name, &where);
16653 : 1 : goto error;
16654 : : }
16655 : 2680 : if (CLASS_DATA (me_arg)->attr.allocatable)
16656 : : {
16657 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16658 : : " be ALLOCATABLE", proc->name, &where);
16659 : 2 : goto error;
16660 : : }
16661 : 2678 : if (CLASS_DATA (me_arg)->attr.class_pointer)
16662 : : {
16663 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16664 : : " be POINTER", proc->name, &where);
16665 : 2 : goto error;
16666 : : }
16667 : : }
16668 : :
16669 : : /* If we are extending some type, check that we don't override a procedure
16670 : : flagged NON_OVERRIDABLE. */
16671 : 8488 : stree->n.tb->overridden = NULL;
16672 : 8488 : if (super_type)
16673 : : {
16674 : 1480 : gfc_symtree* overridden;
16675 : 1480 : overridden = gfc_find_typebound_proc (super_type, NULL,
16676 : : stree->name, true, NULL);
16677 : :
16678 : 1480 : if (overridden)
16679 : : {
16680 : 1210 : if (overridden->n.tb)
16681 : 1210 : stree->n.tb->overridden = overridden->n.tb;
16682 : :
16683 : 1210 : if (!gfc_check_typebound_override (stree, overridden))
16684 : 26 : goto error;
16685 : : }
16686 : : }
16687 : :
16688 : : /* See if there's a name collision with a component directly in this type. */
16689 : 20479 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
16690 : 12018 : if (!strcmp (comp->name, stree->name))
16691 : : {
16692 : 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
16693 : : " %qs",
16694 : : stree->name, &where, resolve_bindings_derived->name);
16695 : 1 : goto error;
16696 : : }
16697 : :
16698 : : /* Try to find a name collision with an inherited component. */
16699 : 8461 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
16700 : : NULL))
16701 : : {
16702 : 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
16703 : : " component of %qs",
16704 : : stree->name, &where, resolve_bindings_derived->name);
16705 : 1 : goto error;
16706 : : }
16707 : :
16708 : 8460 : stree->n.tb->error = 0;
16709 : 8460 : return;
16710 : :
16711 : 82 : error:
16712 : 82 : resolve_bindings_result = false;
16713 : 82 : stree->n.tb->error = 1;
16714 : : }
16715 : :
16716 : :
16717 : : static bool
16718 : 82834 : resolve_typebound_procedures (gfc_symbol* derived)
16719 : : {
16720 : 82834 : int op;
16721 : 82834 : gfc_symbol* super_type;
16722 : :
16723 : 82834 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
16724 : : return true;
16725 : :
16726 : 4620 : super_type = gfc_get_derived_super_type (derived);
16727 : 4620 : if (super_type)
16728 : 847 : resolve_symbol (super_type);
16729 : :
16730 : 4620 : resolve_bindings_derived = derived;
16731 : 4620 : resolve_bindings_result = true;
16732 : :
16733 : 4620 : containing_dt = derived; /* Needed for checks of PDTs. */
16734 : 4620 : if (derived->f2k_derived->tb_sym_root)
16735 : 4620 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
16736 : : &resolve_typebound_procedure);
16737 : :
16738 : 4620 : if (derived->f2k_derived->tb_uop_root)
16739 : 50 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
16740 : : &resolve_typebound_user_op);
16741 : 4620 : containing_dt = NULL;
16742 : :
16743 : 133980 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
16744 : : {
16745 : 129360 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
16746 : 129360 : if (p && !resolve_typebound_intrinsic_op (derived,
16747 : : (gfc_intrinsic_op)op, p))
16748 : 7 : resolve_bindings_result = false;
16749 : : }
16750 : :
16751 : 4620 : return resolve_bindings_result;
16752 : : }
16753 : :
16754 : :
16755 : : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
16756 : : to give all identical derived types the same backend_decl. */
16757 : : static void
16758 : 170458 : add_dt_to_dt_list (gfc_symbol *derived)
16759 : : {
16760 : 170458 : if (!derived->dt_next)
16761 : : {
16762 : 78876 : if (gfc_derived_types)
16763 : : {
16764 : 64692 : derived->dt_next = gfc_derived_types->dt_next;
16765 : 64692 : gfc_derived_types->dt_next = derived;
16766 : : }
16767 : : else
16768 : : {
16769 : 14184 : derived->dt_next = derived;
16770 : : }
16771 : 78876 : gfc_derived_types = derived;
16772 : : }
16773 : 170458 : }
16774 : :
16775 : :
16776 : : /* Ensure that a derived-type is really not abstract, meaning that every
16777 : : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
16778 : :
16779 : : static bool
16780 : 6924 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
16781 : : {
16782 : 6924 : if (!st)
16783 : : return true;
16784 : :
16785 : 2712 : if (!ensure_not_abstract_walker (sub, st->left))
16786 : : return false;
16787 : 2712 : if (!ensure_not_abstract_walker (sub, st->right))
16788 : : return false;
16789 : :
16790 : 2711 : if (st->n.tb && st->n.tb->deferred)
16791 : : {
16792 : 1959 : gfc_symtree* overriding;
16793 : 1959 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
16794 : 1959 : if (!overriding)
16795 : : return false;
16796 : 1958 : gcc_assert (overriding->n.tb);
16797 : 1958 : if (overriding->n.tb->deferred)
16798 : : {
16799 : 5 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
16800 : : " %qs is DEFERRED and not overridden",
16801 : : sub->name, &sub->declared_at, st->name);
16802 : 5 : return false;
16803 : : }
16804 : : }
16805 : :
16806 : : return true;
16807 : : }
16808 : :
16809 : : static bool
16810 : 1352 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
16811 : : {
16812 : : /* The algorithm used here is to recursively travel up the ancestry of sub
16813 : : and for each ancestor-type, check all bindings. If any of them is
16814 : : DEFERRED, look it up starting from sub and see if the found (overriding)
16815 : : binding is not DEFERRED.
16816 : : This is not the most efficient way to do this, but it should be ok and is
16817 : : clearer than something sophisticated. */
16818 : :
16819 : 1501 : gcc_assert (ancestor && !sub->attr.abstract);
16820 : :
16821 : 1501 : if (!ancestor->attr.abstract)
16822 : : return true;
16823 : :
16824 : : /* Walk bindings of this ancestor. */
16825 : 1500 : if (ancestor->f2k_derived)
16826 : : {
16827 : 1500 : bool t;
16828 : 1500 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
16829 : 1500 : if (!t)
16830 : : return false;
16831 : : }
16832 : :
16833 : : /* Find next ancestor type and recurse on it. */
16834 : 1494 : ancestor = gfc_get_derived_super_type (ancestor);
16835 : 1494 : if (ancestor)
16836 : : return ensure_not_abstract (sub, ancestor);
16837 : :
16838 : : return true;
16839 : : }
16840 : :
16841 : :
16842 : : /* This check for typebound defined assignments is done recursively
16843 : : since the order in which derived types are resolved is not always in
16844 : : order of the declarations. */
16845 : :
16846 : : static void
16847 : 174497 : check_defined_assignments (gfc_symbol *derived)
16848 : : {
16849 : 174497 : gfc_component *c;
16850 : :
16851 : 584132 : for (c = derived->components; c; c = c->next)
16852 : : {
16853 : 411187 : if (!gfc_bt_struct (c->ts.type)
16854 : 98564 : || c->attr.pointer
16855 : 18802 : || c->attr.proc_pointer_comp
16856 : 18802 : || c->attr.class_pointer
16857 : 18796 : || c->attr.proc_pointer)
16858 : 392802 : continue;
16859 : :
16860 : 18385 : if (c->ts.u.derived->attr.defined_assign_comp
16861 : 18168 : || (c->ts.u.derived->f2k_derived
16862 : 17599 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
16863 : : {
16864 : 1528 : derived->attr.defined_assign_comp = 1;
16865 : 1528 : return;
16866 : : }
16867 : :
16868 : 16857 : if (c->attr.allocatable)
16869 : 5811 : continue;
16870 : :
16871 : 11046 : check_defined_assignments (c->ts.u.derived);
16872 : 11046 : if (c->ts.u.derived->attr.defined_assign_comp)
16873 : : {
16874 : 24 : derived->attr.defined_assign_comp = 1;
16875 : 24 : return;
16876 : : }
16877 : : }
16878 : : }
16879 : :
16880 : :
16881 : : /* Resolve a single component of a derived type or structure. */
16882 : :
16883 : : static bool
16884 : 392636 : resolve_component (gfc_component *c, gfc_symbol *sym)
16885 : : {
16886 : 392636 : gfc_symbol *super_type;
16887 : 392636 : symbol_attribute *attr;
16888 : :
16889 : 392636 : if (c->attr.artificial)
16890 : : return true;
16891 : :
16892 : : /* Do not allow vtype components to be resolved in nameless namespaces
16893 : : such as block data because the procedure pointers will cause ICEs
16894 : : and vtables are not needed in these contexts. */
16895 : 268089 : if (sym->attr.vtype && sym->attr.use_assoc
16896 : 46997 : && sym->ns->proc_name == NULL)
16897 : : return true;
16898 : :
16899 : : /* F2008, C442. */
16900 : 268080 : if ((!sym->attr.is_class || c != sym->components)
16901 : 268080 : && c->attr.codimension
16902 : 177 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
16903 : : {
16904 : 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
16905 : : "deferred shape", c->name, &c->loc);
16906 : 4 : return false;
16907 : : }
16908 : :
16909 : : /* F2008, C443. */
16910 : 268076 : if (c->attr.codimension && c->ts.type == BT_DERIVED
16911 : 77 : && c->ts.u.derived->ts.is_iso_c)
16912 : : {
16913 : 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16914 : : "shall not be a coarray", c->name, &c->loc);
16915 : 1 : return false;
16916 : : }
16917 : :
16918 : : /* F2008, C444. */
16919 : 268075 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
16920 : 22 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
16921 : 20 : || c->attr.allocatable))
16922 : : {
16923 : 3 : gfc_error ("Component %qs at %L with coarray component "
16924 : : "shall be a nonpointer, nonallocatable scalar",
16925 : : c->name, &c->loc);
16926 : 3 : return false;
16927 : : }
16928 : :
16929 : : /* F2008, C448. */
16930 : 268072 : if (c->ts.type == BT_CLASS)
16931 : : {
16932 : 6636 : if (c->attr.class_ok && CLASS_DATA (c))
16933 : : {
16934 : 6628 : attr = &(CLASS_DATA (c)->attr);
16935 : :
16936 : : /* Fix up contiguous attribute. */
16937 : 6628 : if (c->attr.contiguous)
16938 : 11 : attr->contiguous = 1;
16939 : : }
16940 : : else
16941 : : attr = NULL;
16942 : : }
16943 : : else
16944 : 261436 : attr = &c->attr;
16945 : :
16946 : 268075 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
16947 : : {
16948 : 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
16949 : : "is not an array pointer", c->name, &c->loc);
16950 : 5 : return false;
16951 : : }
16952 : :
16953 : : /* F2003, 15.2.1 - length has to be one. */
16954 : 39855 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
16955 : 268086 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
16956 : 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
16957 : 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
16958 : : {
16959 : 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
16960 : : c->name, &c->loc);
16961 : 1 : return false;
16962 : : }
16963 : :
16964 : 49122 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
16965 : 157 : && !sym->attr.pdt_type && !sym->attr.pdt_template
16966 : 268074 : && !(gfc_get_derived_super_type (sym)
16967 : 0 : && (gfc_get_derived_super_type (sym)->attr.pdt_type
16968 : 0 : || gfc_get_derived_super_type (sym)->attr.pdt_template)))
16969 : : {
16970 : 8 : gfc_actual_arglist *type_spec_list;
16971 : 8 : if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
16972 : : &type_spec_list)
16973 : : != MATCH_YES)
16974 : 0 : return false;
16975 : 8 : gfc_free_actual_arglist (c->param_list);
16976 : 8 : c->param_list = type_spec_list;
16977 : 8 : if (!sym->attr.pdt_type)
16978 : 8 : sym->attr.pdt_comp = 1;
16979 : : }
16980 : 268058 : else if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
16981 : 371 : && !sym->attr.pdt_type)
16982 : 43 : sym->attr.pdt_comp = 1;
16983 : :
16984 : 268066 : if (c->attr.proc_pointer && c->ts.interface)
16985 : : {
16986 : 14137 : gfc_symbol *ifc = c->ts.interface;
16987 : :
16988 : 14137 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
16989 : : {
16990 : 6 : c->tb->error = 1;
16991 : 6 : return false;
16992 : : }
16993 : :
16994 : 14131 : if (ifc->attr.if_source || ifc->attr.intrinsic)
16995 : : {
16996 : : /* Resolve interface and copy attributes. */
16997 : 14082 : if (ifc->formal && !ifc->formal_ns)
16998 : 2492 : resolve_symbol (ifc);
16999 : 14082 : if (ifc->attr.intrinsic)
17000 : 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
17001 : :
17002 : 14082 : if (ifc->result)
17003 : : {
17004 : 7304 : c->ts = ifc->result->ts;
17005 : 7304 : c->attr.allocatable = ifc->result->attr.allocatable;
17006 : 7304 : c->attr.pointer = ifc->result->attr.pointer;
17007 : 7304 : c->attr.dimension = ifc->result->attr.dimension;
17008 : 7304 : c->as = gfc_copy_array_spec (ifc->result->as);
17009 : 7304 : c->attr.class_ok = ifc->result->attr.class_ok;
17010 : : }
17011 : : else
17012 : : {
17013 : 6778 : c->ts = ifc->ts;
17014 : 6778 : c->attr.allocatable = ifc->attr.allocatable;
17015 : 6778 : c->attr.pointer = ifc->attr.pointer;
17016 : 6778 : c->attr.dimension = ifc->attr.dimension;
17017 : 6778 : c->as = gfc_copy_array_spec (ifc->as);
17018 : 6778 : c->attr.class_ok = ifc->attr.class_ok;
17019 : : }
17020 : 14082 : c->ts.interface = ifc;
17021 : 14082 : c->attr.function = ifc->attr.function;
17022 : 14082 : c->attr.subroutine = ifc->attr.subroutine;
17023 : :
17024 : 14082 : c->attr.pure = ifc->attr.pure;
17025 : 14082 : c->attr.elemental = ifc->attr.elemental;
17026 : 14082 : c->attr.recursive = ifc->attr.recursive;
17027 : 14082 : c->attr.always_explicit = ifc->attr.always_explicit;
17028 : 14082 : c->attr.ext_attr |= ifc->attr.ext_attr;
17029 : : /* Copy char length. */
17030 : 14082 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
17031 : : {
17032 : 491 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
17033 : 454 : if (cl->length && !cl->resolved
17034 : 601 : && !gfc_resolve_expr (cl->length))
17035 : : {
17036 : 0 : c->tb->error = 1;
17037 : 0 : return false;
17038 : : }
17039 : 491 : c->ts.u.cl = cl;
17040 : : }
17041 : : }
17042 : : }
17043 : 253929 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
17044 : : {
17045 : : /* Since PPCs are not implicitly typed, a PPC without an explicit
17046 : : interface must be a subroutine. */
17047 : 115 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
17048 : : }
17049 : :
17050 : : /* Procedure pointer components: Check PASS arg. */
17051 : 268060 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
17052 : 717 : && !sym->attr.vtype)
17053 : : {
17054 : 94 : gfc_symbol* me_arg;
17055 : :
17056 : 94 : if (c->tb->pass_arg)
17057 : : {
17058 : 19 : gfc_formal_arglist* i;
17059 : :
17060 : : /* If an explicit passing argument name is given, walk the arg-list
17061 : : and look for it. */
17062 : :
17063 : 19 : me_arg = NULL;
17064 : 19 : c->tb->pass_arg_num = 1;
17065 : 33 : for (i = c->ts.interface->formal; i; i = i->next)
17066 : : {
17067 : 32 : if (!strcmp (i->sym->name, c->tb->pass_arg))
17068 : : {
17069 : : me_arg = i->sym;
17070 : : break;
17071 : : }
17072 : 14 : c->tb->pass_arg_num++;
17073 : : }
17074 : :
17075 : 19 : if (!me_arg)
17076 : : {
17077 : 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
17078 : : "at %L has no argument %qs", c->name,
17079 : : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
17080 : 1 : c->tb->error = 1;
17081 : 1 : return false;
17082 : : }
17083 : : }
17084 : : else
17085 : : {
17086 : : /* Otherwise, take the first one; there should in fact be at least
17087 : : one. */
17088 : 75 : c->tb->pass_arg_num = 1;
17089 : 75 : if (!c->ts.interface->formal)
17090 : : {
17091 : 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
17092 : : "must have at least one argument",
17093 : : c->name, &c->loc);
17094 : 3 : c->tb->error = 1;
17095 : 3 : return false;
17096 : : }
17097 : 72 : me_arg = c->ts.interface->formal->sym;
17098 : : }
17099 : :
17100 : : /* Now check that the argument-type matches. */
17101 : 72 : gcc_assert (me_arg);
17102 : 90 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
17103 : 89 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
17104 : 89 : || (me_arg->ts.type == BT_CLASS
17105 : 81 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
17106 : : {
17107 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
17108 : : " the derived type %qs", me_arg->name, c->name,
17109 : : me_arg->name, &c->loc, sym->name);
17110 : 1 : c->tb->error = 1;
17111 : 1 : return false;
17112 : : }
17113 : :
17114 : : /* Check for F03:C453. */
17115 : 89 : if (CLASS_DATA (me_arg)->attr.dimension)
17116 : : {
17117 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17118 : : "must be scalar", me_arg->name, c->name, me_arg->name,
17119 : : &c->loc);
17120 : 1 : c->tb->error = 1;
17121 : 1 : return false;
17122 : : }
17123 : :
17124 : 88 : if (CLASS_DATA (me_arg)->attr.class_pointer)
17125 : : {
17126 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17127 : : "may not have the POINTER attribute", me_arg->name,
17128 : : c->name, me_arg->name, &c->loc);
17129 : 1 : c->tb->error = 1;
17130 : 1 : return false;
17131 : : }
17132 : :
17133 : 87 : if (CLASS_DATA (me_arg)->attr.allocatable)
17134 : : {
17135 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
17136 : : "may not be ALLOCATABLE", me_arg->name, c->name,
17137 : : me_arg->name, &c->loc);
17138 : 1 : c->tb->error = 1;
17139 : 1 : return false;
17140 : : }
17141 : :
17142 : 86 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
17143 : : {
17144 : 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
17145 : : " at %L", c->name, &c->loc);
17146 : 2 : return false;
17147 : : }
17148 : :
17149 : : }
17150 : :
17151 : : /* Check type-spec if this is not the parent-type component. */
17152 : 268050 : if (((sym->attr.is_class
17153 : 11869 : && (!sym->components->ts.u.derived->attr.extension
17154 : 2318 : || c != CLASS_DATA (sym->components)))
17155 : 257477 : || (!sym->attr.is_class
17156 : 256181 : && (!sym->attr.extension || c != sym->components)))
17157 : 260207 : && !sym->attr.vtype
17158 : 424114 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
17159 : : return false;
17160 : :
17161 : 268049 : super_type = gfc_get_derived_super_type (sym);
17162 : :
17163 : : /* If this type is an extension, set the accessibility of the parent
17164 : : component. */
17165 : 268049 : if (super_type
17166 : 24569 : && ((sym->attr.is_class
17167 : 11869 : && c == CLASS_DATA (sym->components))
17168 : 16362 : || (!sym->attr.is_class && c == sym->components))
17169 : 14754 : && strcmp (super_type->name, c->name) == 0)
17170 : 6421 : c->attr.access = super_type->attr.access;
17171 : :
17172 : : /* If this type is an extension, see if this component has the same name
17173 : : as an inherited type-bound procedure. */
17174 : 24569 : if (super_type && !sym->attr.is_class
17175 : 12700 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
17176 : : {
17177 : 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
17178 : : " inherited type-bound procedure",
17179 : : c->name, sym->name, &c->loc);
17180 : 1 : return false;
17181 : : }
17182 : :
17183 : 268048 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
17184 : 9302 : && !c->ts.deferred)
17185 : : {
17186 : 7121 : if (sym->attr.pdt_template || c->attr.pdt_string)
17187 : 246 : gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
17188 : :
17189 : 7121 : if (c->ts.u.cl->length == NULL
17190 : 7115 : || !resolve_charlen(c->ts.u.cl)
17191 : 14235 : || !gfc_is_constant_expr (c->ts.u.cl->length))
17192 : : {
17193 : 9 : gfc_error ("Character length of component %qs needs to "
17194 : : "be a constant specification expression at %L",
17195 : : c->name,
17196 : 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
17197 : 9 : return false;
17198 : : }
17199 : :
17200 : 7112 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
17201 : : {
17202 : 2 : if (!c->ts.u.cl->length->error)
17203 : : {
17204 : 1 : gfc_error ("Character length expression of component %qs at %L "
17205 : : "must be of INTEGER type, found %s",
17206 : 1 : c->name, &c->ts.u.cl->length->where,
17207 : : gfc_basic_typename (c->ts.u.cl->length->ts.type));
17208 : 1 : c->ts.u.cl->length->error = 1;
17209 : : }
17210 : 2 : return false;
17211 : : }
17212 : : }
17213 : :
17214 : 268037 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
17215 : 2217 : && !c->attr.pointer && !c->attr.allocatable)
17216 : : {
17217 : 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
17218 : : "length must be a POINTER or ALLOCATABLE",
17219 : : c->name, sym->name, &c->loc);
17220 : 1 : return false;
17221 : : }
17222 : :
17223 : : /* Add the hidden deferred length field. */
17224 : 268036 : if (c->ts.type == BT_CHARACTER
17225 : 9802 : && (c->ts.deferred || c->attr.pdt_string)
17226 : 2384 : && !c->attr.function
17227 : 2348 : && !sym->attr.is_class)
17228 : : {
17229 : 2201 : char name[GFC_MAX_SYMBOL_LEN+9];
17230 : 2201 : gfc_component *strlen;
17231 : 2201 : sprintf (name, "_%s_length", c->name);
17232 : 2201 : strlen = gfc_find_component (sym, name, true, true, NULL);
17233 : 2201 : if (strlen == NULL)
17234 : : {
17235 : 467 : if (!gfc_add_component (sym, name, &strlen))
17236 : 0 : return false;
17237 : 467 : strlen->ts.type = BT_INTEGER;
17238 : 467 : strlen->ts.kind = gfc_charlen_int_kind;
17239 : 467 : strlen->attr.access = ACCESS_PRIVATE;
17240 : 467 : strlen->attr.artificial = 1;
17241 : : }
17242 : : }
17243 : :
17244 : 268036 : if (c->ts.type == BT_DERIVED
17245 : 49292 : && sym->component_access != ACCESS_PRIVATE
17246 : 48320 : && gfc_check_symbol_access (sym)
17247 : 94636 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
17248 : 47266 : && !c->ts.u.derived->attr.use_assoc
17249 : 25290 : && !gfc_check_symbol_access (c->ts.u.derived)
17250 : 268230 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
17251 : : "PRIVATE type and cannot be a component of "
17252 : : "%qs, which is PUBLIC at %L", c->name,
17253 : : sym->name, &sym->declared_at))
17254 : : return false;
17255 : :
17256 : 268035 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
17257 : : {
17258 : 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
17259 : : "type %s", c->name, &c->loc, sym->name);
17260 : 2 : return false;
17261 : : }
17262 : :
17263 : 268033 : if (sym->attr.sequence)
17264 : : {
17265 : 2506 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
17266 : : {
17267 : 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
17268 : : "not have the SEQUENCE attribute",
17269 : : c->ts.u.derived->name, &sym->declared_at);
17270 : 0 : return false;
17271 : : }
17272 : : }
17273 : :
17274 : 268033 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
17275 : 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
17276 : 268033 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
17277 : 6968 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
17278 : 0 : CLASS_DATA (c)->ts.u.derived
17279 : 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
17280 : :
17281 : : /* If an allocatable component derived type is of the same type as
17282 : : the enclosing derived type, we need a vtable generating so that
17283 : : the __deallocate procedure is created. */
17284 : 268033 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
17285 : 56270 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
17286 : 378 : gfc_find_vtab (&c->ts);
17287 : :
17288 : : /* Ensure that all the derived type components are put on the
17289 : : derived type list; even in formal namespaces, where derived type
17290 : : pointer components might not have been declared. */
17291 : 268033 : if (c->ts.type == BT_DERIVED
17292 : 49291 : && c->ts.u.derived
17293 : 49291 : && c->ts.u.derived->components
17294 : 46153 : && c->attr.pointer
17295 : 32167 : && sym != c->ts.u.derived)
17296 : 4161 : add_dt_to_dt_list (c->ts.u.derived);
17297 : :
17298 : 268033 : if (c->as && c->as->type != AS_DEFERRED
17299 : 5831 : && (c->attr.pointer || c->attr.allocatable))
17300 : : return false;
17301 : :
17302 : 268019 : if (!gfc_resolve_array_spec (c->as,
17303 : 268019 : !(c->attr.pointer || c->attr.proc_pointer
17304 : 218142 : || c->attr.allocatable)))
17305 : : return false;
17306 : :
17307 : 100102 : if (c->initializer && !sym->attr.vtype
17308 : 29924 : && !c->attr.pdt_kind && !c->attr.pdt_len
17309 : 295559 : && !gfc_check_assign_symbol (sym, c, c->initializer))
17310 : : return false;
17311 : :
17312 : : return true;
17313 : : }
17314 : :
17315 : :
17316 : : /* Be nice about the locus for a structure expression - show the locus of the
17317 : : first non-null sub-expression if we can. */
17318 : :
17319 : : static locus *
17320 : 4 : cons_where (gfc_expr *struct_expr)
17321 : : {
17322 : 4 : gfc_constructor *cons;
17323 : :
17324 : 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
17325 : :
17326 : 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
17327 : 12 : for (; cons; cons = gfc_constructor_next (cons))
17328 : : {
17329 : 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
17330 : 4 : return &cons->expr->where;
17331 : : }
17332 : :
17333 : 0 : return &struct_expr->where;
17334 : : }
17335 : :
17336 : : /* Resolve the components of a structure type. Much less work than derived
17337 : : types. */
17338 : :
17339 : : static bool
17340 : 913 : resolve_fl_struct (gfc_symbol *sym)
17341 : : {
17342 : 913 : gfc_component *c;
17343 : 913 : gfc_expr *init = NULL;
17344 : 913 : bool success;
17345 : :
17346 : : /* Make sure UNIONs do not have overlapping initializers. */
17347 : 913 : if (sym->attr.flavor == FL_UNION)
17348 : : {
17349 : 498 : for (c = sym->components; c; c = c->next)
17350 : : {
17351 : 331 : if (init && c->initializer)
17352 : : {
17353 : 2 : gfc_error ("Conflicting initializers in union at %L and %L",
17354 : : cons_where (init), cons_where (c->initializer));
17355 : 2 : gfc_free_expr (c->initializer);
17356 : 2 : c->initializer = NULL;
17357 : : }
17358 : 291 : if (init == NULL)
17359 : 291 : init = c->initializer;
17360 : : }
17361 : : }
17362 : :
17363 : 913 : success = true;
17364 : 2830 : for (c = sym->components; c; c = c->next)
17365 : 1917 : if (!resolve_component (c, sym))
17366 : 0 : success = false;
17367 : :
17368 : 913 : if (!success)
17369 : : return false;
17370 : :
17371 : 913 : if (sym->components)
17372 : 862 : add_dt_to_dt_list (sym);
17373 : :
17374 : : return true;
17375 : : }
17376 : :
17377 : : /* Figure if the derived type is using itself directly in one of its components
17378 : : or through referencing other derived types. The information is required to
17379 : : generate the __deallocate and __final type bound procedures to ensure
17380 : : freeing larger hierarchies of derived types with allocatable objects. */
17381 : :
17382 : : static void
17383 : 132752 : resolve_cyclic_derived_type (gfc_symbol *derived)
17384 : : {
17385 : 132752 : hash_set<gfc_symbol *> seen, to_examin;
17386 : 132752 : gfc_component *c;
17387 : 132752 : seen.add (derived);
17388 : 132752 : to_examin.add (derived);
17389 : 443985 : while (!to_examin.is_empty ())
17390 : : {
17391 : 180598 : gfc_symbol *cand = *to_examin.begin ();
17392 : 180598 : to_examin.remove (cand);
17393 : 484830 : for (c = cand->components; c; c = c->next)
17394 : 306349 : if (c->ts.type == BT_DERIVED)
17395 : : {
17396 : 66889 : if (c->ts.u.derived == derived)
17397 : : {
17398 : 1147 : derived->attr.recursive = 1;
17399 : 2117 : return;
17400 : : }
17401 : 65742 : else if (!seen.contains (c->ts.u.derived))
17402 : : {
17403 : 43415 : seen.add (c->ts.u.derived);
17404 : 43415 : to_examin.add (c->ts.u.derived);
17405 : : }
17406 : : }
17407 : 239460 : else if (c->ts.type == BT_CLASS)
17408 : : {
17409 : 8846 : if (!c->attr.class_ok)
17410 : 7 : continue;
17411 : 8839 : if (CLASS_DATA (c)->ts.u.derived == derived)
17412 : : {
17413 : 970 : derived->attr.recursive = 1;
17414 : 970 : return;
17415 : : }
17416 : 7869 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
17417 : : {
17418 : 4642 : seen.add (CLASS_DATA (c)->ts.u.derived);
17419 : 4642 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
17420 : : }
17421 : : }
17422 : : }
17423 : 132752 : }
17424 : :
17425 : : /* Resolve the components of a derived type. This does not have to wait until
17426 : : resolution stage, but can be done as soon as the dt declaration has been
17427 : : parsed. */
17428 : :
17429 : : static bool
17430 : 163536 : resolve_fl_derived0 (gfc_symbol *sym)
17431 : : {
17432 : 163536 : gfc_symbol* super_type;
17433 : 163536 : gfc_component *c;
17434 : 163536 : gfc_formal_arglist *f;
17435 : 163536 : bool success;
17436 : :
17437 : 163536 : if (sym->attr.unlimited_polymorphic)
17438 : : return true;
17439 : :
17440 : 163536 : super_type = gfc_get_derived_super_type (sym);
17441 : :
17442 : : /* F2008, C432. */
17443 : 163536 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
17444 : : {
17445 : 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
17446 : : "parent type %qs shall also have one", sym->name,
17447 : : &sym->declared_at, super_type->name);
17448 : 2 : return false;
17449 : : }
17450 : :
17451 : : /* Ensure the extended type gets resolved before we do. */
17452 : 16664 : if (super_type && !resolve_fl_derived0 (super_type))
17453 : : return false;
17454 : :
17455 : : /* An ABSTRACT type must be extensible. */
17456 : 163528 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
17457 : : {
17458 : 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
17459 : : sym->name, &sym->declared_at);
17460 : 2 : return false;
17461 : : }
17462 : :
17463 : : /* Resolving components below, may create vtabs for which the cyclic type
17464 : : information needs to be present. */
17465 : 163526 : if (!sym->attr.vtype)
17466 : 132752 : resolve_cyclic_derived_type (sym);
17467 : :
17468 : 163526 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
17469 : : : sym->components;
17470 : :
17471 : : success = true;
17472 : 554245 : for ( ; c != NULL; c = c->next)
17473 : 390719 : if (!resolve_component (c, sym))
17474 : 85 : success = false;
17475 : :
17476 : 163526 : if (!success)
17477 : : return false;
17478 : :
17479 : : /* Now add the caf token field, where needed. */
17480 : 163451 : if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
17481 : 770 : && !sym->attr.vtype)
17482 : : {
17483 : 1883 : for (c = sym->components; c; c = c->next)
17484 : 1266 : if (!c->attr.dimension && !c->attr.codimension
17485 : 703 : && (c->attr.allocatable || c->attr.pointer))
17486 : : {
17487 : 134 : char name[GFC_MAX_SYMBOL_LEN+9];
17488 : 134 : gfc_component *token;
17489 : 134 : sprintf (name, "_caf_%s", c->name);
17490 : 134 : token = gfc_find_component (sym, name, true, true, NULL);
17491 : 134 : if (token == NULL)
17492 : : {
17493 : 75 : if (!gfc_add_component (sym, name, &token))
17494 : 0 : return false;
17495 : 75 : token->ts.type = BT_VOID;
17496 : 75 : token->ts.kind = gfc_default_integer_kind;
17497 : 75 : token->attr.access = ACCESS_PRIVATE;
17498 : 75 : token->attr.artificial = 1;
17499 : 75 : token->attr.caf_token = 1;
17500 : : }
17501 : 134 : c->caf_token = token;
17502 : : }
17503 : : }
17504 : :
17505 : 163451 : check_defined_assignments (sym);
17506 : :
17507 : 163451 : if (!sym->attr.defined_assign_comp && super_type)
17508 : 15834 : sym->attr.defined_assign_comp
17509 : 15834 : = super_type->attr.defined_assign_comp;
17510 : :
17511 : : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
17512 : : all DEFERRED bindings are overridden. */
17513 : 16657 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
17514 : 1355 : && !sym->attr.is_class
17515 : 2880 : && !ensure_not_abstract (sym, super_type))
17516 : : return false;
17517 : :
17518 : : /* Check that there is a component for every PDT parameter. */
17519 : 163445 : if (sym->attr.pdt_template)
17520 : : {
17521 : 1499 : for (f = sym->formal; f; f = f->next)
17522 : : {
17523 : 931 : if (!f->sym)
17524 : 1 : continue;
17525 : 930 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
17526 : 930 : if (c == NULL)
17527 : : {
17528 : 9 : gfc_error ("Parameterized type %qs does not have a component "
17529 : : "corresponding to parameter %qs at %L", sym->name,
17530 : 9 : f->sym->name, &sym->declared_at);
17531 : 9 : break;
17532 : : }
17533 : : }
17534 : : }
17535 : :
17536 : : /* Add derived type to the derived type list. */
17537 : 163445 : add_dt_to_dt_list (sym);
17538 : :
17539 : 163445 : return true;
17540 : : }
17541 : :
17542 : : /* The following procedure does the full resolution of a derived type,
17543 : : including resolution of all type-bound procedures (if present). In contrast
17544 : : to 'resolve_fl_derived0' this can only be done after the module has been
17545 : : parsed completely. */
17546 : :
17547 : : static bool
17548 : 84923 : resolve_fl_derived (gfc_symbol *sym)
17549 : : {
17550 : 84923 : gfc_symbol *gen_dt = NULL;
17551 : :
17552 : 84923 : if (sym->attr.unlimited_polymorphic)
17553 : : return true;
17554 : :
17555 : 84923 : if (!sym->attr.is_class)
17556 : 72817 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
17557 : 54448 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
17558 : 2177 : && (!gen_dt->generic->sym->attr.use_assoc
17559 : 2073 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
17560 : 85060 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
17561 : : "%qs at %L being the same name as derived "
17562 : : "type at %L", sym->name,
17563 : : gen_dt->generic->sym == sym
17564 : 11 : ? gen_dt->generic->next->sym->name
17565 : : : gen_dt->generic->sym->name,
17566 : : gen_dt->generic->sym == sym
17567 : 11 : ? &gen_dt->generic->next->sym->declared_at
17568 : : : &gen_dt->generic->sym->declared_at,
17569 : : &sym->declared_at))
17570 : : return false;
17571 : :
17572 : 84919 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
17573 : : {
17574 : 13 : gfc_error ("Derived type %qs at %L has not been declared",
17575 : : sym->name, &sym->declared_at);
17576 : 13 : return false;
17577 : : }
17578 : :
17579 : : /* Resolve the finalizer procedures. */
17580 : 84906 : if (!gfc_resolve_finalizers (sym, NULL))
17581 : : return false;
17582 : :
17583 : 84903 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
17584 : : {
17585 : : /* Fix up incomplete CLASS symbols. */
17586 : 12106 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
17587 : 12106 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
17588 : :
17589 : : /* Nothing more to do for unlimited polymorphic entities. */
17590 : 12106 : if (data->ts.u.derived->attr.unlimited_polymorphic)
17591 : : {
17592 : 1990 : add_dt_to_dt_list (sym);
17593 : 1990 : return true;
17594 : : }
17595 : 10116 : else if (vptr->ts.u.derived == NULL)
17596 : : {
17597 : 6069 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
17598 : 6069 : gcc_assert (vtab);
17599 : 6069 : vptr->ts.u.derived = vtab->ts.u.derived;
17600 : 6069 : if (!resolve_fl_derived0 (vptr->ts.u.derived))
17601 : : return false;
17602 : : }
17603 : : }
17604 : :
17605 : 82913 : if (!resolve_fl_derived0 (sym))
17606 : : return false;
17607 : :
17608 : : /* Resolve the type-bound procedures. */
17609 : 82834 : if (!resolve_typebound_procedures (sym))
17610 : : return false;
17611 : :
17612 : : /* Generate module vtables subject to their accessibility and their not
17613 : : being vtables or pdt templates. If this is not done class declarations
17614 : : in external procedures wind up with their own version and so SELECT TYPE
17615 : : fails because the vptrs do not have the same address. */
17616 : 82793 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
17617 : 82732 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
17618 : 62149 : || (sym->attr.recursive && sym->attr.alloc_comp))
17619 : 20730 : && sym->attr.access != ACCESS_PRIVATE
17620 : 20697 : && !(sym->attr.vtype || sym->attr.pdt_template))
17621 : : {
17622 : 18685 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
17623 : 18685 : gfc_set_sym_referenced (vtab);
17624 : : }
17625 : :
17626 : : return true;
17627 : : }
17628 : :
17629 : :
17630 : : static bool
17631 : 805 : resolve_fl_namelist (gfc_symbol *sym)
17632 : : {
17633 : 805 : gfc_namelist *nl;
17634 : 805 : gfc_symbol *nlsym;
17635 : :
17636 : 2894 : for (nl = sym->namelist; nl; nl = nl->next)
17637 : : {
17638 : : /* Check again, the check in match only works if NAMELIST comes
17639 : : after the decl. */
17640 : 2094 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
17641 : : {
17642 : 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
17643 : : "allowed", nl->sym->name, sym->name, &sym->declared_at);
17644 : 1 : return false;
17645 : : }
17646 : :
17647 : 652 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
17648 : 2101 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17649 : : "with assumed shape in namelist %qs at %L",
17650 : : nl->sym->name, sym->name, &sym->declared_at))
17651 : : return false;
17652 : :
17653 : 2092 : if (is_non_constant_shape_array (nl->sym)
17654 : 2142 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17655 : : "with nonconstant shape in namelist %qs at %L",
17656 : 50 : nl->sym->name, sym->name, &sym->declared_at))
17657 : : return false;
17658 : :
17659 : 2091 : if (nl->sym->ts.type == BT_CHARACTER
17660 : 565 : && (nl->sym->ts.u.cl->length == NULL
17661 : 526 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
17662 : 2173 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
17663 : : "nonconstant character length in "
17664 : 82 : "namelist %qs at %L", nl->sym->name,
17665 : : sym->name, &sym->declared_at))
17666 : : return false;
17667 : :
17668 : : }
17669 : :
17670 : : /* Reject PRIVATE objects in a PUBLIC namelist. */
17671 : 800 : if (gfc_check_symbol_access (sym))
17672 : : {
17673 : 2875 : for (nl = sym->namelist; nl; nl = nl->next)
17674 : : {
17675 : 2088 : if (!nl->sym->attr.use_assoc
17676 : 3952 : && !is_sym_host_assoc (nl->sym, sym->ns)
17677 : 4042 : && !gfc_check_symbol_access (nl->sym))
17678 : : {
17679 : 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
17680 : : "cannot be member of PUBLIC namelist %qs at %L",
17681 : 2 : nl->sym->name, sym->name, &sym->declared_at);
17682 : 2 : return false;
17683 : : }
17684 : :
17685 : 2086 : if (nl->sym->ts.type == BT_DERIVED
17686 : 466 : && (nl->sym->ts.u.derived->attr.alloc_comp
17687 : 464 : || nl->sym->ts.u.derived->attr.pointer_comp))
17688 : : {
17689 : 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
17690 : : "namelist %qs at %L with ALLOCATABLE "
17691 : : "or POINTER components", nl->sym->name,
17692 : : sym->name, &sym->declared_at))
17693 : : return false;
17694 : : return true;
17695 : : }
17696 : :
17697 : : /* Types with private components that came here by USE-association. */
17698 : 2081 : if (nl->sym->ts.type == BT_DERIVED
17699 : 2081 : && derived_inaccessible (nl->sym->ts.u.derived))
17700 : : {
17701 : 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
17702 : : "components and cannot be member of namelist %qs at %L",
17703 : : nl->sym->name, sym->name, &sym->declared_at);
17704 : 6 : return false;
17705 : : }
17706 : :
17707 : : /* Types with private components that are defined in the same module. */
17708 : 2075 : if (nl->sym->ts.type == BT_DERIVED
17709 : 910 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
17710 : 2353 : && nl->sym->ts.u.derived->attr.private_comp)
17711 : : {
17712 : 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
17713 : : "cannot be a member of PUBLIC namelist %qs at %L",
17714 : : nl->sym->name, sym->name, &sym->declared_at);
17715 : 0 : return false;
17716 : : }
17717 : : }
17718 : : }
17719 : :
17720 : :
17721 : : /* 14.1.2 A module or internal procedure represent local entities
17722 : : of the same type as a namelist member and so are not allowed. */
17723 : 2859 : for (nl = sym->namelist; nl; nl = nl->next)
17724 : : {
17725 : 2075 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
17726 : 1516 : continue;
17727 : :
17728 : 559 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
17729 : 7 : if ((nl->sym == sym->ns->proc_name)
17730 : 1 : ||
17731 : 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
17732 : 6 : continue;
17733 : :
17734 : 553 : nlsym = NULL;
17735 : 553 : if (nl->sym->name)
17736 : 553 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
17737 : 553 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
17738 : : {
17739 : 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
17740 : : "attribute in %qs at %L", nlsym->name,
17741 : : &sym->declared_at);
17742 : 3 : return false;
17743 : : }
17744 : : }
17745 : :
17746 : : return true;
17747 : : }
17748 : :
17749 : :
17750 : : static bool
17751 : 375917 : resolve_fl_parameter (gfc_symbol *sym)
17752 : : {
17753 : : /* A parameter array's shape needs to be constant. */
17754 : 375917 : if (sym->as != NULL
17755 : 375917 : && (sym->as->type == AS_DEFERRED
17756 : 6164 : || is_non_constant_shape_array (sym)))
17757 : : {
17758 : 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
17759 : : "or of deferred shape", sym->name, &sym->declared_at);
17760 : 17 : return false;
17761 : : }
17762 : :
17763 : : /* Constraints on deferred type parameter. */
17764 : 375900 : if (!deferred_requirements (sym))
17765 : : return false;
17766 : :
17767 : : /* Make sure a parameter that has been implicitly typed still
17768 : : matches the implicit type, since PARAMETER statements can precede
17769 : : IMPLICIT statements. */
17770 : 375899 : if (sym->attr.implicit_type
17771 : 376608 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
17772 : 709 : sym->ns)))
17773 : : {
17774 : 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
17775 : : "later IMPLICIT type", sym->name, &sym->declared_at);
17776 : 0 : return false;
17777 : : }
17778 : :
17779 : : /* Make sure the types of derived parameters are consistent. This
17780 : : type checking is deferred until resolution because the type may
17781 : : refer to a derived type from the host. */
17782 : 375899 : if (sym->ts.type == BT_DERIVED
17783 : 375899 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
17784 : : {
17785 : 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
17786 : 0 : &sym->value->where);
17787 : 0 : return false;
17788 : : }
17789 : :
17790 : : /* F03:C509,C514. */
17791 : 375899 : if (sym->ts.type == BT_CLASS)
17792 : : {
17793 : 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
17794 : : sym->name, &sym->declared_at);
17795 : 0 : return false;
17796 : : }
17797 : :
17798 : : return true;
17799 : : }
17800 : :
17801 : :
17802 : : /* Called by resolve_symbol to check PDTs. */
17803 : :
17804 : : static void
17805 : 967 : resolve_pdt (gfc_symbol* sym)
17806 : : {
17807 : 967 : gfc_symbol *derived = NULL;
17808 : 967 : gfc_actual_arglist *param;
17809 : 967 : gfc_component *c;
17810 : 967 : bool const_len_exprs = true;
17811 : 967 : bool assumed_len_exprs = false;
17812 : 967 : symbol_attribute *attr;
17813 : :
17814 : 967 : if (sym->ts.type == BT_DERIVED)
17815 : : {
17816 : 769 : derived = sym->ts.u.derived;
17817 : 769 : attr = &(sym->attr);
17818 : : }
17819 : 198 : else if (sym->ts.type == BT_CLASS)
17820 : : {
17821 : 198 : derived = CLASS_DATA (sym)->ts.u.derived;
17822 : 198 : attr = &(CLASS_DATA (sym)->attr);
17823 : : }
17824 : : else
17825 : 0 : gcc_unreachable ();
17826 : :
17827 : 967 : gcc_assert (derived->attr.pdt_type);
17828 : :
17829 : 2406 : for (param = sym->param_list; param; param = param->next)
17830 : : {
17831 : 1439 : c = gfc_find_component (derived, param->name, false, true, NULL);
17832 : 1439 : gcc_assert (c);
17833 : 1439 : if (c->attr.pdt_kind)
17834 : 695 : continue;
17835 : :
17836 : 530 : if (param->expr && !gfc_is_constant_expr (param->expr)
17837 : 807 : && c->attr.pdt_len)
17838 : : const_len_exprs = false;
17839 : 681 : else if (param->spec_type == SPEC_ASSUMED)
17840 : 274 : assumed_len_exprs = true;
17841 : :
17842 : 744 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
17843 : 10 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
17844 : 8 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
17845 : 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
17846 : : "parameter %qs and requires either the POINTER "
17847 : : "or ALLOCATABLE attribute",
17848 : : sym->name, &sym->declared_at,
17849 : : param->name);
17850 : :
17851 : : }
17852 : :
17853 : 967 : if (!const_len_exprs
17854 : 63 : && (sym->ns->proc_name->attr.is_main_program
17855 : 62 : || sym->ns->proc_name->attr.flavor == FL_MODULE
17856 : 61 : || sym->attr.save != SAVE_NONE))
17857 : 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
17858 : : "SAVE attribute or be a variable declared in the "
17859 : : "main program, a module or a submodule(F08/C513)",
17860 : : sym->name, &sym->declared_at);
17861 : :
17862 : 967 : if (assumed_len_exprs && !(sym->attr.dummy
17863 : 1 : || sym->attr.select_type_temporary || sym->attr.associate_var))
17864 : 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
17865 : : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
17866 : : sym->name, &sym->declared_at);
17867 : 967 : }
17868 : :
17869 : :
17870 : : /* Resolve the symbol's array spec. */
17871 : :
17872 : : static bool
17873 : 1662186 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
17874 : : {
17875 : 1662186 : gfc_namespace *orig_current_ns = gfc_current_ns;
17876 : 1662186 : gfc_current_ns = gfc_get_spec_ns (sym);
17877 : :
17878 : 1662186 : bool saved_specification_expr = specification_expr;
17879 : 1662186 : specification_expr = true;
17880 : :
17881 : 1662186 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
17882 : :
17883 : 1662186 : specification_expr = saved_specification_expr;
17884 : 1662186 : gfc_current_ns = orig_current_ns;
17885 : :
17886 : 1662186 : return result;
17887 : : }
17888 : :
17889 : :
17890 : : /* Do anything necessary to resolve a symbol. Right now, we just
17891 : : assume that an otherwise unknown symbol is a variable. This sort
17892 : : of thing commonly happens for symbols in module. */
17893 : :
17894 : : static void
17895 : 1790876 : resolve_symbol (gfc_symbol *sym)
17896 : : {
17897 : 1790876 : int check_constant, mp_flag;
17898 : 1790876 : gfc_symtree *symtree;
17899 : 1790876 : gfc_symtree *this_symtree;
17900 : 1790876 : gfc_namespace *ns;
17901 : 1790876 : gfc_component *c;
17902 : 1790876 : symbol_attribute class_attr;
17903 : 1790876 : gfc_array_spec *as;
17904 : :
17905 : 1790876 : if (sym->resolve_symbol_called >= 1)
17906 : 159904 : return;
17907 : 1721967 : sym->resolve_symbol_called = 1;
17908 : :
17909 : : /* No symbol will ever have union type; only components can be unions.
17910 : : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
17911 : : (just like derived type declaration symbols have flavor FL_DERIVED). */
17912 : 1721967 : gcc_assert (sym->ts.type != BT_UNION);
17913 : :
17914 : : /* Coarrayed polymorphic objects with allocatable or pointer components are
17915 : : yet unsupported for -fcoarray=lib. */
17916 : 1721967 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
17917 : 86 : && sym->ts.u.derived && CLASS_DATA (sym)
17918 : 86 : && CLASS_DATA (sym)->attr.codimension
17919 : 72 : && CLASS_DATA (sym)->ts.u.derived
17920 : 71 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
17921 : 68 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
17922 : : {
17923 : 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
17924 : : "type coarrays at %L are unsupported", &sym->declared_at);
17925 : 6 : return;
17926 : : }
17927 : :
17928 : 1721961 : if (sym->attr.artificial)
17929 : : return;
17930 : :
17931 : 1633610 : if (sym->attr.unlimited_polymorphic)
17932 : : return;
17933 : :
17934 : 1632163 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
17935 : : {
17936 : 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
17937 : : "the OpenMP DEPEND clause", &sym->declared_at);
17938 : 4 : return;
17939 : : }
17940 : :
17941 : 1632159 : if (sym->attr.flavor == FL_UNKNOWN
17942 : 1611437 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
17943 : 434688 : && !sym->attr.generic && !sym->attr.external
17944 : 176991 : && sym->attr.if_source == IFSRC_UNKNOWN
17945 : 79400 : && sym->ts.type == BT_UNKNOWN))
17946 : : {
17947 : : /* A symbol in a common block might not have been resolved yet properly.
17948 : : Do not try to find an interface with the same name. */
17949 : 91844 : if (sym->attr.flavor == FL_UNKNOWN && !sym->attr.intrinsic
17950 : 20718 : && !sym->attr.generic && !sym->attr.external
17951 : 20667 : && sym->attr.in_common)
17952 : 2530 : goto skip_interfaces;
17953 : :
17954 : : /* If we find that a flavorless symbol is an interface in one of the
17955 : : parent namespaces, find its symtree in this namespace, free the
17956 : : symbol and set the symtree to point to the interface symbol. */
17957 : 127528 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
17958 : : {
17959 : 38880 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
17960 : 38880 : if (symtree && (symtree->n.sym->generic ||
17961 : 699 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
17962 : 610 : && sym->ns->construct_entities)))
17963 : : {
17964 : 674 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
17965 : : sym->name);
17966 : 674 : if (this_symtree->n.sym == sym)
17967 : : {
17968 : 666 : symtree->n.sym->refs++;
17969 : 666 : gfc_release_symbol (sym);
17970 : 666 : this_symtree->n.sym = symtree->n.sym;
17971 : 666 : return;
17972 : : }
17973 : : }
17974 : : }
17975 : :
17976 : 88648 : skip_interfaces:
17977 : : /* Otherwise give it a flavor according to such attributes as
17978 : : it has. */
17979 : 91178 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
17980 : 20543 : && sym->attr.intrinsic == 0)
17981 : 20539 : sym->attr.flavor = FL_VARIABLE;
17982 : 70639 : else if (sym->attr.flavor == FL_UNKNOWN)
17983 : : {
17984 : 55 : sym->attr.flavor = FL_PROCEDURE;
17985 : 55 : if (sym->attr.dimension)
17986 : 0 : sym->attr.function = 1;
17987 : : }
17988 : : }
17989 : :
17990 : 1631493 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
17991 : 2304 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
17992 : :
17993 : 1445 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
17994 : 1632938 : && !resolve_procedure_interface (sym))
17995 : : return;
17996 : :
17997 : 1631482 : if (sym->attr.is_protected && !sym->attr.proc_pointer
17998 : 130 : && (sym->attr.procedure || sym->attr.external))
17999 : : {
18000 : 0 : if (sym->attr.external)
18001 : 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
18002 : : "at %L", &sym->declared_at);
18003 : : else
18004 : 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
18005 : : "at %L", &sym->declared_at);
18006 : :
18007 : 0 : return;
18008 : : }
18009 : :
18010 : : /* Ensure that variables of derived or class type having a finalizer are
18011 : : marked used even when the variable is not used anything else in the scope.
18012 : : This fixes PR118730. */
18013 : 637983 : if (sym->attr.flavor == FL_VARIABLE && !sym->attr.referenced
18014 : 436318 : && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
18015 : 1679744 : && gfc_may_be_finalized (sym->ts))
18016 : 8176 : gfc_set_sym_referenced (sym);
18017 : :
18018 : 1631482 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
18019 : : return;
18020 : :
18021 : 1630711 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
18022 : 1631474 : && !resolve_fl_struct (sym))
18023 : : return;
18024 : :
18025 : : /* Symbols that are module procedures with results (functions) have
18026 : : the types and array specification copied for type checking in
18027 : : procedures that call them, as well as for saving to a module
18028 : : file. These symbols can't stand the scrutiny that their results
18029 : : can. */
18030 : 1631342 : mp_flag = (sym->result != NULL && sym->result != sym);
18031 : :
18032 : : /* Make sure that the intrinsic is consistent with its internal
18033 : : representation. This needs to be done before assigning a default
18034 : : type to avoid spurious warnings. */
18035 : 1598057 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
18036 : 1662822 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
18037 : : return;
18038 : :
18039 : : /* Resolve associate names. */
18040 : 1631306 : if (sym->assoc)
18041 : 6550 : resolve_assoc_var (sym, true);
18042 : :
18043 : : /* Assign default type to symbols that need one and don't have one. */
18044 : 1631306 : if (sym->ts.type == BT_UNKNOWN)
18045 : : {
18046 : 391600 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
18047 : : {
18048 : 11730 : gfc_set_default_type (sym, 1, NULL);
18049 : : }
18050 : :
18051 : 253445 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
18052 : 59826 : && !sym->attr.function && !sym->attr.subroutine
18053 : 393215 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
18054 : 564 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
18055 : :
18056 : 391600 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18057 : : {
18058 : : /* The specific case of an external procedure should emit an error
18059 : : in the case that there is no implicit type. */
18060 : 99729 : if (!mp_flag)
18061 : : {
18062 : 93860 : if (!sym->attr.mixed_entry_master)
18063 : 93754 : gfc_set_default_type (sym, sym->attr.external, NULL);
18064 : : }
18065 : : else
18066 : : {
18067 : : /* Result may be in another namespace. */
18068 : 5869 : resolve_symbol (sym->result);
18069 : :
18070 : 5869 : if (!sym->result->attr.proc_pointer)
18071 : : {
18072 : 5690 : sym->ts = sym->result->ts;
18073 : 5690 : sym->as = gfc_copy_array_spec (sym->result->as);
18074 : 5690 : sym->attr.dimension = sym->result->attr.dimension;
18075 : 5690 : sym->attr.codimension = sym->result->attr.codimension;
18076 : 5690 : sym->attr.pointer = sym->result->attr.pointer;
18077 : 5690 : sym->attr.allocatable = sym->result->attr.allocatable;
18078 : 5690 : sym->attr.contiguous = sym->result->attr.contiguous;
18079 : : }
18080 : : }
18081 : : }
18082 : : }
18083 : 1239706 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
18084 : 31211 : resolve_symbol_array_spec (sym->result, false);
18085 : :
18086 : : /* For a CLASS-valued function with a result variable, affirm that it has
18087 : : been resolved also when looking at the symbol 'sym'. */
18088 : 422811 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
18089 : 715 : sym->attr.class_ok = sym->result->attr.class_ok;
18090 : :
18091 : 1631306 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
18092 : 18806 : && CLASS_DATA (sym))
18093 : : {
18094 : 18805 : as = CLASS_DATA (sym)->as;
18095 : 18805 : class_attr = CLASS_DATA (sym)->attr;
18096 : 18805 : class_attr.pointer = class_attr.class_pointer;
18097 : : }
18098 : : else
18099 : : {
18100 : 1612501 : class_attr = sym->attr;
18101 : 1612501 : as = sym->as;
18102 : : }
18103 : :
18104 : : /* F2008, C530. */
18105 : 1631306 : if (sym->attr.contiguous
18106 : 7684 : && (!class_attr.dimension
18107 : 7681 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
18108 : 127 : && !class_attr.pointer)))
18109 : : {
18110 : 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
18111 : : "array pointer or an assumed-shape or assumed-rank array",
18112 : : sym->name, &sym->declared_at);
18113 : 7 : return;
18114 : : }
18115 : :
18116 : : /* Assumed size arrays and assumed shape arrays must be dummy
18117 : : arguments. Array-spec's of implied-shape should have been resolved to
18118 : : AS_EXPLICIT already. */
18119 : :
18120 : 1623745 : if (as)
18121 : : {
18122 : : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
18123 : : specification expression. */
18124 : 143605 : if (as->type == AS_IMPLIED_SHAPE)
18125 : : {
18126 : : int i;
18127 : 1 : for (i=0; i<as->rank; i++)
18128 : : {
18129 : 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
18130 : : {
18131 : 1 : gfc_error ("Bad specification for assumed size array at %L",
18132 : : &as->lower[i]->where);
18133 : 1 : return;
18134 : : }
18135 : : }
18136 : 0 : gcc_unreachable();
18137 : : }
18138 : :
18139 : 143604 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
18140 : 111267 : || as->type == AS_ASSUMED_SHAPE)
18141 : 43697 : && !sym->attr.dummy && !sym->attr.select_type_temporary
18142 : 8 : && !sym->attr.associate_var)
18143 : : {
18144 : 7 : if (as->type == AS_ASSUMED_SIZE)
18145 : 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
18146 : : &sym->declared_at);
18147 : : else
18148 : 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
18149 : : &sym->declared_at);
18150 : 7 : return;
18151 : : }
18152 : : /* TS 29113, C535a. */
18153 : 143597 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
18154 : 60 : && !sym->attr.select_type_temporary
18155 : 60 : && !(cs_base && cs_base->current
18156 : 45 : && (cs_base->current->op == EXEC_SELECT_RANK
18157 : 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
18158 : 0 : && cs_base->current->op == EXEC_BLOCK))))
18159 : : {
18160 : 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
18161 : : &sym->declared_at);
18162 : 18 : return;
18163 : : }
18164 : 143579 : if (as->type == AS_ASSUMED_RANK
18165 : 26194 : && (sym->attr.codimension || sym->attr.value))
18166 : : {
18167 : 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
18168 : : "CODIMENSION attribute", &sym->declared_at);
18169 : 2 : return;
18170 : : }
18171 : : }
18172 : :
18173 : : /* Make sure symbols with known intent or optional are really dummy
18174 : : variable. Because of ENTRY statement, this has to be deferred
18175 : : until resolution time. */
18176 : :
18177 : 1631271 : if (!sym->attr.dummy
18178 : 1172219 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
18179 : : {
18180 : 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
18181 : 2 : return;
18182 : : }
18183 : :
18184 : 1631269 : if (sym->attr.value && !sym->attr.dummy)
18185 : : {
18186 : 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
18187 : : "it is not a dummy argument", sym->name, &sym->declared_at);
18188 : 2 : return;
18189 : : }
18190 : :
18191 : 1631267 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
18192 : : {
18193 : 616 : gfc_charlen *cl = sym->ts.u.cl;
18194 : 616 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
18195 : : {
18196 : 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
18197 : : "attribute must have constant length",
18198 : : sym->name, &sym->declared_at);
18199 : 2 : return;
18200 : : }
18201 : :
18202 : 614 : if (sym->ts.is_c_interop
18203 : 381 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
18204 : : {
18205 : 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
18206 : : "with VALUE attribute must have length one",
18207 : : sym->name, &sym->declared_at);
18208 : 1 : return;
18209 : : }
18210 : : }
18211 : :
18212 : 1631264 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18213 : 119978 : && sym->ts.u.derived->attr.generic)
18214 : : {
18215 : 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
18216 : 20 : if (!sym->ts.u.derived)
18217 : : {
18218 : 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
18219 : : "which has not been defined", sym->name,
18220 : : &sym->declared_at, sym->ts.u.derived->name);
18221 : 0 : sym->ts.type = BT_UNKNOWN;
18222 : 0 : return;
18223 : : }
18224 : : }
18225 : :
18226 : : /* Use the same constraints as TYPE(*), except for the type check
18227 : : and that only scalars and assumed-size arrays are permitted. */
18228 : 1631264 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
18229 : : {
18230 : 12960 : if (!sym->attr.dummy)
18231 : : {
18232 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18233 : : "a dummy argument", sym->name, &sym->declared_at);
18234 : 1 : return;
18235 : : }
18236 : :
18237 : 12959 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
18238 : 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
18239 : 0 : && sym->ts.type != BT_COMPLEX)
18240 : : {
18241 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
18242 : : "of type TYPE(*) or of an numeric intrinsic type",
18243 : : sym->name, &sym->declared_at);
18244 : 0 : return;
18245 : : }
18246 : :
18247 : 12959 : if (sym->attr.allocatable || sym->attr.codimension
18248 : 12957 : || sym->attr.pointer || sym->attr.value)
18249 : : {
18250 : 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18251 : : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
18252 : : "attribute", sym->name, &sym->declared_at);
18253 : 4 : return;
18254 : : }
18255 : :
18256 : 12955 : if (sym->attr.intent == INTENT_OUT)
18257 : : {
18258 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
18259 : : "have the INTENT(OUT) attribute",
18260 : : sym->name, &sym->declared_at);
18261 : 0 : return;
18262 : : }
18263 : 12955 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
18264 : : {
18265 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
18266 : : "either be a scalar or an assumed-size array",
18267 : : sym->name, &sym->declared_at);
18268 : 1 : return;
18269 : : }
18270 : :
18271 : : /* Set the type to TYPE(*) and add a dimension(*) to ensure
18272 : : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
18273 : : packing. */
18274 : 12954 : sym->ts.type = BT_ASSUMED;
18275 : 12954 : sym->as = gfc_get_array_spec ();
18276 : 12954 : sym->as->type = AS_ASSUMED_SIZE;
18277 : 12954 : sym->as->rank = 1;
18278 : 12954 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
18279 : : }
18280 : 1618304 : else if (sym->ts.type == BT_ASSUMED)
18281 : : {
18282 : : /* TS 29113, C407a. */
18283 : 11006 : if (!sym->attr.dummy)
18284 : : {
18285 : 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
18286 : : "for dummy variables", sym->name, &sym->declared_at);
18287 : 7 : return;
18288 : : }
18289 : 10999 : if (sym->attr.allocatable || sym->attr.codimension
18290 : 10995 : || sym->attr.pointer || sym->attr.value)
18291 : : {
18292 : 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
18293 : : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
18294 : : sym->name, &sym->declared_at);
18295 : 8 : return;
18296 : : }
18297 : 10991 : if (sym->attr.intent == INTENT_OUT)
18298 : : {
18299 : 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
18300 : : "INTENT(OUT) attribute",
18301 : : sym->name, &sym->declared_at);
18302 : 2 : return;
18303 : : }
18304 : 10989 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
18305 : : {
18306 : 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
18307 : : "explicit-shape array", sym->name, &sym->declared_at);
18308 : 3 : return;
18309 : : }
18310 : : }
18311 : :
18312 : : /* If the symbol is marked as bind(c), that it is declared at module level
18313 : : scope and verify its type and kind. Do not do the latter for symbols
18314 : : that are implicitly typed because that is handled in
18315 : : gfc_set_default_type. Handle dummy arguments and procedure definitions
18316 : : separately. Also, anything that is use associated is not handled here
18317 : : but instead is handled in the module it is declared in. Finally, derived
18318 : : type definitions are allowed to be BIND(C) since that only implies that
18319 : : they're interoperable, and they are checked fully for interoperability
18320 : : when a variable is declared of that type. */
18321 : 1631238 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
18322 : 7158 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
18323 : 567 : && sym->attr.flavor != FL_DERIVED)
18324 : : {
18325 : 167 : bool t = true;
18326 : :
18327 : : /* First, make sure the variable is declared at the
18328 : : module-level scope (J3/04-007, Section 15.3). */
18329 : 167 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
18330 : 7 : && !sym->attr.in_common)
18331 : : {
18332 : 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
18333 : : "is neither a COMMON block nor declared at the "
18334 : : "module level scope", sym->name, &(sym->declared_at));
18335 : 6 : t = false;
18336 : : }
18337 : 161 : else if (sym->ts.type == BT_CHARACTER
18338 : 161 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
18339 : 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
18340 : 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
18341 : : {
18342 : 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
18343 : 1 : sym->name, &sym->declared_at);
18344 : 1 : t = false;
18345 : : }
18346 : 160 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
18347 : : {
18348 : 1 : t = verify_com_block_vars_c_interop (sym->common_head);
18349 : : }
18350 : 159 : else if (sym->attr.implicit_type == 0)
18351 : : {
18352 : : /* If type() declaration, we need to verify that the components
18353 : : of the given type are all C interoperable, etc. */
18354 : 157 : if (sym->ts.type == BT_DERIVED &&
18355 : 24 : sym->ts.u.derived->attr.is_c_interop != 1)
18356 : : {
18357 : : /* Make sure the user marked the derived type as BIND(C). If
18358 : : not, call the verify routine. This could print an error
18359 : : for the derived type more than once if multiple variables
18360 : : of that type are declared. */
18361 : 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
18362 : 1 : verify_bind_c_derived_type (sym->ts.u.derived);
18363 : 157 : t = false;
18364 : : }
18365 : :
18366 : : /* Verify the variable itself as C interoperable if it
18367 : : is BIND(C). It is not possible for this to succeed if
18368 : : the verify_bind_c_derived_type failed, so don't have to handle
18369 : : any error returned by verify_bind_c_derived_type. */
18370 : 157 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
18371 : 157 : sym->common_block);
18372 : : }
18373 : :
18374 : 165 : if (!t)
18375 : : {
18376 : : /* clear the is_bind_c flag to prevent reporting errors more than
18377 : : once if something failed. */
18378 : 10 : sym->attr.is_bind_c = 0;
18379 : 10 : return;
18380 : : }
18381 : : }
18382 : :
18383 : : /* If a derived type symbol has reached this point, without its
18384 : : type being declared, we have an error. Notice that most
18385 : : conditions that produce undefined derived types have already
18386 : : been dealt with. However, the likes of:
18387 : : implicit type(t) (t) ..... call foo (t) will get us here if
18388 : : the type is not declared in the scope of the implicit
18389 : : statement. Change the type to BT_UNKNOWN, both because it is so
18390 : : and to prevent an ICE. */
18391 : 1631228 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
18392 : 119976 : && sym->ts.u.derived->components == NULL
18393 : 1084 : && !sym->ts.u.derived->attr.zero_comp)
18394 : : {
18395 : 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
18396 : : "which has not been defined", sym->name,
18397 : : &sym->declared_at, sym->ts.u.derived->name);
18398 : 3 : sym->ts.type = BT_UNKNOWN;
18399 : 3 : return;
18400 : : }
18401 : :
18402 : : /* Make sure that the derived type has been resolved and that the
18403 : : derived type is visible in the symbol's namespace, if it is a
18404 : : module function and is not PRIVATE. */
18405 : 1631225 : if (sym->ts.type == BT_DERIVED
18406 : 126845 : && sym->ts.u.derived->attr.use_assoc
18407 : 110145 : && sym->ns->proc_name
18408 : 110137 : && sym->ns->proc_name->attr.flavor == FL_MODULE
18409 : 1637031 : && !resolve_fl_derived (sym->ts.u.derived))
18410 : : return;
18411 : :
18412 : : /* Unless the derived-type declaration is use associated, Fortran 95
18413 : : does not allow public entries of private derived types.
18414 : : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
18415 : : 161 in 95-006r3. */
18416 : 1631225 : if (sym->ts.type == BT_DERIVED
18417 : 126845 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
18418 : 7701 : && !sym->ts.u.derived->attr.use_assoc
18419 : 1895 : && gfc_check_symbol_access (sym)
18420 : 1696 : && !gfc_check_symbol_access (sym->ts.u.derived)
18421 : 1631238 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
18422 : : "derived type %qs",
18423 : 13 : (sym->attr.flavor == FL_PARAMETER)
18424 : : ? "parameter" : "variable",
18425 : : sym->name, &sym->declared_at,
18426 : 13 : sym->ts.u.derived->name))
18427 : : return;
18428 : :
18429 : : /* F2008, C1302. */
18430 : 1631218 : if (sym->ts.type == BT_DERIVED
18431 : 126838 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18432 : 118 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
18433 : 126814 : || sym->ts.u.derived->attr.lock_comp)
18434 : 37 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18435 : : {
18436 : 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
18437 : : "type LOCK_TYPE must be a coarray", sym->name,
18438 : : &sym->declared_at);
18439 : 4 : return;
18440 : : }
18441 : :
18442 : : /* TS18508, C702/C703. */
18443 : 1631214 : if (sym->ts.type == BT_DERIVED
18444 : 126834 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
18445 : 117 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
18446 : 126824 : || sym->ts.u.derived->attr.event_comp)
18447 : 10 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
18448 : : {
18449 : 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
18450 : : "type EVENT_TYPE must be a coarray", sym->name,
18451 : : &sym->declared_at);
18452 : 1 : return;
18453 : : }
18454 : :
18455 : : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
18456 : : default initialization is defined (5.1.2.4.4). */
18457 : 1631213 : if (sym->ts.type == BT_DERIVED
18458 : 126833 : && sym->attr.dummy
18459 : 43820 : && sym->attr.intent == INTENT_OUT
18460 : 2354 : && sym->as
18461 : 381 : && sym->as->type == AS_ASSUMED_SIZE)
18462 : : {
18463 : 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
18464 : : {
18465 : 1 : if (c->initializer)
18466 : : {
18467 : 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
18468 : : "ASSUMED SIZE and so cannot have a default initializer",
18469 : : sym->name, &sym->declared_at);
18470 : 1 : return;
18471 : : }
18472 : : }
18473 : : }
18474 : :
18475 : : /* F2008, C542. */
18476 : 1631212 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18477 : 43819 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
18478 : : {
18479 : 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
18480 : : "INTENT(OUT)", sym->name, &sym->declared_at);
18481 : 0 : return;
18482 : : }
18483 : :
18484 : : /* TS18508. */
18485 : 1631212 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
18486 : 43819 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
18487 : : {
18488 : 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
18489 : : "INTENT(OUT)", sym->name, &sym->declared_at);
18490 : 0 : return;
18491 : : }
18492 : :
18493 : : /* F2008, C525. */
18494 : 1631212 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18495 : 1631123 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18496 : 18809 : && sym->ts.u.derived && CLASS_DATA (sym)
18497 : 18803 : && CLASS_DATA (sym)->attr.coarray_comp))
18498 : 1631123 : || class_attr.codimension)
18499 : 1544 : && (sym->attr.result || sym->result == sym))
18500 : : {
18501 : 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
18502 : : "a coarray component", sym->name, &sym->declared_at);
18503 : 8 : return;
18504 : : }
18505 : :
18506 : : /* F2008, C524. */
18507 : 1631204 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
18508 : 370 : && sym->ts.u.derived->ts.is_iso_c)
18509 : : {
18510 : 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
18511 : : "shall not be a coarray", sym->name, &sym->declared_at);
18512 : 3 : return;
18513 : : }
18514 : :
18515 : : /* F2008, C525. */
18516 : 1631201 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18517 : 1631115 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18518 : 18808 : && sym->ts.u.derived && CLASS_DATA (sym)
18519 : 18802 : && CLASS_DATA (sym)->attr.coarray_comp))
18520 : 86 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
18521 : 82 : || class_attr.allocatable))
18522 : : {
18523 : 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
18524 : : "nonpointer, nonallocatable scalar, which is not a coarray",
18525 : : sym->name, &sym->declared_at);
18526 : 4 : return;
18527 : : }
18528 : :
18529 : : /* F2008, C526. The function-result case was handled above. */
18530 : 1631197 : if (class_attr.codimension
18531 : 1447 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
18532 : 296 : || sym->attr.select_type_temporary
18533 : 225 : || sym->attr.associate_var
18534 : 212 : || (sym->ns->save_all && !sym->attr.automatic)
18535 : 212 : || sym->ns->proc_name->attr.flavor == FL_MODULE
18536 : 212 : || sym->ns->proc_name->attr.is_main_program
18537 : 5 : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
18538 : : {
18539 : 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
18540 : : "nor a dummy argument", sym->name, &sym->declared_at);
18541 : 4 : return;
18542 : : }
18543 : : /* F2008, C528. */
18544 : 1631193 : else if (class_attr.codimension && !sym->attr.select_type_temporary
18545 : 1372 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
18546 : : {
18547 : 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
18548 : : "deferred shape without allocatable", sym->name,
18549 : : &sym->declared_at);
18550 : 6 : return;
18551 : : }
18552 : 1631187 : else if (class_attr.codimension && class_attr.allocatable && as
18553 : 523 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
18554 : : {
18555 : 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
18556 : : "deferred shape", sym->name, &sym->declared_at);
18557 : 9 : return;
18558 : : }
18559 : :
18560 : : /* F2008, C541. */
18561 : 1631178 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
18562 : 1631096 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
18563 : 18803 : && sym->ts.u.derived && CLASS_DATA (sym)
18564 : 18797 : && CLASS_DATA (sym)->attr.coarray_comp))
18565 : 1631096 : || (class_attr.codimension && class_attr.allocatable))
18566 : 596 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
18567 : : {
18568 : 3 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
18569 : : "allocatable coarray or have coarray components",
18570 : : sym->name, &sym->declared_at);
18571 : 3 : return;
18572 : : }
18573 : :
18574 : 1631175 : if (class_attr.codimension && sym->attr.dummy
18575 : 425 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
18576 : : {
18577 : 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
18578 : : "procedure %qs", sym->name, &sym->declared_at,
18579 : : sym->ns->proc_name->name);
18580 : 2 : return;
18581 : : }
18582 : :
18583 : 1631173 : if (sym->ts.type == BT_LOGICAL
18584 : 111358 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
18585 : 111355 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
18586 : 30784 : && sym->ns->proc_name->attr.is_bind_c)))
18587 : : {
18588 : : int i;
18589 : 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
18590 : 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
18591 : : break;
18592 : 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
18593 : 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
18594 : : "%L with non-C_Bool kind in BIND(C) procedure "
18595 : : "%qs", sym->name, &sym->declared_at,
18596 : 13 : sym->ns->proc_name->name))
18597 : : return;
18598 : 167 : else if (!gfc_logical_kinds[i].c_bool
18599 : 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
18600 : : "%qs at %L with non-C_Bool kind in "
18601 : : "BIND(C) procedure %qs", sym->name,
18602 : : &sym->declared_at,
18603 : 15 : sym->attr.function ? sym->name
18604 : 13 : : sym->ns->proc_name->name))
18605 : : return;
18606 : : }
18607 : :
18608 : 1631170 : switch (sym->attr.flavor)
18609 : : {
18610 : 637866 : case FL_VARIABLE:
18611 : 637866 : if (!resolve_fl_variable (sym, mp_flag))
18612 : : return;
18613 : : break;
18614 : :
18615 : 465620 : case FL_PROCEDURE:
18616 : 465620 : if (sym->formal && !sym->formal_ns)
18617 : : {
18618 : : /* Check that none of the arguments are a namelist. */
18619 : : gfc_formal_arglist *formal = sym->formal;
18620 : :
18621 : 103676 : for (; formal; formal = formal->next)
18622 : 70475 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
18623 : : {
18624 : 1 : gfc_error ("Namelist %qs cannot be an argument to "
18625 : : "subroutine or function at %L",
18626 : : formal->sym->name, &sym->declared_at);
18627 : 1 : return;
18628 : : }
18629 : : }
18630 : :
18631 : 465619 : if (!resolve_fl_procedure (sym, mp_flag))
18632 : : return;
18633 : : break;
18634 : :
18635 : 805 : case FL_NAMELIST:
18636 : 805 : if (!resolve_fl_namelist (sym))
18637 : : return;
18638 : : break;
18639 : :
18640 : 375917 : case FL_PARAMETER:
18641 : 375917 : if (!resolve_fl_parameter (sym))
18642 : : return;
18643 : : break;
18644 : :
18645 : : default:
18646 : : break;
18647 : : }
18648 : :
18649 : : /* Resolve array specifier. Check as well some constraints
18650 : : on COMMON blocks. */
18651 : :
18652 : 1630975 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
18653 : :
18654 : 1630975 : resolve_symbol_array_spec (sym, check_constant);
18655 : :
18656 : : /* Resolve formal namespaces. */
18657 : 1630975 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
18658 : 254518 : && !sym->attr.contained && !sym->attr.intrinsic)
18659 : 230258 : gfc_resolve (sym->formal_ns);
18660 : :
18661 : : /* Make sure the formal namespace is present. */
18662 : 1630975 : if (sym->formal && !sym->formal_ns)
18663 : : {
18664 : : gfc_formal_arglist *formal = sym->formal;
18665 : 33532 : while (formal && !formal->sym)
18666 : 11 : formal = formal->next;
18667 : :
18668 : 33521 : if (formal)
18669 : : {
18670 : 33510 : sym->formal_ns = formal->sym->ns;
18671 : 33510 : if (sym->formal_ns && sym->ns != formal->sym->ns)
18672 : 25248 : sym->formal_ns->refs++;
18673 : : }
18674 : : }
18675 : :
18676 : : /* Check threadprivate restrictions. */
18677 : 1630975 : if (sym->attr.threadprivate
18678 : 332 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
18679 : 32 : && !(sym->ns->save_all && !sym->attr.automatic)
18680 : 31 : && sym->module == NULL
18681 : 16 : && (sym->ns->proc_name == NULL
18682 : 16 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18683 : 3 : && !sym->ns->proc_name->attr.is_main_program)))
18684 : 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
18685 : :
18686 : : /* Check omp declare target restrictions. */
18687 : 1630975 : if (sym->attr.omp_declare_target
18688 : 1443 : && sym->attr.flavor == FL_VARIABLE
18689 : 604 : && !sym->attr.save
18690 : 195 : && !(sym->ns->save_all && !sym->attr.automatic)
18691 : 195 : && (!sym->attr.in_common
18692 : 182 : && sym->module == NULL
18693 : 92 : && (sym->ns->proc_name == NULL
18694 : 92 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18695 : 2 : && !sym->ns->proc_name->attr.is_main_program))))
18696 : 1 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
18697 : : sym->name, &sym->declared_at);
18698 : :
18699 : : /* If we have come this far we can apply default-initializers, as
18700 : : described in 14.7.5, to those variables that have not already
18701 : : been assigned one. */
18702 : 1630975 : if (sym->ts.type == BT_DERIVED
18703 : 126803 : && !sym->value
18704 : 102324 : && !sym->attr.allocatable
18705 : 99488 : && !sym->attr.alloc_comp)
18706 : : {
18707 : 99459 : symbol_attribute *a = &sym->attr;
18708 : :
18709 : 99459 : if ((!a->save && !a->dummy && !a->pointer
18710 : 54392 : && !a->in_common && !a->use_assoc
18711 : 9934 : && a->referenced
18712 : 7767 : && !((a->function || a->result)
18713 : 1472 : && (!a->dimension
18714 : 130 : || sym->ts.u.derived->attr.alloc_comp
18715 : 89 : || sym->ts.u.derived->attr.pointer_comp))
18716 : 6370 : && !(a->function && sym != sym->result))
18717 : 93109 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
18718 : 1528 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
18719 : 7779 : apply_default_init (sym);
18720 : 91680 : else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
18721 : 2587 : && sym->result)
18722 : : /* Default initialization for function results. */
18723 : 2583 : apply_default_init (sym->result);
18724 : 89097 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
18725 : 11184 : && (sym->ts.u.derived->attr.alloc_comp
18726 : 10769 : || sym->ts.u.derived->attr.pointer_comp))
18727 : : /* Mark the result symbol to be referenced, when it has allocatable
18728 : : components. */
18729 : 461 : sym->result->attr.referenced = 1;
18730 : : }
18731 : :
18732 : 1630975 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
18733 : 18307 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
18734 : 1180 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
18735 : 1105 : && !CLASS_DATA (sym)->attr.class_pointer
18736 : 1079 : && !CLASS_DATA (sym)->attr.allocatable)
18737 : 807 : apply_default_init (sym);
18738 : :
18739 : : /* If this symbol has a type-spec, check it. */
18740 : 1630975 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
18741 : 617300 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
18742 : 1325518 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
18743 : : return;
18744 : :
18745 : 1630972 : if (sym->param_list)
18746 : 967 : resolve_pdt (sym);
18747 : : }
18748 : :
18749 : :
18750 : : /************* Resolve DATA statements *************/
18751 : :
18752 : : static struct
18753 : : {
18754 : : gfc_data_value *vnode;
18755 : : mpz_t left;
18756 : : }
18757 : : values;
18758 : :
18759 : :
18760 : : /* Advance the values structure to point to the next value in the data list. */
18761 : :
18762 : : static bool
18763 : 10856 : next_data_value (void)
18764 : : {
18765 : 16622 : while (mpz_cmp_ui (values.left, 0) == 0)
18766 : : {
18767 : :
18768 : 8179 : if (values.vnode->next == NULL)
18769 : : return false;
18770 : :
18771 : 5766 : values.vnode = values.vnode->next;
18772 : 5766 : mpz_set (values.left, values.vnode->repeat);
18773 : : }
18774 : :
18775 : : return true;
18776 : : }
18777 : :
18778 : :
18779 : : static bool
18780 : 3537 : check_data_variable (gfc_data_variable *var, locus *where)
18781 : : {
18782 : 3537 : gfc_expr *e;
18783 : 3537 : mpz_t size;
18784 : 3537 : mpz_t offset;
18785 : 3537 : bool t;
18786 : 3537 : ar_type mark = AR_UNKNOWN;
18787 : 3537 : int i;
18788 : 3537 : mpz_t section_index[GFC_MAX_DIMENSIONS];
18789 : 3537 : int vector_offset[GFC_MAX_DIMENSIONS];
18790 : 3537 : gfc_ref *ref;
18791 : 3537 : gfc_array_ref *ar;
18792 : 3537 : gfc_symbol *sym;
18793 : 3537 : int has_pointer;
18794 : :
18795 : 3537 : if (!gfc_resolve_expr (var->expr))
18796 : : return false;
18797 : :
18798 : 3537 : ar = NULL;
18799 : 3537 : e = var->expr;
18800 : :
18801 : 3537 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
18802 : 0 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
18803 : 0 : e = e->value.function.actual->expr;
18804 : :
18805 : 3537 : if (e->expr_type != EXPR_VARIABLE)
18806 : : {
18807 : 0 : gfc_error ("Expecting definable entity near %L", where);
18808 : 0 : return false;
18809 : : }
18810 : :
18811 : 3537 : sym = e->symtree->n.sym;
18812 : :
18813 : 3537 : if (sym->ns->is_block_data && !sym->attr.in_common)
18814 : : {
18815 : 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
18816 : : sym->name, &sym->declared_at);
18817 : 2 : return false;
18818 : : }
18819 : :
18820 : 3535 : if (e->ref == NULL && sym->as)
18821 : : {
18822 : 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
18823 : : " declaration", sym->name, where);
18824 : 1 : return false;
18825 : : }
18826 : :
18827 : 3534 : if (gfc_is_coindexed (e))
18828 : : {
18829 : 5 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
18830 : : where);
18831 : 5 : return false;
18832 : : }
18833 : :
18834 : 3529 : has_pointer = sym->attr.pointer;
18835 : :
18836 : 5968 : for (ref = e->ref; ref; ref = ref->next)
18837 : : {
18838 : 2443 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
18839 : : has_pointer = 1;
18840 : :
18841 : 2417 : if (has_pointer)
18842 : : {
18843 : 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
18844 : : {
18845 : 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
18846 : : "be a full array", sym->name, where);
18847 : 1 : return false;
18848 : : }
18849 : :
18850 : 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
18851 : : {
18852 : 1 : gfc_error ("DATA object near %L has the pointer attribute "
18853 : : "and the corresponding DATA value is not a valid "
18854 : : "initial-data-target", where);
18855 : 1 : return false;
18856 : : }
18857 : : }
18858 : :
18859 : 2441 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
18860 : : {
18861 : 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
18862 : : "attribute", ref->u.c.component->name, &e->where);
18863 : 1 : return false;
18864 : : }
18865 : :
18866 : : /* Reject substrings of strings of non-constant length. */
18867 : 2440 : if (ref->type == REF_SUBSTRING
18868 : 73 : && ref->u.ss.length
18869 : 73 : && ref->u.ss.length->length
18870 : 2513 : && !gfc_is_constant_expr (ref->u.ss.length->length))
18871 : 1 : goto bad_charlen;
18872 : : }
18873 : :
18874 : : /* Reject strings with deferred length or non-constant length. */
18875 : 3525 : if (e->ts.type == BT_CHARACTER
18876 : 3525 : && (e->ts.deferred
18877 : 374 : || (e->ts.u.cl->length
18878 : 323 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
18879 : 5 : goto bad_charlen;
18880 : :
18881 : 3520 : mpz_init_set_si (offset, 0);
18882 : :
18883 : 3520 : if (e->rank == 0 || has_pointer)
18884 : : {
18885 : 2675 : mpz_init_set_ui (size, 1);
18886 : 2675 : ref = NULL;
18887 : : }
18888 : : else
18889 : : {
18890 : 845 : ref = e->ref;
18891 : :
18892 : : /* Find the array section reference. */
18893 : 1028 : for (ref = e->ref; ref; ref = ref->next)
18894 : : {
18895 : 1028 : if (ref->type != REF_ARRAY)
18896 : 92 : continue;
18897 : 936 : if (ref->u.ar.type == AR_ELEMENT)
18898 : 91 : continue;
18899 : : break;
18900 : : }
18901 : 845 : gcc_assert (ref);
18902 : :
18903 : : /* Set marks according to the reference pattern. */
18904 : 845 : switch (ref->u.ar.type)
18905 : : {
18906 : : case AR_FULL:
18907 : : mark = AR_FULL;
18908 : : break;
18909 : :
18910 : 149 : case AR_SECTION:
18911 : 149 : ar = &ref->u.ar;
18912 : : /* Get the start position of array section. */
18913 : 149 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
18914 : 149 : mark = AR_SECTION;
18915 : 149 : break;
18916 : :
18917 : 0 : default:
18918 : 0 : gcc_unreachable ();
18919 : : }
18920 : :
18921 : 845 : if (!gfc_array_size (e, &size))
18922 : : {
18923 : 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
18924 : : where);
18925 : 1 : mpz_clear (offset);
18926 : 1 : return false;
18927 : : }
18928 : : }
18929 : :
18930 : 3519 : t = true;
18931 : :
18932 : 11900 : while (mpz_cmp_ui (size, 0) > 0)
18933 : : {
18934 : 8444 : if (!next_data_value ())
18935 : : {
18936 : 1 : gfc_error ("DATA statement at %L has more variables than values",
18937 : : where);
18938 : 1 : t = false;
18939 : 1 : break;
18940 : : }
18941 : :
18942 : 8443 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
18943 : 8443 : if (!t)
18944 : : break;
18945 : :
18946 : : /* If we have more than one element left in the repeat count,
18947 : : and we have more than one element left in the target variable,
18948 : : then create a range assignment. */
18949 : : /* FIXME: Only done for full arrays for now, since array sections
18950 : : seem tricky. */
18951 : 8424 : if (mark == AR_FULL && ref && ref->next == NULL
18952 : 5364 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
18953 : : {
18954 : 137 : mpz_t range;
18955 : :
18956 : 137 : if (mpz_cmp (size, values.left) >= 0)
18957 : : {
18958 : 126 : mpz_init_set (range, values.left);
18959 : 126 : mpz_sub (size, size, values.left);
18960 : 126 : mpz_set_ui (values.left, 0);
18961 : : }
18962 : : else
18963 : : {
18964 : 11 : mpz_init_set (range, size);
18965 : 11 : mpz_sub (values.left, values.left, size);
18966 : 11 : mpz_set_ui (size, 0);
18967 : : }
18968 : :
18969 : 137 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
18970 : : offset, &range);
18971 : :
18972 : 137 : mpz_add (offset, offset, range);
18973 : 137 : mpz_clear (range);
18974 : :
18975 : 137 : if (!t)
18976 : : break;
18977 : 129 : }
18978 : :
18979 : : /* Assign initial value to symbol. */
18980 : : else
18981 : : {
18982 : 8287 : mpz_sub_ui (values.left, values.left, 1);
18983 : 8287 : mpz_sub_ui (size, size, 1);
18984 : :
18985 : 8287 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
18986 : : offset, NULL);
18987 : 8287 : if (!t)
18988 : : break;
18989 : :
18990 : 8252 : if (mark == AR_FULL)
18991 : 5259 : mpz_add_ui (offset, offset, 1);
18992 : :
18993 : : /* Modify the array section indexes and recalculate the offset
18994 : : for next element. */
18995 : 2993 : else if (mark == AR_SECTION)
18996 : 363 : gfc_advance_section (section_index, ar, &offset, vector_offset);
18997 : : }
18998 : : }
18999 : :
19000 : 3519 : if (mark == AR_SECTION)
19001 : : {
19002 : 340 : for (i = 0; i < ar->dimen; i++)
19003 : 192 : mpz_clear (section_index[i]);
19004 : : }
19005 : :
19006 : 3519 : mpz_clear (size);
19007 : 3519 : mpz_clear (offset);
19008 : :
19009 : 3519 : return t;
19010 : :
19011 : 6 : bad_charlen:
19012 : 6 : gfc_error ("Non-constant character length at %L in DATA statement",
19013 : : &e->where);
19014 : 6 : return false;
19015 : : }
19016 : :
19017 : :
19018 : : static bool traverse_data_var (gfc_data_variable *, locus *);
19019 : :
19020 : : /* Iterate over a list of elements in a DATA statement. */
19021 : :
19022 : : static bool
19023 : 236 : traverse_data_list (gfc_data_variable *var, locus *where)
19024 : : {
19025 : 236 : mpz_t trip;
19026 : 236 : iterator_stack frame;
19027 : 236 : gfc_expr *e, *start, *end, *step;
19028 : 236 : bool retval = true;
19029 : :
19030 : 236 : mpz_init (frame.value);
19031 : 236 : mpz_init (trip);
19032 : :
19033 : 236 : start = gfc_copy_expr (var->iter.start);
19034 : 236 : end = gfc_copy_expr (var->iter.end);
19035 : 236 : step = gfc_copy_expr (var->iter.step);
19036 : :
19037 : 236 : if (!gfc_simplify_expr (start, 1)
19038 : 236 : || start->expr_type != EXPR_CONSTANT)
19039 : : {
19040 : 0 : gfc_error ("start of implied-do loop at %L could not be "
19041 : : "simplified to a constant value", &start->where);
19042 : 0 : retval = false;
19043 : 0 : goto cleanup;
19044 : : }
19045 : 236 : if (!gfc_simplify_expr (end, 1)
19046 : 236 : || end->expr_type != EXPR_CONSTANT)
19047 : : {
19048 : 0 : gfc_error ("end of implied-do loop at %L could not be "
19049 : : "simplified to a constant value", &end->where);
19050 : 0 : retval = false;
19051 : 0 : goto cleanup;
19052 : : }
19053 : 236 : if (!gfc_simplify_expr (step, 1)
19054 : 236 : || step->expr_type != EXPR_CONSTANT)
19055 : : {
19056 : 0 : gfc_error ("step of implied-do loop at %L could not be "
19057 : : "simplified to a constant value", &step->where);
19058 : 0 : retval = false;
19059 : 0 : goto cleanup;
19060 : : }
19061 : 236 : if (mpz_cmp_si (step->value.integer, 0) == 0)
19062 : : {
19063 : 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
19064 : : &step->where);
19065 : 1 : retval = false;
19066 : 1 : goto cleanup;
19067 : : }
19068 : :
19069 : 235 : mpz_set (trip, end->value.integer);
19070 : 235 : mpz_sub (trip, trip, start->value.integer);
19071 : 235 : mpz_add (trip, trip, step->value.integer);
19072 : :
19073 : 235 : mpz_div (trip, trip, step->value.integer);
19074 : :
19075 : 235 : mpz_set (frame.value, start->value.integer);
19076 : :
19077 : 235 : frame.prev = iter_stack;
19078 : 235 : frame.variable = var->iter.var->symtree;
19079 : 235 : iter_stack = &frame;
19080 : :
19081 : 1124 : while (mpz_cmp_ui (trip, 0) > 0)
19082 : : {
19083 : 903 : if (!traverse_data_var (var->list, where))
19084 : : {
19085 : 14 : retval = false;
19086 : 14 : goto cleanup;
19087 : : }
19088 : :
19089 : 889 : e = gfc_copy_expr (var->expr);
19090 : 889 : if (!gfc_simplify_expr (e, 1))
19091 : : {
19092 : 0 : gfc_free_expr (e);
19093 : 0 : retval = false;
19094 : 0 : goto cleanup;
19095 : : }
19096 : :
19097 : 889 : mpz_add (frame.value, frame.value, step->value.integer);
19098 : :
19099 : 889 : mpz_sub_ui (trip, trip, 1);
19100 : : }
19101 : :
19102 : 221 : cleanup:
19103 : 236 : mpz_clear (frame.value);
19104 : 236 : mpz_clear (trip);
19105 : :
19106 : 236 : gfc_free_expr (start);
19107 : 236 : gfc_free_expr (end);
19108 : 236 : gfc_free_expr (step);
19109 : :
19110 : 236 : iter_stack = frame.prev;
19111 : 236 : return retval;
19112 : : }
19113 : :
19114 : :
19115 : : /* Type resolve variables in the variable list of a DATA statement. */
19116 : :
19117 : : static bool
19118 : 3397 : traverse_data_var (gfc_data_variable *var, locus *where)
19119 : : {
19120 : 3397 : bool t;
19121 : :
19122 : 7074 : for (; var; var = var->next)
19123 : : {
19124 : 3773 : if (var->expr == NULL)
19125 : 236 : t = traverse_data_list (var, where);
19126 : : else
19127 : 3537 : t = check_data_variable (var, where);
19128 : :
19129 : 3773 : if (!t)
19130 : : return false;
19131 : : }
19132 : :
19133 : : return true;
19134 : : }
19135 : :
19136 : :
19137 : : /* Resolve the expressions and iterators associated with a data statement.
19138 : : This is separate from the assignment checking because data lists should
19139 : : only be resolved once. */
19140 : :
19141 : : static bool
19142 : 2648 : resolve_data_variables (gfc_data_variable *d)
19143 : : {
19144 : 5667 : for (; d; d = d->next)
19145 : : {
19146 : 3024 : if (d->list == NULL)
19147 : : {
19148 : 2872 : if (!gfc_resolve_expr (d->expr))
19149 : : return false;
19150 : : }
19151 : : else
19152 : : {
19153 : 152 : if (!gfc_resolve_iterator (&d->iter, false, true))
19154 : : return false;
19155 : :
19156 : 149 : if (!resolve_data_variables (d->list))
19157 : : return false;
19158 : : }
19159 : : }
19160 : :
19161 : : return true;
19162 : : }
19163 : :
19164 : :
19165 : : /* Resolve a single DATA statement. We implement this by storing a pointer to
19166 : : the value list into static variables, and then recursively traversing the
19167 : : variables list, expanding iterators and such. */
19168 : :
19169 : : static void
19170 : 2499 : resolve_data (gfc_data *d)
19171 : : {
19172 : :
19173 : 2499 : if (!resolve_data_variables (d->var))
19174 : : return;
19175 : :
19176 : 2494 : values.vnode = d->value;
19177 : 2494 : if (d->value == NULL)
19178 : 0 : mpz_set_ui (values.left, 0);
19179 : : else
19180 : 2494 : mpz_set (values.left, d->value->repeat);
19181 : :
19182 : 2494 : if (!traverse_data_var (d->var, &d->where))
19183 : : return;
19184 : :
19185 : : /* At this point, we better not have any values left. */
19186 : :
19187 : 2412 : if (next_data_value ())
19188 : 0 : gfc_error ("DATA statement at %L has more values than variables",
19189 : : &d->where);
19190 : : }
19191 : :
19192 : :
19193 : : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
19194 : : accessed by host or use association, is a dummy argument to a pure function,
19195 : : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
19196 : : is storage associated with any such variable, shall not be used in the
19197 : : following contexts: (clients of this function). */
19198 : :
19199 : : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
19200 : : procedure. Returns zero if assignment is OK, nonzero if there is a
19201 : : problem. */
19202 : : bool
19203 : 53729 : gfc_impure_variable (gfc_symbol *sym)
19204 : : {
19205 : 53729 : gfc_symbol *proc;
19206 : 53729 : gfc_namespace *ns;
19207 : :
19208 : 53729 : if (sym->attr.use_assoc || sym->attr.in_common)
19209 : : return 1;
19210 : :
19211 : : /* The namespace of a module procedure interface holds the arguments and
19212 : : symbols, and so the symbol namespace can be different to that of the
19213 : : procedure. */
19214 : 53208 : if (sym->ns != gfc_current_ns
19215 : 5697 : && gfc_current_ns->proc_name->abr_modproc_decl
19216 : 36 : && sym->ns->proc_name->attr.function
19217 : 12 : && sym->attr.result
19218 : 12 : && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
19219 : : return 0;
19220 : :
19221 : : /* Check if the symbol's ns is inside the pure procedure. */
19222 : 57716 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19223 : : {
19224 : 57436 : if (ns == sym->ns)
19225 : : break;
19226 : 5975 : if (ns->proc_name->attr.flavor == FL_PROCEDURE
19227 : 5000 : && !(sym->attr.function || sym->attr.result))
19228 : : return 1;
19229 : : }
19230 : :
19231 : 51741 : proc = sym->ns->proc_name;
19232 : 51741 : if (sym->attr.dummy
19233 : 5698 : && !sym->attr.value
19234 : 5576 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
19235 : 5381 : || proc->attr.function))
19236 : 675 : return 1;
19237 : :
19238 : : /* TODO: Sort out what can be storage associated, if anything, and include
19239 : : it here. In principle equivalences should be scanned but it does not
19240 : : seem to be possible to storage associate an impure variable this way. */
19241 : : return 0;
19242 : : }
19243 : :
19244 : :
19245 : : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
19246 : : current namespace is inside a pure procedure. */
19247 : :
19248 : : bool
19249 : 2269700 : gfc_pure (gfc_symbol *sym)
19250 : : {
19251 : 2269700 : symbol_attribute attr;
19252 : 2269700 : gfc_namespace *ns;
19253 : :
19254 : 2269700 : if (sym == NULL)
19255 : : {
19256 : : /* Check if the current namespace or one of its parents
19257 : : belongs to a pure procedure. */
19258 : 3117406 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19259 : : {
19260 : 1840789 : sym = ns->proc_name;
19261 : 1840789 : if (sym == NULL)
19262 : : return 0;
19263 : 1839674 : attr = sym->attr;
19264 : 1839674 : if (attr.flavor == FL_PROCEDURE && attr.pure)
19265 : : return 1;
19266 : : }
19267 : : return 0;
19268 : : }
19269 : :
19270 : 984952 : attr = sym->attr;
19271 : :
19272 : 984952 : return attr.flavor == FL_PROCEDURE && attr.pure;
19273 : : }
19274 : :
19275 : :
19276 : : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
19277 : : checks if the current namespace is implicitly pure. Note that this
19278 : : function returns false for a PURE procedure. */
19279 : :
19280 : : bool
19281 : 711038 : gfc_implicit_pure (gfc_symbol *sym)
19282 : : {
19283 : 711038 : gfc_namespace *ns;
19284 : :
19285 : 711038 : if (sym == NULL)
19286 : : {
19287 : : /* Check if the current procedure is implicit_pure. Walk up
19288 : : the procedure list until we find a procedure. */
19289 : 977451 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19290 : : {
19291 : 698592 : sym = ns->proc_name;
19292 : 698592 : if (sym == NULL)
19293 : : return 0;
19294 : :
19295 : 698519 : if (sym->attr.flavor == FL_PROCEDURE)
19296 : : break;
19297 : : }
19298 : : }
19299 : :
19300 : 432103 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
19301 : 737500 : && !sym->attr.pure;
19302 : : }
19303 : :
19304 : :
19305 : : void
19306 : 415868 : gfc_unset_implicit_pure (gfc_symbol *sym)
19307 : : {
19308 : 415868 : gfc_namespace *ns;
19309 : :
19310 : 415868 : if (sym == NULL)
19311 : : {
19312 : : /* Check if the current procedure is implicit_pure. Walk up
19313 : : the procedure list until we find a procedure. */
19314 : 679025 : for (ns = gfc_current_ns; ns; ns = ns->parent)
19315 : : {
19316 : 420150 : sym = ns->proc_name;
19317 : 420150 : if (sym == NULL)
19318 : : return;
19319 : :
19320 : 419343 : if (sym->attr.flavor == FL_PROCEDURE)
19321 : : break;
19322 : : }
19323 : : }
19324 : :
19325 : 415061 : if (sym->attr.flavor == FL_PROCEDURE)
19326 : 148186 : sym->attr.implicit_pure = 0;
19327 : : else
19328 : 266875 : sym->attr.pure = 0;
19329 : : }
19330 : :
19331 : :
19332 : : /* Test whether the current procedure is elemental or not. */
19333 : :
19334 : : bool
19335 : 1319484 : gfc_elemental (gfc_symbol *sym)
19336 : : {
19337 : 1319484 : symbol_attribute attr;
19338 : :
19339 : 1319484 : if (sym == NULL)
19340 : 0 : sym = gfc_current_ns->proc_name;
19341 : 0 : if (sym == NULL)
19342 : : return 0;
19343 : 1319484 : attr = sym->attr;
19344 : :
19345 : 1319484 : return attr.flavor == FL_PROCEDURE && attr.elemental;
19346 : : }
19347 : :
19348 : :
19349 : : /* Warn about unused labels. */
19350 : :
19351 : : static void
19352 : 4643 : warn_unused_fortran_label (gfc_st_label *label)
19353 : : {
19354 : 4669 : if (label == NULL)
19355 : : return;
19356 : :
19357 : 27 : warn_unused_fortran_label (label->left);
19358 : :
19359 : 27 : if (label->defined == ST_LABEL_UNKNOWN)
19360 : : return;
19361 : :
19362 : 26 : switch (label->referenced)
19363 : : {
19364 : 2 : case ST_LABEL_UNKNOWN:
19365 : 2 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
19366 : : label->value, &label->where);
19367 : 2 : break;
19368 : :
19369 : 1 : case ST_LABEL_BAD_TARGET:
19370 : 1 : gfc_warning (OPT_Wunused_label,
19371 : : "Label %d at %L defined but cannot be used",
19372 : : label->value, &label->where);
19373 : 1 : break;
19374 : :
19375 : : default:
19376 : : break;
19377 : : }
19378 : :
19379 : 26 : warn_unused_fortran_label (label->right);
19380 : : }
19381 : :
19382 : :
19383 : : /* Returns the sequence type of a symbol or sequence. */
19384 : :
19385 : : static seq_type
19386 : 1076 : sequence_type (gfc_typespec ts)
19387 : : {
19388 : 1076 : seq_type result;
19389 : 1076 : gfc_component *c;
19390 : :
19391 : 1076 : switch (ts.type)
19392 : : {
19393 : 49 : case BT_DERIVED:
19394 : :
19395 : 49 : if (ts.u.derived->components == NULL)
19396 : : return SEQ_NONDEFAULT;
19397 : :
19398 : 49 : result = sequence_type (ts.u.derived->components->ts);
19399 : 103 : for (c = ts.u.derived->components->next; c; c = c->next)
19400 : 67 : if (sequence_type (c->ts) != result)
19401 : : return SEQ_MIXED;
19402 : :
19403 : : return result;
19404 : :
19405 : 129 : case BT_CHARACTER:
19406 : 129 : if (ts.kind != gfc_default_character_kind)
19407 : 0 : return SEQ_NONDEFAULT;
19408 : :
19409 : : return SEQ_CHARACTER;
19410 : :
19411 : 240 : case BT_INTEGER:
19412 : 240 : if (ts.kind != gfc_default_integer_kind)
19413 : 25 : return SEQ_NONDEFAULT;
19414 : :
19415 : : return SEQ_NUMERIC;
19416 : :
19417 : 559 : case BT_REAL:
19418 : 559 : if (!(ts.kind == gfc_default_real_kind
19419 : 269 : || ts.kind == gfc_default_double_kind))
19420 : 0 : return SEQ_NONDEFAULT;
19421 : :
19422 : : return SEQ_NUMERIC;
19423 : :
19424 : 81 : case BT_COMPLEX:
19425 : 81 : if (ts.kind != gfc_default_complex_kind)
19426 : 48 : return SEQ_NONDEFAULT;
19427 : :
19428 : : return SEQ_NUMERIC;
19429 : :
19430 : 17 : case BT_LOGICAL:
19431 : 17 : if (ts.kind != gfc_default_logical_kind)
19432 : 0 : return SEQ_NONDEFAULT;
19433 : :
19434 : : return SEQ_NUMERIC;
19435 : :
19436 : : default:
19437 : : return SEQ_NONDEFAULT;
19438 : : }
19439 : : }
19440 : :
19441 : :
19442 : : /* Resolve derived type EQUIVALENCE object. */
19443 : :
19444 : : static bool
19445 : 80 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
19446 : : {
19447 : 80 : gfc_component *c = derived->components;
19448 : :
19449 : 80 : if (!derived)
19450 : : return true;
19451 : :
19452 : : /* Shall not be an object of nonsequence derived type. */
19453 : 80 : if (!derived->attr.sequence)
19454 : : {
19455 : 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
19456 : : "attribute to be an EQUIVALENCE object", sym->name,
19457 : : &e->where);
19458 : 0 : return false;
19459 : : }
19460 : :
19461 : : /* Shall not have allocatable components. */
19462 : 80 : if (derived->attr.alloc_comp)
19463 : : {
19464 : 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
19465 : : "components to be an EQUIVALENCE object",sym->name,
19466 : : &e->where);
19467 : 1 : return false;
19468 : : }
19469 : :
19470 : 79 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
19471 : : {
19472 : 1 : gfc_error ("Derived type variable %qs at %L with default "
19473 : : "initialization cannot be in EQUIVALENCE with a variable "
19474 : : "in COMMON", sym->name, &e->where);
19475 : 1 : return false;
19476 : : }
19477 : :
19478 : 245 : for (; c ; c = c->next)
19479 : : {
19480 : 167 : if (gfc_bt_struct (c->ts.type)
19481 : 167 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
19482 : : return false;
19483 : :
19484 : : /* Shall not be an object of sequence derived type containing a pointer
19485 : : in the structure. */
19486 : 167 : if (c->attr.pointer)
19487 : : {
19488 : 0 : gfc_error ("Derived type variable %qs at %L with pointer "
19489 : : "component(s) cannot be an EQUIVALENCE object",
19490 : : sym->name, &e->where);
19491 : 0 : return false;
19492 : : }
19493 : : }
19494 : : return true;
19495 : : }
19496 : :
19497 : :
19498 : : /* Resolve equivalence object.
19499 : : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
19500 : : an allocatable array, an object of nonsequence derived type, an object of
19501 : : sequence derived type containing a pointer at any level of component
19502 : : selection, an automatic object, a function name, an entry name, a result
19503 : : name, a named constant, a structure component, or a subobject of any of
19504 : : the preceding objects. A substring shall not have length zero. A
19505 : : derived type shall not have components with default initialization nor
19506 : : shall two objects of an equivalence group be initialized.
19507 : : Either all or none of the objects shall have an protected attribute.
19508 : : The simple constraints are done in symbol.cc(check_conflict) and the rest
19509 : : are implemented here. */
19510 : :
19511 : : static void
19512 : 1565 : resolve_equivalence (gfc_equiv *eq)
19513 : : {
19514 : 1565 : gfc_symbol *sym;
19515 : 1565 : gfc_symbol *first_sym;
19516 : 1565 : gfc_expr *e;
19517 : 1565 : gfc_ref *r;
19518 : 1565 : locus *last_where = NULL;
19519 : 1565 : seq_type eq_type, last_eq_type;
19520 : 1565 : gfc_typespec *last_ts;
19521 : 1565 : int object, cnt_protected;
19522 : 1565 : const char *msg;
19523 : :
19524 : 1565 : last_ts = &eq->expr->symtree->n.sym->ts;
19525 : :
19526 : 1565 : first_sym = eq->expr->symtree->n.sym;
19527 : :
19528 : 1565 : cnt_protected = 0;
19529 : :
19530 : 4727 : for (object = 1; eq; eq = eq->eq, object++)
19531 : : {
19532 : 3171 : e = eq->expr;
19533 : :
19534 : 3171 : e->ts = e->symtree->n.sym->ts;
19535 : : /* match_varspec might not know yet if it is seeing
19536 : : array reference or substring reference, as it doesn't
19537 : : know the types. */
19538 : 3171 : if (e->ref && e->ref->type == REF_ARRAY)
19539 : : {
19540 : 2152 : gfc_ref *ref = e->ref;
19541 : 2152 : sym = e->symtree->n.sym;
19542 : :
19543 : 2152 : if (sym->attr.dimension)
19544 : : {
19545 : 1855 : ref->u.ar.as = sym->as;
19546 : 1855 : ref = ref->next;
19547 : : }
19548 : :
19549 : : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
19550 : 2152 : if (e->ts.type == BT_CHARACTER
19551 : 592 : && ref
19552 : 371 : && ref->type == REF_ARRAY
19553 : 371 : && ref->u.ar.dimen == 1
19554 : 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
19555 : 371 : && ref->u.ar.stride[0] == NULL)
19556 : : {
19557 : 370 : gfc_expr *start = ref->u.ar.start[0];
19558 : 370 : gfc_expr *end = ref->u.ar.end[0];
19559 : 370 : void *mem = NULL;
19560 : :
19561 : : /* Optimize away the (:) reference. */
19562 : 370 : if (start == NULL && end == NULL)
19563 : : {
19564 : 9 : if (e->ref == ref)
19565 : 0 : e->ref = ref->next;
19566 : : else
19567 : 9 : e->ref->next = ref->next;
19568 : : mem = ref;
19569 : : }
19570 : : else
19571 : : {
19572 : 361 : ref->type = REF_SUBSTRING;
19573 : 361 : if (start == NULL)
19574 : 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
19575 : : NULL, 1);
19576 : 361 : ref->u.ss.start = start;
19577 : 361 : if (end == NULL && e->ts.u.cl)
19578 : 27 : end = gfc_copy_expr (e->ts.u.cl->length);
19579 : 361 : ref->u.ss.end = end;
19580 : 361 : ref->u.ss.length = e->ts.u.cl;
19581 : 361 : e->ts.u.cl = NULL;
19582 : : }
19583 : 370 : ref = ref->next;
19584 : 370 : free (mem);
19585 : : }
19586 : :
19587 : : /* Any further ref is an error. */
19588 : 1930 : if (ref)
19589 : : {
19590 : 1 : gcc_assert (ref->type == REF_ARRAY);
19591 : 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
19592 : : &ref->u.ar.where);
19593 : 1 : continue;
19594 : : }
19595 : : }
19596 : :
19597 : 3170 : if (!gfc_resolve_expr (e))
19598 : 2 : continue;
19599 : :
19600 : 3168 : sym = e->symtree->n.sym;
19601 : :
19602 : 3168 : if (sym->attr.is_protected)
19603 : 2 : cnt_protected++;
19604 : 3168 : if (cnt_protected > 0 && cnt_protected != object)
19605 : : {
19606 : 2 : gfc_error ("Either all or none of the objects in the "
19607 : : "EQUIVALENCE set at %L shall have the "
19608 : : "PROTECTED attribute",
19609 : : &e->where);
19610 : 2 : break;
19611 : : }
19612 : :
19613 : : /* Shall not equivalence common block variables in a PURE procedure. */
19614 : 3166 : if (sym->ns->proc_name
19615 : 3150 : && sym->ns->proc_name->attr.pure
19616 : 7 : && sym->attr.in_common)
19617 : : {
19618 : : /* Need to check for symbols that may have entered the pure
19619 : : procedure via a USE statement. */
19620 : 7 : bool saw_sym = false;
19621 : 7 : if (sym->ns->use_stmts)
19622 : : {
19623 : 6 : gfc_use_rename *r;
19624 : 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
19625 : 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
19626 : : }
19627 : : else
19628 : : saw_sym = true;
19629 : :
19630 : 6 : if (saw_sym)
19631 : 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
19632 : : "EQUIVALENCE object in the pure procedure %qs",
19633 : : sym->name, &e->where, sym->ns->proc_name->name);
19634 : : break;
19635 : : }
19636 : :
19637 : : /* Shall not be a named constant. */
19638 : 3159 : if (e->expr_type == EXPR_CONSTANT)
19639 : : {
19640 : 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
19641 : : "object", sym->name, &e->where);
19642 : 0 : continue;
19643 : : }
19644 : :
19645 : 3161 : if (e->ts.type == BT_DERIVED
19646 : 3159 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
19647 : 2 : continue;
19648 : :
19649 : : /* Check that the types correspond correctly:
19650 : : Note 5.28:
19651 : : A numeric sequence structure may be equivalenced to another sequence
19652 : : structure, an object of default integer type, default real type, double
19653 : : precision real type, default logical type such that components of the
19654 : : structure ultimately only become associated to objects of the same
19655 : : kind. A character sequence structure may be equivalenced to an object
19656 : : of default character kind or another character sequence structure.
19657 : : Other objects may be equivalenced only to objects of the same type and
19658 : : kind parameters. */
19659 : :
19660 : : /* Identical types are unconditionally OK. */
19661 : 3157 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
19662 : 2677 : goto identical_types;
19663 : :
19664 : 480 : last_eq_type = sequence_type (*last_ts);
19665 : 480 : eq_type = sequence_type (sym->ts);
19666 : :
19667 : : /* Since the pair of objects is not of the same type, mixed or
19668 : : non-default sequences can be rejected. */
19669 : :
19670 : 480 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
19671 : : "statement at %L with different type objects");
19672 : 481 : if ((object ==2
19673 : 480 : && last_eq_type == SEQ_MIXED
19674 : 7 : && last_where
19675 : 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19676 : 486 : || (eq_type == SEQ_MIXED
19677 : 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19678 : 1 : continue;
19679 : :
19680 : 479 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
19681 : : "statement at %L with objects of different type");
19682 : 483 : if ((object ==2
19683 : 479 : && last_eq_type == SEQ_NONDEFAULT
19684 : 50 : && last_where
19685 : 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19686 : 525 : || (eq_type == SEQ_NONDEFAULT
19687 : 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19688 : 4 : continue;
19689 : :
19690 : 475 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
19691 : : "EQUIVALENCE statement at %L");
19692 : 479 : if (last_eq_type == SEQ_CHARACTER
19693 : 475 : && eq_type != SEQ_CHARACTER
19694 : 475 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19695 : 4 : continue;
19696 : :
19697 : 471 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
19698 : : "EQUIVALENCE statement at %L");
19699 : 473 : if (last_eq_type == SEQ_NUMERIC
19700 : 471 : && eq_type != SEQ_NUMERIC
19701 : 471 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19702 : 2 : continue;
19703 : :
19704 : 3146 : identical_types:
19705 : :
19706 : 3146 : last_ts =&sym->ts;
19707 : 3146 : last_where = &e->where;
19708 : :
19709 : 3146 : if (!e->ref)
19710 : 1003 : continue;
19711 : :
19712 : : /* Shall not be an automatic array. */
19713 : 2143 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
19714 : : {
19715 : 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
19716 : : "an EQUIVALENCE object", sym->name, &e->where);
19717 : 3 : continue;
19718 : : }
19719 : :
19720 : 2140 : r = e->ref;
19721 : 4326 : while (r)
19722 : : {
19723 : : /* Shall not be a structure component. */
19724 : 2187 : if (r->type == REF_COMPONENT)
19725 : : {
19726 : 0 : gfc_error ("Structure component %qs at %L cannot be an "
19727 : : "EQUIVALENCE object",
19728 : 0 : r->u.c.component->name, &e->where);
19729 : 0 : break;
19730 : : }
19731 : :
19732 : : /* A substring shall not have length zero. */
19733 : 2187 : if (r->type == REF_SUBSTRING)
19734 : : {
19735 : 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
19736 : : {
19737 : 1 : gfc_error ("Substring at %L has length zero",
19738 : : &r->u.ss.start->where);
19739 : 1 : break;
19740 : : }
19741 : : }
19742 : 2186 : r = r->next;
19743 : : }
19744 : : }
19745 : 1565 : }
19746 : :
19747 : :
19748 : : /* Function called by resolve_fntype to flag other symbols used in the
19749 : : length type parameter specification of function results. */
19750 : :
19751 : : static bool
19752 : 4130 : flag_fn_result_spec (gfc_expr *expr,
19753 : : gfc_symbol *sym,
19754 : : int *f ATTRIBUTE_UNUSED)
19755 : : {
19756 : 4130 : gfc_namespace *ns;
19757 : 4130 : gfc_symbol *s;
19758 : :
19759 : 4130 : if (expr->expr_type == EXPR_VARIABLE)
19760 : : {
19761 : 1378 : s = expr->symtree->n.sym;
19762 : 2153 : for (ns = s->ns; ns; ns = ns->parent)
19763 : 2153 : if (!ns->parent)
19764 : : break;
19765 : :
19766 : 1378 : if (sym == s)
19767 : : {
19768 : 1 : gfc_error ("Self reference in character length expression "
19769 : : "for %qs at %L", sym->name, &expr->where);
19770 : 1 : return true;
19771 : : }
19772 : :
19773 : 1377 : if (!s->fn_result_spec
19774 : 1377 : && s->attr.flavor == FL_PARAMETER)
19775 : : {
19776 : : /* Function contained in a module.... */
19777 : 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
19778 : : {
19779 : 32 : gfc_symtree *st;
19780 : 32 : s->fn_result_spec = 1;
19781 : : /* Make sure that this symbol is translated as a module
19782 : : variable. */
19783 : 32 : st = gfc_get_unique_symtree (ns);
19784 : 32 : st->n.sym = s;
19785 : 32 : s->refs++;
19786 : 32 : }
19787 : : /* ... which is use associated and called. */
19788 : 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
19789 : 0 : ||
19790 : : /* External function matched with an interface. */
19791 : 0 : (s->ns->proc_name
19792 : 0 : && ((s->ns == ns
19793 : 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
19794 : 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
19795 : 0 : && s->ns->proc_name->attr.function))
19796 : 31 : s->fn_result_spec = 1;
19797 : : }
19798 : : }
19799 : : return false;
19800 : : }
19801 : :
19802 : :
19803 : : /* Resolve function and ENTRY types, issue diagnostics if needed. */
19804 : :
19805 : : static void
19806 : 336401 : resolve_fntype (gfc_namespace *ns)
19807 : : {
19808 : 336401 : gfc_entry_list *el;
19809 : 336401 : gfc_symbol *sym;
19810 : :
19811 : 336401 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
19812 : : return;
19813 : :
19814 : : /* If there are any entries, ns->proc_name is the entry master
19815 : : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
19816 : 175728 : if (ns->entries)
19817 : 564 : sym = ns->entries->sym;
19818 : : else
19819 : : sym = ns->proc_name;
19820 : 175728 : if (sym->result == sym
19821 : 141120 : && sym->ts.type == BT_UNKNOWN
19822 : 6 : && !gfc_set_default_type (sym, 0, NULL)
19823 : 175732 : && !sym->attr.untyped)
19824 : : {
19825 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
19826 : : sym->name, &sym->declared_at);
19827 : 3 : sym->attr.untyped = 1;
19828 : : }
19829 : :
19830 : 13091 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
19831 : 1680 : && !sym->attr.contained
19832 : 285 : && !gfc_check_symbol_access (sym->ts.u.derived)
19833 : 175728 : && gfc_check_symbol_access (sym))
19834 : : {
19835 : 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
19836 : : "%L of PRIVATE type %qs", sym->name,
19837 : 0 : &sym->declared_at, sym->ts.u.derived->name);
19838 : : }
19839 : :
19840 : 175728 : if (ns->entries)
19841 : 1189 : for (el = ns->entries->next; el; el = el->next)
19842 : : {
19843 : 625 : if (el->sym->result == el->sym
19844 : 413 : && el->sym->ts.type == BT_UNKNOWN
19845 : 2 : && !gfc_set_default_type (el->sym, 0, NULL)
19846 : 627 : && !el->sym->attr.untyped)
19847 : : {
19848 : 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
19849 : : el->sym->name, &el->sym->declared_at);
19850 : 2 : el->sym->attr.untyped = 1;
19851 : : }
19852 : : }
19853 : :
19854 : 175728 : if (sym->ts.type == BT_CHARACTER
19855 : 6697 : && sym->ts.u.cl->length
19856 : 1782 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
19857 : 1777 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
19858 : : }
19859 : :
19860 : :
19861 : : /* 12.3.2.1.1 Defined operators. */
19862 : :
19863 : : static bool
19864 : 447 : check_uop_procedure (gfc_symbol *sym, locus where)
19865 : : {
19866 : 447 : gfc_formal_arglist *formal;
19867 : :
19868 : 447 : if (!sym->attr.function)
19869 : : {
19870 : 4 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
19871 : : sym->name, &where);
19872 : 4 : return false;
19873 : : }
19874 : :
19875 : 443 : if (sym->ts.type == BT_CHARACTER
19876 : 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
19877 : 2 : && !(sym->result && ((sym->result->ts.u.cl
19878 : 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
19879 : : {
19880 : 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
19881 : : "character length", sym->name, &where);
19882 : 2 : return false;
19883 : : }
19884 : :
19885 : 441 : formal = gfc_sym_get_dummy_args (sym);
19886 : 441 : if (!formal || !formal->sym)
19887 : : {
19888 : 1 : gfc_error ("User operator procedure %qs at %L must have at least "
19889 : : "one argument", sym->name, &where);
19890 : 1 : return false;
19891 : : }
19892 : :
19893 : 440 : if (formal->sym->attr.intent != INTENT_IN)
19894 : : {
19895 : 0 : gfc_error ("First argument of operator interface at %L must be "
19896 : : "INTENT(IN)", &where);
19897 : 0 : return false;
19898 : : }
19899 : :
19900 : 440 : if (formal->sym->attr.optional)
19901 : : {
19902 : 0 : gfc_error ("First argument of operator interface at %L cannot be "
19903 : : "optional", &where);
19904 : 0 : return false;
19905 : : }
19906 : :
19907 : 440 : formal = formal->next;
19908 : 440 : if (!formal || !formal->sym)
19909 : : return true;
19910 : :
19911 : 295 : if (formal->sym->attr.intent != INTENT_IN)
19912 : : {
19913 : 0 : gfc_error ("Second argument of operator interface at %L must be "
19914 : : "INTENT(IN)", &where);
19915 : 0 : return false;
19916 : : }
19917 : :
19918 : 295 : if (formal->sym->attr.optional)
19919 : : {
19920 : 1 : gfc_error ("Second argument of operator interface at %L cannot be "
19921 : : "optional", &where);
19922 : 1 : return false;
19923 : : }
19924 : :
19925 : 294 : if (formal->next)
19926 : : {
19927 : 2 : gfc_error ("Operator interface at %L must have, at most, two "
19928 : : "arguments", &where);
19929 : 2 : return false;
19930 : : }
19931 : :
19932 : : return true;
19933 : : }
19934 : :
19935 : : static void
19936 : 337157 : gfc_resolve_uops (gfc_symtree *symtree)
19937 : : {
19938 : 337157 : gfc_interface *itr;
19939 : :
19940 : 337157 : if (symtree == NULL)
19941 : : return;
19942 : :
19943 : 378 : gfc_resolve_uops (symtree->left);
19944 : 378 : gfc_resolve_uops (symtree->right);
19945 : :
19946 : 771 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
19947 : 393 : check_uop_procedure (itr->sym, itr->sym->declared_at);
19948 : : }
19949 : :
19950 : :
19951 : : /* Examine all of the expressions associated with a program unit,
19952 : : assign types to all intermediate expressions, make sure that all
19953 : : assignments are to compatible types and figure out which names
19954 : : refer to which functions or subroutines. It doesn't check code
19955 : : block, which is handled by gfc_resolve_code. */
19956 : :
19957 : : static void
19958 : 338867 : resolve_types (gfc_namespace *ns)
19959 : : {
19960 : 338867 : gfc_namespace *n;
19961 : 338867 : gfc_charlen *cl;
19962 : 338867 : gfc_data *d;
19963 : 338867 : gfc_equiv *eq;
19964 : 338867 : gfc_namespace* old_ns = gfc_current_ns;
19965 : 338867 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
19966 : :
19967 : 338867 : if (ns->types_resolved)
19968 : : return;
19969 : :
19970 : : /* Check that all IMPLICIT types are ok. */
19971 : 336402 : if (!ns->seen_implicit_none)
19972 : : {
19973 : : unsigned letter;
19974 : 8463799 : for (letter = 0; letter != GFC_LETTERS; ++letter)
19975 : 8150325 : if (ns->set_flag[letter]
19976 : 8150325 : && !resolve_typespec_used (&ns->default_type[letter],
19977 : : &ns->implicit_loc[letter], NULL))
19978 : : return;
19979 : : }
19980 : :
19981 : 336401 : gfc_current_ns = ns;
19982 : :
19983 : 336401 : resolve_entries (ns);
19984 : :
19985 : 336401 : resolve_common_vars (&ns->blank_common, false);
19986 : 336401 : resolve_common_blocks (ns->common_root);
19987 : :
19988 : 336401 : resolve_contained_functions (ns);
19989 : :
19990 : 336401 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
19991 : 287760 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
19992 : 188050 : gfc_resolve_formal_arglist (ns->proc_name);
19993 : :
19994 : 336401 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
19995 : :
19996 : 429033 : for (cl = ns->cl_list; cl; cl = cl->next)
19997 : 92632 : resolve_charlen (cl);
19998 : :
19999 : 336401 : gfc_traverse_ns (ns, resolve_symbol);
20000 : :
20001 : 336401 : resolve_fntype (ns);
20002 : :
20003 : 382780 : for (n = ns->contained; n; n = n->sibling)
20004 : : {
20005 : : /* Exclude final wrappers with the test for the artificial attribute. */
20006 : 46379 : if (gfc_pure (ns->proc_name)
20007 : 5 : && !gfc_pure (n->proc_name)
20008 : 46379 : && !n->proc_name->attr.artificial)
20009 : 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
20010 : : "also be PURE", n->proc_name->name,
20011 : : &n->proc_name->declared_at);
20012 : :
20013 : 46379 : resolve_types (n);
20014 : : }
20015 : :
20016 : 336401 : forall_flag = 0;
20017 : 336401 : gfc_do_concurrent_flag = 0;
20018 : 336401 : gfc_check_interfaces (ns);
20019 : :
20020 : 336401 : gfc_traverse_ns (ns, resolve_values);
20021 : :
20022 : 336401 : if (ns->save_all || (!flag_automatic && !recursive))
20023 : 297 : gfc_save_all (ns);
20024 : :
20025 : 336401 : iter_stack = NULL;
20026 : 338900 : for (d = ns->data; d; d = d->next)
20027 : 2499 : resolve_data (d);
20028 : :
20029 : 336401 : iter_stack = NULL;
20030 : 336401 : gfc_traverse_ns (ns, gfc_formalize_init_value);
20031 : :
20032 : 336401 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
20033 : :
20034 : 337966 : for (eq = ns->equiv; eq; eq = eq->next)
20035 : 1565 : resolve_equivalence (eq);
20036 : :
20037 : : /* Warn about unused labels. */
20038 : 336401 : if (warn_unused_label)
20039 : 4616 : warn_unused_fortran_label (ns->st_labels);
20040 : :
20041 : 336401 : gfc_resolve_uops (ns->uop_root);
20042 : :
20043 : 336401 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
20044 : :
20045 : 336401 : gfc_resolve_omp_declare (ns);
20046 : :
20047 : 336401 : gfc_resolve_omp_udrs (ns->omp_udr_root);
20048 : :
20049 : 336401 : ns->types_resolved = 1;
20050 : :
20051 : 336401 : gfc_current_ns = old_ns;
20052 : : }
20053 : :
20054 : :
20055 : : /* Call gfc_resolve_code recursively. */
20056 : :
20057 : : static void
20058 : 338922 : resolve_codes (gfc_namespace *ns)
20059 : : {
20060 : 338922 : gfc_namespace *n;
20061 : 338922 : bitmap_obstack old_obstack;
20062 : :
20063 : 338922 : if (ns->resolved == 1)
20064 : 13201 : return;
20065 : :
20066 : 372155 : for (n = ns->contained; n; n = n->sibling)
20067 : 46434 : resolve_codes (n);
20068 : :
20069 : 325721 : gfc_current_ns = ns;
20070 : :
20071 : : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
20072 : 325721 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
20073 : 313999 : cs_base = NULL;
20074 : :
20075 : : /* Set to an out of range value. */
20076 : 325721 : current_entry_id = -1;
20077 : :
20078 : 325721 : old_obstack = labels_obstack;
20079 : 325721 : bitmap_obstack_initialize (&labels_obstack);
20080 : :
20081 : 325721 : gfc_resolve_oacc_declare (ns);
20082 : 325721 : gfc_resolve_oacc_routines (ns);
20083 : 325721 : gfc_resolve_omp_local_vars (ns);
20084 : 325721 : if (ns->omp_allocate)
20085 : 55 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
20086 : 325721 : gfc_resolve_code (ns->code, ns);
20087 : :
20088 : 325720 : bitmap_obstack_release (&labels_obstack);
20089 : 325720 : labels_obstack = old_obstack;
20090 : : }
20091 : :
20092 : :
20093 : : /* This function is called after a complete program unit has been compiled.
20094 : : Its purpose is to examine all of the expressions associated with a program
20095 : : unit, assign types to all intermediate expressions, make sure that all
20096 : : assignments are to compatible types and figure out which names refer to
20097 : : which functions or subroutines. */
20098 : :
20099 : : void
20100 : 297021 : gfc_resolve (gfc_namespace *ns)
20101 : : {
20102 : 297021 : gfc_namespace *old_ns;
20103 : 297021 : code_stack *old_cs_base;
20104 : 297021 : struct gfc_omp_saved_state old_omp_state;
20105 : :
20106 : 297021 : if (ns->resolved)
20107 : 4533 : return;
20108 : :
20109 : 292488 : ns->resolved = -1;
20110 : 292488 : old_ns = gfc_current_ns;
20111 : 292488 : old_cs_base = cs_base;
20112 : :
20113 : : /* As gfc_resolve can be called during resolution of an OpenMP construct
20114 : : body, we should clear any state associated to it, so that say NS's
20115 : : DO loops are not interpreted as OpenMP loops. */
20116 : 292488 : if (!ns->construct_entities)
20117 : 280766 : gfc_omp_save_and_clear_state (&old_omp_state);
20118 : :
20119 : 292488 : resolve_types (ns);
20120 : 292488 : component_assignment_level = 0;
20121 : 292488 : resolve_codes (ns);
20122 : :
20123 : 292487 : if (ns->omp_assumes)
20124 : 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
20125 : :
20126 : 292487 : gfc_current_ns = old_ns;
20127 : 292487 : cs_base = old_cs_base;
20128 : 292487 : ns->resolved = 1;
20129 : :
20130 : 292487 : gfc_run_passes (ns);
20131 : :
20132 : 292487 : if (!ns->construct_entities)
20133 : 280765 : gfc_omp_restore_state (&old_omp_state);
20134 : : }
|
