Branch data Line data Source code
1 : : /* Perform type resolution on the various structures.
2 : : Copyright (C) 2001-2024 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 : :
58 : : /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
59 : :
60 : : static int forall_flag;
61 : : int gfc_do_concurrent_flag;
62 : :
63 : : /* True when we are resolving an expression that is an actual argument to
64 : : a procedure. */
65 : : static bool actual_arg = false;
66 : : /* True when we are resolving an expression that is the first actual argument
67 : : to a procedure. */
68 : : static bool first_actual_arg = false;
69 : :
70 : :
71 : : /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
72 : :
73 : : static int omp_workshare_flag;
74 : :
75 : :
76 : : /* True if we are resolving a specification expression. */
77 : : static bool specification_expr = false;
78 : :
79 : : /* The id of the last entry seen. */
80 : : static int current_entry_id;
81 : :
82 : : /* We use bitmaps to determine if a branch target is valid. */
83 : : static bitmap_obstack labels_obstack;
84 : :
85 : : /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
86 : : static bool inquiry_argument = false;
87 : :
88 : :
89 : : /* Is the symbol host associated? */
90 : : static bool
91 : 58909 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
92 : : {
93 : 65312 : for (ns = ns->parent; ns; ns = ns->parent)
94 : : {
95 : 6636 : if (sym->ns == ns)
96 : : return true;
97 : : }
98 : :
99 : : return false;
100 : : }
101 : :
102 : : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
103 : : an ABSTRACT derived-type. If where is not NULL, an error message with that
104 : : locus is printed, optionally using name. */
105 : :
106 : : static bool
107 : 1234224 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
108 : : {
109 : 1234224 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
110 : : {
111 : 5 : if (where)
112 : : {
113 : 5 : if (name)
114 : 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
115 : : name, where, ts->u.derived->name);
116 : : else
117 : 1 : gfc_error ("ABSTRACT type %qs used at %L",
118 : : ts->u.derived->name, where);
119 : : }
120 : :
121 : 5 : return false;
122 : : }
123 : :
124 : : return true;
125 : : }
126 : :
127 : :
128 : : static bool
129 : 4756 : check_proc_interface (gfc_symbol *ifc, locus *where)
130 : : {
131 : : /* Several checks for F08:C1216. */
132 : 4756 : if (ifc->attr.procedure)
133 : : {
134 : 2 : gfc_error ("Interface %qs at %L is declared "
135 : : "in a later PROCEDURE statement", ifc->name, where);
136 : 2 : return false;
137 : : }
138 : 4754 : if (ifc->generic)
139 : : {
140 : : /* For generic interfaces, check if there is
141 : : a specific procedure with the same name. */
142 : : gfc_interface *gen = ifc->generic;
143 : 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
144 : 5 : gen = gen->next;
145 : 7 : if (!gen)
146 : : {
147 : 4 : gfc_error ("Interface %qs at %L may not be generic",
148 : : ifc->name, where);
149 : 4 : return false;
150 : : }
151 : : }
152 : 4750 : if (ifc->attr.proc == PROC_ST_FUNCTION)
153 : : {
154 : 4 : gfc_error ("Interface %qs at %L may not be a statement function",
155 : : ifc->name, where);
156 : 4 : return false;
157 : : }
158 : 4746 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
159 : 4746 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
160 : 17 : ifc->attr.intrinsic = 1;
161 : 4746 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
162 : : {
163 : 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
164 : : "PROCEDURE statement at %L", ifc->name, where);
165 : 3 : return false;
166 : : }
167 : 4743 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
168 : : {
169 : 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
170 : 7 : return false;
171 : : }
172 : : return true;
173 : : }
174 : :
175 : :
176 : : static void resolve_symbol (gfc_symbol *sym);
177 : :
178 : :
179 : : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
180 : :
181 : : static bool
182 : 1909 : resolve_procedure_interface (gfc_symbol *sym)
183 : : {
184 : 1909 : gfc_symbol *ifc = sym->ts.interface;
185 : :
186 : 1909 : if (!ifc)
187 : : return true;
188 : :
189 : 1753 : if (ifc == sym)
190 : : {
191 : 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
192 : : sym->name, &sym->declared_at);
193 : 2 : return false;
194 : : }
195 : 1751 : if (!check_proc_interface (ifc, &sym->declared_at))
196 : : return false;
197 : :
198 : 1742 : if (ifc->attr.if_source || ifc->attr.intrinsic)
199 : : {
200 : : /* Resolve interface and copy attributes. */
201 : 1463 : resolve_symbol (ifc);
202 : 1463 : if (ifc->attr.intrinsic)
203 : 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
204 : :
205 : 1463 : if (ifc->result)
206 : : {
207 : 618 : sym->ts = ifc->result->ts;
208 : 618 : sym->attr.allocatable = ifc->result->attr.allocatable;
209 : 618 : sym->attr.pointer = ifc->result->attr.pointer;
210 : 618 : sym->attr.dimension = ifc->result->attr.dimension;
211 : 618 : sym->attr.class_ok = ifc->result->attr.class_ok;
212 : 618 : sym->as = gfc_copy_array_spec (ifc->result->as);
213 : 618 : sym->result = sym;
214 : : }
215 : : else
216 : : {
217 : 845 : sym->ts = ifc->ts;
218 : 845 : sym->attr.allocatable = ifc->attr.allocatable;
219 : 845 : sym->attr.pointer = ifc->attr.pointer;
220 : 845 : sym->attr.dimension = ifc->attr.dimension;
221 : 845 : sym->attr.class_ok = ifc->attr.class_ok;
222 : 845 : sym->as = gfc_copy_array_spec (ifc->as);
223 : : }
224 : 1463 : sym->ts.interface = ifc;
225 : 1463 : sym->attr.function = ifc->attr.function;
226 : 1463 : sym->attr.subroutine = ifc->attr.subroutine;
227 : :
228 : 1463 : sym->attr.pure = ifc->attr.pure;
229 : 1463 : sym->attr.elemental = ifc->attr.elemental;
230 : 1463 : sym->attr.contiguous = ifc->attr.contiguous;
231 : 1463 : sym->attr.recursive = ifc->attr.recursive;
232 : 1463 : sym->attr.always_explicit = ifc->attr.always_explicit;
233 : 1463 : sym->attr.ext_attr |= ifc->attr.ext_attr;
234 : 1463 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
235 : : /* Copy char length. */
236 : 1463 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
237 : : {
238 : 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
239 : 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
240 : 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
241 : : return false;
242 : : }
243 : : }
244 : :
245 : : return true;
246 : : }
247 : :
248 : :
249 : : /* Resolve types of formal argument lists. These have to be done early so that
250 : : the formal argument lists of module procedures can be copied to the
251 : : containing module before the individual procedures are resolved
252 : : individually. We also resolve argument lists of procedures in interface
253 : : blocks because they are self-contained scoping units.
254 : :
255 : : Since a dummy argument cannot be a non-dummy procedure, the only
256 : : resort left for untyped names are the IMPLICIT types. */
257 : :
258 : : void
259 : 434454 : gfc_resolve_formal_arglist (gfc_symbol *proc)
260 : : {
261 : 434454 : gfc_formal_arglist *f;
262 : 434454 : gfc_symbol *sym;
263 : 434454 : bool saved_specification_expr;
264 : 434454 : int i;
265 : :
266 : 434454 : if (proc->result != NULL)
267 : 267127 : sym = proc->result;
268 : : else
269 : : sym = proc;
270 : :
271 : 434454 : if (gfc_elemental (proc)
272 : 294636 : || sym->attr.pointer || sym->attr.allocatable
273 : 726401 : || (sym->as && sym->as->rank != 0))
274 : : {
275 : 144655 : proc->attr.always_explicit = 1;
276 : 144655 : sym->attr.always_explicit = 1;
277 : : }
278 : :
279 : 434454 : gfc_namespace *orig_current_ns = gfc_current_ns;
280 : 434454 : gfc_current_ns = gfc_get_procedure_ns (proc);
281 : :
282 : 1109831 : for (f = proc->formal; f; f = f->next)
283 : : {
284 : 675379 : gfc_array_spec *as;
285 : :
286 : 675379 : sym = f->sym;
287 : :
288 : 675379 : if (sym == NULL)
289 : : {
290 : : /* Alternate return placeholder. */
291 : 171 : if (gfc_elemental (proc))
292 : 1 : gfc_error ("Alternate return specifier in elemental subroutine "
293 : : "%qs at %L is not allowed", proc->name,
294 : : &proc->declared_at);
295 : 171 : if (proc->attr.function)
296 : 1 : gfc_error ("Alternate return specifier in function "
297 : : "%qs at %L is not allowed", proc->name,
298 : : &proc->declared_at);
299 : 171 : continue;
300 : : }
301 : :
302 : 520 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
303 : 675728 : && !resolve_procedure_interface (sym))
304 : : break;
305 : :
306 : 675208 : if (strcmp (proc->name, sym->name) == 0)
307 : : {
308 : 2 : gfc_error ("Self-referential argument "
309 : : "%qs at %L is not allowed", sym->name,
310 : : &proc->declared_at);
311 : 2 : break;
312 : : }
313 : :
314 : 675206 : if (sym->attr.if_source != IFSRC_UNKNOWN)
315 : 806 : gfc_resolve_formal_arglist (sym);
316 : :
317 : 675206 : if (sym->attr.subroutine || sym->attr.external)
318 : : {
319 : 794 : if (sym->attr.flavor == FL_UNKNOWN)
320 : 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
321 : : }
322 : : else
323 : : {
324 : 674412 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
325 : 3602 : && (!sym->attr.function || sym->result == sym))
326 : 3567 : gfc_set_default_type (sym, 1, sym->ns);
327 : : }
328 : :
329 : 12149 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
330 : 687355 : ? CLASS_DATA (sym)->as : sym->as;
331 : :
332 : 675206 : saved_specification_expr = specification_expr;
333 : 675206 : specification_expr = true;
334 : 675206 : gfc_resolve_array_spec (as, 0);
335 : 675206 : specification_expr = saved_specification_expr;
336 : :
337 : : /* We can't tell if an array with dimension (:) is assumed or deferred
338 : : shape until we know if it has the pointer or allocatable attributes.
339 : : */
340 : 675206 : if (as && as->rank > 0 && as->type == AS_DEFERRED
341 : 10668 : && ((sym->ts.type != BT_CLASS
342 : 9681 : && !(sym->attr.pointer || sym->attr.allocatable))
343 : 4762 : || (sym->ts.type == BT_CLASS
344 : 987 : && !(CLASS_DATA (sym)->attr.class_pointer
345 : : || CLASS_DATA (sym)->attr.allocatable)))
346 : 6304 : && sym->attr.flavor != FL_PROCEDURE)
347 : : {
348 : 6303 : as->type = AS_ASSUMED_SHAPE;
349 : 14531 : for (i = 0; i < as->rank; i++)
350 : 8228 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
351 : : }
352 : :
353 : 106689 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
354 : 94965 : || (as && as->type == AS_ASSUMED_RANK)
355 : 634493 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
356 : 625100 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
357 : 10254 : && (CLASS_DATA (sym)->attr.class_pointer
358 : : || CLASS_DATA (sym)->attr.allocatable
359 : 10254 : || CLASS_DATA (sym)->attr.target))
360 : 623788 : || sym->attr.optional)
361 : : {
362 : 59307 : proc->attr.always_explicit = 1;
363 : 59307 : if (proc->result)
364 : 26581 : proc->result->attr.always_explicit = 1;
365 : : }
366 : :
367 : : /* If the flavor is unknown at this point, it has to be a variable.
368 : : A procedure specification would have already set the type. */
369 : :
370 : 675206 : if (sym->attr.flavor == FL_UNKNOWN)
371 : 42903 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
372 : :
373 : 675206 : if (gfc_pure (proc))
374 : : {
375 : 281766 : if (sym->attr.flavor == FL_PROCEDURE)
376 : : {
377 : : /* F08:C1279. */
378 : 24 : if (!gfc_pure (sym))
379 : : {
380 : 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
381 : : "also be PURE", sym->name, &sym->declared_at);
382 : 1 : continue;
383 : : }
384 : : }
385 : 281742 : else if (!sym->attr.pointer)
386 : : {
387 : 281734 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
388 : : {
389 : 107 : if (sym->attr.value)
390 : 106 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
391 : : " of pure function %qs at %L with VALUE "
392 : : "attribute but without INTENT(IN)",
393 : : sym->name, proc->name, &sym->declared_at);
394 : : else
395 : 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
396 : : "be INTENT(IN) or VALUE", sym->name, proc->name,
397 : : &sym->declared_at);
398 : : }
399 : :
400 : 281734 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
401 : : {
402 : 51 : if (sym->attr.value)
403 : 51 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
404 : : " of pure subroutine %qs at %L with VALUE "
405 : : "attribute but without INTENT", sym->name,
406 : : proc->name, &sym->declared_at);
407 : : else
408 : 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
409 : : "must have its INTENT specified or have the "
410 : : "VALUE attribute", sym->name, proc->name,
411 : : &sym->declared_at);
412 : : }
413 : : }
414 : :
415 : : /* F08:C1278a. */
416 : 281765 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
417 : : {
418 : 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
419 : : " may not be polymorphic", sym->name, proc->name,
420 : : &sym->declared_at);
421 : 1 : continue;
422 : : }
423 : : }
424 : :
425 : 675204 : if (proc->attr.implicit_pure)
426 : : {
427 : 22353 : if (sym->attr.flavor == FL_PROCEDURE)
428 : : {
429 : 279 : if (!gfc_pure (sym))
430 : 261 : proc->attr.implicit_pure = 0;
431 : : }
432 : 22074 : else if (!sym->attr.pointer)
433 : : {
434 : 21301 : if (proc->attr.function && sym->attr.intent != INTENT_IN
435 : 2519 : && !sym->value)
436 : 2519 : proc->attr.implicit_pure = 0;
437 : :
438 : 21301 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
439 : 3615 : && !sym->value)
440 : 3615 : proc->attr.implicit_pure = 0;
441 : : }
442 : : }
443 : :
444 : 675204 : if (gfc_elemental (proc))
445 : : {
446 : : /* F08:C1289. */
447 : 260142 : if (sym->attr.codimension
448 : 260141 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
449 : 846 : && CLASS_DATA (sym)->attr.codimension))
450 : : {
451 : 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
452 : : "procedure", sym->name, &sym->declared_at);
453 : 3 : continue;
454 : : }
455 : :
456 : 260139 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
457 : 844 : && CLASS_DATA (sym)->as))
458 : : {
459 : 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
460 : : "be scalar", sym->name, &sym->declared_at);
461 : 2 : continue;
462 : : }
463 : :
464 : 260137 : if (sym->attr.allocatable
465 : 260136 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
466 : 843 : && CLASS_DATA (sym)->attr.allocatable))
467 : : {
468 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
469 : : "have the ALLOCATABLE attribute", sym->name,
470 : : &sym->declared_at);
471 : 2 : continue;
472 : : }
473 : :
474 : 260135 : if (sym->attr.pointer
475 : 260134 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
476 : 842 : && CLASS_DATA (sym)->attr.class_pointer))
477 : : {
478 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
479 : : "have the POINTER attribute", sym->name,
480 : : &sym->declared_at);
481 : 2 : continue;
482 : : }
483 : :
484 : 260133 : if (sym->attr.flavor == FL_PROCEDURE)
485 : : {
486 : 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
487 : : "procedure %qs at %L", sym->name, proc->name,
488 : : &sym->declared_at);
489 : 2 : continue;
490 : : }
491 : :
492 : : /* Fortran 2008 Corrigendum 1, C1290a. */
493 : 260131 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
494 : : {
495 : 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
496 : : "have its INTENT specified or have the VALUE "
497 : : "attribute", sym->name, proc->name,
498 : : &sym->declared_at);
499 : 2 : continue;
500 : : }
501 : : }
502 : :
503 : : /* Each dummy shall be specified to be scalar. */
504 : 675191 : if (proc->attr.proc == PROC_ST_FUNCTION)
505 : : {
506 : 291 : if (sym->as != NULL)
507 : : {
508 : : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
509 : : shall be specified, explicitly or implicitly, to be scalar. */
510 : 1 : gfc_error ("Argument %qs of statement function %qs at %L "
511 : : "must be scalar", sym->name, proc->name,
512 : : &proc->declared_at);
513 : 1 : continue;
514 : : }
515 : :
516 : 290 : if (sym->ts.type == BT_CHARACTER)
517 : : {
518 : 47 : gfc_charlen *cl = sym->ts.u.cl;
519 : 47 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
520 : : {
521 : 0 : gfc_error ("Character-valued argument %qs of statement "
522 : : "function at %L must have constant length",
523 : : sym->name, &sym->declared_at);
524 : 0 : continue;
525 : : }
526 : : }
527 : : }
528 : : }
529 : :
530 : 434454 : gfc_current_ns = orig_current_ns;
531 : 434454 : }
532 : :
533 : :
534 : : /* Work function called when searching for symbols that have argument lists
535 : : associated with them. */
536 : :
537 : : static void
538 : 1477742 : find_arglists (gfc_symbol *sym)
539 : : {
540 : 1477742 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
541 : 276628 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
542 : : return;
543 : :
544 : 275444 : gfc_resolve_formal_arglist (sym);
545 : : }
546 : :
547 : :
548 : : /* Given a namespace, resolve all formal argument lists within the namespace.
549 : : */
550 : :
551 : : static void
552 : 291543 : resolve_formal_arglists (gfc_namespace *ns)
553 : : {
554 : 0 : if (ns == NULL)
555 : : return;
556 : :
557 : 291543 : gfc_traverse_ns (ns, find_arglists);
558 : : }
559 : :
560 : :
561 : : static void
562 : 30711 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
563 : : {
564 : 30711 : bool t;
565 : :
566 : 30711 : if (sym && sym->attr.flavor == FL_PROCEDURE
567 : 30711 : && sym->ns->parent
568 : 1058 : && sym->ns->parent->proc_name
569 : 1058 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
570 : 1 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
571 : 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
572 : : "encompassing procedure", sym->name, &sym->declared_at);
573 : :
574 : : /* If this namespace is not a function or an entry master function,
575 : : ignore it. */
576 : 30711 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
577 : 9683 : || sym->attr.entry_master)
578 : 21216 : return;
579 : :
580 : 9495 : if (!sym->result)
581 : : return;
582 : :
583 : : /* Try to find out of what the return type is. */
584 : 9494 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
585 : : {
586 : 51 : t = gfc_set_default_type (sym->result, 0, ns);
587 : :
588 : 51 : if (!t && !sym->result->attr.untyped)
589 : : {
590 : 19 : if (sym->result == sym)
591 : 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
592 : : sym->name, &sym->declared_at);
593 : 18 : else if (!sym->result->attr.proc_pointer)
594 : 0 : gfc_error ("Result %qs of contained function %qs at %L has "
595 : : "no IMPLICIT type", sym->result->name, sym->name,
596 : : &sym->result->declared_at);
597 : 19 : sym->result->attr.untyped = 1;
598 : : }
599 : : }
600 : :
601 : : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
602 : : type, lists the only ways a character length value of * can be used:
603 : : dummy arguments of procedures, named constants, function results and
604 : : in allocate statements if the allocate_object is an assumed length dummy
605 : : in external functions. Internal function results and results of module
606 : : procedures are not on this list, ergo, not permitted. */
607 : :
608 : 9494 : if (sym->result->ts.type == BT_CHARACTER)
609 : : {
610 : 1065 : gfc_charlen *cl = sym->result->ts.u.cl;
611 : 1065 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
612 : : {
613 : : /* See if this is a module-procedure and adapt error message
614 : : accordingly. */
615 : 4 : bool module_proc;
616 : 4 : gcc_assert (ns->parent && ns->parent->proc_name);
617 : 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
618 : :
619 : 7 : gfc_error (module_proc
620 : : ? G_("Character-valued module procedure %qs at %L"
621 : : " must not be assumed length")
622 : : : G_("Character-valued internal function %qs at %L"
623 : : " must not be assumed length"),
624 : : sym->name, &sym->declared_at);
625 : : }
626 : : }
627 : : }
628 : :
629 : :
630 : : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
631 : : introduce duplicates. */
632 : :
633 : : static void
634 : 1418 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
635 : : {
636 : 1418 : gfc_formal_arglist *f, *new_arglist;
637 : 1418 : gfc_symbol *new_sym;
638 : :
639 : 2557 : for (; new_args != NULL; new_args = new_args->next)
640 : : {
641 : 1139 : new_sym = new_args->sym;
642 : : /* See if this arg is already in the formal argument list. */
643 : 2162 : for (f = proc->formal; f; f = f->next)
644 : : {
645 : 1469 : if (new_sym == f->sym)
646 : : break;
647 : : }
648 : :
649 : 1139 : if (f)
650 : 446 : continue;
651 : :
652 : : /* Add a new argument. Argument order is not important. */
653 : 693 : new_arglist = gfc_get_formal_arglist ();
654 : 693 : new_arglist->sym = new_sym;
655 : 693 : new_arglist->next = proc->formal;
656 : 693 : proc->formal = new_arglist;
657 : : }
658 : 1418 : }
659 : :
660 : :
661 : : /* Flag the arguments that are not present in all entries. */
662 : :
663 : : static void
664 : 1418 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
665 : : {
666 : 1418 : gfc_formal_arglist *f, *head;
667 : 1418 : head = new_args;
668 : :
669 : 2988 : for (f = proc->formal; f; f = f->next)
670 : : {
671 : 1570 : if (f->sym == NULL)
672 : 36 : continue;
673 : :
674 : 2698 : for (new_args = head; new_args; new_args = new_args->next)
675 : : {
676 : 2258 : if (new_args->sym == f->sym)
677 : : break;
678 : : }
679 : :
680 : 1534 : if (new_args)
681 : 1094 : continue;
682 : :
683 : 440 : f->sym->attr.not_always_present = 1;
684 : : }
685 : 1418 : }
686 : :
687 : :
688 : : /* Resolve alternate entry points. If a symbol has multiple entry points we
689 : : create a new master symbol for the main routine, and turn the existing
690 : : symbol into an entry point. */
691 : :
692 : : static void
693 : 321749 : resolve_entries (gfc_namespace *ns)
694 : : {
695 : 321749 : gfc_namespace *old_ns;
696 : 321749 : gfc_code *c;
697 : 321749 : gfc_symbol *proc;
698 : 321749 : gfc_entry_list *el;
699 : : /* Provide sufficient space to hold "master.%d.%s". */
700 : 321749 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
701 : 321749 : static int master_count = 0;
702 : :
703 : 321749 : if (ns->proc_name == NULL)
704 : 321082 : return;
705 : :
706 : : /* No need to do anything if this procedure doesn't have alternate entry
707 : : points. */
708 : 321701 : if (!ns->entries)
709 : : return;
710 : :
711 : : /* We may already have resolved alternate entry points. */
712 : 917 : if (ns->proc_name->attr.entry_master)
713 : : return;
714 : :
715 : : /* If this isn't a procedure something has gone horribly wrong. */
716 : 667 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
717 : :
718 : : /* Remember the current namespace. */
719 : 667 : old_ns = gfc_current_ns;
720 : :
721 : 667 : gfc_current_ns = ns;
722 : :
723 : : /* Add the main entry point to the list of entry points. */
724 : 667 : el = gfc_get_entry_list ();
725 : 667 : el->sym = ns->proc_name;
726 : 667 : el->id = 0;
727 : 667 : el->next = ns->entries;
728 : 667 : ns->entries = el;
729 : 667 : ns->proc_name->attr.entry = 1;
730 : :
731 : : /* If it is a module function, it needs to be in the right namespace
732 : : so that gfc_get_fake_result_decl can gather up the results. The
733 : : need for this arose in get_proc_name, where these beasts were
734 : : left in their own namespace, to keep prior references linked to
735 : : the entry declaration.*/
736 : 667 : if (ns->proc_name->attr.function
737 : 563 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
738 : 188 : el->sym->ns = ns;
739 : :
740 : : /* Do the same for entries where the master is not a module
741 : : procedure. These are retained in the module namespace because
742 : : of the module procedure declaration. */
743 : 1418 : for (el = el->next; el; el = el->next)
744 : 751 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
745 : 0 : && el->sym->attr.mod_proc)
746 : 0 : el->sym->ns = ns;
747 : 667 : el = ns->entries;
748 : :
749 : : /* Add an entry statement for it. */
750 : 667 : c = gfc_get_code (EXEC_ENTRY);
751 : 667 : c->ext.entry = el;
752 : 667 : c->next = ns->code;
753 : 667 : ns->code = c;
754 : :
755 : : /* Create a new symbol for the master function. */
756 : : /* Give the internal function a unique name (within this file).
757 : : Also include the function name so the user has some hope of figuring
758 : : out what is going on. */
759 : 667 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
760 : 667 : master_count++, ns->proc_name->name);
761 : 667 : gfc_get_ha_symbol (name, &proc);
762 : 667 : gcc_assert (proc != NULL);
763 : :
764 : 667 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
765 : 667 : if (ns->proc_name->attr.subroutine)
766 : 104 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
767 : : else
768 : : {
769 : 563 : gfc_symbol *sym;
770 : 563 : gfc_typespec *ts, *fts;
771 : 563 : gfc_array_spec *as, *fas;
772 : 563 : gfc_add_function (&proc->attr, proc->name, NULL);
773 : 563 : proc->result = proc;
774 : 563 : fas = ns->entries->sym->as;
775 : 563 : fas = fas ? fas : ns->entries->sym->result->as;
776 : 563 : fts = &ns->entries->sym->result->ts;
777 : 563 : if (fts->type == BT_UNKNOWN)
778 : 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
779 : 1056 : for (el = ns->entries->next; el; el = el->next)
780 : : {
781 : 602 : ts = &el->sym->result->ts;
782 : 602 : as = el->sym->as;
783 : 602 : as = as ? as : el->sym->result->as;
784 : 602 : if (ts->type == BT_UNKNOWN)
785 : 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
786 : :
787 : 602 : if (! gfc_compare_types (ts, fts)
788 : 496 : || (el->sym->result->attr.dimension
789 : 496 : != ns->entries->sym->result->attr.dimension)
790 : 602 : || (el->sym->result->attr.pointer
791 : : != ns->entries->sym->result->attr.pointer))
792 : : break;
793 : 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
794 : 558 : && gfc_compare_array_spec (as, fas) == 0)
795 : 5 : gfc_error ("Function %s at %L has entries with mismatched "
796 : : "array specifications", ns->entries->sym->name,
797 : 5 : &ns->entries->sym->declared_at);
798 : : /* The characteristics need to match and thus both need to have
799 : : the same string length, i.e. both len=*, or both len=4.
800 : : Having both len=<variable> is also possible, but difficult to
801 : : check at compile time. */
802 : 491 : else if (ts->type == BT_CHARACTER
803 : 88 : && (el->sym->result->attr.allocatable
804 : 88 : != ns->entries->sym->result->attr.allocatable))
805 : : {
806 : 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
807 : : "characteristics", ns->entries->sym->name,
808 : : &ns->entries->sym->declared_at, el->sym->name);
809 : 3 : goto cleanup;
810 : : }
811 : 488 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
812 : 85 : && (((ts->u.cl->length && !fts->u.cl->length)
813 : 84 : ||(!ts->u.cl->length && fts->u.cl->length))
814 : 65 : || (ts->u.cl->length
815 : 28 : && ts->u.cl->length->expr_type
816 : 28 : != fts->u.cl->length->expr_type)
817 : 65 : || (ts->u.cl->length
818 : 28 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
819 : 27 : && mpz_cmp (ts->u.cl->length->value.integer,
820 : 27 : fts->u.cl->length->value.integer) != 0)))
821 : 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
822 : : "entries returning variables of different "
823 : : "string lengths", ns->entries->sym->name,
824 : 21 : &ns->entries->sym->declared_at);
825 : 467 : else if (el->sym->result->attr.allocatable
826 : 467 : != ns->entries->sym->result->attr.allocatable)
827 : : break;
828 : : }
829 : :
830 : 560 : if (el == NULL)
831 : : {
832 : 454 : sym = ns->entries->sym->result;
833 : : /* All result types the same. */
834 : 454 : proc->ts = *fts;
835 : 454 : if (sym->attr.dimension)
836 : 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
837 : 454 : if (sym->attr.pointer)
838 : 78 : gfc_add_pointer (&proc->attr, NULL);
839 : 454 : if (sym->attr.allocatable)
840 : 24 : gfc_add_allocatable (&proc->attr, NULL);
841 : : }
842 : : else
843 : : {
844 : : /* Otherwise the result will be passed through a union by
845 : : reference. */
846 : 106 : proc->attr.mixed_entry_master = 1;
847 : 340 : for (el = ns->entries; el; el = el->next)
848 : : {
849 : 234 : sym = el->sym->result;
850 : 234 : if (sym->attr.dimension)
851 : : {
852 : 1 : if (el == ns->entries)
853 : 0 : gfc_error ("FUNCTION result %s cannot be an array in "
854 : : "FUNCTION %s at %L", sym->name,
855 : 0 : ns->entries->sym->name, &sym->declared_at);
856 : : else
857 : 1 : gfc_error ("ENTRY result %s cannot be an array in "
858 : : "FUNCTION %s at %L", sym->name,
859 : 1 : ns->entries->sym->name, &sym->declared_at);
860 : : }
861 : 233 : else if (sym->attr.pointer)
862 : : {
863 : 1 : if (el == ns->entries)
864 : 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
865 : : "FUNCTION %s at %L", sym->name,
866 : 1 : ns->entries->sym->name, &sym->declared_at);
867 : : else
868 : 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
869 : : "FUNCTION %s at %L", sym->name,
870 : 0 : ns->entries->sym->name, &sym->declared_at);
871 : : }
872 : 232 : else if (sym->attr.allocatable)
873 : : {
874 : 0 : if (el == ns->entries)
875 : 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
876 : : "FUNCTION %s at %L", sym->name,
877 : 0 : ns->entries->sym->name, &sym->declared_at);
878 : : else
879 : 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
880 : : "FUNCTION %s at %L", sym->name,
881 : 0 : ns->entries->sym->name, &sym->declared_at);
882 : : }
883 : : else
884 : : {
885 : 232 : ts = &sym->ts;
886 : 232 : if (ts->type == BT_UNKNOWN)
887 : 9 : ts = gfc_get_default_type (sym->name, NULL);
888 : 232 : switch (ts->type)
889 : : {
890 : 84 : case BT_INTEGER:
891 : 84 : if (ts->kind == gfc_default_integer_kind)
892 : : sym = NULL;
893 : : break;
894 : 99 : case BT_REAL:
895 : 99 : if (ts->kind == gfc_default_real_kind
896 : 18 : || ts->kind == gfc_default_double_kind)
897 : : sym = NULL;
898 : : break;
899 : 19 : case BT_COMPLEX:
900 : 19 : if (ts->kind == gfc_default_complex_kind)
901 : : sym = NULL;
902 : : break;
903 : 27 : case BT_LOGICAL:
904 : 27 : if (ts->kind == gfc_default_logical_kind)
905 : : sym = NULL;
906 : : break;
907 : : case BT_UNKNOWN:
908 : : /* We will issue error elsewhere. */
909 : : sym = NULL;
910 : : break;
911 : : default:
912 : : break;
913 : : }
914 : 3 : if (sym)
915 : : {
916 : 3 : if (el == ns->entries)
917 : 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
918 : : "in FUNCTION %s at %L", sym->name,
919 : 1 : gfc_typename (ts), ns->entries->sym->name,
920 : : &sym->declared_at);
921 : : else
922 : 2 : gfc_error ("ENTRY result %s cannot be of type %s "
923 : : "in FUNCTION %s at %L", sym->name,
924 : 2 : gfc_typename (ts), ns->entries->sym->name,
925 : : &sym->declared_at);
926 : : }
927 : : }
928 : : }
929 : : }
930 : : }
931 : :
932 : 106 : cleanup:
933 : 667 : proc->attr.access = ACCESS_PRIVATE;
934 : 667 : proc->attr.entry_master = 1;
935 : :
936 : : /* Merge all the entry point arguments. */
937 : 2085 : for (el = ns->entries; el; el = el->next)
938 : 1418 : merge_argument_lists (proc, el->sym->formal);
939 : :
940 : : /* Check the master formal arguments for any that are not
941 : : present in all entry points. */
942 : 2085 : for (el = ns->entries; el; el = el->next)
943 : 1418 : check_argument_lists (proc, el->sym->formal);
944 : :
945 : : /* Use the master function for the function body. */
946 : 667 : ns->proc_name = proc;
947 : :
948 : : /* Finalize the new symbols. */
949 : 667 : gfc_commit_symbols ();
950 : :
951 : : /* Restore the original namespace. */
952 : 667 : gfc_current_ns = old_ns;
953 : : }
954 : :
955 : :
956 : : /* Forward declaration. */
957 : : static bool is_non_constant_shape_array (gfc_symbol *sym);
958 : :
959 : :
960 : : /* Resolve common variables. */
961 : : static void
962 : 293471 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
963 : : {
964 : 293471 : gfc_symbol *csym = common_block->head;
965 : 293471 : gfc_gsymbol *gsym;
966 : :
967 : 299528 : for (; csym; csym = csym->common_next)
968 : : {
969 : 6057 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
970 : 6057 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
971 : : {
972 : 3 : if (csym->common_block)
973 : 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
974 : : "COMMON block at %L", gsym->name,
975 : : &gsym->where, &csym->common_block->where);
976 : : else
977 : 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
978 : : "COMMON block", gsym->name, &gsym->where);
979 : : }
980 : :
981 : : /* gfc_add_in_common may have been called before, but the reported errors
982 : : have been ignored to continue parsing.
983 : : We do the checks again here, unless the symbol is USE associated. */
984 : 6057 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
985 : : {
986 : 5784 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
987 : 5784 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
988 : : &common_block->where);
989 : : }
990 : :
991 : 6057 : if (csym->value || csym->attr.data)
992 : : {
993 : 131 : if (!csym->ns->is_block_data)
994 : 32 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
995 : : "but only in BLOCK DATA initialization is "
996 : : "allowed", csym->name, &csym->declared_at);
997 : 99 : else if (!named_common)
998 : 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
999 : : "in a blank COMMON but initialization is only "
1000 : : "allowed in named common blocks", csym->name,
1001 : : &csym->declared_at);
1002 : : }
1003 : :
1004 : 6057 : if (UNLIMITED_POLY (csym))
1005 : 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1006 : : "[F2008:C5100]", csym->name, &csym->declared_at);
1007 : :
1008 : 6057 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1009 : : {
1010 : 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1011 : : "COMMON at %L", csym->name, &csym->declared_at,
1012 : : &common_block->where);
1013 : : /* Avoid confusing follow-on error. */
1014 : 1 : csym->error = 1;
1015 : : }
1016 : :
1017 : 6057 : if (csym->ts.type != BT_DERIVED)
1018 : 6010 : continue;
1019 : :
1020 : 47 : if (!(csym->ts.u.derived->attr.sequence
1021 : : || csym->ts.u.derived->attr.is_bind_c))
1022 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1023 : : "has neither the SEQUENCE nor the BIND(C) "
1024 : : "attribute", csym->name, &csym->declared_at);
1025 : 47 : if (csym->ts.u.derived->attr.alloc_comp)
1026 : 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1027 : : "has an ultimate component that is "
1028 : : "allocatable", csym->name, &csym->declared_at);
1029 : 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1030 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1031 : : "may not have default initializer", csym->name,
1032 : : &csym->declared_at);
1033 : :
1034 : 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1035 : 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1036 : : }
1037 : 293471 : }
1038 : :
1039 : : /* Resolve common blocks. */
1040 : : static void
1041 : 292008 : resolve_common_blocks (gfc_symtree *common_root)
1042 : : {
1043 : 292008 : gfc_symbol *sym;
1044 : 292008 : gfc_gsymbol * gsym;
1045 : :
1046 : 292008 : if (common_root == NULL)
1047 : 291886 : return;
1048 : :
1049 : 1928 : if (common_root->left)
1050 : 210 : resolve_common_blocks (common_root->left);
1051 : 1928 : if (common_root->right)
1052 : 255 : resolve_common_blocks (common_root->right);
1053 : :
1054 : 1928 : resolve_common_vars (common_root->n.common, true);
1055 : :
1056 : : /* The common name is a global name - in Fortran 2003 also if it has a
1057 : : C binding name, since Fortran 2008 only the C binding name is a global
1058 : : identifier. */
1059 : 1928 : if (!common_root->n.common->binding_label
1060 : 1928 : || gfc_notification_std (GFC_STD_F2008))
1061 : : {
1062 : 3712 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1063 : 1856 : common_root->n.common->name);
1064 : :
1065 : 833 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1066 : 14 : && gsym->type == GSYM_COMMON
1067 : 1869 : && ((common_root->n.common->binding_label
1068 : 6 : && (!gsym->binding_label
1069 : 0 : || strcmp (common_root->n.common->binding_label,
1070 : : gsym->binding_label) != 0))
1071 : 7 : || (!common_root->n.common->binding_label
1072 : 7 : && gsym->binding_label)))
1073 : : {
1074 : 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1075 : : "identifier and must thus have the same binding name "
1076 : : "as the same-named COMMON block at %L: %s vs %s",
1077 : 6 : common_root->n.common->name, &common_root->n.common->where,
1078 : : &gsym->where,
1079 : : common_root->n.common->binding_label
1080 : : ? common_root->n.common->binding_label : "(blank)",
1081 : 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1082 : 6 : return;
1083 : : }
1084 : :
1085 : 1850 : if (gsym && gsym->type != GSYM_COMMON
1086 : 1 : && !common_root->n.common->binding_label)
1087 : : {
1088 : 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1089 : : "as entity at %L",
1090 : 0 : common_root->n.common->name, &common_root->n.common->where,
1091 : : &gsym->where);
1092 : 0 : return;
1093 : : }
1094 : 827 : if (gsym && gsym->type != GSYM_COMMON)
1095 : : {
1096 : 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1097 : : "%L sharing the identifier with global non-COMMON-block "
1098 : 1 : "entity at %L", common_root->n.common->name,
1099 : 1 : &common_root->n.common->where, &gsym->where);
1100 : 1 : return;
1101 : : }
1102 : 1023 : if (!gsym)
1103 : : {
1104 : 1023 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1105 : 1023 : gsym->type = GSYM_COMMON;
1106 : 1023 : gsym->where = common_root->n.common->where;
1107 : 1023 : gsym->defined = 1;
1108 : : }
1109 : 1849 : gsym->used = 1;
1110 : : }
1111 : :
1112 : 1921 : if (common_root->n.common->binding_label)
1113 : : {
1114 : 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1115 : : common_root->n.common->binding_label);
1116 : 76 : if (gsym && gsym->type != GSYM_COMMON)
1117 : : {
1118 : 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1119 : : "global identifier as entity at %L",
1120 : : &common_root->n.common->where,
1121 : 1 : common_root->n.common->binding_label, &gsym->where);
1122 : 1 : return;
1123 : : }
1124 : 57 : if (!gsym)
1125 : : {
1126 : 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1127 : 57 : gsym->type = GSYM_COMMON;
1128 : 57 : gsym->where = common_root->n.common->where;
1129 : 57 : gsym->defined = 1;
1130 : : }
1131 : 75 : gsym->used = 1;
1132 : : }
1133 : :
1134 : 1920 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1135 : 1920 : if (sym == NULL)
1136 : : return;
1137 : :
1138 : 122 : if (sym->attr.flavor == FL_PARAMETER)
1139 : 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1140 : 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1141 : :
1142 : 122 : if (sym->attr.external)
1143 : 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1144 : 1 : sym->name, &common_root->n.common->where);
1145 : :
1146 : 122 : if (sym->attr.intrinsic)
1147 : 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1148 : 2 : sym->name, &common_root->n.common->where);
1149 : 120 : else if (sym->attr.result
1150 : 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1151 : 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1152 : : "that is also a function result", sym->name,
1153 : 1 : &common_root->n.common->where);
1154 : 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1155 : 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1156 : 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1157 : : "that is also a global procedure", sym->name,
1158 : 3 : &common_root->n.common->where);
1159 : : }
1160 : :
1161 : :
1162 : : /* Resolve contained function types. Because contained functions can call one
1163 : : another, they have to be worked out before any of the contained procedures
1164 : : can be resolved.
1165 : :
1166 : : The good news is that if a function doesn't already have a type, the only
1167 : : way it can get one is through an IMPLICIT type or a RESULT variable, because
1168 : : by definition contained functions are contained namespace they're contained
1169 : : in, not in a sibling or parent namespace. */
1170 : :
1171 : : static void
1172 : 291543 : resolve_contained_functions (gfc_namespace *ns)
1173 : : {
1174 : 291543 : gfc_namespace *child;
1175 : 291543 : gfc_entry_list *el;
1176 : :
1177 : 291543 : resolve_formal_arglists (ns);
1178 : :
1179 : 321749 : for (child = ns->contained; child; child = child->sibling)
1180 : : {
1181 : : /* Resolve alternate entry points first. */
1182 : 30206 : resolve_entries (child);
1183 : :
1184 : : /* Then check function return types. */
1185 : 30206 : resolve_contained_fntype (child->proc_name, child);
1186 : 30711 : for (el = child->entries; el; el = el->next)
1187 : 505 : resolve_contained_fntype (el->sym, child);
1188 : : }
1189 : 291543 : }
1190 : :
1191 : :
1192 : :
1193 : : /* A Parameterized Derived Type constructor must contain values for
1194 : : the PDT KIND parameters or they must have a default initializer.
1195 : : Go through the constructor picking out the KIND expressions,
1196 : : storing them in 'param_list' and then call gfc_get_pdt_instance
1197 : : to obtain the PDT instance. */
1198 : :
1199 : : static gfc_actual_arglist *param_list, *param_tail, *param;
1200 : :
1201 : : static bool
1202 : 24 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1203 : : {
1204 : 24 : param = gfc_get_actual_arglist ();
1205 : 24 : if (!param_list)
1206 : 18 : param_list = param_tail = param;
1207 : : else
1208 : : {
1209 : 6 : param_tail->next = param;
1210 : 6 : param_tail = param_tail->next;
1211 : : }
1212 : :
1213 : 24 : param_tail->name = c->name;
1214 : 24 : if (expr)
1215 : 24 : param_tail->expr = gfc_copy_expr (expr);
1216 : 0 : else if (c->initializer)
1217 : 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1218 : : else
1219 : : {
1220 : 0 : param_tail->spec_type = SPEC_ASSUMED;
1221 : 0 : if (c->attr.pdt_kind)
1222 : : {
1223 : 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1224 : : "at %C has no value", param->name);
1225 : 0 : return false;
1226 : : }
1227 : : }
1228 : :
1229 : : return true;
1230 : : }
1231 : :
1232 : : static bool
1233 : 18 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1234 : : gfc_symbol *derived)
1235 : : {
1236 : 18 : gfc_constructor *cons = NULL;
1237 : 18 : gfc_component *comp;
1238 : 18 : bool t = true;
1239 : :
1240 : 18 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1241 : 18 : cons = gfc_constructor_first (expr->value.constructor);
1242 : 0 : else if (constr)
1243 : 0 : cons = *constr;
1244 : 18 : gcc_assert (cons);
1245 : :
1246 : 18 : comp = derived->components;
1247 : :
1248 : 66 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1249 : : {
1250 : 48 : if (cons->expr
1251 : 48 : && cons->expr->expr_type == EXPR_STRUCTURE
1252 : 0 : && comp->ts.type == BT_DERIVED)
1253 : : {
1254 : 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1255 : 0 : if (!t)
1256 : : return t;
1257 : : }
1258 : 48 : else if (comp->ts.type == BT_DERIVED)
1259 : : {
1260 : 0 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1261 : 0 : if (!t)
1262 : : return t;
1263 : : }
1264 : 48 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1265 : 24 : && derived->attr.pdt_template)
1266 : : {
1267 : 24 : t = get_pdt_spec_expr (comp, cons->expr);
1268 : 24 : if (!t)
1269 : : return t;
1270 : : }
1271 : : }
1272 : : return t;
1273 : : }
1274 : :
1275 : :
1276 : : static bool resolve_fl_derived0 (gfc_symbol *sym);
1277 : : static bool resolve_fl_struct (gfc_symbol *sym);
1278 : :
1279 : :
1280 : : /* Resolve all of the elements of a structure constructor and make sure that
1281 : : the types are correct. The 'init' flag indicates that the given
1282 : : constructor is an initializer. */
1283 : :
1284 : : static bool
1285 : 66662 : resolve_structure_cons (gfc_expr *expr, int init)
1286 : : {
1287 : 66662 : gfc_constructor *cons;
1288 : 66662 : gfc_component *comp;
1289 : 66662 : bool t;
1290 : 66662 : symbol_attribute a;
1291 : :
1292 : 66662 : t = true;
1293 : :
1294 : 66662 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1295 : : {
1296 : 64120 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1297 : 63970 : resolve_fl_derived0 (expr->ts.u.derived);
1298 : : else
1299 : 150 : resolve_fl_struct (expr->ts.u.derived);
1300 : :
1301 : : /* If this is a Parameterized Derived Type template, find the
1302 : : instance corresponding to the PDT kind parameters. */
1303 : 64120 : if (expr->ts.u.derived->attr.pdt_template)
1304 : : {
1305 : 18 : param_list = NULL;
1306 : 18 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1307 : 18 : if (!t)
1308 : : return t;
1309 : 18 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1310 : :
1311 : 18 : expr->param_list = gfc_copy_actual_arglist (param_list);
1312 : :
1313 : 18 : if (param_list)
1314 : 18 : gfc_free_actual_arglist (param_list);
1315 : :
1316 : 18 : if (!expr->ts.u.derived->attr.pdt_type)
1317 : : return false;
1318 : : }
1319 : : }
1320 : :
1321 : : /* A constructor may have references if it is the result of substituting a
1322 : : parameter variable. In this case we just pull out the component we
1323 : : want. */
1324 : 66662 : if (expr->ref)
1325 : 144 : comp = expr->ref->u.c.sym->components;
1326 : 66518 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1327 : : || expr->ts.type == BT_UNION)
1328 : 66516 : && expr->ts.u.derived)
1329 : 66516 : comp = expr->ts.u.derived->components;
1330 : : else
1331 : : return false;
1332 : :
1333 : 66660 : cons = gfc_constructor_first (expr->value.constructor);
1334 : :
1335 : 282597 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1336 : : {
1337 : 215939 : int rank;
1338 : :
1339 : 215939 : if (!cons->expr)
1340 : 73723 : continue;
1341 : :
1342 : : /* Unions use an EXPR_NULL contrived expression to tell the translation
1343 : : phase to generate an initializer of the appropriate length.
1344 : : Ignore it here. */
1345 : 142216 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1346 : 15 : continue;
1347 : :
1348 : 142201 : if (!gfc_resolve_expr (cons->expr))
1349 : : {
1350 : 0 : t = false;
1351 : 0 : continue;
1352 : : }
1353 : :
1354 : 142201 : rank = comp->as ? comp->as->rank : 0;
1355 : 142201 : if (comp->ts.type == BT_CLASS
1356 : 1846 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1357 : 1845 : && CLASS_DATA (comp)->as)
1358 : 448 : rank = CLASS_DATA (comp)->as->rank;
1359 : :
1360 : 142201 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1361 : 141 : gfc_find_vtab (&cons->expr->ts);
1362 : :
1363 : 142201 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1364 : 434 : && (comp->attr.allocatable || cons->expr->rank))
1365 : : {
1366 : 3 : gfc_error ("The rank of the element in the structure "
1367 : : "constructor at %L does not match that of the "
1368 : : "component (%d/%d)", &cons->expr->where,
1369 : : cons->expr->rank, rank);
1370 : 3 : t = false;
1371 : : }
1372 : :
1373 : : /* If we don't have the right type, try to convert it. */
1374 : :
1375 : 242118 : if (!comp->attr.proc_pointer &&
1376 : 99917 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1377 : : {
1378 : 10617 : if (strcmp (comp->name, "_extends") == 0)
1379 : : {
1380 : : /* Can afford to be brutal with the _extends initializer.
1381 : : The derived type can get lost because it is PRIVATE
1382 : : but it is not usage constrained by the standard. */
1383 : 7820 : cons->expr->ts = comp->ts;
1384 : : }
1385 : 2797 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1386 : : {
1387 : 2 : gfc_error ("The element in the structure constructor at %L, "
1388 : : "for pointer component %qs, is %s but should be %s",
1389 : 2 : &cons->expr->where, comp->name,
1390 : 2 : gfc_basic_typename (cons->expr->ts.type),
1391 : : gfc_basic_typename (comp->ts.type));
1392 : 2 : t = false;
1393 : : }
1394 : 2795 : else if (!UNLIMITED_POLY (comp))
1395 : : {
1396 : 2757 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1397 : 2757 : if (t)
1398 : 142201 : t = t2;
1399 : : }
1400 : : }
1401 : :
1402 : : /* For strings, the length of the constructor should be the same as
1403 : : the one of the structure, ensure this if the lengths are known at
1404 : : compile time and when we are dealing with PARAMETER or structure
1405 : : constructors. */
1406 : 142201 : if (cons->expr->ts.type == BT_CHARACTER
1407 : 3546 : && comp->ts.type == BT_CHARACTER
1408 : 3527 : && comp->ts.u.cl && comp->ts.u.cl->length
1409 : 2267 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1410 : 2250 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1411 : 821 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1412 : 821 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1413 : 821 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1414 : 821 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1415 : 821 : comp->ts.u.cl->length->value.integer) != 0)
1416 : : {
1417 : 11 : if (comp->attr.pointer)
1418 : : {
1419 : 3 : HOST_WIDE_INT la, lb;
1420 : 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1421 : 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1422 : 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1423 : : "component %qs in constructor at %L",
1424 : 3 : la, lb, comp->name, &cons->expr->where);
1425 : 3 : t = false;
1426 : : }
1427 : :
1428 : 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1429 : 4 : && cons->expr->rank != 0
1430 : 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1431 : : {
1432 : : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1433 : : to make use of the gfc_resolve_character_array_constructor
1434 : : machinery. The expression is later simplified away to
1435 : : an array of string literals. */
1436 : 1 : gfc_expr *para = cons->expr;
1437 : 1 : cons->expr = gfc_get_expr ();
1438 : 1 : cons->expr->ts = para->ts;
1439 : 1 : cons->expr->where = para->where;
1440 : 1 : cons->expr->expr_type = EXPR_ARRAY;
1441 : 1 : cons->expr->rank = para->rank;
1442 : 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1443 : 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1444 : 1 : para, &cons->expr->where);
1445 : : }
1446 : :
1447 : 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1448 : : {
1449 : : /* Rely on the cleanup of the namespace to deal correctly with
1450 : : the old charlen. (There was a block here that attempted to
1451 : : remove the charlen but broke the chain in so doing.) */
1452 : 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1453 : 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1454 : 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1455 : 5 : gfc_resolve_character_array_constructor (cons->expr);
1456 : : }
1457 : : }
1458 : :
1459 : 142201 : if (cons->expr->expr_type == EXPR_NULL
1460 : 46415 : && !(comp->attr.pointer || comp->attr.allocatable
1461 : 45507 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1462 : 908 : || (comp->ts.type == BT_CLASS
1463 : 906 : && (CLASS_DATA (comp)->attr.class_pointer
1464 : 906 : || CLASS_DATA (comp)->attr.allocatable))))
1465 : : {
1466 : 2 : t = false;
1467 : 2 : gfc_error ("The NULL in the structure constructor at %L is "
1468 : : "being applied to component %qs, which is neither "
1469 : : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1470 : : comp->name);
1471 : : }
1472 : :
1473 : 142201 : if (comp->attr.proc_pointer && comp->ts.interface)
1474 : : {
1475 : : /* Check procedure pointer interface. */
1476 : 15175 : gfc_symbol *s2 = NULL;
1477 : 15175 : gfc_component *c2;
1478 : 15175 : const char *name;
1479 : 15175 : char err[200];
1480 : :
1481 : 15175 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1482 : 15175 : if (c2)
1483 : : {
1484 : 12 : s2 = c2->ts.interface;
1485 : 12 : name = c2->name;
1486 : : }
1487 : 15163 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1488 : : {
1489 : 0 : s2 = cons->expr->symtree->n.sym->result;
1490 : 0 : name = cons->expr->symtree->n.sym->result->name;
1491 : : }
1492 : 15163 : else if (cons->expr->expr_type != EXPR_NULL)
1493 : : {
1494 : 14417 : s2 = cons->expr->symtree->n.sym;
1495 : 14417 : name = cons->expr->symtree->n.sym->name;
1496 : : }
1497 : :
1498 : 14429 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1499 : : err, sizeof (err), NULL, NULL))
1500 : : {
1501 : 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1502 : : "component %qs in structure constructor at %L:"
1503 : 2 : " %s", comp->name, &cons->expr->where, err);
1504 : 2 : return false;
1505 : : }
1506 : : }
1507 : :
1508 : : /* Validate shape, except for dynamic or PDT arrays. */
1509 : 142199 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1510 : 2015 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1511 : 1311 : && !comp->attr.pdt_array)
1512 : : {
1513 : 1257 : mpz_t len;
1514 : 1257 : mpz_init (len);
1515 : 2616 : for (int n = 0; n < rank; n++)
1516 : : {
1517 : 1360 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1518 : 1359 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1519 : : {
1520 : 1 : gfc_error ("Bad array spec of component %qs referenced in "
1521 : : "structure constructor at %L",
1522 : 1 : comp->name, &cons->expr->where);
1523 : 1 : t = false;
1524 : 1 : break;
1525 : 1359 : };
1526 : 1359 : if (cons->expr->shape == NULL)
1527 : 12 : continue;
1528 : 1347 : mpz_set_ui (len, 1);
1529 : 1347 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1530 : 1347 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1531 : 1347 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1532 : : {
1533 : 9 : gfc_error ("The shape of component %qs in the structure "
1534 : : "constructor at %L differs from the shape of the "
1535 : : "declared component for dimension %d (%ld/%ld)",
1536 : : comp->name, &cons->expr->where, n+1,
1537 : : mpz_get_si (cons->expr->shape[n]),
1538 : : mpz_get_si (len));
1539 : 9 : t = false;
1540 : : }
1541 : : }
1542 : 1257 : mpz_clear (len);
1543 : : }
1544 : :
1545 : 142199 : if (!comp->attr.pointer || comp->attr.proc_pointer
1546 : 18962 : || cons->expr->expr_type == EXPR_NULL)
1547 : 133388 : continue;
1548 : :
1549 : 8811 : a = gfc_expr_attr (cons->expr);
1550 : :
1551 : 8811 : if (!a.pointer && !a.target)
1552 : : {
1553 : 1 : t = false;
1554 : 1 : gfc_error ("The element in the structure constructor at %L, "
1555 : : "for pointer component %qs should be a POINTER or "
1556 : 1 : "a TARGET", &cons->expr->where, comp->name);
1557 : : }
1558 : :
1559 : 8811 : if (init)
1560 : : {
1561 : : /* F08:C461. Additional checks for pointer initialization. */
1562 : 8738 : if (a.allocatable)
1563 : : {
1564 : 0 : t = false;
1565 : 0 : gfc_error ("Pointer initialization target at %L "
1566 : 0 : "must not be ALLOCATABLE", &cons->expr->where);
1567 : : }
1568 : 8738 : if (!a.save)
1569 : : {
1570 : 0 : t = false;
1571 : 0 : gfc_error ("Pointer initialization target at %L "
1572 : 0 : "must have the SAVE attribute", &cons->expr->where);
1573 : : }
1574 : : }
1575 : :
1576 : : /* F2003, C1272 (3). */
1577 : 8811 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1578 : 8811 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1579 : 8776 : || gfc_is_coindexed (cons->expr));
1580 : 32 : if (impure && gfc_pure (NULL))
1581 : : {
1582 : 1 : t = false;
1583 : 1 : gfc_error ("Invalid expression in the structure constructor for "
1584 : : "pointer component %qs at %L in PURE procedure",
1585 : 1 : comp->name, &cons->expr->where);
1586 : : }
1587 : :
1588 : 8811 : if (impure)
1589 : 32 : gfc_unset_implicit_pure (NULL);
1590 : : }
1591 : :
1592 : : return t;
1593 : : }
1594 : :
1595 : :
1596 : : /****************** Expression name resolution ******************/
1597 : :
1598 : : /* Returns 0 if a symbol was not declared with a type or
1599 : : attribute declaration statement, nonzero otherwise. */
1600 : :
1601 : : static bool
1602 : 642966 : was_declared (gfc_symbol *sym)
1603 : : {
1604 : 642966 : symbol_attribute a;
1605 : :
1606 : 642966 : a = sym->attr;
1607 : :
1608 : 642966 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1609 : : return 1;
1610 : :
1611 : 541877 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1612 : : || a.optional || a.pointer || a.save || a.target || a.volatile_
1613 : 541877 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1614 : 533884 : || a.asynchronous || a.codimension)
1615 : 7993 : return 1;
1616 : :
1617 : : return 0;
1618 : : }
1619 : :
1620 : :
1621 : : /* Determine if a symbol is generic or not. */
1622 : :
1623 : : static int
1624 : 359485 : generic_sym (gfc_symbol *sym)
1625 : : {
1626 : 359485 : gfc_symbol *s;
1627 : :
1628 : 359485 : if (sym->attr.generic ||
1629 : 332201 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1630 : 28351 : return 1;
1631 : :
1632 : 331134 : if (was_declared (sym) || sym->ns->parent == NULL)
1633 : : return 0;
1634 : :
1635 : 58001 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1636 : :
1637 : 58001 : if (s != NULL)
1638 : : {
1639 : 1262 : if (s == sym)
1640 : : return 0;
1641 : : else
1642 : 1251 : return generic_sym (s);
1643 : : }
1644 : :
1645 : : return 0;
1646 : : }
1647 : :
1648 : :
1649 : : /* Determine if a symbol is specific or not. */
1650 : :
1651 : : static int
1652 : 329941 : specific_sym (gfc_symbol *sym)
1653 : : {
1654 : 329941 : gfc_symbol *s;
1655 : :
1656 : 329941 : if (sym->attr.if_source == IFSRC_IFBODY
1657 : 319509 : || sym->attr.proc == PROC_MODULE
1658 : : || sym->attr.proc == PROC_INTERNAL
1659 : : || sym->attr.proc == PROC_ST_FUNCTION
1660 : 253920 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1661 : 583130 : || sym->attr.external)
1662 : 79026 : return 1;
1663 : :
1664 : 250915 : if (was_declared (sym) || sym->ns->parent == NULL)
1665 : : return 0;
1666 : :
1667 : 56433 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1668 : :
1669 : 56433 : return (s == NULL) ? 0 : specific_sym (s);
1670 : : }
1671 : :
1672 : :
1673 : : /* Figure out if the procedure is specific, generic or unknown. */
1674 : :
1675 : : enum proc_type
1676 : : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1677 : :
1678 : : static proc_type
1679 : 358090 : procedure_kind (gfc_symbol *sym)
1680 : : {
1681 : 358090 : if (generic_sym (sym))
1682 : : return PTYPE_GENERIC;
1683 : :
1684 : 329880 : if (specific_sym (sym))
1685 : 79026 : return PTYPE_SPECIFIC;
1686 : :
1687 : : return PTYPE_UNKNOWN;
1688 : : }
1689 : :
1690 : : /* Check references to assumed size arrays. The flag need_full_assumed_size
1691 : : is nonzero when matching actual arguments. */
1692 : :
1693 : : static int need_full_assumed_size = 0;
1694 : :
1695 : : static bool
1696 : 1039835 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1697 : : {
1698 : 1039835 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1699 : : return false;
1700 : :
1701 : : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1702 : : What should it be? */
1703 : 3760 : if (e->ref
1704 : 3758 : && e->ref->u.ar.as
1705 : 3757 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1706 : 3262 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1707 : 3262 : && (e->ref->u.ar.type == AR_FULL))
1708 : : {
1709 : 22 : gfc_error ("The upper bound in the last dimension must "
1710 : : "appear in the reference to the assumed size "
1711 : : "array %qs at %L", sym->name, &e->where);
1712 : 22 : return true;
1713 : : }
1714 : : return false;
1715 : : }
1716 : :
1717 : :
1718 : : /* Look for bad assumed size array references in argument expressions
1719 : : of elemental and array valued intrinsic procedures. Since this is
1720 : : called from procedure resolution functions, it only recurses at
1721 : : operators. */
1722 : :
1723 : : static bool
1724 : 177317 : resolve_assumed_size_actual (gfc_expr *e)
1725 : : {
1726 : 177317 : if (e == NULL)
1727 : : return false;
1728 : :
1729 : 176850 : switch (e->expr_type)
1730 : : {
1731 : 85811 : case EXPR_VARIABLE:
1732 : 85811 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1733 : : return true;
1734 : : break;
1735 : :
1736 : 39313 : case EXPR_OP:
1737 : 39313 : if (resolve_assumed_size_actual (e->value.op.op1)
1738 : 39313 : || resolve_assumed_size_actual (e->value.op.op2))
1739 : 0 : return true;
1740 : : break;
1741 : :
1742 : : default:
1743 : : break;
1744 : : }
1745 : : return false;
1746 : : }
1747 : :
1748 : :
1749 : : /* Check a generic procedure, passed as an actual argument, to see if
1750 : : there is a matching specific name. If none, it is an error, and if
1751 : : more than one, the reference is ambiguous. */
1752 : : static int
1753 : 8 : count_specific_procs (gfc_expr *e)
1754 : : {
1755 : 8 : int n;
1756 : 8 : gfc_interface *p;
1757 : 8 : gfc_symbol *sym;
1758 : :
1759 : 8 : n = 0;
1760 : 8 : sym = e->symtree->n.sym;
1761 : :
1762 : 22 : for (p = sym->generic; p; p = p->next)
1763 : 14 : if (strcmp (sym->name, p->sym->name) == 0)
1764 : : {
1765 : 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1766 : : sym->name);
1767 : 8 : n++;
1768 : : }
1769 : :
1770 : 8 : if (n > 1)
1771 : 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1772 : : &e->where);
1773 : :
1774 : 8 : if (n == 0)
1775 : 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1776 : : "argument at %L", sym->name, &e->where);
1777 : :
1778 : 8 : return n;
1779 : : }
1780 : :
1781 : :
1782 : : /* See if a call to sym could possibly be a not allowed RECURSION because of
1783 : : a missing RECURSIVE declaration. This means that either sym is the current
1784 : : context itself, or sym is the parent of a contained procedure calling its
1785 : : non-RECURSIVE containing procedure.
1786 : : This also works if sym is an ENTRY. */
1787 : :
1788 : : static bool
1789 : 133180 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1790 : : {
1791 : 133180 : gfc_symbol* proc_sym;
1792 : 133180 : gfc_symbol* context_proc;
1793 : 133180 : gfc_namespace* real_context;
1794 : :
1795 : 133180 : if (sym->attr.flavor == FL_PROGRAM
1796 : : || gfc_fl_struct (sym->attr.flavor))
1797 : : return false;
1798 : :
1799 : : /* If we've got an ENTRY, find real procedure. */
1800 : 133179 : if (sym->attr.entry && sym->ns->entries)
1801 : 45 : proc_sym = sym->ns->entries->sym;
1802 : : else
1803 : : proc_sym = sym;
1804 : :
1805 : : /* If sym is RECURSIVE, all is well of course. */
1806 : 133179 : if (proc_sym->attr.recursive || flag_recursive)
1807 : : return false;
1808 : :
1809 : : /* Find the context procedure's "real" symbol if it has entries.
1810 : : We look for a procedure symbol, so recurse on the parents if we don't
1811 : : find one (like in case of a BLOCK construct). */
1812 : 1542 : for (real_context = context; ; real_context = real_context->parent)
1813 : : {
1814 : : /* We should find something, eventually! */
1815 : 114751 : gcc_assert (real_context);
1816 : :
1817 : 114751 : context_proc = (real_context->entries ? real_context->entries->sym
1818 : : : real_context->proc_name);
1819 : :
1820 : : /* In some special cases, there may not be a proc_name, like for this
1821 : : invalid code:
1822 : : real(bad_kind()) function foo () ...
1823 : : when checking the call to bad_kind ().
1824 : : In these cases, we simply return here and assume that the
1825 : : call is ok. */
1826 : 114751 : if (!context_proc)
1827 : : return false;
1828 : :
1829 : 114488 : if (context_proc->attr.flavor != FL_LABEL)
1830 : : break;
1831 : : }
1832 : :
1833 : : /* A call from sym's body to itself is recursion, of course. */
1834 : 112946 : if (context_proc == proc_sym)
1835 : : return true;
1836 : :
1837 : : /* The same is true if context is a contained procedure and sym the
1838 : : containing one. */
1839 : 112934 : if (context_proc->attr.contained)
1840 : : {
1841 : 16945 : gfc_symbol* parent_proc;
1842 : :
1843 : 16945 : gcc_assert (context->parent);
1844 : 16945 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1845 : : : context->parent->proc_name);
1846 : :
1847 : 16945 : if (parent_proc == proc_sym)
1848 : 9 : return true;
1849 : : }
1850 : :
1851 : : return false;
1852 : : }
1853 : :
1854 : :
1855 : : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1856 : : its typespec and formal argument list. */
1857 : :
1858 : : bool
1859 : 35172 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1860 : : {
1861 : 35172 : gfc_intrinsic_sym* isym = NULL;
1862 : 35172 : const char* symstd;
1863 : :
1864 : 35172 : if (sym->resolve_symbol_called >= 2)
1865 : : return true;
1866 : :
1867 : 25799 : sym->resolve_symbol_called = 2;
1868 : :
1869 : : /* Already resolved. */
1870 : 25799 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1871 : : return true;
1872 : :
1873 : : /* We already know this one is an intrinsic, so we don't call
1874 : : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1875 : : gfc_find_subroutine directly to check whether it is a function or
1876 : : subroutine. */
1877 : :
1878 : 18995 : if (sym->intmod_sym_id && sym->attr.subroutine)
1879 : : {
1880 : 7779 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1881 : 7779 : isym = gfc_intrinsic_subroutine_by_id (id);
1882 : 7779 : }
1883 : 11216 : else if (sym->intmod_sym_id)
1884 : : {
1885 : 7980 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1886 : 7980 : isym = gfc_intrinsic_function_by_id (id);
1887 : : }
1888 : 3236 : else if (!sym->attr.subroutine)
1889 : 3164 : isym = gfc_find_function (sym->name);
1890 : :
1891 : 18923 : if (isym && !sym->attr.subroutine)
1892 : : {
1893 : 11105 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1894 : 24 : && !sym->attr.implicit_type)
1895 : 10 : gfc_warning (OPT_Wsurprising,
1896 : : "Type specified for intrinsic function %qs at %L is"
1897 : : " ignored", sym->name, &sym->declared_at);
1898 : :
1899 : 14377 : if (!sym->attr.function &&
1900 : 3272 : !gfc_add_function(&sym->attr, sym->name, loc))
1901 : : return false;
1902 : :
1903 : 11105 : sym->ts = isym->ts;
1904 : : }
1905 : 7890 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1906 : : {
1907 : 7887 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1908 : : {
1909 : 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1910 : : " specifier", sym->name, &sym->declared_at);
1911 : 1 : return false;
1912 : : }
1913 : :
1914 : 7921 : if (!sym->attr.subroutine &&
1915 : 35 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1916 : : return false;
1917 : : }
1918 : : else
1919 : : {
1920 : 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1921 : : &sym->declared_at);
1922 : 3 : return false;
1923 : : }
1924 : :
1925 : 18990 : gfc_copy_formal_args_intr (sym, isym, NULL);
1926 : :
1927 : 18990 : sym->attr.pure = isym->pure;
1928 : 18990 : sym->attr.elemental = isym->elemental;
1929 : :
1930 : : /* Check it is actually available in the standard settings. */
1931 : 18990 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1932 : : {
1933 : 24 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1934 : : "available in the current standard settings but %s. Use "
1935 : : "an appropriate %<-std=*%> option or enable "
1936 : : "%<-fall-intrinsics%> in order to use it.",
1937 : : sym->name, &sym->declared_at, symstd);
1938 : 24 : return false;
1939 : : }
1940 : :
1941 : : return true;
1942 : : }
1943 : :
1944 : :
1945 : : /* Resolve a procedure expression, like passing it to a called procedure or as
1946 : : RHS for a procedure pointer assignment. */
1947 : :
1948 : : static bool
1949 : 965619 : resolve_procedure_expression (gfc_expr* expr)
1950 : : {
1951 : 965619 : gfc_symbol* sym;
1952 : :
1953 : 965619 : if (expr->expr_type != EXPR_VARIABLE)
1954 : : return true;
1955 : 965614 : gcc_assert (expr->symtree);
1956 : :
1957 : 965614 : sym = expr->symtree->n.sym;
1958 : :
1959 : 965614 : if (sym->attr.intrinsic)
1960 : 1345 : gfc_resolve_intrinsic (sym, &expr->where);
1961 : :
1962 : 965614 : if (sym->attr.flavor != FL_PROCEDURE
1963 : 29298 : || (sym->attr.function && sym->result == sym))
1964 : : return true;
1965 : :
1966 : : /* A non-RECURSIVE procedure that is used as procedure expression within its
1967 : : own body is in danger of being called recursively. */
1968 : 12701 : if (is_illegal_recursion (sym, gfc_current_ns))
1969 : : {
1970 : 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
1971 : 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
1972 : : " possibly calling itself recursively in procedure %qs. "
1973 : : " Declare it RECURSIVE or use %<-frecursive%>",
1974 : 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
1975 : : else
1976 : 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1977 : : " itself recursively. Declare it RECURSIVE or use"
1978 : : " %<-frecursive%>", sym->name, &expr->where);
1979 : : }
1980 : :
1981 : : return true;
1982 : : }
1983 : :
1984 : :
1985 : : /* Check that name is not a derived type. */
1986 : :
1987 : : static bool
1988 : 2835 : is_dt_name (const char *name)
1989 : : {
1990 : 2835 : gfc_symbol *dt_list, *dt_first;
1991 : :
1992 : 2835 : dt_list = dt_first = gfc_derived_types;
1993 : 4987 : for (; dt_list; dt_list = dt_list->dt_next)
1994 : : {
1995 : 2918 : if (strcmp(dt_list->name, name) == 0)
1996 : : return true;
1997 : 2915 : if (dt_first == dt_list->dt_next)
1998 : : break;
1999 : : }
2000 : : return false;
2001 : : }
2002 : :
2003 : :
2004 : : /* Resolve an actual argument list. Most of the time, this is just
2005 : : resolving the expressions in the list.
2006 : : The exception is that we sometimes have to decide whether arguments
2007 : : that look like procedure arguments are really simple variable
2008 : : references. */
2009 : :
2010 : : static bool
2011 : 370195 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2012 : : bool no_formal_args)
2013 : : {
2014 : 370195 : gfc_symbol *sym;
2015 : 370195 : gfc_symtree *parent_st;
2016 : 370195 : gfc_expr *e;
2017 : 370195 : gfc_component *comp;
2018 : 370195 : int save_need_full_assumed_size;
2019 : 370195 : bool return_value = false;
2020 : 370195 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2021 : :
2022 : 370195 : actual_arg = true;
2023 : 370195 : first_actual_arg = true;
2024 : :
2025 : 951747 : for (; arg; arg = arg->next)
2026 : : {
2027 : 581642 : e = arg->expr;
2028 : 581642 : if (e == NULL)
2029 : : {
2030 : : /* Check the label is a valid branching target. */
2031 : 2113 : if (arg->label)
2032 : : {
2033 : 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2034 : : {
2035 : 0 : gfc_error ("Label %d referenced at %L is never defined",
2036 : : arg->label->value, &arg->label->where);
2037 : 0 : goto cleanup;
2038 : : }
2039 : : }
2040 : 2113 : first_actual_arg = false;
2041 : 2113 : continue;
2042 : : }
2043 : :
2044 : 579529 : if (e->expr_type == EXPR_VARIABLE
2045 : 251924 : && e->symtree->n.sym->attr.generic
2046 : 8 : && no_formal_args
2047 : 579534 : && count_specific_procs (e) != 1)
2048 : 2 : goto cleanup;
2049 : :
2050 : 579527 : if (e->ts.type != BT_PROCEDURE)
2051 : : {
2052 : 515775 : save_need_full_assumed_size = need_full_assumed_size;
2053 : 515775 : if (e->expr_type != EXPR_VARIABLE)
2054 : 327605 : need_full_assumed_size = 0;
2055 : 515775 : if (!gfc_resolve_expr (e))
2056 : 56 : goto cleanup;
2057 : 515719 : need_full_assumed_size = save_need_full_assumed_size;
2058 : 515719 : goto argument_list;
2059 : : }
2060 : :
2061 : : /* See if the expression node should really be a variable reference. */
2062 : :
2063 : 63752 : sym = e->symtree->n.sym;
2064 : :
2065 : 63752 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2066 : : {
2067 : 3 : gfc_error ("Derived type %qs is used as an actual "
2068 : : "argument at %L", sym->name, &e->where);
2069 : 3 : goto cleanup;
2070 : : }
2071 : :
2072 : 63749 : if (sym->attr.flavor == FL_PROCEDURE
2073 : : || sym->attr.intrinsic
2074 : 60917 : || sym->attr.external)
2075 : : {
2076 : 2832 : int actual_ok;
2077 : :
2078 : : /* If a procedure is not already determined to be something else
2079 : : check if it is intrinsic. */
2080 : 2832 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2081 : 1254 : sym->attr.intrinsic = 1;
2082 : :
2083 : 2832 : if (sym->attr.proc == PROC_ST_FUNCTION)
2084 : : {
2085 : 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2086 : : "actual argument", sym->name, &e->where);
2087 : : }
2088 : :
2089 : 5664 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2090 : 2832 : sym->attr.subroutine);
2091 : 2832 : if (sym->attr.intrinsic && actual_ok == 0)
2092 : : {
2093 : 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2094 : : "actual argument", sym->name, &e->where);
2095 : : }
2096 : :
2097 : 2832 : if (sym->attr.contained && !sym->attr.use_assoc
2098 : 293 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2099 : : {
2100 : 107 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2101 : : " used as actual argument at %L",
2102 : : sym->name, &e->where))
2103 : 2 : goto cleanup;
2104 : : }
2105 : :
2106 : 2830 : if (sym->attr.elemental && !sym->attr.intrinsic)
2107 : : {
2108 : 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2109 : : "allowed as an actual argument at %L", sym->name,
2110 : : &e->where);
2111 : : }
2112 : :
2113 : : /* Check if a generic interface has a specific procedure
2114 : : with the same name before emitting an error. */
2115 : 2830 : if (sym->attr.generic && count_specific_procs (e) != 1)
2116 : 0 : goto cleanup;
2117 : :
2118 : : /* Just in case a specific was found for the expression. */
2119 : 2830 : sym = e->symtree->n.sym;
2120 : :
2121 : : /* If the symbol is the function that names the current (or
2122 : : parent) scope, then we really have a variable reference. */
2123 : :
2124 : 2830 : if (gfc_is_function_return_value (sym, sym->ns))
2125 : 0 : goto got_variable;
2126 : :
2127 : : /* If all else fails, see if we have a specific intrinsic. */
2128 : 2830 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2129 : : {
2130 : 0 : gfc_intrinsic_sym *isym;
2131 : :
2132 : 0 : isym = gfc_find_function (sym->name);
2133 : 0 : if (isym == NULL || !isym->specific)
2134 : : {
2135 : 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2136 : : "for the reference %qs at %L", sym->name,
2137 : : &e->where);
2138 : 0 : goto cleanup;
2139 : : }
2140 : 0 : sym->ts = isym->ts;
2141 : 0 : sym->attr.intrinsic = 1;
2142 : 0 : sym->attr.function = 1;
2143 : : }
2144 : :
2145 : 2830 : if (!gfc_resolve_expr (e))
2146 : 0 : goto cleanup;
2147 : 2830 : goto argument_list;
2148 : : }
2149 : :
2150 : : /* See if the name is a module procedure in a parent unit. */
2151 : :
2152 : 60917 : if (was_declared (sym) || sym->ns->parent == NULL)
2153 : 60837 : goto got_variable;
2154 : :
2155 : 80 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2156 : : {
2157 : 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2158 : 0 : goto cleanup;
2159 : : }
2160 : :
2161 : 80 : if (parent_st == NULL)
2162 : 80 : goto got_variable;
2163 : :
2164 : 0 : sym = parent_st->n.sym;
2165 : 0 : e->symtree = parent_st; /* Point to the right thing. */
2166 : :
2167 : 0 : if (sym->attr.flavor == FL_PROCEDURE
2168 : : || sym->attr.intrinsic
2169 : 0 : || sym->attr.external)
2170 : : {
2171 : 0 : if (!gfc_resolve_expr (e))
2172 : 0 : goto cleanup;
2173 : 0 : goto argument_list;
2174 : : }
2175 : :
2176 : 0 : got_variable:
2177 : 60917 : e->expr_type = EXPR_VARIABLE;
2178 : 60917 : e->ts = sym->ts;
2179 : 60917 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2180 : 31963 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2181 : 3612 : && CLASS_DATA (sym)->as))
2182 : : {
2183 : 63078 : e->rank = sym->ts.type == BT_CLASS
2184 : 31539 : ? CLASS_DATA (sym)->as->rank : sym->as->rank;
2185 : 31539 : e->ref = gfc_get_ref ();
2186 : 31539 : e->ref->type = REF_ARRAY;
2187 : 31539 : e->ref->u.ar.type = AR_FULL;
2188 : 31539 : e->ref->u.ar.as = sym->ts.type == BT_CLASS
2189 : 31539 : ? CLASS_DATA (sym)->as : sym->as;
2190 : : }
2191 : :
2192 : : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2193 : : primary.cc (match_actual_arg). If above code determines that it
2194 : : is a variable instead, it needs to be resolved as it was not
2195 : : done at the beginning of this function. */
2196 : 60917 : save_need_full_assumed_size = need_full_assumed_size;
2197 : 60917 : if (e->expr_type != EXPR_VARIABLE)
2198 : 0 : need_full_assumed_size = 0;
2199 : 60917 : if (!gfc_resolve_expr (e))
2200 : 18 : goto cleanup;
2201 : 60899 : need_full_assumed_size = save_need_full_assumed_size;
2202 : :
2203 : 579448 : argument_list:
2204 : : /* Check argument list functions %VAL, %LOC and %REF. There is
2205 : : nothing to do for %REF. */
2206 : 579448 : if (arg->name && arg->name[0] == '%')
2207 : : {
2208 : 132 : if (strcmp ("%VAL", arg->name) == 0)
2209 : : {
2210 : 58 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2211 : : {
2212 : 2 : gfc_error ("By-value argument at %L is not of numeric "
2213 : : "type", &e->where);
2214 : 2 : goto cleanup;
2215 : : }
2216 : :
2217 : 56 : if (e->rank)
2218 : : {
2219 : 1 : gfc_error ("By-value argument at %L cannot be an array or "
2220 : : "an array section", &e->where);
2221 : 1 : goto cleanup;
2222 : : }
2223 : :
2224 : : /* Intrinsics are still PROC_UNKNOWN here. However,
2225 : : since same file external procedures are not resolvable
2226 : : in gfortran, it is a good deal easier to leave them to
2227 : : intrinsic.cc. */
2228 : 55 : if (ptype != PROC_UNKNOWN
2229 : 55 : && ptype != PROC_DUMMY
2230 : 9 : && ptype != PROC_EXTERNAL
2231 : 9 : && ptype != PROC_MODULE)
2232 : : {
2233 : 3 : gfc_error ("By-value argument at %L is not allowed "
2234 : : "in this context", &e->where);
2235 : 3 : goto cleanup;
2236 : : }
2237 : : }
2238 : :
2239 : : /* Statement functions have already been excluded above. */
2240 : 74 : else if (strcmp ("%LOC", arg->name) == 0
2241 : 38 : && e->ts.type == BT_PROCEDURE)
2242 : : {
2243 : 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2244 : : {
2245 : 0 : gfc_error ("Passing internal procedure at %L by location "
2246 : : "not allowed", &e->where);
2247 : 0 : goto cleanup;
2248 : : }
2249 : : }
2250 : : }
2251 : :
2252 : 579442 : comp = gfc_get_proc_ptr_comp(e);
2253 : 579442 : if (e->expr_type == EXPR_VARIABLE
2254 : 250378 : && comp && comp->attr.elemental)
2255 : : {
2256 : 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2257 : : "allowed as an actual argument at %L", comp->name,
2258 : : &e->where);
2259 : : }
2260 : :
2261 : : /* Fortran 2008, C1237. */
2262 : 250378 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2263 : 579589 : && gfc_has_ultimate_pointer (e))
2264 : : {
2265 : 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2266 : : "component", &e->where);
2267 : 3 : goto cleanup;
2268 : : }
2269 : :
2270 : 579439 : first_actual_arg = false;
2271 : : }
2272 : :
2273 : : return_value = true;
2274 : :
2275 : 370195 : cleanup:
2276 : 370195 : actual_arg = actual_arg_sav;
2277 : 370195 : first_actual_arg = first_actual_arg_sav;
2278 : :
2279 : 370195 : return return_value;
2280 : : }
2281 : :
2282 : :
2283 : : /* Do the checks of the actual argument list that are specific to elemental
2284 : : procedures. If called with c == NULL, we have a function, otherwise if
2285 : : expr == NULL, we have a subroutine. */
2286 : :
2287 : : static bool
2288 : 278266 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2289 : : {
2290 : 278266 : gfc_actual_arglist *arg0;
2291 : 278266 : gfc_actual_arglist *arg;
2292 : 278266 : gfc_symbol *esym = NULL;
2293 : 278266 : gfc_intrinsic_sym *isym = NULL;
2294 : 278266 : gfc_expr *e = NULL;
2295 : 278266 : gfc_intrinsic_arg *iformal = NULL;
2296 : 278266 : gfc_formal_arglist *eformal = NULL;
2297 : 278266 : bool formal_optional = false;
2298 : 278266 : bool set_by_optional = false;
2299 : 278266 : int i;
2300 : 278266 : int rank = 0;
2301 : :
2302 : : /* Is this an elemental procedure? */
2303 : 278266 : if (expr && expr->value.function.actual != NULL)
2304 : : {
2305 : 200502 : if (expr->value.function.esym != NULL
2306 : 41667 : && expr->value.function.esym->attr.elemental)
2307 : : {
2308 : : arg0 = expr->value.function.actual;
2309 : : esym = expr->value.function.esym;
2310 : : }
2311 : 184472 : else if (expr->value.function.isym != NULL
2312 : 157889 : && expr->value.function.isym->elemental)
2313 : : {
2314 : : arg0 = expr->value.function.actual;
2315 : : isym = expr->value.function.isym;
2316 : : }
2317 : : else
2318 : : return true;
2319 : : }
2320 : 77764 : else if (c && c->ext.actual != NULL)
2321 : : {
2322 : 63827 : arg0 = c->ext.actual;
2323 : :
2324 : 63827 : if (c->resolved_sym)
2325 : : esym = c->resolved_sym;
2326 : : else
2327 : 298 : esym = c->symtree->n.sym;
2328 : 63827 : gcc_assert (esym);
2329 : :
2330 : 63827 : if (!esym->attr.elemental)
2331 : : return true;
2332 : : }
2333 : : else
2334 : : return true;
2335 : :
2336 : : /* The rank of an elemental is the rank of its array argument(s). */
2337 : 161340 : for (arg = arg0; arg; arg = arg->next)
2338 : : {
2339 : 103795 : if (arg->expr != NULL && arg->expr->rank != 0)
2340 : : {
2341 : 8066 : rank = arg->expr->rank;
2342 : 8066 : if (arg->expr->expr_type == EXPR_VARIABLE
2343 : 3629 : && arg->expr->symtree->n.sym->attr.optional)
2344 : 8066 : set_by_optional = true;
2345 : :
2346 : : /* Function specific; set the result rank and shape. */
2347 : 8066 : if (expr)
2348 : : {
2349 : 6342 : expr->rank = rank;
2350 : 6342 : if (!expr->shape && arg->expr->shape)
2351 : : {
2352 : 2608 : expr->shape = gfc_get_shape (rank);
2353 : 5906 : for (i = 0; i < rank; i++)
2354 : 3298 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2355 : : }
2356 : : }
2357 : : break;
2358 : : }
2359 : : }
2360 : :
2361 : : /* If it is an array, it shall not be supplied as an actual argument
2362 : : to an elemental procedure unless an array of the same rank is supplied
2363 : : as an actual argument corresponding to a nonoptional dummy argument of
2364 : : that elemental procedure(12.4.1.5). */
2365 : 65611 : formal_optional = false;
2366 : 65611 : if (isym)
2367 : 44515 : iformal = isym->formal;
2368 : : else
2369 : 21096 : eformal = esym->formal;
2370 : :
2371 : 173789 : for (arg = arg0; arg; arg = arg->next)
2372 : : {
2373 : 108178 : if (eformal)
2374 : : {
2375 : 38139 : if (eformal->sym && eformal->sym->attr.optional)
2376 : 38139 : formal_optional = true;
2377 : 38139 : eformal = eformal->next;
2378 : : }
2379 : 70039 : else if (isym && iformal)
2380 : : {
2381 : 62001 : if (iformal->optional)
2382 : 11922 : formal_optional = true;
2383 : 62001 : iformal = iformal->next;
2384 : : }
2385 : 8038 : else if (isym)
2386 : 8030 : formal_optional = true;
2387 : :
2388 : 108178 : if (pedantic && arg->expr != NULL
2389 : 65578 : && arg->expr->expr_type == EXPR_VARIABLE
2390 : 31434 : && arg->expr->symtree->n.sym->attr.optional
2391 : 390 : && formal_optional
2392 : 351 : && arg->expr->rank
2393 : 151 : && (set_by_optional || arg->expr->rank != rank)
2394 : 40 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2395 : : {
2396 : 110 : bool t = false;
2397 : : gfc_actual_arglist *a;
2398 : :
2399 : : /* Scan the argument list for a non-optional argument with the
2400 : : same rank as arg. */
2401 : 110 : for (a = arg0; a; a = a->next)
2402 : 83 : if (a != arg
2403 : 43 : && a->expr->rank == arg->expr->rank
2404 : 37 : && !a->expr->symtree->n.sym->attr.optional)
2405 : : {
2406 : : t = true;
2407 : : break;
2408 : : }
2409 : :
2410 : 40 : if (!t)
2411 : 27 : gfc_warning (OPT_Wpedantic,
2412 : : "%qs at %L is an array and OPTIONAL; If it is not "
2413 : : "present, then it cannot be the actual argument of "
2414 : : "an ELEMENTAL procedure unless there is a non-optional"
2415 : : " argument with the same rank "
2416 : : "(Fortran 2018, 15.5.2.12)",
2417 : : arg->expr->symtree->n.sym->name, &arg->expr->where);
2418 : : }
2419 : : }
2420 : :
2421 : 173778 : for (arg = arg0; arg; arg = arg->next)
2422 : : {
2423 : 108176 : if (arg->expr == NULL || arg->expr->rank == 0)
2424 : 97772 : continue;
2425 : :
2426 : : /* Being elemental, the last upper bound of an assumed size array
2427 : : argument must be present. */
2428 : 10404 : if (resolve_assumed_size_actual (arg->expr))
2429 : : return false;
2430 : :
2431 : : /* Elemental procedure's array actual arguments must conform. */
2432 : 10401 : if (e != NULL)
2433 : : {
2434 : 2338 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2435 : : return false;
2436 : : }
2437 : : else
2438 : 8063 : e = arg->expr;
2439 : : }
2440 : :
2441 : : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2442 : : is an array, the intent inout/out variable needs to be also an array. */
2443 : 65602 : if (rank > 0 && esym && expr == NULL)
2444 : 5449 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2445 : 3731 : arg = arg->next, eformal = eformal->next)
2446 : 3733 : if (eformal->sym
2447 : 3732 : && (eformal->sym->attr.intent == INTENT_OUT
2448 : 2944 : || eformal->sym->attr.intent == INTENT_INOUT)
2449 : 1182 : && arg->expr && arg->expr->rank == 0)
2450 : : {
2451 : 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2452 : : "ELEMENTAL subroutine %qs is a scalar, but another "
2453 : : "actual argument is an array", &arg->expr->where,
2454 : : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2455 : : : "INOUT", eformal->sym->name, esym->name);
2456 : 2 : return false;
2457 : : }
2458 : : return true;
2459 : : }
2460 : :
2461 : :
2462 : : /* This function does the checking of references to global procedures
2463 : : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2464 : : 77 and 95 standards. It checks for a gsymbol for the name, making
2465 : : one if it does not already exist. If it already exists, then the
2466 : : reference being resolved must correspond to the type of gsymbol.
2467 : : Otherwise, the new symbol is equipped with the attributes of the
2468 : : reference. The corresponding code that is called in creating
2469 : : global entities is parse.cc.
2470 : :
2471 : : In addition, for all but -std=legacy, the gsymbols are used to
2472 : : check the interfaces of external procedures from the same file.
2473 : : The namespace of the gsymbol is resolved and then, once this is
2474 : : done the interface is checked. */
2475 : :
2476 : :
2477 : : static bool
2478 : 14759 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2479 : : {
2480 : 14759 : if (!gsym_ns->proc_name->attr.recursive)
2481 : : return true;
2482 : :
2483 : 151 : if (sym->ns == gsym_ns)
2484 : : return false;
2485 : :
2486 : 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2487 : 0 : return false;
2488 : :
2489 : : return true;
2490 : : }
2491 : :
2492 : : static bool
2493 : 14759 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2494 : : {
2495 : 14759 : if (gsym_ns->entries)
2496 : : {
2497 : : gfc_entry_list *entry = gsym_ns->entries;
2498 : :
2499 : 3234 : for (; entry; entry = entry->next)
2500 : : {
2501 : 2281 : if (strcmp (sym->name, entry->sym->name) == 0)
2502 : : {
2503 : 946 : if (strcmp (gsym_ns->proc_name->name,
2504 : 946 : sym->ns->proc_name->name) == 0)
2505 : : return false;
2506 : :
2507 : 946 : if (sym->ns->parent
2508 : 0 : && strcmp (gsym_ns->proc_name->name,
2509 : 0 : sym->ns->parent->proc_name->name) == 0)
2510 : : return false;
2511 : : }
2512 : : }
2513 : : }
2514 : : return true;
2515 : : }
2516 : :
2517 : :
2518 : : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2519 : :
2520 : : bool
2521 : 15510 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2522 : : {
2523 : 15510 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2524 : :
2525 : 58285 : for ( ; arg; arg = arg->next)
2526 : : {
2527 : 27611 : if (!arg->sym)
2528 : 157 : continue;
2529 : :
2530 : 27454 : if (arg->sym->attr.allocatable) /* (2a) */
2531 : : {
2532 : 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2533 : 0 : return true;
2534 : : }
2535 : 27454 : else if (arg->sym->attr.asynchronous)
2536 : : {
2537 : 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2538 : 0 : return true;
2539 : : }
2540 : 27454 : else if (arg->sym->attr.optional)
2541 : : {
2542 : 75 : strncpy (errmsg, _("optional argument"), err_len);
2543 : 75 : return true;
2544 : : }
2545 : 27379 : else if (arg->sym->attr.pointer)
2546 : : {
2547 : 12 : strncpy (errmsg, _("pointer argument"), err_len);
2548 : 12 : return true;
2549 : : }
2550 : 27367 : else if (arg->sym->attr.target)
2551 : : {
2552 : 48 : strncpy (errmsg, _("target argument"), err_len);
2553 : 48 : return true;
2554 : : }
2555 : 27319 : else if (arg->sym->attr.value)
2556 : : {
2557 : 0 : strncpy (errmsg, _("value argument"), err_len);
2558 : 0 : return true;
2559 : : }
2560 : 27319 : else if (arg->sym->attr.volatile_)
2561 : : {
2562 : 1 : strncpy (errmsg, _("volatile argument"), err_len);
2563 : 1 : return true;
2564 : : }
2565 : 27318 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2566 : : {
2567 : 45 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2568 : 45 : return true;
2569 : : }
2570 : 27273 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2571 : : {
2572 : 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2573 : 1 : return true;
2574 : : }
2575 : 27272 : else if (arg->sym->attr.codimension) /* (2c) */
2576 : : {
2577 : 1 : strncpy (errmsg, _("coarray argument"), err_len);
2578 : 1 : return true;
2579 : : }
2580 : 27271 : else if (false) /* (2d) TODO: parametrized derived type */
2581 : : {
2582 : : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2583 : : return true;
2584 : : }
2585 : 27271 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2586 : : {
2587 : 162 : strncpy (errmsg, _("polymorphic argument"), err_len);
2588 : 162 : return true;
2589 : : }
2590 : 27109 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2591 : : {
2592 : 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2593 : 0 : return true;
2594 : : }
2595 : 27109 : else if (arg->sym->ts.type == BT_ASSUMED)
2596 : : {
2597 : : /* As assumed-type is unlimited polymorphic (cf. above).
2598 : : See also TS 29113, Note 6.1. */
2599 : 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2600 : 1 : return true;
2601 : : }
2602 : : }
2603 : :
2604 : 15164 : if (sym->attr.function)
2605 : : {
2606 : 3460 : gfc_symbol *res = sym->result ? sym->result : sym;
2607 : :
2608 : 3460 : if (res->attr.dimension) /* (3a) */
2609 : : {
2610 : 93 : strncpy (errmsg, _("array result"), err_len);
2611 : 93 : return true;
2612 : : }
2613 : 3367 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2614 : : {
2615 : 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2616 : 38 : return true;
2617 : : }
2618 : 3329 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2619 : 347 : && res->ts.u.cl->length
2620 : 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2621 : : {
2622 : 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2623 : 12 : return true;
2624 : : }
2625 : : }
2626 : :
2627 : 15021 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2628 : : {
2629 : 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2630 : 7 : return true;
2631 : : }
2632 : 15014 : else if (sym->attr.is_bind_c) /* (5) */
2633 : : {
2634 : 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2635 : 0 : return true;
2636 : : }
2637 : :
2638 : : return false;
2639 : : }
2640 : :
2641 : :
2642 : : static void
2643 : 27871 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2644 : : {
2645 : 27871 : gfc_gsymbol * gsym;
2646 : 27871 : gfc_namespace *ns;
2647 : 27871 : enum gfc_symbol_type type;
2648 : 27871 : char reason[200];
2649 : :
2650 : 27871 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2651 : :
2652 : 27871 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2653 : 27871 : sym->binding_label != NULL);
2654 : :
2655 : 27871 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2656 : 10 : gfc_global_used (gsym, where);
2657 : :
2658 : 27871 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2659 : 8274 : || sym->attr.if_source == IFSRC_IFBODY)
2660 : 24154 : && gsym->type != GSYM_UNKNOWN
2661 : 22133 : && !gsym->binding_label
2662 : 19969 : && gsym->ns
2663 : 14759 : && gsym->ns->proc_name
2664 : 14759 : && not_in_recursive (sym, gsym->ns)
2665 : 42630 : && not_entry_self_reference (sym, gsym->ns))
2666 : : {
2667 : 14759 : gfc_symbol *def_sym;
2668 : 14759 : def_sym = gsym->ns->proc_name;
2669 : :
2670 : 14759 : if (gsym->ns->resolved != -1)
2671 : : {
2672 : :
2673 : : /* Resolve the gsymbol namespace if needed. */
2674 : 14738 : if (!gsym->ns->resolved)
2675 : : {
2676 : 2727 : gfc_symbol *old_dt_list;
2677 : :
2678 : : /* Stash away derived types so that the backend_decls
2679 : : do not get mixed up. */
2680 : 2727 : old_dt_list = gfc_derived_types;
2681 : 2727 : gfc_derived_types = NULL;
2682 : :
2683 : 2727 : gfc_resolve (gsym->ns);
2684 : :
2685 : : /* Store the new derived types with the global namespace. */
2686 : 2727 : if (gfc_derived_types)
2687 : 293 : gsym->ns->derived_types = gfc_derived_types;
2688 : :
2689 : : /* Restore the derived types of this namespace. */
2690 : 2727 : gfc_derived_types = old_dt_list;
2691 : : }
2692 : :
2693 : : /* Make sure that translation for the gsymbol occurs before
2694 : : the procedure currently being resolved. */
2695 : 14738 : ns = gfc_global_ns_list;
2696 : 24768 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2697 : : {
2698 : 16399 : if (ns->sibling == gsym->ns)
2699 : : {
2700 : 6369 : ns->sibling = gsym->ns->sibling;
2701 : 6369 : gsym->ns->sibling = gfc_global_ns_list;
2702 : 6369 : gfc_global_ns_list = gsym->ns;
2703 : 6369 : break;
2704 : : }
2705 : : }
2706 : :
2707 : : /* This can happen if a binding name has been specified. */
2708 : 14738 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2709 : 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2710 : :
2711 : 14738 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2712 : : {
2713 : 953 : gfc_entry_list *entry;
2714 : 1659 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2715 : 1659 : if (strcmp (entry->sym->name, sym->name) == 0)
2716 : : {
2717 : 953 : def_sym = entry->sym;
2718 : 953 : break;
2719 : : }
2720 : : }
2721 : : }
2722 : :
2723 : 14759 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2724 : : {
2725 : 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2726 : : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2727 : 6 : gfc_typename (&def_sym->ts));
2728 : 29 : goto done;
2729 : : }
2730 : :
2731 : 14753 : if (sym->attr.if_source == IFSRC_UNKNOWN
2732 : 14753 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2733 : : {
2734 : 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2735 : : sym->name, &sym->declared_at, reason);
2736 : 8 : goto done;
2737 : : }
2738 : :
2739 : 14745 : bool bad_result_characteristics;
2740 : 14745 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2741 : : reason, sizeof(reason), NULL, NULL,
2742 : : &bad_result_characteristics))
2743 : : {
2744 : : /* Turn erros into warnings with -std=gnu and -std=legacy,
2745 : : unless a function returns a wrong type, which can lead
2746 : : to all kinds of ICEs and wrong code. */
2747 : :
2748 : 15 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2749 : 2 : && !bad_result_characteristics)
2750 : 2 : gfc_errors_to_warnings (true);
2751 : :
2752 : 15 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2753 : : sym->name, &sym->declared_at, reason);
2754 : 15 : sym->error = 1;
2755 : 15 : gfc_errors_to_warnings (false);
2756 : 15 : goto done;
2757 : : }
2758 : : }
2759 : :
2760 : 27871 : done:
2761 : :
2762 : 27871 : if (gsym->type == GSYM_UNKNOWN)
2763 : : {
2764 : 3638 : gsym->type = type;
2765 : 3638 : gsym->where = *where;
2766 : : }
2767 : :
2768 : 27871 : gsym->used = 1;
2769 : 27871 : }
2770 : :
2771 : :
2772 : : /************* Function resolution *************/
2773 : :
2774 : : /* Resolve a function call known to be generic.
2775 : : Section 14.1.2.4.1. */
2776 : :
2777 : : static match
2778 : 26186 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2779 : : {
2780 : 26186 : gfc_symbol *s;
2781 : :
2782 : 26186 : if (sym->attr.generic)
2783 : : {
2784 : 25079 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2785 : 25079 : if (s != NULL)
2786 : : {
2787 : 19468 : expr->value.function.name = s->name;
2788 : 19468 : expr->value.function.esym = s;
2789 : :
2790 : 19468 : if (s->ts.type != BT_UNKNOWN)
2791 : 19452 : expr->ts = s->ts;
2792 : 16 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2793 : 14 : expr->ts = s->result->ts;
2794 : :
2795 : 19468 : if (s->as != NULL)
2796 : 54 : expr->rank = s->as->rank;
2797 : 19414 : else if (s->result != NULL && s->result->as != NULL)
2798 : 0 : expr->rank = s->result->as->rank;
2799 : :
2800 : 19468 : gfc_set_sym_referenced (expr->value.function.esym);
2801 : :
2802 : 19468 : return MATCH_YES;
2803 : : }
2804 : :
2805 : : /* TODO: Need to search for elemental references in generic
2806 : : interface. */
2807 : : }
2808 : :
2809 : 6718 : if (sym->attr.intrinsic)
2810 : 1066 : return gfc_intrinsic_func_interface (expr, 0);
2811 : :
2812 : : return MATCH_NO;
2813 : : }
2814 : :
2815 : :
2816 : : static bool
2817 : 26047 : resolve_generic_f (gfc_expr *expr)
2818 : : {
2819 : 26047 : gfc_symbol *sym;
2820 : 26047 : match m;
2821 : 26047 : gfc_interface *intr = NULL;
2822 : :
2823 : 26047 : sym = expr->symtree->n.sym;
2824 : :
2825 : 26186 : for (;;)
2826 : : {
2827 : 26186 : m = resolve_generic_f0 (expr, sym);
2828 : 26186 : if (m == MATCH_YES)
2829 : : return true;
2830 : 5654 : else if (m == MATCH_ERROR)
2831 : : return false;
2832 : :
2833 : 5654 : generic:
2834 : 5657 : if (!intr)
2835 : 5610 : for (intr = sym->generic; intr; intr = intr->next)
2836 : 5530 : if (gfc_fl_struct (intr->sym->attr.flavor))
2837 : : break;
2838 : :
2839 : 5657 : if (sym->ns->parent == NULL)
2840 : : break;
2841 : 270 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2842 : :
2843 : 270 : if (sym == NULL)
2844 : : break;
2845 : 142 : if (!generic_sym (sym))
2846 : 3 : goto generic;
2847 : : }
2848 : :
2849 : : /* Last ditch attempt. See if the reference is to an intrinsic
2850 : : that possesses a matching interface. 14.1.2.4 */
2851 : 5515 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2852 : : {
2853 : 4 : if (gfc_init_expr_flag)
2854 : 1 : gfc_error ("Function %qs in initialization expression at %L "
2855 : : "must be an intrinsic function",
2856 : 1 : expr->symtree->n.sym->name, &expr->where);
2857 : : else
2858 : 3 : gfc_error ("There is no specific function for the generic %qs "
2859 : 3 : "at %L", expr->symtree->n.sym->name, &expr->where);
2860 : 4 : return false;
2861 : : }
2862 : :
2863 : 5511 : if (intr)
2864 : : {
2865 : 5477 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2866 : : NULL, false))
2867 : : return false;
2868 : 5457 : if (!gfc_use_derived (expr->ts.u.derived))
2869 : : return false;
2870 : 5456 : return resolve_structure_cons (expr, 0);
2871 : : }
2872 : :
2873 : 34 : m = gfc_intrinsic_func_interface (expr, 0);
2874 : 34 : if (m == MATCH_YES)
2875 : : return true;
2876 : :
2877 : 3 : if (m == MATCH_NO)
2878 : 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2879 : 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2880 : : &expr->where);
2881 : :
2882 : : return false;
2883 : : }
2884 : :
2885 : :
2886 : : /* Resolve a function call known to be specific. */
2887 : :
2888 : : static match
2889 : 24787 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2890 : : {
2891 : 24787 : match m;
2892 : :
2893 : 24787 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2894 : : {
2895 : 7340 : if (sym->attr.dummy)
2896 : : {
2897 : 249 : sym->attr.proc = PROC_DUMMY;
2898 : 249 : goto found;
2899 : : }
2900 : :
2901 : 7091 : sym->attr.proc = PROC_EXTERNAL;
2902 : 7091 : goto found;
2903 : : }
2904 : :
2905 : 17447 : if (sym->attr.proc == PROC_MODULE
2906 : : || sym->attr.proc == PROC_ST_FUNCTION
2907 : : || sym->attr.proc == PROC_INTERNAL)
2908 : 16709 : goto found;
2909 : :
2910 : 738 : if (sym->attr.intrinsic)
2911 : : {
2912 : 731 : m = gfc_intrinsic_func_interface (expr, 1);
2913 : 731 : if (m == MATCH_YES)
2914 : : return MATCH_YES;
2915 : 0 : if (m == MATCH_NO)
2916 : 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2917 : : "with an intrinsic", sym->name, &expr->where);
2918 : :
2919 : 0 : return MATCH_ERROR;
2920 : : }
2921 : :
2922 : : return MATCH_NO;
2923 : :
2924 : 24049 : found:
2925 : 24049 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2926 : :
2927 : 24049 : if (sym->result)
2928 : 24049 : expr->ts = sym->result->ts;
2929 : : else
2930 : 0 : expr->ts = sym->ts;
2931 : 24049 : expr->value.function.name = sym->name;
2932 : 24049 : expr->value.function.esym = sym;
2933 : : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2934 : : error(s). */
2935 : 24049 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2936 : : return MATCH_ERROR;
2937 : 24048 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2938 : 273 : expr->rank = CLASS_DATA (sym)->as->rank;
2939 : 23775 : else if (sym->as != NULL)
2940 : 2168 : expr->rank = sym->as->rank;
2941 : :
2942 : : return MATCH_YES;
2943 : : }
2944 : :
2945 : :
2946 : : static bool
2947 : 24780 : resolve_specific_f (gfc_expr *expr)
2948 : : {
2949 : 24780 : gfc_symbol *sym;
2950 : 24780 : match m;
2951 : :
2952 : 24780 : sym = expr->symtree->n.sym;
2953 : :
2954 : 24787 : for (;;)
2955 : : {
2956 : 24787 : m = resolve_specific_f0 (sym, expr);
2957 : 24787 : if (m == MATCH_YES)
2958 : : return true;
2959 : 8 : if (m == MATCH_ERROR)
2960 : : return false;
2961 : :
2962 : 7 : if (sym->ns->parent == NULL)
2963 : : break;
2964 : :
2965 : 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2966 : :
2967 : 7 : if (sym == NULL)
2968 : : break;
2969 : : }
2970 : :
2971 : 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
2972 : 0 : expr->symtree->n.sym->name, &expr->where);
2973 : :
2974 : 0 : return true;
2975 : : }
2976 : :
2977 : : /* Recursively append candidate SYM to CANDIDATES. Store the number of
2978 : : candidates in CANDIDATES_LEN. */
2979 : :
2980 : : static void
2981 : 207 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
2982 : : char **&candidates,
2983 : : size_t &candidates_len)
2984 : : {
2985 : 366 : gfc_symtree *p;
2986 : :
2987 : 366 : if (sym == NULL)
2988 : : return;
2989 : 366 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
2990 : 120 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
2991 : 47 : vec_push (candidates, candidates_len, sym->name);
2992 : :
2993 : 366 : p = sym->left;
2994 : 366 : if (p)
2995 : 153 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2996 : :
2997 : 366 : p = sym->right;
2998 : 366 : if (p)
2999 : : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3000 : : }
3001 : :
3002 : :
3003 : : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3004 : :
3005 : : const char*
3006 : 54 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3007 : : {
3008 : 54 : char **candidates = NULL;
3009 : 54 : size_t candidates_len = 0;
3010 : 54 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3011 : 54 : return gfc_closest_fuzzy_match (fn, candidates);
3012 : : }
3013 : :
3014 : :
3015 : : /* Resolve a procedure call not known to be generic nor specific. */
3016 : :
3017 : : static bool
3018 : 236037 : resolve_unknown_f (gfc_expr *expr)
3019 : : {
3020 : 236037 : gfc_symbol *sym;
3021 : 236037 : gfc_typespec *ts;
3022 : :
3023 : 236037 : sym = expr->symtree->n.sym;
3024 : :
3025 : 236037 : if (sym->attr.dummy)
3026 : : {
3027 : 287 : sym->attr.proc = PROC_DUMMY;
3028 : 287 : expr->value.function.name = sym->name;
3029 : 287 : goto set_type;
3030 : : }
3031 : :
3032 : : /* See if we have an intrinsic function reference. */
3033 : :
3034 : 235750 : if (gfc_is_intrinsic (sym, 0, expr->where))
3035 : : {
3036 : 233466 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3037 : : return true;
3038 : : return false;
3039 : : }
3040 : :
3041 : : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3042 : : /* Intrinsics were handled above, only non-intrinsics left here. */
3043 : 2284 : if (sym->attr.flavor == FL_PROCEDURE
3044 : 2281 : && sym->attr.implicit_type
3045 : 379 : && sym->ns
3046 : 379 : && sym->ns->has_implicit_none_export)
3047 : : {
3048 : 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3049 : : "for symbol %qs at %L", sym->name, &sym->declared_at);
3050 : 3 : sym->error = 1;
3051 : 3 : return false;
3052 : : }
3053 : :
3054 : : /* The reference is to an external name. */
3055 : :
3056 : 2281 : sym->attr.proc = PROC_EXTERNAL;
3057 : 2281 : expr->value.function.name = sym->name;
3058 : 2281 : expr->value.function.esym = expr->symtree->n.sym;
3059 : :
3060 : 2281 : if (sym->as != NULL)
3061 : 1 : expr->rank = sym->as->rank;
3062 : :
3063 : : /* Type of the expression is either the type of the symbol or the
3064 : : default type of the symbol. */
3065 : :
3066 : 2280 : set_type:
3067 : 2568 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3068 : :
3069 : 2568 : if (sym->ts.type != BT_UNKNOWN)
3070 : 2519 : expr->ts = sym->ts;
3071 : : else
3072 : : {
3073 : 49 : ts = gfc_get_default_type (sym->name, sym->ns);
3074 : :
3075 : 49 : if (ts->type == BT_UNKNOWN)
3076 : : {
3077 : 39 : const char *guessed
3078 : 39 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3079 : 39 : if (guessed)
3080 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3081 : : "; did you mean %qs?",
3082 : : sym->name, &expr->where, guessed);
3083 : : else
3084 : 36 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3085 : : sym->name, &expr->where);
3086 : 39 : return false;
3087 : : }
3088 : : else
3089 : 10 : expr->ts = *ts;
3090 : : }
3091 : :
3092 : : return true;
3093 : : }
3094 : :
3095 : :
3096 : : /* Return true, if the symbol is an external procedure. */
3097 : : static bool
3098 : 738382 : is_external_proc (gfc_symbol *sym)
3099 : : {
3100 : 736766 : if (!sym->attr.dummy && !sym->attr.contained
3101 : 645403 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3102 : 149962 : && sym->attr.proc != PROC_ST_FUNCTION
3103 : : && !sym->attr.proc_pointer
3104 : 149407 : && !sym->attr.use_assoc
3105 : 794146 : && sym->name)
3106 : : return true;
3107 : :
3108 : : return false;
3109 : : }
3110 : :
3111 : :
3112 : : /* Figure out if a function reference is pure or not. Also set the name
3113 : : of the function for a potential error message. Return nonzero if the
3114 : : function is PURE, zero if not. */
3115 : : static bool
3116 : : pure_stmt_function (gfc_expr *, gfc_symbol *);
3117 : :
3118 : : bool
3119 : 218534 : gfc_pure_function (gfc_expr *e, const char **name)
3120 : : {
3121 : 218534 : bool pure;
3122 : 218534 : gfc_component *comp;
3123 : :
3124 : 218534 : *name = NULL;
3125 : :
3126 : 218534 : if (e->symtree != NULL
3127 : 218241 : && e->symtree->n.sym != NULL
3128 : 218241 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3129 : 285 : return pure_stmt_function (e, e->symtree->n.sym);
3130 : :
3131 : 218249 : comp = gfc_get_proc_ptr_comp (e);
3132 : 218249 : if (comp)
3133 : : {
3134 : 275 : pure = gfc_pure (comp->ts.interface);
3135 : 275 : *name = comp->name;
3136 : : }
3137 : 217974 : else if (e->value.function.esym)
3138 : : {
3139 : 48963 : pure = gfc_pure (e->value.function.esym);
3140 : 48963 : *name = e->value.function.esym->name;
3141 : : }
3142 : 169011 : else if (e->value.function.isym)
3143 : : {
3144 : 168051 : pure = e->value.function.isym->pure
3145 : 168051 : || e->value.function.isym->elemental;
3146 : 168051 : *name = e->value.function.isym->name;
3147 : : }
3148 : : else
3149 : : {
3150 : : /* Implicit functions are not pure. */
3151 : 960 : pure = 0;
3152 : 960 : *name = e->value.function.name;
3153 : : }
3154 : :
3155 : : return pure;
3156 : : }
3157 : :
3158 : :
3159 : : /* Check if the expression is a reference to an implicitly pure function. */
3160 : :
3161 : : bool
3162 : 34512 : gfc_implicit_pure_function (gfc_expr *e)
3163 : : {
3164 : 34512 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3165 : 34512 : if (comp)
3166 : 259 : return gfc_implicit_pure (comp->ts.interface);
3167 : 34253 : else if (e->value.function.esym)
3168 : 28961 : return gfc_implicit_pure (e->value.function.esym);
3169 : : else
3170 : : return 0;
3171 : : }
3172 : :
3173 : :
3174 : : static bool
3175 : 869 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3176 : : int *f ATTRIBUTE_UNUSED)
3177 : : {
3178 : 869 : const char *name;
3179 : :
3180 : : /* Don't bother recursing into other statement functions
3181 : : since they will be checked individually for purity. */
3182 : 869 : if (e->expr_type != EXPR_FUNCTION
3183 : 305 : || !e->symtree
3184 : 305 : || e->symtree->n.sym == sym
3185 : 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3186 : : return false;
3187 : :
3188 : 19 : return gfc_pure_function (e, &name) ? false : true;
3189 : : }
3190 : :
3191 : :
3192 : : static bool
3193 : 285 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3194 : : {
3195 : 285 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3196 : : }
3197 : :
3198 : :
3199 : : /* Check if an impure function is allowed in the current context. */
3200 : :
3201 : 207254 : static bool check_pure_function (gfc_expr *e)
3202 : : {
3203 : 207254 : const char *name = NULL;
3204 : 207254 : if (!gfc_pure_function (e, &name) && name)
3205 : : {
3206 : 33238 : if (forall_flag)
3207 : : {
3208 : 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3209 : : "FORALL %s", name, &e->where,
3210 : : forall_flag == 2 ? "mask" : "block");
3211 : 4 : return false;
3212 : : }
3213 : 33234 : else if (gfc_do_concurrent_flag)
3214 : : {
3215 : 0 : gfc_error ("Reference to impure function %qs at %L inside a "
3216 : : "DO CONCURRENT %s", name, &e->where,
3217 : : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3218 : 0 : return false;
3219 : : }
3220 : 33234 : else if (gfc_pure (NULL))
3221 : : {
3222 : 5 : gfc_error ("Reference to impure function %qs at %L "
3223 : : "within a PURE procedure", name, &e->where);
3224 : 5 : return false;
3225 : : }
3226 : 33229 : if (!gfc_implicit_pure_function (e))
3227 : 27528 : gfc_unset_implicit_pure (NULL);
3228 : : }
3229 : : return true;
3230 : : }
3231 : :
3232 : :
3233 : : /* Update current procedure's array_outer_dependency flag, considering
3234 : : a call to procedure SYM. */
3235 : :
3236 : : static void
3237 : 118646 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3238 : : {
3239 : : /* Check to see if this is a sibling function that has not yet
3240 : : been resolved. */
3241 : 118646 : gfc_namespace *sibling = gfc_current_ns->sibling;
3242 : 219793 : for (; sibling; sibling = sibling->sibling)
3243 : : {
3244 : 105358 : if (sibling->proc_name == sym)
3245 : : {
3246 : 4211 : gfc_resolve (sibling);
3247 : 4211 : break;
3248 : : }
3249 : : }
3250 : :
3251 : : /* If SYM has references to outer arrays, so has the procedure calling
3252 : : SYM. If SYM is a procedure pointer, we can assume the worst. */
3253 : 118646 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3254 : 62794 : && gfc_current_ns->proc_name)
3255 : 62750 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3256 : 118646 : }
3257 : :
3258 : :
3259 : : /* Resolve a function call, which means resolving the arguments, then figuring
3260 : : out which entity the name refers to. */
3261 : :
3262 : : static bool
3263 : 298274 : resolve_function (gfc_expr *expr)
3264 : : {
3265 : 298274 : gfc_actual_arglist *arg;
3266 : 298274 : gfc_symbol *sym;
3267 : 298274 : bool t;
3268 : 298274 : int temp;
3269 : 298274 : procedure_type p = PROC_INTRINSIC;
3270 : 298274 : bool no_formal_args;
3271 : :
3272 : 298274 : sym = NULL;
3273 : 298274 : if (expr->symtree)
3274 : 297981 : sym = expr->symtree->n.sym;
3275 : :
3276 : : /* If this is a procedure pointer component, it has already been resolved. */
3277 : 298274 : if (gfc_is_proc_ptr_comp (expr))
3278 : : return true;
3279 : :
3280 : : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3281 : : another caf_get. */
3282 : 297955 : if (sym && sym->attr.intrinsic
3283 : 8103 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3284 : 8103 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3285 : : return true;
3286 : :
3287 : 297953 : if (expr->ref)
3288 : : {
3289 : 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3290 : : &expr->where);
3291 : 1 : return false;
3292 : : }
3293 : :
3294 : 297659 : if (sym && sym->attr.intrinsic
3295 : 306053 : && !gfc_resolve_intrinsic (sym, &expr->where))
3296 : : return false;
3297 : :
3298 : 297952 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3299 : : {
3300 : 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3301 : 4 : return false;
3302 : : }
3303 : :
3304 : : /* If this is a deferred TBP with an abstract interface (which may
3305 : : of course be referenced), expr->value.function.esym will be set. */
3306 : 297655 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3307 : : {
3308 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3309 : : sym->name, &expr->where);
3310 : 1 : return false;
3311 : : }
3312 : :
3313 : : /* If this is a deferred TBP with an abstract interface, its result
3314 : : cannot be an assumed length character (F2003: C418). */
3315 : 297654 : if (sym && sym->attr.abstract && sym->attr.function
3316 : 176 : && sym->result->ts.u.cl
3317 : 156 : && sym->result->ts.u.cl->length == NULL
3318 : 2 : && !sym->result->ts.deferred)
3319 : : {
3320 : 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3321 : : "character length result (F2008: C418)", sym->name,
3322 : : &sym->declared_at);
3323 : 1 : return false;
3324 : : }
3325 : :
3326 : : /* Switch off assumed size checking and do this again for certain kinds
3327 : : of procedure, once the procedure itself is resolved. */
3328 : 297946 : need_full_assumed_size++;
3329 : :
3330 : 297946 : if (expr->symtree && expr->symtree->n.sym)
3331 : 297653 : p = expr->symtree->n.sym->attr.proc;
3332 : :
3333 : 297946 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3334 : 953 : inquiry_argument = true;
3335 : 297653 : no_formal_args = sym && is_external_proc (sym)
3336 : 310695 : && gfc_sym_get_dummy_args (sym) == NULL;
3337 : :
3338 : 297946 : if (!resolve_actual_arglist (expr->value.function.actual,
3339 : : p, no_formal_args))
3340 : : {
3341 : 58 : inquiry_argument = false;
3342 : 58 : return false;
3343 : : }
3344 : :
3345 : 297888 : inquiry_argument = false;
3346 : :
3347 : : /* Resume assumed_size checking. */
3348 : 297888 : need_full_assumed_size--;
3349 : :
3350 : : /* If the procedure is external, check for usage. */
3351 : 297888 : if (sym && is_external_proc (sym))
3352 : 12732 : resolve_global_procedure (sym, &expr->where, 0);
3353 : :
3354 : 297888 : if (sym && sym->ts.type == BT_CHARACTER
3355 : 2769 : && sym->ts.u.cl
3356 : 2751 : && sym->ts.u.cl->length == NULL
3357 : 322 : && !sym->attr.dummy
3358 : 317 : && !sym->ts.deferred
3359 : 2 : && expr->value.function.esym == NULL
3360 : 2 : && !sym->attr.contained)
3361 : : {
3362 : : /* Internal procedures are taken care of in resolve_contained_fntype. */
3363 : 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3364 : : "be used at %L since it is not a dummy argument",
3365 : : sym->name, &expr->where);
3366 : 1 : return false;
3367 : : }
3368 : :
3369 : : /* See if function is already resolved. */
3370 : :
3371 : 297887 : if (expr->value.function.name != NULL
3372 : 287542 : || expr->value.function.isym != NULL)
3373 : : {
3374 : 11023 : if (expr->ts.type == BT_UNKNOWN)
3375 : 3 : expr->ts = sym->ts;
3376 : : t = true;
3377 : : }
3378 : : else
3379 : : {
3380 : : /* Apply the rules of section 14.1.2. */
3381 : :
3382 : 286864 : switch (procedure_kind (sym))
3383 : : {
3384 : 26047 : case PTYPE_GENERIC:
3385 : 26047 : t = resolve_generic_f (expr);
3386 : 26047 : break;
3387 : :
3388 : 24780 : case PTYPE_SPECIFIC:
3389 : 24780 : t = resolve_specific_f (expr);
3390 : 24780 : break;
3391 : :
3392 : 236037 : case PTYPE_UNKNOWN:
3393 : 236037 : t = resolve_unknown_f (expr);
3394 : 236037 : break;
3395 : :
3396 : 0 : default:
3397 : 0 : gfc_internal_error ("resolve_function(): bad function type");
3398 : : }
3399 : : }
3400 : :
3401 : : /* If the expression is still a function (it might have simplified),
3402 : : then we check to see if we are calling an elemental function. */
3403 : :
3404 : 297887 : if (expr->expr_type != EXPR_FUNCTION)
3405 : : return t;
3406 : :
3407 : : /* Walk the argument list looking for invalid BOZ. */
3408 : 609552 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3409 : 402557 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3410 : : {
3411 : 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3412 : : "actual argument in a function reference",
3413 : : &arg->expr->where);
3414 : 5 : return false;
3415 : : }
3416 : :
3417 : 206995 : temp = need_full_assumed_size;
3418 : 206995 : need_full_assumed_size = 0;
3419 : :
3420 : 206995 : if (!resolve_elemental_actual (expr, NULL))
3421 : : return false;
3422 : :
3423 : 206992 : if (omp_workshare_flag
3424 : 32 : && expr->value.function.esym
3425 : 206997 : && ! gfc_elemental (expr->value.function.esym))
3426 : : {
3427 : 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3428 : 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3429 : : &expr->where);
3430 : 4 : t = false;
3431 : : }
3432 : :
3433 : : #define GENERIC_ID expr->value.function.isym->id
3434 : 206988 : else if (expr->value.function.actual != NULL
3435 : 200499 : && expr->value.function.isym != NULL
3436 : 157888 : && GENERIC_ID != GFC_ISYM_LBOUND
3437 : : && GENERIC_ID != GFC_ISYM_LCOBOUND
3438 : : && GENERIC_ID != GFC_ISYM_UCOBOUND
3439 : : && GENERIC_ID != GFC_ISYM_LEN
3440 : : && GENERIC_ID != GFC_ISYM_LOC
3441 : : && GENERIC_ID != GFC_ISYM_C_LOC
3442 : : && GENERIC_ID != GFC_ISYM_PRESENT)
3443 : : {
3444 : : /* Array intrinsics must also have the last upper bound of an
3445 : : assumed size array argument. UBOUND and SIZE have to be
3446 : : excluded from the check if the second argument is anything
3447 : : than a constant. */
3448 : :
3449 : 418918 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3450 : : {
3451 : 285296 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3452 : 39896 : && arg == expr->value.function.actual
3453 : 14886 : && arg->next != NULL && arg->next->expr)
3454 : : {
3455 : 7290 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3456 : : break;
3457 : :
3458 : 7066 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3459 : : break;
3460 : :
3461 : 7066 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3462 : 7066 : < arg->expr->rank)
3463 : : break;
3464 : : }
3465 : :
3466 : 282917 : if (arg->expr != NULL
3467 : 191914 : && arg->expr->rank > 0
3468 : 371204 : && resolve_assumed_size_actual (arg->expr))
3469 : : return false;
3470 : : }
3471 : : }
3472 : : #undef GENERIC_ID
3473 : :
3474 : 206989 : need_full_assumed_size = temp;
3475 : :
3476 : 206989 : if (!check_pure_function(expr))
3477 : 8 : t = false;
3478 : :
3479 : : /* Functions without the RECURSIVE attribution are not allowed to
3480 : : * call themselves. */
3481 : 206989 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3482 : : {
3483 : 47745 : gfc_symbol *esym;
3484 : 47745 : esym = expr->value.function.esym;
3485 : :
3486 : 47745 : if (is_illegal_recursion (esym, gfc_current_ns))
3487 : : {
3488 : 5 : if (esym->attr.entry && esym->ns->entries)
3489 : 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3490 : : " function %qs is not RECURSIVE",
3491 : 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3492 : : else
3493 : 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3494 : : " is not RECURSIVE", esym->name, &expr->where);
3495 : :
3496 : : t = false;
3497 : : }
3498 : : }
3499 : :
3500 : : /* Character lengths of use associated functions may contains references to
3501 : : symbols not referenced from the current program unit otherwise. Make sure
3502 : : those symbols are marked as referenced. */
3503 : :
3504 : 206989 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3505 : 2947 : && expr->value.function.esym->attr.use_assoc)
3506 : : {
3507 : 977 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3508 : : }
3509 : :
3510 : : /* Make sure that the expression has a typespec that works. */
3511 : 206989 : if (expr->ts.type == BT_UNKNOWN)
3512 : : {
3513 : 806 : if (expr->symtree->n.sym->result
3514 : 798 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3515 : 497 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3516 : 497 : expr->ts = expr->symtree->n.sym->result->ts;
3517 : : }
3518 : :
3519 : : /* These derived types with an incomplete namespace, arising from use
3520 : : association, cause gfc_get_derived_vtab to segfault. If the function
3521 : : namespace does not suffice, something is badly wrong. */
3522 : 206989 : if (expr->ts.type == BT_DERIVED
3523 : 8471 : && !expr->ts.u.derived->ns->proc_name)
3524 : : {
3525 : 3 : gfc_symbol *der;
3526 : 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3527 : 3 : if (der)
3528 : : {
3529 : 3 : expr->ts.u.derived->refs--;
3530 : 3 : expr->ts.u.derived = der;
3531 : 3 : der->refs++;
3532 : : }
3533 : : else
3534 : 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3535 : : }
3536 : :
3537 : 206989 : if (!expr->ref && !expr->value.function.isym)
3538 : : {
3539 : 48980 : if (expr->value.function.esym)
3540 : 48020 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3541 : : else
3542 : 960 : update_current_proc_array_outer_dependency (sym);
3543 : : }
3544 : 158009 : else if (expr->ref)
3545 : : /* typebound procedure: Assume the worst. */
3546 : 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3547 : :
3548 : 206989 : if (expr->value.function.esym
3549 : 48020 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3550 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
3551 : : "Using function %qs at %L is deprecated",
3552 : : sym->name, &expr->where);
3553 : : return t;
3554 : : }
3555 : :
3556 : :
3557 : : /************* Subroutine resolution *************/
3558 : :
3559 : : static bool
3560 : 67703 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3561 : : {
3562 : 67703 : if (gfc_pure (sym))
3563 : : return true;
3564 : :
3565 : 63143 : if (forall_flag)
3566 : : {
3567 : 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3568 : : name, loc);
3569 : 0 : return false;
3570 : : }
3571 : 63143 : else if (gfc_do_concurrent_flag)
3572 : : {
3573 : 1 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3574 : : "PURE", name, loc);
3575 : 1 : return false;
3576 : : }
3577 : 63142 : else if (gfc_pure (NULL))
3578 : : {
3579 : 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3580 : 4 : return false;
3581 : : }
3582 : :
3583 : 63138 : gfc_unset_implicit_pure (NULL);
3584 : 63138 : return true;
3585 : : }
3586 : :
3587 : :
3588 : : static match
3589 : 2165 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3590 : : {
3591 : 2165 : gfc_symbol *s;
3592 : :
3593 : 2165 : if (sym->attr.generic)
3594 : : {
3595 : 2164 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3596 : 2164 : if (s != NULL)
3597 : : {
3598 : 2155 : c->resolved_sym = s;
3599 : 2155 : if (!pure_subroutine (s, s->name, &c->loc))
3600 : : return MATCH_ERROR;
3601 : 2155 : return MATCH_YES;
3602 : : }
3603 : :
3604 : : /* TODO: Need to search for elemental references in generic interface. */
3605 : : }
3606 : :
3607 : 10 : if (sym->attr.intrinsic)
3608 : 1 : return gfc_intrinsic_sub_interface (c, 0);
3609 : :
3610 : : return MATCH_NO;
3611 : : }
3612 : :
3613 : :
3614 : : static bool
3615 : 2163 : resolve_generic_s (gfc_code *c)
3616 : : {
3617 : 2163 : gfc_symbol *sym;
3618 : 2163 : match m;
3619 : :
3620 : 2163 : sym = c->symtree->n.sym;
3621 : :
3622 : 2165 : for (;;)
3623 : : {
3624 : 2165 : m = resolve_generic_s0 (c, sym);
3625 : 2165 : if (m == MATCH_YES)
3626 : : return true;
3627 : 9 : else if (m == MATCH_ERROR)
3628 : : return false;
3629 : :
3630 : 9 : generic:
3631 : 9 : if (sym->ns->parent == NULL)
3632 : : break;
3633 : 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3634 : :
3635 : 3 : if (sym == NULL)
3636 : : break;
3637 : 2 : if (!generic_sym (sym))
3638 : 0 : goto generic;
3639 : : }
3640 : :
3641 : : /* Last ditch attempt. See if the reference is to an intrinsic
3642 : : that possesses a matching interface. 14.1.2.4 */
3643 : 7 : sym = c->symtree->n.sym;
3644 : :
3645 : 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3646 : : {
3647 : 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3648 : : sym->name, &c->loc);
3649 : 4 : return false;
3650 : : }
3651 : :
3652 : 3 : m = gfc_intrinsic_sub_interface (c, 0);
3653 : 3 : if (m == MATCH_YES)
3654 : : return true;
3655 : 1 : if (m == MATCH_NO)
3656 : 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3657 : : "intrinsic subroutine interface", sym->name, &c->loc);
3658 : :
3659 : : return false;
3660 : : }
3661 : :
3662 : :
3663 : : /* Resolve a subroutine call known to be specific. */
3664 : :
3665 : : static match
3666 : 54246 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3667 : : {
3668 : 54246 : match m;
3669 : :
3670 : 54246 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3671 : : {
3672 : 5428 : if (sym->attr.dummy)
3673 : : {
3674 : 250 : sym->attr.proc = PROC_DUMMY;
3675 : 250 : goto found;
3676 : : }
3677 : :
3678 : 5178 : sym->attr.proc = PROC_EXTERNAL;
3679 : 5178 : goto found;
3680 : : }
3681 : :
3682 : 48818 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3683 : 48818 : goto found;
3684 : :
3685 : 0 : if (sym->attr.intrinsic)
3686 : : {
3687 : 0 : m = gfc_intrinsic_sub_interface (c, 1);
3688 : 0 : if (m == MATCH_YES)
3689 : : return MATCH_YES;
3690 : 0 : if (m == MATCH_NO)
3691 : 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3692 : : "with an intrinsic", sym->name, &c->loc);
3693 : :
3694 : 0 : return MATCH_ERROR;
3695 : : }
3696 : :
3697 : : return MATCH_NO;
3698 : :
3699 : 54246 : found:
3700 : 54246 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3701 : :
3702 : 54246 : c->resolved_sym = sym;
3703 : 54246 : if (!pure_subroutine (sym, sym->name, &c->loc))
3704 : : return MATCH_ERROR;
3705 : :
3706 : : return MATCH_YES;
3707 : : }
3708 : :
3709 : :
3710 : : static bool
3711 : 54246 : resolve_specific_s (gfc_code *c)
3712 : : {
3713 : 54246 : gfc_symbol *sym;
3714 : 54246 : match m;
3715 : :
3716 : 54246 : sym = c->symtree->n.sym;
3717 : :
3718 : 54246 : for (;;)
3719 : : {
3720 : 54246 : m = resolve_specific_s0 (c, sym);
3721 : 54246 : if (m == MATCH_YES)
3722 : : return true;
3723 : 3 : if (m == MATCH_ERROR)
3724 : : return false;
3725 : :
3726 : 0 : if (sym->ns->parent == NULL)
3727 : : break;
3728 : :
3729 : 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3730 : :
3731 : 0 : if (sym == NULL)
3732 : : break;
3733 : : }
3734 : :
3735 : 0 : sym = c->symtree->n.sym;
3736 : 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3737 : : sym->name, &c->loc);
3738 : :
3739 : 0 : return false;
3740 : : }
3741 : :
3742 : :
3743 : : /* Resolve a subroutine call not known to be generic nor specific. */
3744 : :
3745 : : static bool
3746 : 14817 : resolve_unknown_s (gfc_code *c)
3747 : : {
3748 : 14817 : gfc_symbol *sym;
3749 : :
3750 : 14817 : sym = c->symtree->n.sym;
3751 : :
3752 : 14817 : if (sym->attr.dummy)
3753 : : {
3754 : 19 : sym->attr.proc = PROC_DUMMY;
3755 : 19 : goto found;
3756 : : }
3757 : :
3758 : : /* See if we have an intrinsic function reference. */
3759 : :
3760 : 14798 : if (gfc_is_intrinsic (sym, 1, c->loc))
3761 : : {
3762 : 3635 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3763 : : return true;
3764 : 294 : return false;
3765 : : }
3766 : :
3767 : : /* The reference is to an external name. */
3768 : :
3769 : 11163 : found:
3770 : 11182 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3771 : :
3772 : 11182 : c->resolved_sym = sym;
3773 : :
3774 : 11182 : return pure_subroutine (sym, sym->name, &c->loc);
3775 : : }
3776 : :
3777 : :
3778 : : /* Resolve a subroutine call. Although it was tempting to use the same code
3779 : : for functions, subroutines and functions are stored differently and this
3780 : : makes things awkward. */
3781 : :
3782 : : static bool
3783 : 71310 : resolve_call (gfc_code *c)
3784 : : {
3785 : 71310 : bool t;
3786 : 71310 : procedure_type ptype = PROC_INTRINSIC;
3787 : 71310 : gfc_symbol *csym, *sym;
3788 : 71310 : bool no_formal_args;
3789 : :
3790 : 71310 : csym = c->symtree ? c->symtree->n.sym : NULL;
3791 : :
3792 : 71310 : if (csym && csym->ts.type != BT_UNKNOWN)
3793 : : {
3794 : 5 : gfc_error ("%qs at %L has a type, which is not consistent with "
3795 : : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3796 : 5 : return false;
3797 : : }
3798 : :
3799 : 71305 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3800 : : {
3801 : 14354 : gfc_symtree *st;
3802 : 14354 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3803 : 14354 : sym = st ? st->n.sym : NULL;
3804 : 14354 : if (sym && csym != sym
3805 : 3 : && sym->ns == gfc_current_ns
3806 : : && sym->attr.flavor == FL_PROCEDURE
3807 : 3 : && sym->attr.contained)
3808 : : {
3809 : 3 : sym->refs++;
3810 : 3 : if (csym->attr.generic)
3811 : 2 : c->symtree->n.sym = sym;
3812 : : else
3813 : 1 : c->symtree = st;
3814 : 3 : csym = c->symtree->n.sym;
3815 : : }
3816 : : }
3817 : :
3818 : : /* If this ia a deferred TBP, c->expr1 will be set. */
3819 : 71305 : if (!c->expr1 && csym)
3820 : : {
3821 : 69708 : if (csym->attr.abstract)
3822 : : {
3823 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3824 : : csym->name, &c->loc);
3825 : 1 : return false;
3826 : : }
3827 : :
3828 : : /* Subroutines without the RECURSIVE attribution are not allowed to
3829 : : call themselves. */
3830 : 69707 : if (is_illegal_recursion (csym, gfc_current_ns))
3831 : : {
3832 : 4 : if (csym->attr.entry && csym->ns->entries)
3833 : 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3834 : : "as subroutine %qs is not RECURSIVE",
3835 : 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
3836 : : else
3837 : 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3838 : : "as it is not RECURSIVE", csym->name, &c->loc);
3839 : :
3840 : 71304 : t = false;
3841 : : }
3842 : : }
3843 : :
3844 : : /* Switch off assumed size checking and do this again for certain kinds
3845 : : of procedure, once the procedure itself is resolved. */
3846 : 71304 : need_full_assumed_size++;
3847 : :
3848 : 71304 : if (csym)
3849 : 71304 : ptype = csym->attr.proc;
3850 : :
3851 : 71304 : no_formal_args = csym && is_external_proc (csym)
3852 : 15144 : && gfc_sym_get_dummy_args (csym) == NULL;
3853 : 71304 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3854 : : return false;
3855 : :
3856 : : /* Resume assumed_size checking. */
3857 : 71272 : need_full_assumed_size--;
3858 : :
3859 : : /* If external, check for usage. */
3860 : 71272 : if (csym && is_external_proc (csym))
3861 : 15139 : resolve_global_procedure (csym, &c->loc, 1);
3862 : :
3863 : 71272 : t = true;
3864 : 71272 : if (c->resolved_sym == NULL)
3865 : : {
3866 : 71226 : c->resolved_isym = NULL;
3867 : 71226 : switch (procedure_kind (csym))
3868 : : {
3869 : 2163 : case PTYPE_GENERIC:
3870 : 2163 : t = resolve_generic_s (c);
3871 : 2163 : break;
3872 : :
3873 : 54246 : case PTYPE_SPECIFIC:
3874 : 54246 : t = resolve_specific_s (c);
3875 : 54246 : break;
3876 : :
3877 : 14817 : case PTYPE_UNKNOWN:
3878 : 14817 : t = resolve_unknown_s (c);
3879 : 14817 : break;
3880 : :
3881 : 0 : default:
3882 : 0 : gfc_internal_error ("resolve_subroutine(): bad function type");
3883 : : }
3884 : : }
3885 : :
3886 : : /* Some checks of elemental subroutine actual arguments. */
3887 : 71271 : if (!resolve_elemental_actual (NULL, c))
3888 : : return false;
3889 : :
3890 : 71263 : if (!c->expr1)
3891 : 69666 : update_current_proc_array_outer_dependency (csym);
3892 : : else
3893 : : /* Typebound procedure: Assume the worst. */
3894 : 1597 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3895 : :
3896 : 71263 : if (c->resolved_sym
3897 : 70965 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3898 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
3899 : : "Using subroutine %qs at %L is deprecated",
3900 : : c->resolved_sym->name, &c->loc);
3901 : :
3902 : : return t;
3903 : : }
3904 : :
3905 : :
3906 : : /* Compare the shapes of two arrays that have non-NULL shapes. If both
3907 : : op1->shape and op2->shape are non-NULL return true if their shapes
3908 : : match. If both op1->shape and op2->shape are non-NULL return false
3909 : : if their shapes do not match. If either op1->shape or op2->shape is
3910 : : NULL, return true. */
3911 : :
3912 : : static bool
3913 : 26465 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
3914 : : {
3915 : 26465 : bool t;
3916 : 26465 : int i;
3917 : :
3918 : 26465 : t = true;
3919 : :
3920 : 26465 : if (op1->shape != NULL && op2->shape != NULL)
3921 : : {
3922 : 37751 : for (i = 0; i < op1->rank; i++)
3923 : : {
3924 : 20267 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3925 : : {
3926 : 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
3927 : : &op1->where, &op2->where);
3928 : 3 : t = false;
3929 : 3 : break;
3930 : : }
3931 : : }
3932 : : }
3933 : :
3934 : 26465 : return t;
3935 : : }
3936 : :
3937 : : /* Convert a logical operator to the corresponding bitwise intrinsic call.
3938 : : For example A .AND. B becomes IAND(A, B). */
3939 : : static gfc_expr *
3940 : 668 : logical_to_bitwise (gfc_expr *e)
3941 : : {
3942 : 668 : gfc_expr *tmp, *op1, *op2;
3943 : 668 : gfc_isym_id isym;
3944 : 668 : gfc_actual_arglist *args = NULL;
3945 : :
3946 : 668 : gcc_assert (e->expr_type == EXPR_OP);
3947 : :
3948 : 668 : isym = GFC_ISYM_NONE;
3949 : 668 : op1 = e->value.op.op1;
3950 : 668 : op2 = e->value.op.op2;
3951 : :
3952 : 668 : switch (e->value.op.op)
3953 : : {
3954 : : case INTRINSIC_NOT:
3955 : : isym = GFC_ISYM_NOT;
3956 : : break;
3957 : 126 : case INTRINSIC_AND:
3958 : 126 : isym = GFC_ISYM_IAND;
3959 : 126 : break;
3960 : 127 : case INTRINSIC_OR:
3961 : 127 : isym = GFC_ISYM_IOR;
3962 : 127 : break;
3963 : 270 : case INTRINSIC_NEQV:
3964 : 270 : isym = GFC_ISYM_IEOR;
3965 : 270 : break;
3966 : 126 : case INTRINSIC_EQV:
3967 : : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3968 : : Change the old expression to NEQV, which will get replaced by IEOR,
3969 : : and wrap it in NOT. */
3970 : 126 : tmp = gfc_copy_expr (e);
3971 : 126 : tmp->value.op.op = INTRINSIC_NEQV;
3972 : 126 : tmp = logical_to_bitwise (tmp);
3973 : 126 : isym = GFC_ISYM_NOT;
3974 : 126 : op1 = tmp;
3975 : 126 : op2 = NULL;
3976 : 126 : break;
3977 : 0 : default:
3978 : 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3979 : : }
3980 : :
3981 : : /* Inherit the original operation's operands as arguments. */
3982 : 668 : args = gfc_get_actual_arglist ();
3983 : 668 : args->expr = op1;
3984 : 668 : if (op2)
3985 : : {
3986 : 523 : args->next = gfc_get_actual_arglist ();
3987 : 523 : args->next->expr = op2;
3988 : : }
3989 : :
3990 : : /* Convert the expression to a function call. */
3991 : 668 : e->expr_type = EXPR_FUNCTION;
3992 : 668 : e->value.function.actual = args;
3993 : 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
3994 : 668 : e->value.function.name = e->value.function.isym->name;
3995 : 668 : e->value.function.esym = NULL;
3996 : :
3997 : : /* Make up a pre-resolved function call symtree if we need to. */
3998 : 668 : if (!e->symtree || !e->symtree->n.sym)
3999 : : {
4000 : 668 : gfc_symbol *sym;
4001 : 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4002 : 668 : sym = e->symtree->n.sym;
4003 : 668 : sym->result = sym;
4004 : 668 : sym->attr.flavor = FL_PROCEDURE;
4005 : 668 : sym->attr.function = 1;
4006 : 668 : sym->attr.elemental = 1;
4007 : 668 : sym->attr.pure = 1;
4008 : 668 : sym->attr.referenced = 1;
4009 : 668 : gfc_intrinsic_symbol (sym);
4010 : 668 : gfc_commit_symbol (sym);
4011 : : }
4012 : :
4013 : 668 : args->name = e->value.function.isym->formal->name;
4014 : 668 : if (e->value.function.isym->formal->next)
4015 : 523 : args->next->name = e->value.function.isym->formal->next->name;
4016 : :
4017 : 668 : return e;
4018 : : }
4019 : :
4020 : : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4021 : : candidates in CANDIDATES_LEN. */
4022 : : static void
4023 : 43 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4024 : : char **&candidates,
4025 : : size_t &candidates_len)
4026 : : {
4027 : 45 : gfc_symtree *p;
4028 : :
4029 : 45 : if (uop == NULL)
4030 : : return;
4031 : :
4032 : : /* Not sure how to properly filter here. Use all for a start.
4033 : : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4034 : : these as i suppose they don't make terribly sense. */
4035 : :
4036 : 45 : if (uop->n.uop->op != NULL)
4037 : 2 : vec_push (candidates, candidates_len, uop->name);
4038 : :
4039 : 45 : p = uop->left;
4040 : 45 : if (p)
4041 : 0 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4042 : :
4043 : 45 : p = uop->right;
4044 : 45 : if (p)
4045 : : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4046 : : }
4047 : :
4048 : : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4049 : :
4050 : : static const char*
4051 : 43 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4052 : : {
4053 : 43 : char **candidates = NULL;
4054 : 43 : size_t candidates_len = 0;
4055 : 43 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4056 : 43 : return gfc_closest_fuzzy_match (op, candidates);
4057 : : }
4058 : :
4059 : :
4060 : : /* Callback finding an impure function as an operand to an .and. or
4061 : : .or. expression. Remember the last function warned about to
4062 : : avoid double warnings when recursing. */
4063 : :
4064 : : static int
4065 : 111572 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4066 : : void *data)
4067 : : {
4068 : 111572 : gfc_expr *f = *e;
4069 : 111572 : const char *name;
4070 : 111572 : static gfc_expr *last = NULL;
4071 : 111572 : bool *found = (bool *) data;
4072 : :
4073 : 111572 : if (f->expr_type == EXPR_FUNCTION)
4074 : : {
4075 : 11255 : *found = 1;
4076 : 11255 : if (f != last && !gfc_pure_function (f, &name)
4077 : 12536 : && !gfc_implicit_pure_function (f))
4078 : : {
4079 : 1142 : if (name)
4080 : 1142 : gfc_warning (OPT_Wfunction_elimination,
4081 : : "Impure function %qs at %L might not be evaluated",
4082 : : name, &f->where);
4083 : : else
4084 : 0 : gfc_warning (OPT_Wfunction_elimination,
4085 : : "Impure function at %L might not be evaluated",
4086 : : &f->where);
4087 : : }
4088 : 11255 : last = f;
4089 : : }
4090 : :
4091 : 111572 : return 0;
4092 : : }
4093 : :
4094 : : /* Return true if TYPE is character based, false otherwise. */
4095 : :
4096 : : static int
4097 : 1373 : is_character_based (bt type)
4098 : : {
4099 : 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4100 : : }
4101 : :
4102 : :
4103 : : /* If expression is a hollerith, convert it to character and issue a warning
4104 : : for the conversion. */
4105 : :
4106 : : static void
4107 : 408 : convert_hollerith_to_character (gfc_expr *e)
4108 : : {
4109 : 408 : if (e->ts.type == BT_HOLLERITH)
4110 : : {
4111 : 108 : gfc_typespec t;
4112 : 108 : gfc_clear_ts (&t);
4113 : 108 : t.type = BT_CHARACTER;
4114 : 108 : t.kind = e->ts.kind;
4115 : 108 : gfc_convert_type_warn (e, &t, 2, 1);
4116 : : }
4117 : 408 : }
4118 : :
4119 : : /* Convert to numeric and issue a warning for the conversion. */
4120 : :
4121 : : static void
4122 : 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4123 : : {
4124 : 240 : gfc_typespec t;
4125 : 240 : gfc_clear_ts (&t);
4126 : 240 : t.type = b->ts.type;
4127 : 240 : t.kind = b->ts.kind;
4128 : 240 : gfc_convert_type_warn (a, &t, 2, 1);
4129 : 240 : }
4130 : :
4131 : : /* Resolve an operator expression node. This can involve replacing the
4132 : : operation with a user defined function call. */
4133 : :
4134 : : static bool
4135 : 374313 : resolve_operator (gfc_expr *e)
4136 : : {
4137 : 374313 : gfc_expr *op1, *op2;
4138 : : /* One error uses 3 names; additional space for wording (also via gettext). */
4139 : 374313 : char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50];
4140 : 374313 : bool dual_locus_error;
4141 : 374313 : bool t = true;
4142 : :
4143 : : /* Reduce stacked parentheses to single pair */
4144 : 374313 : while (e->expr_type == EXPR_OP
4145 : 374423 : && e->value.op.op == INTRINSIC_PARENTHESES
4146 : 20442 : && e->value.op.op1->expr_type == EXPR_OP
4147 : 390657 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4148 : : {
4149 : 110 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4150 : 110 : gfc_replace_expr (e, tmp);
4151 : : }
4152 : :
4153 : : /* Resolve all subnodes-- give them types. */
4154 : :
4155 : 374313 : switch (e->value.op.op)
4156 : : {
4157 : 327247 : default:
4158 : 327247 : if (!gfc_resolve_expr (e->value.op.op2))
4159 : 374313 : t = false;
4160 : :
4161 : : /* Fall through. */
4162 : :
4163 : 374313 : case INTRINSIC_NOT:
4164 : 374313 : case INTRINSIC_UPLUS:
4165 : 374313 : case INTRINSIC_UMINUS:
4166 : 374313 : case INTRINSIC_PARENTHESES:
4167 : 374313 : if (!gfc_resolve_expr (e->value.op.op1))
4168 : : return false;
4169 : 374146 : if (e->value.op.op1
4170 : 374137 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4171 : : {
4172 : 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4173 : 0 : "unary operator %qs", &e->value.op.op1->where,
4174 : : gfc_op2string (e->value.op.op));
4175 : 0 : return false;
4176 : : }
4177 : 374146 : break;
4178 : : }
4179 : :
4180 : : /* Typecheck the new node. */
4181 : :
4182 : 374146 : op1 = e->value.op.op1;
4183 : 374146 : op2 = e->value.op.op2;
4184 : 374146 : if (op1 == NULL && op2 == NULL)
4185 : : return false;
4186 : : /* Error out if op2 did not resolve. We already diagnosed op1. */
4187 : 374137 : if (t == false)
4188 : : return false;
4189 : :
4190 : 374075 : dual_locus_error = false;
4191 : :
4192 : : /* op1 and op2 cannot both be BOZ. */
4193 : 374075 : if (op1 && op1->ts.type == BT_BOZ
4194 : 0 : && op2 && op2->ts.type == BT_BOZ)
4195 : : {
4196 : 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4197 : 0 : "binary operator %qs", &op1->where, &op2->where,
4198 : : gfc_op2string (e->value.op.op));
4199 : 0 : return false;
4200 : : }
4201 : :
4202 : 374075 : if ((op1 && op1->expr_type == EXPR_NULL)
4203 : 374073 : || (op2 && op2->expr_type == EXPR_NULL))
4204 : : {
4205 : 3 : snprintf (msg, sizeof (msg),
4206 : 3 : _("Invalid context for NULL() pointer at %%L"));
4207 : 3 : goto bad_op;
4208 : : }
4209 : :
4210 : 374072 : switch (e->value.op.op)
4211 : : {
4212 : 7769 : case INTRINSIC_UPLUS:
4213 : 7769 : case INTRINSIC_UMINUS:
4214 : 7769 : if (op1->ts.type == BT_INTEGER
4215 : 3796 : || op1->ts.type == BT_REAL
4216 : 85 : || op1->ts.type == BT_COMPLEX)
4217 : : {
4218 : 7700 : e->ts = op1->ts;
4219 : 7700 : break;
4220 : : }
4221 : :
4222 : 69 : snprintf (msg, sizeof (msg),
4223 : 69 : _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4224 : : gfc_op2string (e->value.op.op), gfc_typename (e));
4225 : 69 : goto bad_op;
4226 : :
4227 : 101726 : case INTRINSIC_PLUS:
4228 : 101726 : case INTRINSIC_MINUS:
4229 : 101726 : case INTRINSIC_TIMES:
4230 : 101726 : case INTRINSIC_DIVIDE:
4231 : 101726 : case INTRINSIC_POWER:
4232 : 101726 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4233 : : {
4234 : : /* Do not perform conversions if operands are not conformable as
4235 : : required for the binary intrinsic operators (F2018:10.1.5).
4236 : : Defer to a possibly overloading user-defined operator. */
4237 : 101282 : if (!gfc_op_rank_conformable (op1, op2))
4238 : : {
4239 : 36 : dual_locus_error = true;
4240 : 36 : snprintf (msg, sizeof (msg),
4241 : 36 : _("Inconsistent ranks for operator at %%L and %%L"));
4242 : 36 : goto bad_op;
4243 : : }
4244 : :
4245 : 101246 : gfc_type_convert_binary (e, 1);
4246 : 101246 : break;
4247 : : }
4248 : :
4249 : 444 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4250 : 215 : snprintf (msg, sizeof (msg),
4251 : 215 : _("Unexpected derived-type entities in binary intrinsic "
4252 : : "numeric operator %%<%s%%> at %%L"),
4253 : : gfc_op2string (e->value.op.op));
4254 : : else
4255 : 229 : snprintf (msg, sizeof(msg),
4256 : 229 : _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4257 : : gfc_op2string (e->value.op.op), gfc_typename (op1),
4258 : : gfc_typename (op2));
4259 : 444 : goto bad_op;
4260 : :
4261 : 2199 : case INTRINSIC_CONCAT:
4262 : 2199 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4263 : 2174 : && op1->ts.kind == op2->ts.kind)
4264 : : {
4265 : 2165 : e->ts.type = BT_CHARACTER;
4266 : 2165 : e->ts.kind = op1->ts.kind;
4267 : 2165 : break;
4268 : : }
4269 : :
4270 : 34 : snprintf (msg, sizeof (msg),
4271 : 34 : _("Operands of string concatenation operator at %%L are %s/%s"),
4272 : : gfc_typename (op1), gfc_typename (op2));
4273 : 34 : goto bad_op;
4274 : :
4275 : 37254 : case INTRINSIC_AND:
4276 : 37254 : case INTRINSIC_OR:
4277 : 37254 : case INTRINSIC_EQV:
4278 : 37254 : case INTRINSIC_NEQV:
4279 : 37254 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4280 : : {
4281 : 36703 : e->ts.type = BT_LOGICAL;
4282 : 36703 : e->ts.kind = gfc_kind_max (op1, op2);
4283 : 36703 : if (op1->ts.kind < e->ts.kind)
4284 : 136 : gfc_convert_type (op1, &e->ts, 2);
4285 : 36567 : else if (op2->ts.kind < e->ts.kind)
4286 : 111 : gfc_convert_type (op2, &e->ts, 2);
4287 : :
4288 : 36703 : if (flag_frontend_optimize &&
4289 : 30963 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4290 : : {
4291 : : /* Warn about short-circuiting
4292 : : with impure function as second operand. */
4293 : 25390 : bool op2_f = false;
4294 : 25390 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4295 : : }
4296 : : break;
4297 : : }
4298 : :
4299 : : /* Logical ops on integers become bitwise ops with -fdec. */
4300 : 551 : else if (flag_dec
4301 : 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4302 : : {
4303 : 523 : e->ts.type = BT_INTEGER;
4304 : 523 : e->ts.kind = gfc_kind_max (op1, op2);
4305 : 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4306 : 289 : gfc_convert_type (op1, &e->ts, 1);
4307 : 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4308 : 144 : gfc_convert_type (op2, &e->ts, 1);
4309 : 523 : e = logical_to_bitwise (e);
4310 : 523 : goto simplify_op;
4311 : : }
4312 : :
4313 : 28 : snprintf (msg, sizeof (msg),
4314 : 28 : _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4315 : : gfc_op2string (e->value.op.op), gfc_typename (op1),
4316 : : gfc_typename (op2));
4317 : :
4318 : 28 : goto bad_op;
4319 : :
4320 : 18951 : case INTRINSIC_NOT:
4321 : : /* Logical ops on integers become bitwise ops with -fdec. */
4322 : 18951 : if (flag_dec && op1->ts.type == BT_INTEGER)
4323 : : {
4324 : 19 : e->ts.type = BT_INTEGER;
4325 : 19 : e->ts.kind = op1->ts.kind;
4326 : 19 : e = logical_to_bitwise (e);
4327 : 19 : goto simplify_op;
4328 : : }
4329 : :
4330 : 18932 : if (op1->ts.type == BT_LOGICAL)
4331 : : {
4332 : 18926 : e->ts.type = BT_LOGICAL;
4333 : 18926 : e->ts.kind = op1->ts.kind;
4334 : 18926 : break;
4335 : : }
4336 : :
4337 : 6 : snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"),
4338 : : gfc_typename (op1));
4339 : 6 : goto bad_op;
4340 : :
4341 : 20629 : case INTRINSIC_GT:
4342 : 20629 : case INTRINSIC_GT_OS:
4343 : 20629 : case INTRINSIC_GE:
4344 : 20629 : case INTRINSIC_GE_OS:
4345 : 20629 : case INTRINSIC_LT:
4346 : 20629 : case INTRINSIC_LT_OS:
4347 : 20629 : case INTRINSIC_LE:
4348 : 20629 : case INTRINSIC_LE_OS:
4349 : 20629 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4350 : : {
4351 : 18 : strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
4352 : 18 : goto bad_op;
4353 : : }
4354 : :
4355 : : /* Fall through. */
4356 : :
4357 : 185637 : case INTRINSIC_EQ:
4358 : 185637 : case INTRINSIC_EQ_OS:
4359 : 185637 : case INTRINSIC_NE:
4360 : 185637 : case INTRINSIC_NE_OS:
4361 : :
4362 : 185637 : if (flag_dec
4363 : 1038 : && is_character_based (op1->ts.type)
4364 : 185972 : && is_character_based (op2->ts.type))
4365 : : {
4366 : 204 : convert_hollerith_to_character (op1);
4367 : 204 : convert_hollerith_to_character (op2);
4368 : : }
4369 : :
4370 : 185637 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4371 : 36046 : && op1->ts.kind == op2->ts.kind)
4372 : : {
4373 : 36009 : e->ts.type = BT_LOGICAL;
4374 : 36009 : e->ts.kind = gfc_default_logical_kind;
4375 : 36009 : break;
4376 : : }
4377 : :
4378 : : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4379 : 149628 : if (op1->ts.type == BT_BOZ)
4380 : : {
4381 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4382 : : "as an operand of a relational operator"),
4383 : : &op1->where))
4384 : : return false;
4385 : :
4386 : 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4387 : : return false;
4388 : :
4389 : 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4390 : : return false;
4391 : : }
4392 : :
4393 : : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4394 : 149628 : if (op2->ts.type == BT_BOZ)
4395 : : {
4396 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4397 : : " as an operand of a relational operator"),
4398 : : &op2->where))
4399 : : return false;
4400 : :
4401 : 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4402 : : return false;
4403 : :
4404 : 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4405 : : return false;
4406 : : }
4407 : 149628 : if (flag_dec
4408 : 149628 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4409 : 120 : convert_to_numeric (op1, op2);
4410 : :
4411 : 149628 : if (flag_dec
4412 : 149628 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4413 : 120 : convert_to_numeric (op2, op1);
4414 : :
4415 : 149628 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4416 : : {
4417 : : /* Do not perform conversions if operands are not conformable as
4418 : : required for the binary intrinsic operators (F2018:10.1.5).
4419 : : Defer to a possibly overloading user-defined operator. */
4420 : 148503 : if (!gfc_op_rank_conformable (op1, op2))
4421 : : {
4422 : 70 : dual_locus_error = true;
4423 : 70 : snprintf (msg, sizeof (msg),
4424 : 70 : _("Inconsistent ranks for operator at %%L and %%L"));
4425 : 70 : goto bad_op;
4426 : : }
4427 : :
4428 : 148433 : gfc_type_convert_binary (e, 1);
4429 : :
4430 : 148433 : e->ts.type = BT_LOGICAL;
4431 : 148433 : e->ts.kind = gfc_default_logical_kind;
4432 : :
4433 : 148433 : if (warn_compare_reals)
4434 : : {
4435 : 69 : gfc_intrinsic_op op = e->value.op.op;
4436 : :
4437 : : /* Type conversion has made sure that the types of op1 and op2
4438 : : agree, so it is only necessary to check the first one. */
4439 : 69 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4440 : 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4441 : 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4442 : : {
4443 : 13 : const char *msg;
4444 : :
4445 : 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4446 : : msg = G_("Equality comparison for %s at %L");
4447 : : else
4448 : 6 : msg = G_("Inequality comparison for %s at %L");
4449 : :
4450 : 13 : gfc_warning (OPT_Wcompare_reals, msg,
4451 : : gfc_typename (op1), &op1->where);
4452 : : }
4453 : : }
4454 : :
4455 : : break;
4456 : : }
4457 : :
4458 : 1125 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4459 : 2 : snprintf (msg, sizeof (msg),
4460 : 2 : _("Logicals at %%L must be compared with %s instead of %s"),
4461 : 2 : (e->value.op.op == INTRINSIC_EQ
4462 : 2 : || e->value.op.op == INTRINSIC_EQ_OS)
4463 : : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4464 : : else
4465 : 1123 : snprintf (msg, sizeof (msg),
4466 : 1123 : _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4467 : : gfc_op2string (e->value.op.op), gfc_typename (op1),
4468 : : gfc_typename (op2));
4469 : :
4470 : 1125 : goto bad_op;
4471 : :
4472 : 232 : case INTRINSIC_USER:
4473 : 232 : if (e->value.op.uop->op == NULL)
4474 : : {
4475 : 43 : const char *name = e->value.op.uop->name;
4476 : 43 : const char *guessed;
4477 : 43 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4478 : 43 : if (guessed)
4479 : 1 : snprintf (msg, sizeof (msg),
4480 : 1 : _("Unknown operator %%<%s%%> at %%L; did you mean "
4481 : : "%%<%s%%>?"), name, guessed);
4482 : : else
4483 : 42 : snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"),
4484 : : name);
4485 : : }
4486 : 189 : else if (op2 == NULL)
4487 : 48 : snprintf (msg, sizeof (msg),
4488 : 48 : _("Operand of user operator %%<%s%%> at %%L is %s"),
4489 : 48 : e->value.op.uop->name, gfc_typename (op1));
4490 : : else
4491 : : {
4492 : 141 : snprintf (msg, sizeof (msg),
4493 : 141 : _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4494 : 141 : e->value.op.uop->name, gfc_typename (op1),
4495 : : gfc_typename (op2));
4496 : 141 : e->value.op.uop->op->sym->attr.referenced = 1;
4497 : : }
4498 : :
4499 : 232 : goto bad_op;
4500 : :
4501 : 20286 : case INTRINSIC_PARENTHESES:
4502 : 20286 : e->ts = op1->ts;
4503 : 20286 : if (e->ts.type == BT_CHARACTER)
4504 : 297 : e->ts.u.cl = op1->ts.u.cl;
4505 : : break;
4506 : :
4507 : 0 : default:
4508 : 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
4509 : : }
4510 : :
4511 : : /* Deal with arrayness of an operand through an operator. */
4512 : :
4513 : 371468 : switch (e->value.op.op)
4514 : : {
4515 : 324556 : case INTRINSIC_PLUS:
4516 : 324556 : case INTRINSIC_MINUS:
4517 : 324556 : case INTRINSIC_TIMES:
4518 : 324556 : case INTRINSIC_DIVIDE:
4519 : 324556 : case INTRINSIC_POWER:
4520 : 324556 : case INTRINSIC_CONCAT:
4521 : 324556 : case INTRINSIC_AND:
4522 : 324556 : case INTRINSIC_OR:
4523 : 324556 : case INTRINSIC_EQV:
4524 : 324556 : case INTRINSIC_NEQV:
4525 : 324556 : case INTRINSIC_EQ:
4526 : 324556 : case INTRINSIC_EQ_OS:
4527 : 324556 : case INTRINSIC_NE:
4528 : 324556 : case INTRINSIC_NE_OS:
4529 : 324556 : case INTRINSIC_GT:
4530 : 324556 : case INTRINSIC_GT_OS:
4531 : 324556 : case INTRINSIC_GE:
4532 : 324556 : case INTRINSIC_GE_OS:
4533 : 324556 : case INTRINSIC_LT:
4534 : 324556 : case INTRINSIC_LT_OS:
4535 : 324556 : case INTRINSIC_LE:
4536 : 324556 : case INTRINSIC_LE_OS:
4537 : :
4538 : 324556 : if (op1->rank == 0 && op2->rank == 0)
4539 : 282439 : e->rank = 0;
4540 : :
4541 : 324556 : if (op1->rank == 0 && op2->rank != 0)
4542 : : {
4543 : 2183 : e->rank = op2->rank;
4544 : :
4545 : 2183 : if (e->shape == NULL)
4546 : 2153 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
4547 : : }
4548 : :
4549 : 324556 : if (op1->rank != 0 && op2->rank == 0)
4550 : : {
4551 : 13408 : e->rank = op1->rank;
4552 : :
4553 : 13408 : if (e->shape == NULL)
4554 : 13390 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4555 : : }
4556 : :
4557 : 324556 : if (op1->rank != 0 && op2->rank != 0)
4558 : : {
4559 : 26526 : if (op1->rank == op2->rank)
4560 : : {
4561 : 26526 : e->rank = op1->rank;
4562 : 26526 : if (e->shape == NULL)
4563 : : {
4564 : 26465 : t = compare_shapes (op1, op2);
4565 : 26465 : if (!t)
4566 : 3 : e->shape = NULL;
4567 : : else
4568 : 26462 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4569 : : }
4570 : : }
4571 : : else
4572 : : {
4573 : : /* Allow higher level expressions to work. */
4574 : 0 : e->rank = 0;
4575 : :
4576 : : /* Try user-defined operators, and otherwise throw an error. */
4577 : 0 : dual_locus_error = true;
4578 : 0 : snprintf (msg, sizeof (msg),
4579 : 0 : _("Inconsistent ranks for operator at %%L and %%L"));
4580 : 0 : goto bad_op;
4581 : : }
4582 : : }
4583 : :
4584 : : break;
4585 : :
4586 : 46912 : case INTRINSIC_PARENTHESES:
4587 : 46912 : case INTRINSIC_NOT:
4588 : 46912 : case INTRINSIC_UPLUS:
4589 : 46912 : case INTRINSIC_UMINUS:
4590 : : /* Simply copy arrayness attribute */
4591 : 46912 : e->rank = op1->rank;
4592 : :
4593 : 46912 : if (e->shape == NULL)
4594 : 46906 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4595 : :
4596 : : break;
4597 : :
4598 : : default:
4599 : : break;
4600 : : }
4601 : :
4602 : 372010 : simplify_op:
4603 : :
4604 : : /* Attempt to simplify the expression. */
4605 : 372010 : if (t)
4606 : : {
4607 : 372007 : t = gfc_simplify_expr (e, 0);
4608 : : /* Some calls do not succeed in simplification and return false
4609 : : even though there is no error; e.g. variable references to
4610 : : PARAMETER arrays. */
4611 : 372007 : if (!gfc_is_constant_expr (e))
4612 : 330471 : t = true;
4613 : : }
4614 : : return t;
4615 : :
4616 : 2065 : bad_op:
4617 : :
4618 : 2065 : {
4619 : 2065 : match m = gfc_extend_expr (e);
4620 : 2065 : if (m == MATCH_YES)
4621 : : return true;
4622 : 206 : if (m == MATCH_ERROR)
4623 : : return false;
4624 : : }
4625 : :
4626 : 204 : if (dual_locus_error)
4627 : 0 : gfc_error (msg, &op1->where, &op2->where);
4628 : : else
4629 : 204 : gfc_error (msg, &e->where);
4630 : :
4631 : : return false;
4632 : : }
4633 : :
4634 : :
4635 : : /************** Array resolution subroutines **************/
4636 : :
4637 : : enum compare_result
4638 : : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
4639 : :
4640 : : /* Compare two integer expressions. */
4641 : :
4642 : : static compare_result
4643 : 409914 : compare_bound (gfc_expr *a, gfc_expr *b)
4644 : : {
4645 : 409914 : int i;
4646 : :
4647 : 409914 : if (a == NULL || a->expr_type != EXPR_CONSTANT
4648 : 268149 : || b == NULL || b->expr_type != EXPR_CONSTANT)
4649 : : return CMP_UNKNOWN;
4650 : :
4651 : : /* If either of the types isn't INTEGER, we must have
4652 : : raised an error earlier. */
4653 : :
4654 : 195601 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4655 : : return CMP_UNKNOWN;
4656 : :
4657 : 195597 : i = mpz_cmp (a->value.integer, b->value.integer);
4658 : :
4659 : 195597 : if (i < 0)
4660 : : return CMP_LT;
4661 : 92661 : if (i > 0)
4662 : 35914 : return CMP_GT;
4663 : : return CMP_EQ;
4664 : : }
4665 : :
4666 : :
4667 : : /* Compare an integer expression with an integer. */
4668 : :
4669 : : static compare_result
4670 : 63070 : compare_bound_int (gfc_expr *a, int b)
4671 : : {
4672 : 63070 : int i;
4673 : :
4674 : 63070 : if (a == NULL
4675 : 28996 : || a->expr_type != EXPR_CONSTANT
4676 : 26378 : || a->ts.type != BT_INTEGER)
4677 : : return CMP_UNKNOWN;
4678 : :
4679 : 26378 : i = mpz_cmp_si (a->value.integer, b);
4680 : :
4681 : 26378 : if (i < 0)
4682 : : return CMP_LT;
4683 : 23479 : if (i > 0)
4684 : 20589 : return CMP_GT;
4685 : : return CMP_EQ;
4686 : : }
4687 : :
4688 : :
4689 : : /* Compare an integer expression with a mpz_t. */
4690 : :
4691 : : static compare_result
4692 : 63408 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4693 : : {
4694 : 63408 : int i;
4695 : :
4696 : 63408 : if (a == NULL
4697 : 52100 : || a->expr_type != EXPR_CONSTANT
4698 : 50042 : || a->ts.type != BT_INTEGER)
4699 : : return CMP_UNKNOWN;
4700 : :
4701 : 50039 : i = mpz_cmp (a->value.integer, b);
4702 : :
4703 : 50039 : if (i < 0)
4704 : : return CMP_LT;
4705 : 22636 : if (i > 0)
4706 : 9410 : return CMP_GT;
4707 : : return CMP_EQ;
4708 : : }
4709 : :
4710 : :
4711 : : /* Compute the last value of a sequence given by a triplet.
4712 : : Return 0 if it wasn't able to compute the last value, or if the
4713 : : sequence if empty, and 1 otherwise. */
4714 : :
4715 : : static int
4716 : 42218 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4717 : : gfc_expr *stride, mpz_t last)
4718 : : {
4719 : 42218 : mpz_t rem;
4720 : :
4721 : 42218 : if (start == NULL || start->expr_type != EXPR_CONSTANT
4722 : 33507 : || end == NULL || end->expr_type != EXPR_CONSTANT
4723 : 29306 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4724 : : return 0;
4725 : :
4726 : 29143 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4727 : 29142 : || (stride != NULL && stride->ts.type != BT_INTEGER))
4728 : : return 0;
4729 : :
4730 : 5975 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
4731 : : {
4732 : 23298 : if (compare_bound (start, end) == CMP_GT)
4733 : : return 0;
4734 : 21921 : mpz_set (last, end->value.integer);
4735 : 21921 : return 1;
4736 : : }
4737 : :
4738 : 5844 : if (compare_bound_int (stride, 0) == CMP_GT)
4739 : : {
4740 : : /* Stride is positive */
4741 : 4981 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4742 : : return 0;
4743 : : }
4744 : : else
4745 : : {
4746 : : /* Stride is negative */
4747 : 863 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4748 : : return 0;
4749 : : }
4750 : :
4751 : 5824 : mpz_init (rem);
4752 : 5824 : mpz_sub (rem, end->value.integer, start->value.integer);
4753 : 5824 : mpz_tdiv_r (rem, rem, stride->value.integer);
4754 : 5824 : mpz_sub (last, end->value.integer, rem);
4755 : 5824 : mpz_clear (rem);
4756 : :
4757 : 5824 : return 1;
4758 : : }
4759 : :
4760 : :
4761 : : /* Compare a single dimension of an array reference to the array
4762 : : specification. */
4763 : :
4764 : : static bool
4765 : 180288 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4766 : : {
4767 : 180288 : mpz_t last_value;
4768 : :
4769 : 180288 : if (ar->dimen_type[i] == DIMEN_STAR)
4770 : : {
4771 : 377 : gcc_assert (ar->stride[i] == NULL);
4772 : : /* This implies [*] as [*:] and [*:3] are not possible. */
4773 : 377 : if (ar->start[i] == NULL)
4774 : : {
4775 : 303 : gcc_assert (ar->end[i] == NULL);
4776 : : return true;
4777 : : }
4778 : : }
4779 : :
4780 : : /* Given start, end and stride values, calculate the minimum and
4781 : : maximum referenced indexes. */
4782 : :
4783 : 179985 : switch (ar->dimen_type[i])
4784 : : {
4785 : : case DIMEN_VECTOR:
4786 : : case DIMEN_THIS_IMAGE:
4787 : : break;
4788 : :
4789 : 136618 : case DIMEN_STAR:
4790 : 136618 : case DIMEN_ELEMENT:
4791 : 136618 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4792 : : {
4793 : 2 : if (i < as->rank)
4794 : 2 : gfc_warning (0, "Array reference at %L is out of bounds "
4795 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
4796 : 2 : mpz_get_si (ar->start[i]->value.integer),
4797 : 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
4798 : : else
4799 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
4800 : : "(%ld < %ld) in codimension %d", &ar->c_where[i],
4801 : 0 : mpz_get_si (ar->start[i]->value.integer),
4802 : 0 : mpz_get_si (as->lower[i]->value.integer),
4803 : 0 : i + 1 - as->rank);
4804 : 2 : return true;
4805 : : }
4806 : 136616 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4807 : : {
4808 : 39 : if (i < as->rank)
4809 : 39 : gfc_warning (0, "Array reference at %L is out of bounds "
4810 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
4811 : 39 : mpz_get_si (ar->start[i]->value.integer),
4812 : 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
4813 : : else
4814 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
4815 : : "(%ld > %ld) in codimension %d", &ar->c_where[i],
4816 : 0 : mpz_get_si (ar->start[i]->value.integer),
4817 : 0 : mpz_get_si (as->upper[i]->value.integer),
4818 : 0 : i + 1 - as->rank);
4819 : 39 : return true;
4820 : : }
4821 : :
4822 : : break;
4823 : :
4824 : 42262 : case DIMEN_RANGE:
4825 : 42262 : {
4826 : : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4827 : : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4828 : :
4829 : 42262 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
4830 : 42262 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
4831 : :
4832 : : /* Check for zero stride, which is not allowed. */
4833 : 42262 : if (comp_stride_zero == CMP_EQ)
4834 : : {
4835 : 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4836 : 1 : return false;
4837 : : }
4838 : :
4839 : : /* if start == end || (stride > 0 && start < end)
4840 : : || (stride < 0 && start > end),
4841 : : then the array section contains at least one element. In this
4842 : : case, there is an out-of-bounds access if
4843 : : (start < lower || start > upper). */
4844 : 42261 : if (comp_start_end == CMP_EQ
4845 : 41600 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
4846 : 39682 : && comp_start_end == CMP_LT)
4847 : 15314 : || (comp_stride_zero == CMP_LT
4848 : 15314 : && comp_start_end == CMP_GT))
4849 : : {
4850 : 27790 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4851 : : {
4852 : 26 : gfc_warning (0, "Lower array reference at %L is out of bounds "
4853 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
4854 : 26 : mpz_get_si (AR_START->value.integer),
4855 : 26 : mpz_get_si (as->lower[i]->value.integer), i+1);
4856 : 26 : return true;
4857 : : }
4858 : 27764 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4859 : : {
4860 : 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
4861 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
4862 : 17 : mpz_get_si (AR_START->value.integer),
4863 : 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
4864 : 17 : return true;
4865 : : }
4866 : : }
4867 : :
4868 : : /* If we can compute the highest index of the array section,
4869 : : then it also has to be between lower and upper. */
4870 : 42218 : mpz_init (last_value);
4871 : 42218 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4872 : : last_value))
4873 : : {
4874 : 27745 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4875 : : {
4876 : 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
4877 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
4878 : : mpz_get_si (last_value),
4879 : 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
4880 : 3 : mpz_clear (last_value);
4881 : 3 : return true;
4882 : : }
4883 : 27742 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4884 : : {
4885 : 6 : gfc_warning (0, "Upper array reference at %L is out of bounds "
4886 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
4887 : : mpz_get_si (last_value),
4888 : 6 : mpz_get_si (as->upper[i]->value.integer), i+1);
4889 : 6 : mpz_clear (last_value);
4890 : 6 : return true;
4891 : : }
4892 : : }
4893 : 42209 : mpz_clear (last_value);
4894 : :
4895 : : #undef AR_START
4896 : : #undef AR_END
4897 : : }
4898 : 42209 : break;
4899 : :
4900 : 0 : default:
4901 : 0 : gfc_internal_error ("check_dimension(): Bad array reference");
4902 : : }
4903 : :
4904 : : return true;
4905 : : }
4906 : :
4907 : :
4908 : : /* Compare an array reference with an array specification. */
4909 : :
4910 : : static bool
4911 : 352930 : compare_spec_to_ref (gfc_array_ref *ar)
4912 : : {
4913 : 352930 : gfc_array_spec *as;
4914 : 352930 : int i;
4915 : :
4916 : 352930 : as = ar->as;
4917 : 352930 : i = as->rank - 1;
4918 : : /* TODO: Full array sections are only allowed as actual parameters. */
4919 : 352930 : if (as->type == AS_ASSUMED_SIZE
4920 : 5703 : && (/*ar->type == AR_FULL
4921 : 5703 : ||*/ (ar->type == AR_SECTION
4922 : 514 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4923 : : {
4924 : 5 : gfc_error ("Rightmost upper bound of assumed size array section "
4925 : : "not specified at %L", &ar->where);
4926 : 5 : return false;
4927 : : }
4928 : :
4929 : 352925 : if (ar->type == AR_FULL)
4930 : : return true;
4931 : :
4932 : 142755 : if (as->rank != ar->dimen)
4933 : : {
4934 : 30 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4935 : : &ar->where, ar->dimen, as->rank);
4936 : 30 : return false;
4937 : : }
4938 : :
4939 : : /* ar->codimen == 0 is a local array. */
4940 : 142725 : if (as->corank != ar->codimen && ar->codimen != 0)
4941 : : {
4942 : 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4943 : : &ar->where, ar->codimen, as->corank);
4944 : 0 : return false;
4945 : : }
4946 : :
4947 : 320636 : for (i = 0; i < as->rank; i++)
4948 : 177912 : if (!check_dimension (i, ar, as))
4949 : : return false;
4950 : :
4951 : : /* Local access has no coarray spec. */
4952 : 142724 : if (ar->codimen != 0)
4953 : 4499 : for (i = as->rank; i < as->rank + as->corank; i++)
4954 : : {
4955 : 2378 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4956 : 107 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4957 : : {
4958 : 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
4959 : 2 : i + 1 - as->rank, &ar->where);
4960 : 2 : return false;
4961 : : }
4962 : 2376 : if (!check_dimension (i, ar, as))
4963 : : return false;
4964 : : }
4965 : :
4966 : : return true;
4967 : : }
4968 : :
4969 : :
4970 : : /* Resolve one part of an array index. */
4971 : :
4972 : : static bool
4973 : 597096 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4974 : : int force_index_integer_kind)
4975 : : {
4976 : 597096 : gfc_typespec ts;
4977 : :
4978 : 597096 : if (index == NULL)
4979 : : return true;
4980 : :
4981 : 191331 : if (!gfc_resolve_expr (index))
4982 : : return false;
4983 : :
4984 : 191321 : if (check_scalar && index->rank != 0)
4985 : : {
4986 : 1 : gfc_error ("Array index at %L must be scalar", &index->where);
4987 : 1 : return false;
4988 : : }
4989 : :
4990 : 191320 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4991 : : {
4992 : 1 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
4993 : : &index->where, gfc_basic_typename (index->ts.type));
4994 : 1 : return false;
4995 : : }
4996 : :
4997 : 191319 : if (index->ts.type == BT_REAL)
4998 : 336 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4999 : : &index->where))
5000 : : return false;
5001 : :
5002 : 191319 : if ((index->ts.kind != gfc_index_integer_kind
5003 : 187326 : && force_index_integer_kind)
5004 : 163010 : || index->ts.type != BT_INTEGER)
5005 : : {
5006 : 28644 : gfc_clear_ts (&ts);
5007 : 28644 : ts.type = BT_INTEGER;
5008 : 28644 : ts.kind = gfc_index_integer_kind;
5009 : :
5010 : 28644 : gfc_convert_type_warn (index, &ts, 2, 0);
5011 : : }
5012 : :
5013 : : return true;
5014 : : }
5015 : :
5016 : : /* Resolve one part of an array index. */
5017 : :
5018 : : bool
5019 : 398293 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5020 : : {
5021 : 398293 : return gfc_resolve_index_1 (index, check_scalar, 1);
5022 : : }
5023 : :
5024 : : /* Resolve a dim argument to an intrinsic function. */
5025 : :
5026 : : bool
5027 : 14787 : gfc_resolve_dim_arg (gfc_expr *dim)
5028 : : {
5029 : 14787 : if (dim == NULL)
5030 : : return true;
5031 : :
5032 : 14787 : if (!gfc_resolve_expr (dim))
5033 : : return false;
5034 : :
5035 : 14787 : if (dim->rank != 0)
5036 : : {
5037 : 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5038 : 0 : return false;
5039 : :
5040 : : }
5041 : :
5042 : 14787 : if (dim->ts.type != BT_INTEGER)
5043 : : {
5044 : 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5045 : 0 : return false;
5046 : : }
5047 : :
5048 : 14787 : if (dim->ts.kind != gfc_index_integer_kind)
5049 : : {
5050 : 9353 : gfc_typespec ts;
5051 : :
5052 : 9353 : gfc_clear_ts (&ts);
5053 : 9353 : ts.type = BT_INTEGER;
5054 : 9353 : ts.kind = gfc_index_integer_kind;
5055 : :
5056 : 9353 : gfc_convert_type_warn (dim, &ts, 2, 0);
5057 : : }
5058 : :
5059 : : return true;
5060 : : }
5061 : :
5062 : : /* Given an expression that contains array references, update those array
5063 : : references to point to the right array specifications. While this is
5064 : : filled in during matching, this information is difficult to save and load
5065 : : in a module, so we take care of it here.
5066 : :
5067 : : The idea here is that the original array reference comes from the
5068 : : base symbol. We traverse the list of reference structures, setting
5069 : : the stored reference to references. Component references can
5070 : : provide an additional array specification. */
5071 : : static void
5072 : : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5073 : :
5074 : : static bool
5075 : 853 : find_array_spec (gfc_expr *e)
5076 : : {
5077 : 853 : gfc_array_spec *as;
5078 : 853 : gfc_component *c;
5079 : 853 : gfc_ref *ref;
5080 : 853 : bool class_as = false;
5081 : :
5082 : 853 : if (e->symtree->n.sym->assoc)
5083 : : {
5084 : 203 : if (e->symtree->n.sym->assoc->target)
5085 : 203 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5086 : 203 : resolve_assoc_var (e->symtree->n.sym, false);
5087 : : }
5088 : :
5089 : 853 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5090 : : {
5091 : 106 : as = CLASS_DATA (e->symtree->n.sym)->as;
5092 : 106 : class_as = true;
5093 : : }
5094 : : else
5095 : 747 : as = e->symtree->n.sym->as;
5096 : :
5097 : 1944 : for (ref = e->ref; ref; ref = ref->next)
5098 : 1098 : switch (ref->type)
5099 : : {
5100 : 855 : case REF_ARRAY:
5101 : 855 : if (as == NULL)
5102 : : {
5103 : 7 : locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where;
5104 : 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5105 : : &loc);
5106 : 7 : return false;
5107 : : }
5108 : :
5109 : 848 : ref->u.ar.as = as;
5110 : 848 : as = NULL;
5111 : 848 : break;
5112 : :
5113 : 219 : case REF_COMPONENT:
5114 : 219 : c = ref->u.c.component;
5115 : 219 : if (c->attr.dimension)
5116 : : {
5117 : 90 : if (as != NULL && !(class_as && as == c->as))
5118 : 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5119 : 90 : as = c->as;
5120 : : }
5121 : :
5122 : : break;
5123 : :
5124 : : case REF_SUBSTRING:
5125 : : case REF_INQUIRY:
5126 : : break;
5127 : : }
5128 : :
5129 : 846 : if (as != NULL)
5130 : 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5131 : :
5132 : : return true;
5133 : : }
5134 : :
5135 : :
5136 : : /* Resolve an array reference. */
5137 : :
5138 : : static bool
5139 : 353639 : resolve_array_ref (gfc_array_ref *ar)
5140 : : {
5141 : 353639 : int i, check_scalar;
5142 : 353639 : gfc_expr *e;
5143 : :
5144 : 552430 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5145 : : {
5146 : 198803 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5147 : :
5148 : : /* Do not force gfc_index_integer_kind for the start. We can
5149 : : do fine with any integer kind. This avoids temporary arrays
5150 : : created for indexing with a vector. */
5151 : 198803 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5152 : : return false;
5153 : 198792 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5154 : : return false;
5155 : 198791 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5156 : : return false;
5157 : :
5158 : 198791 : e = ar->start[i];
5159 : :
5160 : 198791 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5161 : 129938 : switch (e->rank)
5162 : : {
5163 : 129083 : case 0:
5164 : 129083 : ar->dimen_type[i] = DIMEN_ELEMENT;
5165 : 129083 : break;
5166 : :
5167 : 855 : case 1:
5168 : 855 : ar->dimen_type[i] = DIMEN_VECTOR;
5169 : 855 : if (e->expr_type == EXPR_VARIABLE
5170 : 466 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5171 : 13 : ar->start[i] = gfc_get_parentheses (e);
5172 : : break;
5173 : :
5174 : 0 : default:
5175 : 0 : gfc_error ("Array index at %L is an array of rank %d",
5176 : : &ar->c_where[i], e->rank);
5177 : 0 : return false;
5178 : : }
5179 : :
5180 : : /* Fill in the upper bound, which may be lower than the
5181 : : specified one for something like a(2:10:5), which is
5182 : : identical to a(2:7:5). Only relevant for strides not equal
5183 : : to one. Don't try a division by zero. */
5184 : 198791 : if (ar->dimen_type[i] == DIMEN_RANGE
5185 : 56771 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5186 : 7397 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5187 : 7246 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5188 : : {
5189 : 7245 : mpz_t size, end;
5190 : :
5191 : 7245 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5192 : : {
5193 : 5854 : if (ar->end[i] == NULL)
5194 : : {
5195 : 7644 : ar->end[i] =
5196 : 3822 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5197 : : &ar->where);
5198 : 3822 : mpz_set (ar->end[i]->value.integer, end);
5199 : : }
5200 : 2032 : else if (ar->end[i]->ts.type == BT_INTEGER
5201 : 2032 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5202 : : {
5203 : 2032 : mpz_set (ar->end[i]->value.integer, end);
5204 : : }
5205 : : else
5206 : 0 : gcc_unreachable ();
5207 : :
5208 : 5854 : mpz_clear (size);
5209 : 5854 : mpz_clear (end);
5210 : : }
5211 : : }
5212 : : }
5213 : :
5214 : 353627 : if (ar->type == AR_FULL)
5215 : : {
5216 : 213876 : if (ar->as->rank == 0)
5217 : 3672 : ar->type = AR_ELEMENT;
5218 : :
5219 : : /* Make sure array is the same as array(:,:), this way
5220 : : we don't need to special case all the time. */
5221 : 213876 : ar->dimen = ar->as->rank;
5222 : 494622 : for (i = 0; i < ar->dimen; i++)
5223 : : {
5224 : 280746 : ar->dimen_type[i] = DIMEN_RANGE;
5225 : :
5226 : 280746 : gcc_assert (ar->start[i] == NULL);
5227 : 280746 : gcc_assert (ar->end[i] == NULL);
5228 : 280746 : gcc_assert (ar->stride[i] == NULL);
5229 : : }
5230 : : }
5231 : :
5232 : : /* If the reference type is unknown, figure out what kind it is. */
5233 : :
5234 : 353627 : if (ar->type == AR_UNKNOWN)
5235 : : {
5236 : 130980 : ar->type = AR_ELEMENT;
5237 : 255997 : for (i = 0; i < ar->dimen; i++)
5238 : 157596 : if (ar->dimen_type[i] == DIMEN_RANGE
5239 : 157596 : || ar->dimen_type[i] == DIMEN_VECTOR)
5240 : : {
5241 : 32579 : ar->type = AR_SECTION;
5242 : 32579 : break;
5243 : : }
5244 : : }
5245 : :
5246 : 353627 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5247 : : return false;
5248 : :
5249 : 353589 : if (ar->as->corank && ar->codimen == 0)
5250 : : {
5251 : 7687 : int n;
5252 : 7687 : ar->codimen = ar->as->corank;
5253 : 17833 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5254 : 10146 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5255 : : }
5256 : :
5257 : : return true;
5258 : : }
5259 : :
5260 : :
5261 : : bool
5262 : 8069 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5263 : : {
5264 : 8069 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5265 : :
5266 : 8069 : if (ref->u.ss.start != NULL)
5267 : : {
5268 : 8069 : if (!gfc_resolve_expr (ref->u.ss.start))
5269 : : return false;
5270 : :
5271 : 8069 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5272 : : {
5273 : 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5274 : : &ref->u.ss.start->where);
5275 : 1 : return false;
5276 : : }
5277 : :
5278 : 8068 : if (ref->u.ss.start->rank != 0)
5279 : : {
5280 : 0 : gfc_error ("Substring start index at %L must be scalar",
5281 : : &ref->u.ss.start->where);
5282 : 0 : return false;
5283 : : }
5284 : :
5285 : 8068 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5286 : 8068 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5287 : 34 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5288 : : {
5289 : 1 : gfc_error ("Substring start index at %L is less than one",
5290 : : &ref->u.ss.start->where);
5291 : 1 : return false;
5292 : : }
5293 : : }
5294 : :
5295 : 8067 : if (ref->u.ss.end != NULL)
5296 : : {
5297 : 7926 : if (!gfc_resolve_expr (ref->u.ss.end))
5298 : : return false;
5299 : :
5300 : 7926 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5301 : : {
5302 : 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5303 : : &ref->u.ss.end->where);
5304 : 1 : return false;
5305 : : }
5306 : :
5307 : 7925 : if (ref->u.ss.end->rank != 0)
5308 : : {
5309 : 0 : gfc_error ("Substring end index at %L must be scalar",
5310 : : &ref->u.ss.end->where);
5311 : 0 : return false;
5312 : : }
5313 : :
5314 : 7925 : if (ref->u.ss.length != NULL
5315 : 7591 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5316 : 7935 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5317 : 10 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5318 : : {
5319 : 4 : gfc_error ("Substring end index at %L exceeds the string length",
5320 : : &ref->u.ss.start->where);
5321 : 4 : return false;
5322 : : }
5323 : :
5324 : 7921 : if (compare_bound_mpz_t (ref->u.ss.end,
5325 : 7921 : gfc_integer_kinds[k].huge) == CMP_GT
5326 : 7921 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5327 : 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5328 : : {
5329 : 4 : gfc_error ("Substring end index at %L is too large",
5330 : : &ref->u.ss.end->where);
5331 : 4 : return false;
5332 : : }
5333 : : /* If the substring has the same length as the original
5334 : : variable, the reference itself can be deleted. */
5335 : :
5336 : 7917 : if (ref->u.ss.length != NULL
5337 : 7583 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5338 : 8838 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5339 : 228 : *equal_length = true;
5340 : : }
5341 : :
5342 : : return true;
5343 : : }
5344 : :
5345 : :
5346 : : /* This function supplies missing substring charlens. */
5347 : :
5348 : : void
5349 : 4348 : gfc_resolve_substring_charlen (gfc_expr *e)
5350 : : {
5351 : 4348 : gfc_ref *char_ref;
5352 : 4348 : gfc_expr *start, *end;
5353 : 4348 : gfc_typespec *ts = NULL;
5354 : 4348 : mpz_t diff;
5355 : :
5356 : 8335 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5357 : : {
5358 : 6498 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5359 : : break;
5360 : 3987 : if (char_ref->type == REF_COMPONENT)
5361 : 242 : ts = &char_ref->u.c.component->ts;
5362 : : }
5363 : :
5364 : 4348 : if (!char_ref || char_ref->type == REF_INQUIRY)
5365 : 1887 : return;
5366 : :
5367 : 2511 : gcc_assert (char_ref->next == NULL);
5368 : :
5369 : 2511 : if (e->ts.u.cl)
5370 : : {
5371 : 120 : if (e->ts.u.cl->length)
5372 : 108 : gfc_free_expr (e->ts.u.cl->length);
5373 : 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5374 : : return;
5375 : : }
5376 : :
5377 : 2499 : if (!e->ts.u.cl)
5378 : 2391 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5379 : :
5380 : 2499 : if (char_ref->u.ss.start)
5381 : 2499 : start = gfc_copy_expr (char_ref->u.ss.start);
5382 : : else
5383 : 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5384 : :
5385 : 2499 : if (char_ref->u.ss.end)
5386 : 2461 : end = gfc_copy_expr (char_ref->u.ss.end);
5387 : 38 : else if (e->expr_type == EXPR_VARIABLE)
5388 : : {
5389 : 38 : if (!ts)
5390 : 20 : ts = &e->symtree->n.sym->ts;
5391 : 38 : end = gfc_copy_expr (ts->u.cl->length);
5392 : : }
5393 : : else
5394 : : end = NULL;
5395 : :
5396 : 2499 : if (!start || !end)
5397 : : {
5398 : 38 : gfc_free_expr (start);
5399 : 38 : gfc_free_expr (end);
5400 : 38 : return;
5401 : : }
5402 : :
5403 : : /* Length = (end - start + 1).
5404 : : Check first whether it has a constant length. */
5405 : 2461 : if (gfc_dep_difference (end, start, &diff))
5406 : : {
5407 : 2353 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5408 : : &e->where);
5409 : :
5410 : 2353 : mpz_add_ui (len->value.integer, diff, 1);
5411 : 2353 : mpz_clear (diff);
5412 : 2353 : e->ts.u.cl->length = len;
5413 : : /* The check for length < 0 is handled below */
5414 : : }
5415 : : else
5416 : : {
5417 : 108 : e->ts.u.cl->length = gfc_subtract (end, start);
5418 : 108 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5419 : : gfc_get_int_expr (gfc_charlen_int_kind,
5420 : : NULL, 1));
5421 : : }
5422 : :
5423 : : /* F2008, 6.4.1: Both the starting point and the ending point shall
5424 : : be within the range 1, 2, ..., n unless the starting point exceeds
5425 : : the ending point, in which case the substring has length zero. */
5426 : :
5427 : 2461 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5428 : 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5429 : :
5430 : 2461 : e->ts.u.cl->length->ts.type = BT_INTEGER;
5431 : 2461 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5432 : :
5433 : : /* Make sure that the length is simplified. */
5434 : 2461 : gfc_simplify_expr (e->ts.u.cl->length, 1);
5435 : 2461 : gfc_resolve_expr (e->ts.u.cl->length);
5436 : : }
5437 : :
5438 : :
5439 : : /* Resolve subtype references. */
5440 : :
5441 : : bool
5442 : 452737 : gfc_resolve_ref (gfc_expr *expr)
5443 : : {
5444 : 452737 : int current_part_dimension, n_components, seen_part_dimension, dim;
5445 : 452737 : gfc_ref *ref, **prev, *array_ref;
5446 : 452737 : bool equal_length;
5447 : :
5448 : 886399 : for (ref = expr->ref; ref; ref = ref->next)
5449 : 434515 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5450 : : {
5451 : 853 : if (!find_array_spec (expr))
5452 : : return false;
5453 : : break;
5454 : : }
5455 : :
5456 : 887326 : for (prev = &expr->ref; *prev != NULL;
5457 : 434596 : prev = *prev == NULL ? prev : &(*prev)->next)
5458 : 434654 : switch ((*prev)->type)
5459 : : {
5460 : 353639 : case REF_ARRAY:
5461 : 353639 : if (!resolve_array_ref (&(*prev)->u.ar))
5462 : : return false;
5463 : : break;
5464 : :
5465 : : case REF_COMPONENT:
5466 : : case REF_INQUIRY:
5467 : : break;
5468 : :
5469 : 7792 : case REF_SUBSTRING:
5470 : 7792 : equal_length = false;
5471 : 7792 : if (!gfc_resolve_substring (*prev, &equal_length))
5472 : : return false;
5473 : :
5474 : 7784 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
5475 : : {
5476 : : /* Remove the reference and move the charlen, if any. */
5477 : 203 : ref = *prev;
5478 : 203 : *prev = ref->next;
5479 : 203 : ref->next = NULL;
5480 : 203 : expr->ts.u.cl = ref->u.ss.length;
5481 : 203 : ref->u.ss.length = NULL;
5482 : 203 : gfc_free_ref_list (ref);
5483 : : }
5484 : : break;
5485 : : }
5486 : :
5487 : : /* Check constraints on part references. */
5488 : :
5489 : 452672 : current_part_dimension = 0;
5490 : 452672 : seen_part_dimension = 0;
5491 : 452672 : n_components = 0;
5492 : 452672 : array_ref = NULL;
5493 : :
5494 : 887040 : for (ref = expr->ref; ref; ref = ref->next)
5495 : : {
5496 : 434379 : switch (ref->type)
5497 : : {
5498 : 353582 : case REF_ARRAY:
5499 : 353582 : array_ref = ref;
5500 : 353582 : switch (ref->u.ar.type)
5501 : : {
5502 : 210202 : case AR_FULL:
5503 : : /* Coarray scalar. */
5504 : 210202 : if (ref->u.ar.as->rank == 0)
5505 : : {
5506 : : current_part_dimension = 0;
5507 : : break;
5508 : : }
5509 : : /* Fall through. */
5510 : 244678 : case AR_SECTION:
5511 : 244678 : current_part_dimension = 1;
5512 : 244678 : break;
5513 : :
5514 : 108904 : case AR_ELEMENT:
5515 : 108904 : array_ref = NULL;
5516 : 108904 : current_part_dimension = 0;
5517 : 108904 : break;
5518 : :
5519 : 0 : case AR_UNKNOWN:
5520 : 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
5521 : : }
5522 : :
5523 : : break;
5524 : :
5525 : 72667 : case REF_COMPONENT:
5526 : 72667 : if (current_part_dimension || seen_part_dimension)
5527 : : {
5528 : : /* F03:C614. */
5529 : 5148 : if (ref->u.c.component->attr.pointer
5530 : 5148 : || ref->u.c.component->attr.proc_pointer
5531 : 5144 : || (ref->u.c.component->ts.type == BT_CLASS
5532 : 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
5533 : : {
5534 : 4 : gfc_error ("Component to the right of a part reference "
5535 : : "with nonzero rank must not have the POINTER "
5536 : : "attribute at %L", &expr->where);
5537 : 4 : return false;
5538 : : }
5539 : 5144 : else if (ref->u.c.component->attr.allocatable
5540 : 5138 : || (ref->u.c.component->ts.type == BT_CLASS
5541 : 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5542 : :
5543 : : {
5544 : 7 : gfc_error ("Component to the right of a part reference "
5545 : : "with nonzero rank must not have the ALLOCATABLE "
5546 : : "attribute at %L", &expr->where);
5547 : 7 : return false;
5548 : : }
5549 : : }
5550 : :
5551 : 72656 : n_components++;
5552 : 72656 : break;
5553 : :
5554 : : case REF_SUBSTRING:
5555 : : break;
5556 : :
5557 : 549 : case REF_INQUIRY:
5558 : : /* Implement requirement in note 9.7 of F2018 that the result of the
5559 : : LEN inquiry be a scalar. */
5560 : 549 : if (ref->u.i == INQUIRY_LEN && array_ref
5561 : 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
5562 : 40 : || expr->ts.type == BT_INTEGER))
5563 : : {
5564 : 14 : array_ref->u.ar.type = AR_ELEMENT;
5565 : 14 : expr->rank = 0;
5566 : : /* INQUIRY_LEN is not evaluated from the rest of the expr
5567 : : but directly from the string length. This means that setting
5568 : : the array indices to one does not matter but might trigger
5569 : : a runtime bounds error. Suppress the check. */
5570 : 14 : expr->no_bounds_check = 1;
5571 : 28 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5572 : : {
5573 : 14 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5574 : 14 : if (array_ref->u.ar.start[dim])
5575 : 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
5576 : 14 : array_ref->u.ar.start[dim]
5577 : 14 : = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5578 : 14 : if (array_ref->u.ar.end[dim])
5579 : 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
5580 : 14 : if (array_ref->u.ar.stride[dim])
5581 : 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
5582 : : }
5583 : : }
5584 : : break;
5585 : : }
5586 : :
5587 : 434368 : if (((ref->type == REF_COMPONENT && n_components > 1)
5588 : 425034 : || ref->next == NULL)
5589 : : && current_part_dimension
5590 : 383769 : && seen_part_dimension)
5591 : : {
5592 : 0 : gfc_error ("Two or more part references with nonzero rank must "
5593 : : "not be specified at %L", &expr->where);
5594 : 0 : return false;
5595 : : }
5596 : :
5597 : 434368 : if (ref->type == REF_COMPONENT)
5598 : : {
5599 : 72656 : if (current_part_dimension)
5600 : 4968 : seen_part_dimension = 1;
5601 : :
5602 : : /* reset to make sure */
5603 : : current_part_dimension = 0;
5604 : : }
5605 : : }
5606 : :
5607 : : return true;
5608 : : }
5609 : :
5610 : :
5611 : : /* Given an expression, determine its shape. This is easier than it sounds.
5612 : : Leaves the shape array NULL if it is not possible to determine the shape. */
5613 : :
5614 : : static void
5615 : 1590190 : expression_shape (gfc_expr *e)
5616 : : {
5617 : 1590190 : mpz_t array[GFC_MAX_DIMENSIONS];
5618 : 1590190 : int i;
5619 : :
5620 : 1590190 : if (e->rank <= 0 || e->shape != NULL)
5621 : 1450192 : return;
5622 : :
5623 : 574175 : for (i = 0; i < e->rank; i++)
5624 : 383931 : if (!gfc_array_dimen_size (e, i, &array[i]))
5625 : 139998 : goto fail;
5626 : :
5627 : 190244 : e->shape = gfc_get_shape (e->rank);
5628 : :
5629 : 190244 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5630 : :
5631 : 190244 : return;
5632 : :
5633 : 139998 : fail:
5634 : 141677 : for (i--; i >= 0; i--)
5635 : 1679 : mpz_clear (array[i]);
5636 : : }
5637 : :
5638 : :
5639 : : /* Given a variable expression node, compute the rank of the expression by
5640 : : examining the base symbol and any reference structures it may have. */
5641 : :
5642 : : void
5643 : 1590190 : gfc_expression_rank (gfc_expr *e)
5644 : : {
5645 : 1590190 : gfc_ref *ref;
5646 : 1590190 : int i, rank;
5647 : :
5648 : : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5649 : : could lead to serious confusion... */
5650 : 1590190 : gcc_assert (e->expr_type != EXPR_COMPCALL);
5651 : :
5652 : 1590190 : if (e->ref == NULL)
5653 : : {
5654 : 1002945 : if (e->expr_type == EXPR_ARRAY)
5655 : 57280 : goto done;
5656 : : /* Constructors can have a rank different from one via RESHAPE(). */
5657 : :
5658 : 945653 : e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
5659 : 945967 : ? 0 : e->symtree->n.sym->as->rank);
5660 : 945665 : goto done;
5661 : : }
5662 : :
5663 : : rank = 0;
5664 : :
5665 : 931936 : for (ref = e->ref; ref; ref = ref->next)
5666 : : {
5667 : 667957 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5668 : 123082 : && ref->u.c.component->attr.function && !ref->next)
5669 : 341 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5670 : :
5671 : 667957 : if (ref->type != REF_ARRAY)
5672 : 129694 : continue;
5673 : :
5674 : 538263 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
5675 : : {
5676 : 285402 : rank = ref->u.ar.as->rank;
5677 : 285402 : break;
5678 : : }
5679 : :
5680 : 252861 : if (ref->u.ar.type == AR_SECTION)
5681 : : {
5682 : : /* Figure out the rank of the section. */
5683 : 37864 : if (rank != 0)
5684 : 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
5685 : :
5686 : 90878 : for (i = 0; i < ref->u.ar.dimen; i++)
5687 : 53014 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5688 : 53014 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5689 : 47466 : rank++;
5690 : :
5691 : : break;
5692 : : }
5693 : : }
5694 : :
5695 : 587245 : e->rank = rank;
5696 : :
5697 : 1590190 : done:
5698 : 1590190 : expression_shape (e);
5699 : 1590190 : }
5700 : :
5701 : :
5702 : : /* Given two expressions, check that their rank is conformable, i.e. either
5703 : : both have the same rank or at least one is a scalar. */
5704 : :
5705 : : bool
5706 : 11793784 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
5707 : : {
5708 : 11793784 : if (op1->expr_type == EXPR_VARIABLE)
5709 : 405629 : gfc_expression_rank (op1);
5710 : 11793784 : if (op2->expr_type == EXPR_VARIABLE)
5711 : 150736 : gfc_expression_rank (op2);
5712 : :
5713 : 11793784 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
5714 : : }
5715 : :
5716 : :
5717 : : static void
5718 : 1344 : add_caf_get_intrinsic (gfc_expr *e)
5719 : : {
5720 : 1344 : gfc_expr *wrapper, *tmp_expr;
5721 : 1344 : gfc_ref *ref;
5722 : 1344 : int n;
5723 : :
5724 : 1395 : for (ref = e->ref; ref; ref = ref->next)
5725 : 1395 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5726 : : break;
5727 : 1344 : if (ref == NULL)
5728 : : return;
5729 : :
5730 : 2575 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5731 : 1391 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
5732 : : return;
5733 : :
5734 : 1184 : tmp_expr = XCNEW (gfc_expr);
5735 : 1184 : *tmp_expr = *e;
5736 : 1184 : wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
5737 : : "caf_get", tmp_expr->where, 1, tmp_expr);
5738 : 1184 : wrapper->ts = e->ts;
5739 : 1184 : wrapper->rank = e->rank;
5740 : 1184 : if (e->rank)
5741 : 658 : wrapper->shape = gfc_copy_shape (e->shape, e->rank);
5742 : 1184 : *e = *wrapper;
5743 : 1184 : free (wrapper);
5744 : : }
5745 : :
5746 : :
5747 : : static void
5748 : 662 : remove_caf_get_intrinsic (gfc_expr *e)
5749 : : {
5750 : 662 : gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
5751 : : && e->value.function.isym->id == GFC_ISYM_CAF_GET);
5752 : 662 : gfc_expr *e2 = e->value.function.actual->expr;
5753 : 662 : e->value.function.actual->expr = NULL;
5754 : 662 : gfc_free_actual_arglist (e->value.function.actual);
5755 : 662 : gfc_free_shape (&e->shape, e->rank);
5756 : 662 : *e = *e2;
5757 : 662 : free (e2);
5758 : 662 : }
5759 : :
5760 : :
5761 : : /* Resolve a variable expression. */
5762 : :
5763 : : static bool
5764 : 966400 : resolve_variable (gfc_expr *e)
5765 : : {
5766 : 966400 : gfc_symbol *sym;
5767 : 966400 : bool t;
5768 : :
5769 : 966400 : t = true;
5770 : :
5771 : 966400 : if (e->symtree == NULL)
5772 : : return false;
5773 : 966021 : sym = e->symtree->n.sym;
5774 : :
5775 : : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5776 : : as ts.type is set to BT_ASSUMED in resolve_symbol. */
5777 : 966021 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
5778 : : {
5779 : 167 : if (!actual_arg || inquiry_argument)
5780 : : {
5781 : 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5782 : : "be used as actual argument", sym->name, &e->where);
5783 : 2 : return false;
5784 : : }
5785 : : }
5786 : : /* TS 29113, 407b. */
5787 : 965854 : else if (e->ts.type == BT_ASSUMED)
5788 : : {
5789 : 555 : if (!actual_arg)
5790 : : {
5791 : 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
5792 : : "as actual argument", sym->name, &e->where);
5793 : 20 : return false;
5794 : : }
5795 : 535 : else if (inquiry_argument && !first_actual_arg)
5796 : : {
5797 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
5798 : : for all inquiry functions in resolve_function; the reason is
5799 : : that the function-name resolution happens too late in that
5800 : : function. */
5801 : 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
5802 : : "an inquiry function shall be the first argument",
5803 : : sym->name, &e->where);
5804 : 0 : return false;
5805 : : }
5806 : : }
5807 : : /* TS 29113, C535b. */
5808 : 965299 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5809 : 32995 : && sym->ts.u.derived && CLASS_DATA (sym)
5810 : 32989 : && CLASS_DATA (sym)->as
5811 : 12248 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5812 : 964438 : || (sym->ts.type != BT_CLASS && sym->as
5813 : 307223 : && sym->as->type == AS_ASSUMED_RANK))
5814 : 7577 : && !sym->attr.select_rank_temporary)
5815 : : {
5816 : 7577 : if (!actual_arg
5817 : 1189 : && !(cs_base && cs_base->current
5818 : 1188 : && cs_base->current->op == EXEC_SELECT_RANK))
5819 : : {
5820 : 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
5821 : : "actual argument", sym->name, &e->where);
5822 : 144 : return false;
5823 : : }
5824 : 7433 : else if (inquiry_argument && !first_actual_arg)
5825 : : {
5826 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
5827 : : for all inquiry functions in resolve_function; the reason is
5828 : : that the function-name resolution happens too late in that
5829 : : function. */
5830 : 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
5831 : : "to an inquiry function shall be the first argument",
5832 : : sym->name, &e->where);
5833 : 0 : return false;
5834 : : }
5835 : : }
5836 : :
5837 : 965855 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
5838 : 165 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5839 : 164 : && e->ref->next == NULL))
5840 : : {
5841 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5842 : : "a subobject reference", sym->name, &e->ref->u.ar.where);
5843 : 1 : return false;
5844 : : }
5845 : : /* TS 29113, 407b. */
5846 : 965854 : else if (e->ts.type == BT_ASSUMED && e->ref
5847 : 655 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5848 : 648 : && e->ref->next == NULL))
5849 : : {
5850 : 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5851 : : "reference", sym->name, &e->ref->u.ar.where);
5852 : 7 : return false;
5853 : : }
5854 : :
5855 : : /* TS 29113, C535b. */
5856 : 965847 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5857 : 32995 : && sym->ts.u.derived && CLASS_DATA (sym)
5858 : 32989 : && CLASS_DATA (sym)->as
5859 : 12248 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5860 : 964986 : || (sym->ts.type != BT_CLASS && sym->as
5861 : 307727 : && sym->as->type == AS_ASSUMED_RANK))
5862 : 7701 : && e->ref
5863 : 7701 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5864 : 7697 : && e->ref->next == NULL))
5865 : : {
5866 : 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5867 : : "reference", sym->name, &e->ref->u.ar.where);
5868 : 4 : return false;
5869 : : }
5870 : :
5871 : : /* Guessed type variables are associate_names whose selector had not been
5872 : : parsed at the time that the construct was parsed. Now the namespace is
5873 : : being resolved, the TKR of the selector will be available for fixup of
5874 : : the associate_name. */
5875 : 965843 : if (IS_INFERRED_TYPE (e) && e->ref)
5876 : : {
5877 : 354 : gfc_fixup_inferred_type_refs (e);
5878 : : /* KIND inquiry ref returns the kind of the target. */
5879 : 354 : if (e->expr_type == EXPR_CONSTANT)
5880 : : return true;
5881 : : }
5882 : :
5883 : : /* For variables that are used in an associate (target => object) where
5884 : : the object's basetype is array valued while the target is scalar,
5885 : : the ts' type of the component refs is still array valued, which
5886 : : can't be translated that way. */
5887 : 965831 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
5888 : 487 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
5889 : 487 : && sym->assoc->target->ts.u.derived
5890 : 486 : && CLASS_DATA (sym->assoc->target)
5891 : 486 : && CLASS_DATA (sym->assoc->target)->as)
5892 : : {
5893 : : gfc_ref *ref = e->ref;
5894 : 515 : while (ref)
5895 : : {
5896 : 400 : switch (ref->type)
5897 : : {
5898 : 188 : case REF_COMPONENT:
5899 : 188 : ref->u.c.sym = sym->ts.u.derived;
5900 : : /* Stop the loop. */
5901 : 188 : ref = NULL;
5902 : 188 : break;
5903 : 212 : default:
5904 : 212 : ref = ref->next;
5905 : 212 : break;
5906 : : }
5907 : : }
5908 : : }
5909 : :
5910 : : /* If this is an associate-name, it may be parsed with an array reference
5911 : : in error even though the target is scalar. Fail directly in this case.
5912 : : TODO Understand why class scalar expressions must be excluded. */
5913 : 965831 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5914 : : {
5915 : 10082 : if (sym->ts.type == BT_CLASS)
5916 : 218 : gfc_fix_class_refs (e);
5917 : 10082 : if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5918 : : {
5919 : : /* Unambiguously scalar! */
5920 : 3 : if (sym->assoc->target
5921 : 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
5922 : 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
5923 : 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
5924 : : sym->name, &e->where);
5925 : 3 : return false;
5926 : : }
5927 : 10079 : else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
5928 : : {
5929 : : /* This can happen because the parser did not detect that the
5930 : : associate name is an array and the expression had no array
5931 : : part_ref. */
5932 : 122 : gfc_ref *ref = gfc_get_ref ();
5933 : 122 : ref->type = REF_ARRAY;
5934 : 122 : ref->u.ar.type = AR_FULL;
5935 : 122 : if (sym->as)
5936 : : {
5937 : 121 : ref->u.ar.as = sym->as;
5938 : 121 : ref->u.ar.dimen = sym->as->rank;
5939 : : }
5940 : 122 : ref->next = e->ref;
5941 : 122 : e->ref = ref;
5942 : :
5943 : : }
5944 : : }
5945 : :
5946 : 965828 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5947 : 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5948 : :
5949 : : /* On the other hand, the parser may not have known this is an array;
5950 : : in this case, we have to add a FULL reference. */
5951 : 965828 : if (sym->assoc && sym->attr.dimension && !e->ref)
5952 : : {
5953 : 0 : e->ref = gfc_get_ref ();
5954 : 0 : e->ref->type = REF_ARRAY;
5955 : 0 : e->ref->u.ar.type = AR_FULL;
5956 : 0 : e->ref->u.ar.dimen = 0;
5957 : : }
5958 : :
5959 : : /* Like above, but for class types, where the checking whether an array
5960 : : ref is present is more complicated. Furthermore make sure not to add
5961 : : the full array ref to _vptr or _len refs. */
5962 : 965828 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
5963 : 843 : && CLASS_DATA (sym)
5964 : 843 : && CLASS_DATA (sym)->attr.dimension
5965 : 454 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5966 : : {
5967 : 430 : gfc_ref *ref, *newref;
5968 : :
5969 : 430 : newref = gfc_get_ref ();
5970 : 430 : newref->type = REF_ARRAY;
5971 : 430 : newref->u.ar.type = AR_FULL;
5972 : 430 : newref->u.ar.dimen = 0;
5973 : : /* Because this is an associate var and the first ref either is a ref to
5974 : : the _data component or not, no traversal of the ref chain is
5975 : : needed. The array ref needs to be inserted after the _data ref,
5976 : : or when that is not present, which may happened for polymorphic
5977 : : types, then at the first position. */
5978 : 430 : ref = e->ref;
5979 : 430 : if (!ref)
5980 : 12 : e->ref = newref;
5981 : 418 : else if (ref->type == REF_COMPONENT
5982 : 206 : && strcmp ("_data", ref->u.c.component->name) == 0)
5983 : : {
5984 : 206 : if (!ref->next || ref->next->type != REF_ARRAY)
5985 : : {
5986 : 12 : newref->next = ref->next;
5987 : 12 : ref->next = newref;
5988 : : }
5989 : : else
5990 : : /* Array ref present already. */
5991 : 194 : gfc_free_ref_list (newref);
5992 : : }
5993 : 212 : else if (ref->type == REF_ARRAY)
5994 : : /* Array ref present already. */
5995 : 212 : gfc_free_ref_list (newref);
5996 : : else
5997 : : {
5998 : 0 : newref->next = ref;
5999 : 0 : e->ref = newref;
6000 : : }
6001 : : }
6002 : :
6003 : 965828 : if (e->ref && !gfc_resolve_ref (e))
6004 : : return false;
6005 : :
6006 : 965758 : if (sym->attr.flavor == FL_PROCEDURE
6007 : 29304 : && (!sym->attr.function
6008 : 17688 : || (sym->attr.function && sym->result
6009 : : && sym->result->attr.proc_pointer
6010 : 17257 : && !sym->result->attr.function)))
6011 : : {
6012 : 11616 : e->ts.type = BT_PROCEDURE;
6013 : 11616 : goto resolve_procedure;
6014 : : }
6015 : :
6016 : 954142 : if (sym->ts.type != BT_UNKNOWN)
6017 : 953678 : gfc_variable_attr (e, &e->ts);
6018 : 464 : else if (sym->attr.flavor == FL_PROCEDURE
6019 : 12 : && sym->attr.function && sym->result
6020 : 12 : && sym->result->ts.type != BT_UNKNOWN
6021 : 10 : && sym->result->attr.proc_pointer)
6022 : 10 : e->ts = sym->result->ts;
6023 : : else
6024 : : {
6025 : : /* Must be a simple variable reference. */
6026 : 454 : if (!gfc_set_default_type (sym, 1, sym->ns))
6027 : : return false;
6028 : 336 : e->ts = sym->ts;
6029 : : }
6030 : :
6031 : 954024 : if (check_assumed_size_reference (sym, e))
6032 : : return false;
6033 : :
6034 : : /* Deal with forward references to entries during gfc_resolve_code, to
6035 : : satisfy, at least partially, 12.5.2.5. */
6036 : 954008 : if (gfc_current_ns->entries
6037 : 3057 : && current_entry_id == sym->entry_id
6038 : 1000 : && cs_base
6039 : 914 : && cs_base->current
6040 : 914 : && cs_base->current->op != EXEC_ENTRY)
6041 : : {
6042 : 914 : gfc_entry_list *entry;
6043 : 914 : gfc_formal_arglist *formal;
6044 : 914 : int n;
6045 : 914 : bool seen, saved_specification_expr;
6046 : :
6047 : : /* If the symbol is a dummy... */
6048 : 914 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6049 : : {
6050 : : entry = gfc_current_ns->entries;
6051 : : seen = false;
6052 : :
6053 : : /* ...test if the symbol is a parameter of previous entries. */
6054 : 1033 : for (; entry && entry->id <= current_entry_id; entry = entry->next)
6055 : 1006 : for (formal = entry->sym->formal; formal; formal = formal->next)
6056 : : {
6057 : 997 : if (formal->sym && sym->name == formal->sym->name)
6058 : : {
6059 : : seen = true;
6060 : : break;
6061 : : }
6062 : : }
6063 : :
6064 : : /* If it has not been seen as a dummy, this is an error. */
6065 : 453 : if (!seen)
6066 : : {
6067 : 3 : if (specification_expr)
6068 : 2 : gfc_error ("Variable %qs, used in a specification expression"
6069 : : ", is referenced at %L before the ENTRY statement "
6070 : : "in which it is a parameter",
6071 : : sym->name, &cs_base->current->loc);
6072 : : else
6073 : 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6074 : : "statement in which it is a parameter",
6075 : : sym->name, &cs_base->current->loc);
6076 : : t = false;
6077 : : }
6078 : : }
6079 : :
6080 : : /* Now do the same check on the specification expressions. */
6081 : 914 : saved_specification_expr = specification_expr;
6082 : 914 : specification_expr = true;
6083 : 914 : if (sym->ts.type == BT_CHARACTER
6084 : 914 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6085 : : t = false;
6086 : :
6087 : 914 : if (sym->as)
6088 : 271 : for (n = 0; n < sym->as->rank; n++)
6089 : : {
6090 : 159 : if (!gfc_resolve_expr (sym->as->lower[n]))
6091 : 0 : t = false;
6092 : 159 : if (!gfc_resolve_expr (sym->as->upper[n]))
6093 : 1 : t = false;
6094 : : }
6095 : 914 : specification_expr = saved_specification_expr;
6096 : :
6097 : 914 : if (t)
6098 : : /* Update the symbol's entry level. */
6099 : 909 : sym->entry_id = current_entry_id + 1;
6100 : : }
6101 : :
6102 : : /* If a symbol has been host_associated mark it. This is used latter,
6103 : : to identify if aliasing is possible via host association. */
6104 : 954008 : if (sym->attr.flavor == FL_VARIABLE
6105 : 924049 : && gfc_current_ns->parent
6106 : 307845 : && (gfc_current_ns->parent == sym->ns
6107 : 275182 : || (gfc_current_ns->parent->parent
6108 : 9934 : && gfc_current_ns->parent->parent == sym->ns)))
6109 : 38730 : sym->attr.host_assoc = 1;
6110 : :
6111 : 954008 : if (gfc_current_ns->proc_name
6112 : 950988 : && sym->attr.dimension
6113 : 302563 : && (sym->ns != gfc_current_ns
6114 : : || sym->attr.use_assoc
6115 : 284739 : || sym->attr.in_common))
6116 : 26373 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6117 : :
6118 : 965624 : resolve_procedure:
6119 : 965624 : if (t && !resolve_procedure_expression (e))
6120 : : t = false;
6121 : :
6122 : : /* F2008, C617 and C1229. */
6123 : 964715 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6124 : 1049792 : && gfc_is_coindexed (e))
6125 : : {
6126 : 284 : gfc_ref *ref, *ref2 = NULL;
6127 : :
6128 : 353 : for (ref = e->ref; ref; ref = ref->next)
6129 : : {
6130 : 353 : if (ref->type == REF_COMPONENT)
6131 : 69 : ref2 = ref;
6132 : 353 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6133 : : break;
6134 : : }
6135 : :
6136 : 568 : for ( ; ref; ref = ref->next)
6137 : 296 : if (ref->type == REF_COMPONENT)
6138 : : break;
6139 : :
6140 : : /* Expression itself is not coindexed object. */
6141 : 284 : if (ref && e->ts.type == BT_CLASS)
6142 : : {
6143 : 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6144 : : &e->where);
6145 : 3 : t = false;
6146 : : }
6147 : :
6148 : : /* Expression itself is coindexed object. */
6149 : 272 : if (ref == NULL)
6150 : : {
6151 : 272 : gfc_component *c;
6152 : 272 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6153 : 366 : for ( ; c; c = c->next)
6154 : 94 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6155 : : {
6156 : 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6157 : : "subcomponent at %L", &e->where);
6158 : 0 : t = false;
6159 : 0 : break;
6160 : : }
6161 : : }
6162 : : }
6163 : :
6164 : 965624 : if (t)
6165 : 965616 : gfc_expression_rank (e);
6166 : :
6167 : 965616 : if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
6168 : 1344 : add_caf_get_intrinsic (e);
6169 : :
6170 : 965624 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6171 : 3 : gfc_warning (OPT_Wdeprecated_declarations,
6172 : : "Using variable %qs at %L is deprecated",
6173 : : sym->name, &e->where);
6174 : : /* Simplify cases where access to a parameter array results in a
6175 : : single constant. Suppress errors since those will have been
6176 : : issued before, as warnings. */
6177 : 965624 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6178 : : {
6179 : 2458 : gfc_push_suppress_errors ();
6180 : 2458 : gfc_simplify_expr (e, 1);
6181 : 2458 : gfc_pop_suppress_errors ();
6182 : : }
6183 : :
6184 : : return t;
6185 : : }
6186 : :
6187 : :
6188 : : /* 'sym' was initially guessed to be derived type but has been corrected
6189 : : in resolve_assoc_var to be a class entity or the derived type correcting.
6190 : : If a class entity it will certainly need the _data reference or the
6191 : : reference derived type symbol correcting in the first component ref if
6192 : : a derived type. */
6193 : :
6194 : : void
6195 : 708 : gfc_fixup_inferred_type_refs (gfc_expr *e)
6196 : : {
6197 : 708 : gfc_ref *ref, *new_ref;
6198 : 708 : gfc_symbol *sym, *derived;
6199 : 708 : gfc_expr *target;
6200 : 708 : sym = e->symtree->n.sym;
6201 : :
6202 : : /* An associate_name whose selector is (i) a component ref of a selector
6203 : : that is a inferred type associate_name; or (ii) an intrinsic type that
6204 : : has been inferred from an inquiry ref. */
6205 : 708 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
6206 : : {
6207 : 282 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
6208 : 282 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
6209 : : {
6210 : 60 : ref = e->ref;
6211 : : /* A substring misidentified as an array section. */
6212 : 60 : if (sym->ts.type == BT_CHARACTER
6213 : 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
6214 : 6 : && !ref->u.ar.stride[0])
6215 : : {
6216 : 6 : new_ref = gfc_get_ref ();
6217 : 6 : new_ref->type = REF_SUBSTRING;
6218 : 6 : new_ref->u.ss.start = ref->u.ar.start[0];
6219 : 6 : new_ref->u.ss.end = ref->u.ar.end[0];
6220 : 6 : new_ref->u.ss.length = sym->ts.u.cl;
6221 : 6 : *ref = *new_ref;
6222 : 6 : free (new_ref);
6223 : : }
6224 : : else
6225 : : {
6226 : 54 : e->ref = ref->next;
6227 : 54 : free (ref);
6228 : : }
6229 : : }
6230 : :
6231 : : /* It is possible for an inquiry reference to be mistaken for a
6232 : : component reference. Correct this now. */
6233 : 282 : ref = e->ref;
6234 : 282 : if (ref && ref->type == REF_ARRAY)
6235 : 138 : ref = ref->next;
6236 : 150 : if (ref && ref->type == REF_COMPONENT
6237 : 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
6238 : : {
6239 : 12 : e->symtree->n.sym = sym;
6240 : 12 : *ref = *new_ref;
6241 : 12 : gfc_free_ref_list (new_ref);
6242 : : }
6243 : :
6244 : : /* The kind of the associate name is best evaluated directly from the
6245 : : selector because of the guesses made in primary.cc, when the type
6246 : : is still unknown. */
6247 : 282 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
6248 : : {
6249 : 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6250 : 12 : sym->assoc->target->ts.kind);
6251 : 12 : gfc_replace_expr (e, ne);
6252 : : }
6253 : :
6254 : : /* Now that the references are all sorted out, set the expression rank
6255 : : and return. */
6256 : 282 : gfc_expression_rank (e);
6257 : 282 : return;
6258 : : }
6259 : :
6260 : 426 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
6261 : : : sym->ts.u.derived;
6262 : :
6263 : : /* Ensure that class symbols have an array spec and ensure that there
6264 : : is a _data field reference following class type references. */
6265 : 426 : if (sym->ts.type == BT_CLASS
6266 : 186 : && sym->assoc->target->ts.type == BT_CLASS)
6267 : : {
6268 : 186 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
6269 : 186 : sym->attr.dimension = 0;
6270 : 186 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
6271 : 186 : if (e->ref && (e->ref->type != REF_COMPONENT
6272 : 150 : || e->ref->u.c.component->name[0] != '_'))
6273 : : {
6274 : 78 : ref = gfc_get_ref ();
6275 : 78 : ref->type = REF_COMPONENT;
6276 : 78 : ref->next = e->ref;
6277 : 78 : e->ref = ref;
6278 : 78 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
6279 : : true, true, NULL);
6280 : 78 : ref->u.c.sym = sym->ts.u.derived;
6281 : : }
6282 : : }
6283 : :
6284 : : /* Proceed as far as the first component reference and ensure that the
6285 : : correct derived type is being used. */
6286 : 618 : for (ref = e->ref; ref; ref = ref->next)
6287 : 582 : if (ref->type == REF_COMPONENT)
6288 : : {
6289 : 390 : if (ref->u.c.component->name[0] != '_')
6290 : 204 : ref->u.c.sym = derived;
6291 : : else
6292 : 186 : ref->u.c.sym = sym->ts.u.derived;
6293 : : break;
6294 : : }
6295 : :
6296 : : /* Verify that the type inferrence mechanism has not introduced a spurious
6297 : : array reference. This can happen with an associate name, whose selector
6298 : : is an element of another inferred type. */
6299 : 426 : target = e->symtree->n.sym->assoc->target;
6300 : 426 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
6301 : 108 : && e != target && !target->rank)
6302 : : {
6303 : : /* First case: array ref after the scalar class or derived
6304 : : associate_name. */
6305 : 108 : if (e->ref && e->ref->type == REF_ARRAY
6306 : 6 : && e->ref->u.ar.type != AR_ELEMENT)
6307 : : {
6308 : 6 : ref = e->ref;
6309 : 6 : e->ref = ref->next;
6310 : 6 : free (ref);
6311 : :
6312 : : /* If it hasn't a ref to the '_data' field supply one. */
6313 : 6 : if (sym->ts.type == BT_CLASS
6314 : 0 : && !(e->ref->type == REF_COMPONENT
6315 : 0 : && strcmp (e->ref->u.c.component->name, "_data")))
6316 : : {
6317 : 0 : gfc_ref *new_ref;
6318 : 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
6319 : : "_data", true, true, &new_ref);
6320 : 0 : new_ref->next = e->ref;
6321 : 0 : e->ref = new_ref;
6322 : : }
6323 : : }
6324 : : /* 2nd case: a ref to the '_data' field followed by an array ref. */
6325 : 102 : else if (e->ref && e->ref->type == REF_COMPONENT
6326 : 102 : && strcmp (e->ref->u.c.component->name, "_data") == 0
6327 : 60 : && e->ref->next && e->ref->next->type == REF_ARRAY
6328 : 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
6329 : : {
6330 : 0 : ref = e->ref->next;
6331 : 0 : e->ref->next = e->ref->next->next;
6332 : 0 : free (ref);
6333 : : }
6334 : : }
6335 : :
6336 : : /* Now that all the references are OK, get the expression rank. */
6337 : 426 : gfc_expression_rank (e);
6338 : : }
6339 : :
6340 : :
6341 : : /* Checks to see that the correct symbol has been host associated.
6342 : : The only situations where this arises are:
6343 : : (i) That in which a twice contained function is parsed after
6344 : : the host association is made. On detecting this, change
6345 : : the symbol in the expression and convert the array reference
6346 : : into an actual arglist if the old symbol is a variable; or
6347 : : (ii) That in which an external function is typed but not declared
6348 : : explicitly to be external. Here, the old symbol is changed
6349 : : from a variable to an external function. */
6350 : : static bool
6351 : 1264674 : check_host_association (gfc_expr *e)
6352 : : {
6353 : 1264674 : gfc_symbol *sym, *old_sym;
6354 : 1264674 : gfc_symtree *st;
6355 : 1264674 : int n;
6356 : 1264674 : gfc_ref *ref;
6357 : 1264674 : gfc_actual_arglist *arg, *tail = NULL;
6358 : 1264674 : bool retval = e->expr_type == EXPR_FUNCTION;
6359 : :
6360 : : /* If the expression is the result of substitution in
6361 : : interface.cc(gfc_extend_expr) because there is no way in
6362 : : which the host association can be wrong. */
6363 : 1264674 : if (e->symtree == NULL
6364 : 1264002 : || e->symtree->n.sym == NULL
6365 : 1264002 : || e->user_operator)
6366 : : return retval;
6367 : :
6368 : 1262292 : old_sym = e->symtree->n.sym;
6369 : :
6370 : 1262292 : if (gfc_current_ns->parent
6371 : 400169 : && old_sym->ns != gfc_current_ns)
6372 : : {
6373 : : /* Use the 'USE' name so that renamed module symbols are
6374 : : correctly handled. */
6375 : 74719 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
6376 : :
6377 : 74719 : if (sym && old_sym != sym
6378 : : && sym->attr.flavor == FL_PROCEDURE
6379 : 372 : && sym->attr.contained)
6380 : : {
6381 : : /* Clear the shape, since it might not be valid. */
6382 : 71 : gfc_free_shape (&e->shape, e->rank);
6383 : :
6384 : : /* Give the expression the right symtree! */
6385 : 71 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
6386 : 71 : gcc_assert (st != NULL);
6387 : :
6388 : 71 : if (old_sym->attr.flavor == FL_PROCEDURE
6389 : 47 : || e->expr_type == EXPR_FUNCTION)
6390 : : {
6391 : : /* Original was function so point to the new symbol, since
6392 : : the actual argument list is already attached to the
6393 : : expression. */
6394 : 30 : e->value.function.esym = NULL;
6395 : 30 : e->symtree = st;
6396 : : }
6397 : : else
6398 : : {
6399 : : /* Original was variable so convert array references into
6400 : : an actual arglist. This does not need any checking now
6401 : : since resolve_function will take care of it. */
6402 : 41 : e->value.function.actual = NULL;
6403 : 41 : e->expr_type = EXPR_FUNCTION;
6404 : 41 : e->symtree = st;
6405 : :
6406 : : /* Ambiguity will not arise if the array reference is not
6407 : : the last reference. */
6408 : 43 : for (ref = e->ref; ref; ref = ref->next)
6409 : 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
6410 : : break;
6411 : :
6412 : 41 : if ((ref == NULL || ref->type != REF_ARRAY)
6413 : 5 : && sym->attr.proc == PROC_INTERNAL)
6414 : : {
6415 : 4 : gfc_error ("%qs at %L is host associated at %L into "
6416 : : "a contained procedure with an internal "
6417 : : "procedure of the same name", sym->name,
6418 : : &old_sym->declared_at, &e->where);
6419 : 4 : return false;
6420 : : }
6421 : :
6422 : 1 : if (ref == NULL)
6423 : : return false;
6424 : :
6425 : 36 : gcc_assert (ref->type == REF_ARRAY);
6426 : :
6427 : : /* Grab the start expressions from the array ref and
6428 : : copy them into actual arguments. */
6429 : 84 : for (n = 0; n < ref->u.ar.dimen; n++)
6430 : : {
6431 : 48 : arg = gfc_get_actual_arglist ();
6432 : 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
6433 : 48 : if (e->value.function.actual == NULL)
6434 : 36 : tail = e->value.function.actual = arg;
6435 : : else
6436 : : {
6437 : 12 : tail->next = arg;
6438 : 12 : tail = arg;
6439 : : }
6440 : : }
6441 : :
6442 : : /* Dump the reference list and set the rank. */
6443 : 36 : gfc_free_ref_list (e->ref);
6444 : 36 : e->ref = NULL;
6445 : 36 : e->rank = sym->as ? sym->as->rank : 0;
6446 : : }
6447 : :
6448 : 66 : gfc_resolve_expr (e);
6449 : 66 : sym->refs++;
6450 : : }
6451 : : /* This case corresponds to a call, from a block or a contained
6452 : : procedure, to an external function, which has not been declared
6453 : : as being external in the main program but has been typed. */
6454 : 74648 : else if (sym && old_sym != sym
6455 : 301 : && !e->ref
6456 : 201 : && sym->ts.type == BT_UNKNOWN
6457 : 21 : && old_sym->ts.type != BT_UNKNOWN
6458 : 19 : && sym->attr.flavor == FL_PROCEDURE
6459 : 19 : && old_sym->attr.flavor == FL_VARIABLE
6460 : 7 : && sym->ns->parent == old_sym->ns
6461 : 7 : && sym->ns->proc_name
6462 : 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
6463 : 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
6464 : 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
6465 : : {
6466 : 6 : old_sym->attr.flavor = FL_PROCEDURE;
6467 : 6 : old_sym->attr.external = 1;
6468 : 6 : old_sym->attr.function = 1;
6469 : 6 : old_sym->result = old_sym;
6470 : 6 : gfc_resolve_expr (e);
6471 : : }
6472 : : }
6473 : : /* This might have changed! */
6474 : 1262287 : return e->expr_type == EXPR_FUNCTION;
6475 : : }
6476 : :
6477 : :
6478 : : static void
6479 : 1434 : gfc_resolve_character_operator (gfc_expr *e)
6480 : : {
6481 : 1434 : gfc_expr *op1 = e->value.op.op1;
6482 : 1434 : gfc_expr *op2 = e->value.op.op2;
6483 : 1434 : gfc_expr *e1 = NULL;
6484 : 1434 : gfc_expr *e2 = NULL;
6485 : :
6486 : 1434 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
6487 : :
6488 : 1434 : if (op1->ts.u.cl && op1->ts.u.cl->length)
6489 : 694 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
6490 : 740 : else if (op1->expr_type == EXPR_CONSTANT)
6491 : 316 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
6492 : : op1->value.character.length);
6493 : :
6494 : 1434 : if (op2->ts.u.cl && op2->ts.u.cl->length)
6495 : 693 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
6496 : 741 : else if (op2->expr_type == EXPR_CONSTANT)
6497 : 521 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
6498 : : op2->value.character.length);
6499 : :
6500 : 1434 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6501 : :
6502 : 1434 : if (!e1 || !e2)
6503 : : {
6504 : 543 : gfc_free_expr (e1);
6505 : 543 : gfc_free_expr (e2);
6506 : :
6507 : 543 : return;
6508 : : }
6509 : :
6510 : 891 : e->ts.u.cl->length = gfc_add (e1, e2);
6511 : 891 : e->ts.u.cl->length->ts.type = BT_INTEGER;
6512 : 891 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6513 : 891 : gfc_simplify_expr (e->ts.u.cl->length, 0);
6514 : 891 : gfc_resolve_expr (e->ts.u.cl->length);
6515 : :
6516 : 891 : return;
6517 : : }
6518 : :
6519 : :
6520 : : /* Ensure that an character expression has a charlen and, if possible, a
6521 : : length expression. */
6522 : :
6523 : : static void
6524 : 171916 : fixup_charlen (gfc_expr *e)
6525 : : {
6526 : : /* The cases fall through so that changes in expression type and the need
6527 : : for multiple fixes are picked up. In all circumstances, a charlen should
6528 : : be available for the middle end to hang a backend_decl on. */
6529 : 171916 : switch (e->expr_type)
6530 : : {
6531 : 1434 : case EXPR_OP:
6532 : 1434 : gfc_resolve_character_operator (e);
6533 : : /* FALLTHRU */
6534 : :
6535 : 1489 : case EXPR_ARRAY:
6536 : 1489 : if (e->expr_type == EXPR_ARRAY)
6537 : 55 : gfc_resolve_character_array_constructor (e);
6538 : : /* FALLTHRU */
6539 : :
6540 : 1952 : case EXPR_SUBSTRING:
6541 : 1952 : if (!e->ts.u.cl && e->ref)
6542 : 459 : gfc_resolve_substring_charlen (e);
6543 : : /* FALLTHRU */
6544 : :
6545 : 171916 : default:
6546 : 171916 : if (!e->ts.u.cl)
6547 : 169968 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6548 : :
6549 : 171916 : break;
6550 : : }
6551 : 171916 : }
6552 : :
6553 : :
6554 : : /* Update an actual argument to include the passed-object for type-bound
6555 : : procedures at the right position. */
6556 : :
6557 : : static gfc_actual_arglist*
6558 : 2649 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
6559 : : const char *name)
6560 : : {
6561 : 2673 : gcc_assert (argpos > 0);
6562 : :
6563 : 2673 : if (argpos == 1)
6564 : : {
6565 : 2536 : gfc_actual_arglist* result;
6566 : :
6567 : 2536 : result = gfc_get_actual_arglist ();
6568 : 2536 : result->expr = po;
6569 : 2536 : result->next = lst;
6570 : 2536 : if (name)
6571 : 496 : result->name = name;
6572 : :
6573 : 2536 : return result;
6574 : : }
6575 : :
6576 : 137 : if (lst)
6577 : 113 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
6578 : : else
6579 : 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
6580 : : return lst;
6581 : : }
6582 : :
6583 : :
6584 : : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6585 : :
6586 : : static gfc_expr*
6587 : 6540 : extract_compcall_passed_object (gfc_expr* e)
6588 : : {
6589 : 6540 : gfc_expr* po;
6590 : :
6591 : 6540 : if (e->expr_type == EXPR_UNKNOWN)
6592 : : {
6593 : 0 : gfc_error ("Error in typebound call at %L",
6594 : : &e->where);
6595 : 0 : return NULL;
6596 : : }
6597 : :
6598 : 6540 : gcc_assert (e->expr_type == EXPR_COMPCALL);
6599 : :
6600 : 6540 : if (e->value.compcall.base_object)
6601 : 1446 : po = gfc_copy_expr (e->value.compcall.base_object);
6602 : : else
6603 : : {
6604 : 5094 : po = gfc_get_expr ();
6605 : 5094 : po->expr_type = EXPR_VARIABLE;
6606 : 5094 : po->symtree = e->symtree;
6607 : 5094 : po->ref = gfc_copy_ref (e->ref);
6608 : 5094 : po->where = e->where;
6609 : : }
6610 : :
6611 : 6540 : if (!gfc_resolve_expr (po))
6612 : : return NULL;
6613 : :
6614 : : return po;
6615 : : }
6616 : :
6617 : :
6618 : : /* Update the arglist of an EXPR_COMPCALL expression to include the
6619 : : passed-object. */
6620 : :
6621 : : static bool
6622 : 3029 : update_compcall_arglist (gfc_expr* e)
6623 : : {
6624 : 3029 : gfc_expr* po;
6625 : 3029 : gfc_typebound_proc* tbp;
6626 : :
6627 : 3029 : tbp = e->value.compcall.tbp;
6628 : :
6629 : 3029 : if (tbp->error)
6630 : : return false;
6631 : :
6632 : 3028 : po = extract_compcall_passed_object (e);
6633 : 3028 : if (!po)
6634 : : return false;
6635 : :
6636 : 3028 : if (tbp->nopass || e->value.compcall.ignore_pass)
6637 : : {
6638 : 1047 : gfc_free_expr (po);
6639 : 1047 : return true;
6640 : : }
6641 : :
6642 : 1981 : if (tbp->pass_arg_num <= 0)
6643 : : return false;
6644 : :
6645 : 1980 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
6646 : : tbp->pass_arg_num,
6647 : : tbp->pass_arg);
6648 : :
6649 : 1980 : return true;
6650 : : }
6651 : :
6652 : :
6653 : : /* Extract the passed object from a PPC call (a copy of it). */
6654 : :
6655 : : static gfc_expr*
6656 : 85 : extract_ppc_passed_object (gfc_expr *e)
6657 : : {
6658 : 85 : gfc_expr *po;
6659 : 85 : gfc_ref **ref;
6660 : :
6661 : 85 : po = gfc_get_expr ();
6662 : 85 : po->expr_type = EXPR_VARIABLE;
6663 : 85 : po->symtree = e->symtree;
6664 : 85 : po->ref = gfc_copy_ref (e->ref);
6665 : 85 : po->where = e->where;
6666 : :
6667 : : /* Remove PPC reference. */
6668 : 85 : ref = &po->ref;
6669 : 91 : while ((*ref)->next)
6670 : 6 : ref = &(*ref)->next;
6671 : 85 : gfc_free_ref_list (*ref);
6672 : 85 : *ref = NULL;
6673 : :
6674 : 85 : if (!gfc_resolve_expr (po))
6675 : 0 : return NULL;
6676 : :
6677 : : return po;
6678 : : }
6679 : :
6680 : :
6681 : : /* Update the actual arglist of a procedure pointer component to include the
6682 : : passed-object. */
6683 : :
6684 : : static bool
6685 : 388 : update_ppc_arglist (gfc_expr* e)
6686 : : {
6687 : 388 : gfc_expr* po;
6688 : 388 : gfc_component *ppc;
6689 : 388 : gfc_typebound_proc* tb;
6690 : :
6691 : 388 : ppc = gfc_get_proc_ptr_comp (e);
6692 : 388 : if (!ppc)
6693 : : return false;
6694 : :
6695 : 388 : tb = ppc->tb;
6696 : :
6697 : 388 : if (tb->error)
6698 : : return false;
6699 : 386 : else if (tb->nopass)
6700 : : return true;
6701 : :
6702 : 85 : po = extract_ppc_passed_object (e);
6703 : 85 : if (!po)
6704 : : return false;
6705 : :
6706 : : /* F08:R739. */
6707 : 85 : if (po->rank != 0)
6708 : : {
6709 : 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
6710 : 0 : return false;
6711 : : }
6712 : :
6713 : : /* F08:C611. */
6714 : 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
6715 : : {
6716 : 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
6717 : : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
6718 : 1 : return false;
6719 : : }
6720 : :
6721 : 84 : gcc_assert (tb->pass_arg_num > 0);
6722 : 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
6723 : : tb->pass_arg_num,
6724 : : tb->pass_arg);
6725 : :
6726 : 84 : return true;
6727 : : }
6728 : :
6729 : :
6730 : : /* Check that the object a TBP is called on is valid, i.e. it must not be
6731 : : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6732 : :
6733 : : static bool
6734 : 3040 : check_typebound_baseobject (gfc_expr* e)
6735 : : {
6736 : 3040 : gfc_expr* base;
6737 : 3040 : bool return_value = false;
6738 : :
6739 : 3040 : base = extract_compcall_passed_object (e);
6740 : 3040 : if (!base)
6741 : : return false;
6742 : :
6743 : 3037 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
6744 : : {
6745 : 1 : gfc_error ("Error in typebound call at %L", &e->where);
6746 : 1 : goto cleanup;
6747 : : }
6748 : :
6749 : 3036 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
6750 : 1 : return false;
6751 : :
6752 : : /* F08:C611. */
6753 : 3035 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
6754 : : {
6755 : 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
6756 : : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
6757 : 3 : goto cleanup;
6758 : : }
6759 : :
6760 : : /* F08:C1230. If the procedure called is NOPASS,
6761 : : the base object must be scalar. */
6762 : 3032 : if (e->value.compcall.tbp->nopass && base->rank != 0)
6763 : : {
6764 : 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6765 : : " be scalar", &e->where);
6766 : 1 : goto cleanup;
6767 : : }
6768 : :
6769 : : return_value = true;
6770 : :
6771 : 3036 : cleanup:
6772 : 3036 : gfc_free_expr (base);
6773 : 3036 : return return_value;
6774 : : }
6775 : :
6776 : :
6777 : : /* Resolve a call to a type-bound procedure, either function or subroutine,
6778 : : statically from the data in an EXPR_COMPCALL expression. The adapted
6779 : : arglist and the target-procedure symtree are returned. */
6780 : :
6781 : : static bool
6782 : 3029 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
6783 : : gfc_actual_arglist** actual)
6784 : : {
6785 : 3029 : gcc_assert (e->expr_type == EXPR_COMPCALL);
6786 : 3029 : gcc_assert (!e->value.compcall.tbp->is_generic);
6787 : :
6788 : : /* Update the actual arglist for PASS. */
6789 : 3029 : if (!update_compcall_arglist (e))
6790 : : return false;
6791 : :
6792 : 3027 : *actual = e->value.compcall.actual;
6793 : 3027 : *target = e->value.compcall.tbp->u.specific;
6794 : :
6795 : 3027 : gfc_free_ref_list (e->ref);
6796 : 3027 : e->ref = NULL;
6797 : 3027 : e->value.compcall.actual = NULL;
6798 : :
6799 : : /* If we find a deferred typebound procedure, check for derived types
6800 : : that an overriding typebound procedure has not been missed. */
6801 : 3027 : if (e->value.compcall.name
6802 : 3027 : && !e->value.compcall.tbp->non_overridable
6803 : 3017 : && e->value.compcall.base_object
6804 : 723 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
6805 : : {
6806 : 436 : gfc_symtree *st;
6807 : 436 : gfc_symbol *derived;
6808 : :
6809 : : /* Use the derived type of the base_object. */
6810 : 436 : derived = e->value.compcall.base_object->ts.u.derived;
6811 : 436 : st = NULL;
6812 : :
6813 : : /* If necessary, go through the inheritance chain. */
6814 : 1309 : while (!st && derived)
6815 : : {
6816 : : /* Look for the typebound procedure 'name'. */
6817 : 437 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
6818 : 436 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
6819 : : e->value.compcall.name);
6820 : 437 : if (!st)
6821 : 1 : derived = gfc_get_derived_super_type (derived);
6822 : : }
6823 : :
6824 : : /* Now find the specific name in the derived type namespace. */
6825 : 436 : if (st && st->n.tb && st->n.tb->u.specific)
6826 : 436 : gfc_find_sym_tree (st->n.tb->u.specific->name,
6827 : : derived->ns, 1, &st);
6828 : 436 : if (st)
6829 : 436 : *target = st;
6830 : : }
6831 : :
6832 : 3027 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
6833 : 3027 : && !e->value.compcall.tbp->deferred)
6834 : 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
6835 : : " itself recursively. Declare it RECURSIVE or use"
6836 : : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
6837 : :
6838 : : return true;
6839 : : }
6840 : :
6841 : :
6842 : : /* Get the ultimate declared type from an expression. In addition,
6843 : : return the last class/derived type reference and the copy of the
6844 : : reference list. If check_types is set true, derived types are
6845 : : identified as well as class references. */
6846 : : static gfc_symbol*
6847 : 2986 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
6848 : : gfc_expr *e, bool check_types)
6849 : : {
6850 : 2986 : gfc_symbol *declared;
6851 : 2986 : gfc_ref *ref;
6852 : :
6853 : 2986 : declared = NULL;
6854 : 2986 : if (class_ref)
6855 : 2616 : *class_ref = NULL;
6856 : 2986 : if (new_ref)
6857 : 2329 : *new_ref = gfc_copy_ref (e->ref);
6858 : :
6859 : 3743 : for (ref = e->ref; ref; ref = ref->next)
6860 : : {
6861 : 757 : if (ref->type != REF_COMPONENT)
6862 : 275 : continue;
6863 : :
6864 : 482 : if ((ref->u.c.component->ts.type == BT_CLASS
6865 : 236 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
6866 : 407 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
6867 : : {
6868 : 333 : declared = ref->u.c.component->ts.u.derived;
6869 : 333 : if (class_ref)
6870 : 315 : *class_ref = ref;
6871 : : }
6872 : : }
6873 : :
6874 : 2986 : if (declared == NULL)
6875 : 2679 : declared = e->symtree->n.sym->ts.u.derived;
6876 : :
6877 : 2986 : return declared;
6878 : : }
6879 : :
6880 : :
6881 : : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6882 : : which of the specific bindings (if any) matches the arglist and transform
6883 : : the expression into a call of that binding. */
6884 : :
6885 : : static bool
6886 : 3031 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
6887 : : {
6888 : 3031 : gfc_typebound_proc* genproc;
6889 : 3031 : const char* genname;
6890 : 3031 : gfc_symtree *st;
6891 : 3031 : gfc_symbol *derived;
6892 : :
6893 : 3031 : gcc_assert (e->expr_type == EXPR_COMPCALL);
6894 : 3031 : genname = e->value.compcall.name;
6895 : 3031 : genproc = e->value.compcall.tbp;
6896 : :
6897 : 3031 : if (!genproc->is_generic)
6898 : : return true;
6899 : :
6900 : : /* Try the bindings on this type and in the inheritance hierarchy. */
6901 : 382 : for (; genproc; genproc = genproc->overridden)
6902 : : {
6903 : 380 : gfc_tbp_generic* g;
6904 : :
6905 : 380 : gcc_assert (genproc->is_generic);
6906 : 568 : for (g = genproc->u.generic; g; g = g->next)
6907 : : {
6908 : 558 : gfc_symbol* target;
6909 : 558 : gfc_actual_arglist* args;
6910 : 558 : bool matches;
6911 : :
6912 : 558 : gcc_assert (g->specific);
6913 : :
6914 : 558 : if (g->specific->error)
6915 : 0 : continue;
6916 : :
6917 : 558 : target = g->specific->u.specific->n.sym;
6918 : :
6919 : : /* Get the right arglist by handling PASS/NOPASS. */
6920 : 558 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
6921 : 558 : if (!g->specific->nopass)
6922 : : {
6923 : 472 : gfc_expr* po;
6924 : 472 : po = extract_compcall_passed_object (e);
6925 : 472 : if (!po)
6926 : : {
6927 : 0 : gfc_free_actual_arglist (args);
6928 : 0 : return false;
6929 : : }
6930 : :
6931 : 472 : gcc_assert (g->specific->pass_arg_num > 0);
6932 : 472 : gcc_assert (!g->specific->error);
6933 : 472 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
6934 : : g->specific->pass_arg);
6935 : : }
6936 : 558 : resolve_actual_arglist (args, target->attr.proc,
6937 : 558 : is_external_proc (target)
6938 : 558 : && gfc_sym_get_dummy_args (target) == NULL);
6939 : :
6940 : : /* Check if this arglist matches the formal. */
6941 : 558 : matches = gfc_arglist_matches_symbol (&args, target);
6942 : :
6943 : : /* Clean up and break out of the loop if we've found it. */
6944 : 558 : gfc_free_actual_arglist (args);
6945 : 558 : if (matches)
6946 : : {
6947 : 370 : e->value.compcall.tbp = g->specific;
6948 : 370 : genname = g->specific_st->name;
6949 : : /* Pass along the name for CLASS methods, where the vtab
6950 : : procedure pointer component has to be referenced. */
6951 : 370 : if (name)
6952 : 158 : *name = genname;
6953 : 370 : goto success;
6954 : : }
6955 : : }
6956 : : }
6957 : :
6958 : : /* Nothing matching found! */
6959 : 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
6960 : : " %qs at %L", genname, &e->where);
6961 : 2 : return false;
6962 : :
6963 : 370 : success:
6964 : : /* Make sure that we have the right specific instance for the name. */
6965 : 370 : derived = get_declared_from_expr (NULL, NULL, e, true);
6966 : :
6967 : 370 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
6968 : 370 : if (st)
6969 : 370 : e->value.compcall.tbp = st->n.tb;
6970 : :
6971 : : return true;
6972 : : }
6973 : :
6974 : :
6975 : : /* Resolve a call to a type-bound subroutine. */
6976 : :
6977 : : static bool
6978 : 1612 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
6979 : : {
6980 : 1612 : gfc_actual_arglist* newactual;
6981 : 1612 : gfc_symtree* target;
6982 : :
6983 : : /* Check that's really a SUBROUTINE. */
6984 : 1612 : if (!c->expr1->value.compcall.tbp->subroutine)
6985 : : {
6986 : 17 : if (!c->expr1->value.compcall.tbp->is_generic
6987 : 15 : && c->expr1->value.compcall.tbp->u.specific
6988 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
6989 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
6990 : 12 : c->expr1->value.compcall.tbp->subroutine = 1;
6991 : : else
6992 : : {
6993 : 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
6994 : : c->expr1->value.compcall.name, &c->loc);
6995 : 5 : return false;
6996 : : }
6997 : : }
6998 : :
6999 : 1607 : if (!check_typebound_baseobject (c->expr1))
7000 : : return false;
7001 : :
7002 : : /* Pass along the name for CLASS methods, where the vtab
7003 : : procedure pointer component has to be referenced. */
7004 : 1600 : if (name)
7005 : 464 : *name = c->expr1->value.compcall.name;
7006 : :
7007 : 1600 : if (!resolve_typebound_generic_call (c->expr1, name))
7008 : : return false;
7009 : :
7010 : : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7011 : 1599 : if (overridable)
7012 : 361 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7013 : :
7014 : : /* Transform into an ordinary EXEC_CALL for now. */
7015 : :
7016 : 1599 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7017 : : return false;
7018 : :
7019 : 1597 : c->ext.actual = newactual;
7020 : 1597 : c->symtree = target;
7021 : 1597 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7022 : :
7023 : 1597 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7024 : :
7025 : 1597 : gfc_free_expr (c->expr1);
7026 : 1597 : c->expr1 = gfc_get_expr ();
7027 : 1597 : c->expr1->expr_type = EXPR_FUNCTION;
7028 : 1597 : c->expr1->symtree = target;
7029 : 1597 : c->expr1->where = c->loc;
7030 : :
7031 : 1597 : return resolve_call (c);
7032 : : }
7033 : :
7034 : :
7035 : : /* Resolve a component-call expression. */
7036 : : static bool
7037 : 1440 : resolve_compcall (gfc_expr* e, const char **name)
7038 : : {
7039 : 1440 : gfc_actual_arglist* newactual;
7040 : 1440 : gfc_symtree* target;
7041 : :
7042 : : /* Check that's really a FUNCTION. */
7043 : 1440 : if (!e->value.compcall.tbp->function)
7044 : : {
7045 : 7 : gfc_error ("%qs at %L should be a FUNCTION",
7046 : : e->value.compcall.name, &e->where);
7047 : 7 : return false;
7048 : : }
7049 : :
7050 : :
7051 : : /* These must not be assign-calls! */
7052 : 1433 : gcc_assert (!e->value.compcall.assign);
7053 : :
7054 : 1433 : if (!check_typebound_baseobject (e))
7055 : : return false;
7056 : :
7057 : : /* Pass along the name for CLASS methods, where the vtab
7058 : : procedure pointer component has to be referenced. */
7059 : 1431 : if (name)
7060 : 791 : *name = e->value.compcall.name;
7061 : :
7062 : 1431 : if (!resolve_typebound_generic_call (e, name))
7063 : : return false;
7064 : 1430 : gcc_assert (!e->value.compcall.tbp->is_generic);
7065 : :
7066 : : /* Take the rank from the function's symbol. */
7067 : 1430 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7068 : 141 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7069 : :
7070 : : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7071 : : arglist to the TBP's binding target. */
7072 : :
7073 : 1430 : if (!resolve_typebound_static (e, &target, &newactual))
7074 : : return false;
7075 : :
7076 : 1430 : e->value.function.actual = newactual;
7077 : 1430 : e->value.function.name = NULL;
7078 : 1430 : e->value.function.esym = target->n.sym;
7079 : 1430 : e->value.function.isym = NULL;
7080 : 1430 : e->symtree = target;
7081 : 1430 : e->ts = target->n.sym->ts;
7082 : 1430 : e->expr_type = EXPR_FUNCTION;
7083 : :
7084 : : /* Resolution is not necessary if this is a class subroutine; this
7085 : : function only has to identify the specific proc. Resolution of
7086 : : the call will be done next in resolve_typebound_call. */
7087 : 1430 : return gfc_resolve_expr (e);
7088 : : }
7089 : :
7090 : :
7091 : : static bool resolve_fl_derived (gfc_symbol *sym);
7092 : :
7093 : :
7094 : : /* Resolve a typebound function, or 'method'. First separate all
7095 : : the non-CLASS references by calling resolve_compcall directly. */
7096 : :
7097 : : static bool
7098 : 1440 : resolve_typebound_function (gfc_expr* e)
7099 : : {
7100 : 1440 : gfc_symbol *declared;
7101 : 1440 : gfc_component *c;
7102 : 1440 : gfc_ref *new_ref;
7103 : 1440 : gfc_ref *class_ref;
7104 : 1440 : gfc_symtree *st;
7105 : 1440 : const char *name;
7106 : 1440 : gfc_typespec ts;
7107 : 1440 : gfc_expr *expr;
7108 : 1440 : bool overridable;
7109 : :
7110 : 1440 : st = e->symtree;
7111 : :
7112 : : /* Deal with typebound operators for CLASS objects. */
7113 : 1440 : expr = e->value.compcall.base_object;
7114 : 1440 : overridable = !e->value.compcall.tbp->non_overridable;
7115 : 1440 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7116 : : {
7117 : : /* Since the typebound operators are generic, we have to ensure
7118 : : that any delays in resolution are corrected and that the vtab
7119 : : is present. */
7120 : 184 : ts = expr->ts;
7121 : 184 : declared = ts.u.derived;
7122 : 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7123 : 184 : if (c->ts.u.derived == NULL)
7124 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7125 : :
7126 : 184 : if (!resolve_compcall (e, &name))
7127 : : return false;
7128 : :
7129 : : /* Use the generic name if it is there. */
7130 : 184 : name = name ? name : e->value.function.esym->name;
7131 : 184 : e->symtree = expr->symtree;
7132 : 184 : e->ref = gfc_copy_ref (expr->ref);
7133 : 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7134 : :
7135 : : /* Trim away the extraneous references that emerge from nested
7136 : : use of interface.cc (extend_expr). */
7137 : 184 : if (class_ref && class_ref->next)
7138 : : {
7139 : 0 : gfc_free_ref_list (class_ref->next);
7140 : 0 : class_ref->next = NULL;
7141 : : }
7142 : 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7143 : : {
7144 : 0 : gfc_free_ref_list (e->ref);
7145 : 0 : e->ref = NULL;
7146 : : }
7147 : :
7148 : 184 : gfc_add_vptr_component (e);
7149 : 184 : gfc_add_component_ref (e, name);
7150 : 184 : e->value.function.esym = NULL;
7151 : 184 : if (expr->expr_type != EXPR_VARIABLE)
7152 : 80 : e->base_expr = expr;
7153 : 184 : return true;
7154 : : }
7155 : :
7156 : 1256 : if (st == NULL)
7157 : 147 : return resolve_compcall (e, NULL);
7158 : :
7159 : 1109 : if (!gfc_resolve_ref (e))
7160 : : return false;
7161 : :
7162 : : /* Get the CLASS declared type. */
7163 : 1109 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
7164 : :
7165 : 1109 : if (!resolve_fl_derived (declared))
7166 : : return false;
7167 : :
7168 : : /* Weed out cases of the ultimate component being a derived type. */
7169 : 1109 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7170 : 1025 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7171 : : {
7172 : 500 : gfc_free_ref_list (new_ref);
7173 : 500 : return resolve_compcall (e, NULL);
7174 : : }
7175 : :
7176 : 609 : c = gfc_find_component (declared, "_data", true, true, NULL);
7177 : :
7178 : : /* Treat the call as if it is a typebound procedure, in order to roll
7179 : : out the correct name for the specific function. */
7180 : 609 : if (!resolve_compcall (e, &name))
7181 : : {
7182 : 3 : gfc_free_ref_list (new_ref);
7183 : 3 : return false;
7184 : : }
7185 : 606 : ts = e->ts;
7186 : :
7187 : 606 : if (overridable)
7188 : : {
7189 : : /* Convert the expression to a procedure pointer component call. */
7190 : 604 : e->value.function.esym = NULL;
7191 : 604 : e->symtree = st;
7192 : :
7193 : 604 : if (new_ref)
7194 : 124 : e->ref = new_ref;
7195 : :
7196 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7197 : 604 : gfc_add_vptr_component (e);
7198 : 604 : gfc_add_component_ref (e, name);
7199 : :
7200 : : /* Recover the typespec for the expression. This is really only
7201 : : necessary for generic procedures, where the additional call
7202 : : to gfc_add_component_ref seems to throw the collection of the
7203 : : correct typespec. */
7204 : 604 : e->ts = ts;
7205 : : }
7206 : 2 : else if (new_ref)
7207 : 0 : gfc_free_ref_list (new_ref);
7208 : :
7209 : : return true;
7210 : : }
7211 : :
7212 : : /* Resolve a typebound subroutine, or 'method'. First separate all
7213 : : the non-CLASS references by calling resolve_typebound_call
7214 : : directly. */
7215 : :
7216 : : static bool
7217 : 1612 : resolve_typebound_subroutine (gfc_code *code)
7218 : : {
7219 : 1612 : gfc_symbol *declared;
7220 : 1612 : gfc_component *c;
7221 : 1612 : gfc_ref *new_ref;
7222 : 1612 : gfc_ref *class_ref;
7223 : 1612 : gfc_symtree *st;
7224 : 1612 : const char *name;
7225 : 1612 : gfc_typespec ts;
7226 : 1612 : gfc_expr *expr;
7227 : 1612 : bool overridable;
7228 : :
7229 : 1612 : st = code->expr1->symtree;
7230 : :
7231 : : /* Deal with typebound operators for CLASS objects. */
7232 : 1612 : expr = code->expr1->value.compcall.base_object;
7233 : 1612 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
7234 : 1612 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7235 : : {
7236 : : /* If the base_object is not a variable, the corresponding actual
7237 : : argument expression must be stored in e->base_expression so
7238 : : that the corresponding tree temporary can be used as the base
7239 : : object in gfc_conv_procedure_call. */
7240 : 103 : if (expr->expr_type != EXPR_VARIABLE)
7241 : : {
7242 : : gfc_actual_arglist *args;
7243 : :
7244 : : args= code->expr1->value.function.actual;
7245 : : for (; args; args = args->next)
7246 : : if (expr == args->expr)
7247 : : expr = args->expr;
7248 : : }
7249 : :
7250 : : /* Since the typebound operators are generic, we have to ensure
7251 : : that any delays in resolution are corrected and that the vtab
7252 : : is present. */
7253 : 103 : declared = expr->ts.u.derived;
7254 : 103 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7255 : 103 : if (c->ts.u.derived == NULL)
7256 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7257 : :
7258 : 103 : if (!resolve_typebound_call (code, &name, NULL))
7259 : : return false;
7260 : :
7261 : : /* Use the generic name if it is there. */
7262 : 103 : name = name ? name : code->expr1->value.function.esym->name;
7263 : 103 : code->expr1->symtree = expr->symtree;
7264 : 103 : code->expr1->ref = gfc_copy_ref (expr->ref);
7265 : :
7266 : : /* Trim away the extraneous references that emerge from nested
7267 : : use of interface.cc (extend_expr). */
7268 : 103 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
7269 : 103 : if (class_ref && class_ref->next)
7270 : : {
7271 : 0 : gfc_free_ref_list (class_ref->next);
7272 : 0 : class_ref->next = NULL;
7273 : : }
7274 : 103 : else if (code->expr1->ref && !class_ref)
7275 : : {
7276 : 12 : gfc_free_ref_list (code->expr1->ref);
7277 : 12 : code->expr1->ref = NULL;
7278 : : }
7279 : :
7280 : : /* Now use the procedure in the vtable. */
7281 : 103 : gfc_add_vptr_component (code->expr1);
7282 : 103 : gfc_add_component_ref (code->expr1, name);
7283 : 103 : code->expr1->value.function.esym = NULL;
7284 : 103 : if (expr->expr_type != EXPR_VARIABLE)
7285 : 0 : code->expr1->base_expr = expr;
7286 : 103 : return true;
7287 : : }
7288 : :
7289 : 1509 : if (st == NULL)
7290 : 289 : return resolve_typebound_call (code, NULL, NULL);
7291 : :
7292 : 1220 : if (!gfc_resolve_ref (code->expr1))
7293 : : return false;
7294 : :
7295 : : /* Get the CLASS declared type. */
7296 : 1220 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
7297 : :
7298 : : /* Weed out cases of the ultimate component being a derived type. */
7299 : 1220 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7300 : 1161 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
7301 : : {
7302 : 854 : gfc_free_ref_list (new_ref);
7303 : 854 : return resolve_typebound_call (code, NULL, NULL);
7304 : : }
7305 : :
7306 : 366 : if (!resolve_typebound_call (code, &name, &overridable))
7307 : : {
7308 : 5 : gfc_free_ref_list (new_ref);
7309 : 5 : return false;
7310 : : }
7311 : 361 : ts = code->expr1->ts;
7312 : :
7313 : 361 : if (overridable)
7314 : : {
7315 : : /* Convert the expression to a procedure pointer component call. */
7316 : 359 : code->expr1->value.function.esym = NULL;
7317 : 359 : code->expr1->symtree = st;
7318 : :
7319 : 359 : if (new_ref)
7320 : 90 : code->expr1->ref = new_ref;
7321 : :
7322 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
7323 : 359 : gfc_add_vptr_component (code->expr1);
7324 : 359 : gfc_add_component_ref (code->expr1, name);
7325 : :
7326 : : /* Recover the typespec for the expression. This is really only
7327 : : necessary for generic procedures, where the additional call
7328 : : to gfc_add_component_ref seems to throw the collection of the
7329 : : correct typespec. */
7330 : 359 : code->expr1->ts = ts;
7331 : : }
7332 : 2 : else if (new_ref)
7333 : 0 : gfc_free_ref_list (new_ref);
7334 : :
7335 : : return true;
7336 : : }
7337 : :
7338 : :
7339 : : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7340 : :
7341 : : static bool
7342 : 121 : resolve_ppc_call (gfc_code* c)
7343 : : {
7344 : 121 : gfc_component *comp;
7345 : :
7346 : 121 : comp = gfc_get_proc_ptr_comp (c->expr1);
7347 : 121 : gcc_assert (comp != NULL);
7348 : :
7349 : 121 : c->resolved_sym = c->expr1->symtree->n.sym;
7350 : 121 : c->expr1->expr_type = EXPR_VARIABLE;
7351 : :
7352 : 121 : if (!comp->attr.subroutine)
7353 : 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
7354 : :
7355 : 121 : if (!gfc_resolve_ref (c->expr1))
7356 : : return false;
7357 : :
7358 : 121 : if (!update_ppc_arglist (c->expr1))
7359 : : return false;
7360 : :
7361 : 120 : c->ext.actual = c->expr1->value.compcall.actual;
7362 : :
7363 : 120 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
7364 : 120 : !(comp->ts.interface
7365 : 93 : && comp->ts.interface->formal)))
7366 : : return false;
7367 : :
7368 : 120 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
7369 : : return false;
7370 : :
7371 : 119 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
7372 : :
7373 : 119 : return true;
7374 : : }
7375 : :
7376 : :
7377 : : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
7378 : :
7379 : : static bool
7380 : 267 : resolve_expr_ppc (gfc_expr* e)
7381 : : {
7382 : 267 : gfc_component *comp;
7383 : :
7384 : 267 : comp = gfc_get_proc_ptr_comp (e);
7385 : 267 : gcc_assert (comp != NULL);
7386 : :
7387 : : /* Convert to EXPR_FUNCTION. */
7388 : 267 : e->expr_type = EXPR_FUNCTION;
7389 : 267 : e->value.function.isym = NULL;
7390 : 267 : e->value.function.actual = e->value.compcall.actual;
7391 : 267 : e->ts = comp->ts;
7392 : 267 : if (comp->as != NULL)
7393 : 28 : e->rank = comp->as->rank;
7394 : :
7395 : 267 : if (!comp->attr.function)
7396 : 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
7397 : :
7398 : 267 : if (!gfc_resolve_ref (e))
7399 : : return false;
7400 : :
7401 : 267 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
7402 : 267 : !(comp->ts.interface
7403 : 266 : && comp->ts.interface->formal)))
7404 : : return false;
7405 : :
7406 : 267 : if (!update_ppc_arglist (e))
7407 : : return false;
7408 : :
7409 : 265 : if (!check_pure_function(e))
7410 : : return false;
7411 : :
7412 : 264 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
7413 : :
7414 : 264 : return true;
7415 : : }
7416 : :
7417 : :
7418 : : static bool
7419 : 9604 : gfc_is_expandable_expr (gfc_expr *e)
7420 : : {
7421 : 9604 : gfc_constructor *con;
7422 : :
7423 : 9604 : if (e->expr_type == EXPR_ARRAY)
7424 : : {
7425 : : /* Traverse the constructor looking for variables that are flavor
7426 : : parameter. Parameters must be expanded since they are fully used at
7427 : : compile time. */
7428 : 9604 : con = gfc_constructor_first (e->value.constructor);
7429 : 25259 : for (; con; con = gfc_constructor_next (con))
7430 : : {
7431 : 11259 : if (con->expr->expr_type == EXPR_VARIABLE
7432 : 4550 : && con->expr->symtree
7433 : 4550 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7434 : 4495 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
7435 : : return true;
7436 : 6709 : if (con->expr->expr_type == EXPR_ARRAY
7437 : 6709 : && gfc_is_expandable_expr (con->expr))
7438 : : return true;
7439 : : }
7440 : : }
7441 : :
7442 : : return false;
7443 : : }
7444 : :
7445 : :
7446 : : /* Sometimes variables in specification expressions of the result
7447 : : of module procedures in submodules wind up not being the 'real'
7448 : : dummy. Find this, if possible, in the namespace of the first
7449 : : formal argument. */
7450 : :
7451 : : static void
7452 : 2973 : fixup_unique_dummy (gfc_expr *e)
7453 : : {
7454 : 2973 : gfc_symtree *st = NULL;
7455 : 2973 : gfc_symbol *s = NULL;
7456 : :
7457 : 2973 : if (e->symtree->n.sym->ns->proc_name
7458 : 2973 : && e->symtree->n.sym->ns->proc_name->formal)
7459 : 2973 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
7460 : :
7461 : 2973 : if (s != NULL)
7462 : 2973 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
7463 : :
7464 : 2973 : if (st != NULL
7465 : 14 : && st->n.sym != NULL
7466 : 14 : && st->n.sym->attr.dummy)
7467 : 14 : e->symtree = st;
7468 : 2973 : }
7469 : :
7470 : : /* Resolve an expression. That is, make sure that types of operands agree
7471 : : with their operators, intrinsic operators are converted to function calls
7472 : : for overloaded types and unresolved function references are resolved. */
7473 : :
7474 : : bool
7475 : 5839671 : gfc_resolve_expr (gfc_expr *e)
7476 : : {
7477 : 5839671 : bool t;
7478 : 5839671 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
7479 : :
7480 : 5839671 : if (e == NULL || e->do_not_resolve_again)
7481 : : return true;
7482 : :
7483 : : /* inquiry_argument only applies to variables. */
7484 : 4191648 : inquiry_save = inquiry_argument;
7485 : 4191648 : actual_arg_save = actual_arg;
7486 : 4191648 : first_actual_arg_save = first_actual_arg;
7487 : :
7488 : 4191648 : if (e->expr_type != EXPR_VARIABLE)
7489 : : {
7490 : 3225212 : inquiry_argument = false;
7491 : 3225212 : actual_arg = false;
7492 : 3225212 : first_actual_arg = false;
7493 : : }
7494 : 966436 : else if (e->symtree != NULL
7495 : 966057 : && *e->symtree->name == '@'
7496 : 5546 : && e->symtree->n.sym->attr.dummy)
7497 : : {
7498 : : /* Deal with submodule specification expressions that are not
7499 : : found to be referenced in module.cc(read_cleanup). */
7500 : 2973 : fixup_unique_dummy (e);
7501 : : }
7502 : :
7503 : 4191648 : switch (e->expr_type)
7504 : : {
7505 : 374313 : case EXPR_OP:
7506 : 374313 : t = resolve_operator (e);
7507 : 374313 : break;
7508 : :
7509 : 1264674 : case EXPR_FUNCTION:
7510 : 1264674 : case EXPR_VARIABLE:
7511 : :
7512 : 1264674 : if (check_host_association (e))
7513 : 298274 : t = resolve_function (e);
7514 : : else
7515 : 966400 : t = resolve_variable (e);
7516 : :
7517 : 1264674 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
7518 : 6593 : && e->ref->type != REF_SUBSTRING)
7519 : 1968 : gfc_resolve_substring_charlen (e);
7520 : :
7521 : : break;
7522 : :
7523 : 1440 : case EXPR_COMPCALL:
7524 : 1440 : t = resolve_typebound_function (e);
7525 : 1440 : break;
7526 : :
7527 : 514 : case EXPR_SUBSTRING:
7528 : 514 : t = gfc_resolve_ref (e);
7529 : 514 : break;
7530 : :
7531 : : case EXPR_CONSTANT:
7532 : : case EXPR_NULL:
7533 : : t = true;
7534 : : break;
7535 : :
7536 : 267 : case EXPR_PPC:
7537 : 267 : t = resolve_expr_ppc (e);
7538 : 267 : break;
7539 : :
7540 : 57444 : case EXPR_ARRAY:
7541 : 57444 : t = false;
7542 : 57444 : if (!gfc_resolve_ref (e))
7543 : : break;
7544 : :
7545 : 57444 : t = gfc_resolve_array_constructor (e);
7546 : : /* Also try to expand a constructor. */
7547 : 57444 : if (t)
7548 : : {
7549 : 57357 : gfc_expression_rank (e);
7550 : 57357 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
7551 : 53866 : gfc_expand_constructor (e, false);
7552 : : }
7553 : :
7554 : : /* This provides the opportunity for the length of constructors with
7555 : : character valued function elements to propagate the string length
7556 : : to the expression. */
7557 : 57357 : if (t && e->ts.type == BT_CHARACTER)
7558 : : {
7559 : : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7560 : : here rather then add a duplicate test for it above. */
7561 : 9420 : gfc_expand_constructor (e, false);
7562 : 9420 : t = gfc_resolve_character_array_constructor (e);
7563 : : }
7564 : :
7565 : : break;
7566 : :
7567 : 14162 : case EXPR_STRUCTURE:
7568 : 14162 : t = gfc_resolve_ref (e);
7569 : 14162 : if (!t)
7570 : : break;
7571 : :
7572 : 14162 : t = resolve_structure_cons (e, 0);
7573 : 14162 : if (!t)
7574 : : break;
7575 : :
7576 : 14150 : t = gfc_simplify_expr (e, 0);
7577 : 14150 : break;
7578 : :
7579 : 0 : default:
7580 : 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7581 : : }
7582 : :
7583 : 4191648 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
7584 : 171916 : fixup_charlen (e);
7585 : :
7586 : 4191648 : inquiry_argument = inquiry_save;
7587 : 4191648 : actual_arg = actual_arg_save;
7588 : 4191648 : first_actual_arg = first_actual_arg_save;
7589 : :
7590 : : /* For some reason, resolving these expressions a second time mangles
7591 : : the typespec of the expression itself. */
7592 : 4191648 : if (t && e->expr_type == EXPR_VARIABLE
7593 : 962374 : && e->symtree->n.sym->attr.select_rank_temporary
7594 : 3391 : && UNLIMITED_POLY (e->symtree->n.sym))
7595 : 64 : e->do_not_resolve_again = 1;
7596 : :
7597 : : return t;
7598 : : }
7599 : :
7600 : :
7601 : : /* Resolve an expression from an iterator. They must be scalar and have
7602 : : INTEGER or (optionally) REAL type. */
7603 : :
7604 : : static bool
7605 : 138009 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
7606 : : const char *name_msgid)
7607 : : {
7608 : 138009 : if (!gfc_resolve_expr (expr))
7609 : : return false;
7610 : :
7611 : 138004 : if (expr->rank != 0)
7612 : : {
7613 : 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
7614 : 0 : return false;
7615 : : }
7616 : :
7617 : 138004 : if (expr->ts.type != BT_INTEGER)
7618 : : {
7619 : 274 : if (expr->ts.type == BT_REAL)
7620 : : {
7621 : 274 : if (real_ok)
7622 : 271 : return gfc_notify_std (GFC_STD_F95_DEL,
7623 : : "%s at %L must be integer",
7624 : 271 : _(name_msgid), &expr->where);
7625 : : else
7626 : : {
7627 : 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
7628 : : &expr->where);
7629 : 3 : return false;
7630 : : }
7631 : : }
7632 : : else
7633 : : {
7634 : 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
7635 : 0 : return false;
7636 : : }
7637 : : }
7638 : : return true;
7639 : : }
7640 : :
7641 : :
7642 : : /* Resolve the expressions in an iterator structure. If REAL_OK is
7643 : : false allow only INTEGER type iterators, otherwise allow REAL types.
7644 : : Set own_scope to true for ac-implied-do and data-implied-do as those
7645 : : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7646 : :
7647 : : bool
7648 : 34511 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
7649 : : {
7650 : 34511 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
7651 : : return false;
7652 : :
7653 : 34507 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
7654 : 34507 : _("iterator variable")))
7655 : : return false;
7656 : :
7657 : 34501 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
7658 : : "Start expression in DO loop"))
7659 : : return false;
7660 : :
7661 : 34500 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
7662 : : "End expression in DO loop"))
7663 : : return false;
7664 : :
7665 : 34497 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
7666 : : "Step expression in DO loop"))
7667 : : return false;
7668 : :
7669 : : /* Convert start, end, and step to the same type as var. */
7670 : 34496 : if (iter->start->ts.kind != iter->var->ts.kind
7671 : 34496 : || iter->start->ts.type != iter->var->ts.type)
7672 : 313 : gfc_convert_type (iter->start, &iter->var->ts, 1);
7673 : :
7674 : 34496 : if (iter->end->ts.kind != iter->var->ts.kind
7675 : 34496 : || iter->end->ts.type != iter->var->ts.type)
7676 : 282 : gfc_convert_type (iter->end, &iter->var->ts, 1);
7677 : :
7678 : 34496 : if (iter->step->ts.kind != iter->var->ts.kind
7679 : 34496 : || iter->step->ts.type != iter->var->ts.type)
7680 : 279 : gfc_convert_type (iter->step, &iter->var->ts, 1);
7681 : :
7682 : 34496 : if (iter->step->expr_type == EXPR_CONSTANT)
7683 : : {
7684 : 33455 : if ((iter->step->ts.type == BT_INTEGER
7685 : 33372 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
7686 : 66825 : || (iter->step->ts.type == BT_REAL
7687 : 83 : && mpfr_sgn (iter->step->value.real) == 0))
7688 : : {
7689 : 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
7690 : 3 : &iter->step->where);
7691 : 3 : return false;
7692 : : }
7693 : : }
7694 : :
7695 : 34493 : if (iter->start->expr_type == EXPR_CONSTANT
7696 : 31567 : && iter->end->expr_type == EXPR_CONSTANT
7697 : 24635 : && iter->step->expr_type == EXPR_CONSTANT)
7698 : : {
7699 : 24369 : int sgn, cmp;
7700 : 24369 : if (iter->start->ts.type == BT_INTEGER)
7701 : : {
7702 : 24315 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
7703 : 24315 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
7704 : : }
7705 : : else
7706 : : {
7707 : 54 : sgn = mpfr_sgn (iter->step->value.real);
7708 : 54 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
7709 : : }
7710 : 24369 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
7711 : 146 : gfc_warning (OPT_Wzerotrip,
7712 : : "DO loop at %L will be executed zero times",
7713 : 146 : &iter->step->where);
7714 : : }
7715 : :
7716 : 34493 : if (iter->end->expr_type == EXPR_CONSTANT
7717 : 24958 : && iter->end->ts.type == BT_INTEGER
7718 : 24904 : && iter->step->expr_type == EXPR_CONSTANT
7719 : 24597 : && iter->step->ts.type == BT_INTEGER
7720 : 24597 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
7721 : 24269 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
7722 : : {
7723 : 23657 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
7724 : 23657 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
7725 : :
7726 : 23657 : if (is_step_positive
7727 : 23329 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
7728 : 7 : gfc_warning (OPT_Wundefined_do_loop,
7729 : : "DO loop at %L is undefined as it overflows",
7730 : 7 : &iter->step->where);
7731 : 328 : else if (!is_step_positive
7732 : 328 : && mpz_cmp (iter->end->value.integer,
7733 : 328 : gfc_integer_kinds[k].min_int) == 0)
7734 : 7 : gfc_warning (OPT_Wundefined_do_loop,
7735 : : "DO loop at %L is undefined as it underflows",
7736 : 7 : &iter->step->where);
7737 : : }
7738 : :
7739 : : return true;
7740 : : }
7741 : :
7742 : :
7743 : : /* Traversal function for find_forall_index. f == 2 signals that
7744 : : that variable itself is not to be checked - only the references. */
7745 : :
7746 : : static bool
7747 : 41662 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
7748 : : {
7749 : 41662 : if (expr->expr_type != EXPR_VARIABLE)
7750 : : return false;
7751 : :
7752 : : /* A scalar assignment */
7753 : 17756 : if (!expr->ref || *f == 1)
7754 : : {
7755 : 12020 : if (expr->symtree->n.sym == sym)
7756 : : return true;
7757 : : else
7758 : : return false;
7759 : : }
7760 : :
7761 : 5736 : if (*f == 2)
7762 : 1744 : *f = 1;
7763 : : return false;
7764 : : }
7765 : :
7766 : :
7767 : : /* Check whether the FORALL index appears in the expression or not.
7768 : : Returns true if SYM is found in EXPR. */
7769 : :
7770 : : bool
7771 : 26255 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
7772 : : {
7773 : 26255 : if (gfc_traverse_expr (expr, sym, forall_index, f))
7774 : : return true;
7775 : : else
7776 : 22288 : return false;
7777 : : }
7778 : :
7779 : :
7780 : : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7781 : : to be a scalar INTEGER variable. The subscripts and stride are scalar
7782 : : INTEGERs, and if stride is a constant it must be nonzero.
7783 : : Furthermore "A subscript or stride in a forall-triplet-spec shall
7784 : : not contain a reference to any index-name in the
7785 : : forall-triplet-spec-list in which it appears." (7.5.4.1) */
7786 : :
7787 : : static void
7788 : 2067 : resolve_forall_iterators (gfc_forall_iterator *it)
7789 : : {
7790 : 2067 : gfc_forall_iterator *iter, *iter2;
7791 : :
7792 : 6063 : for (iter = it; iter; iter = iter->next)
7793 : : {
7794 : 3996 : if (gfc_resolve_expr (iter->var)
7795 : 3996 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
7796 : 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7797 : : &iter->var->where);
7798 : :
7799 : 3996 : if (gfc_resolve_expr (iter->start)
7800 : 3996 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
7801 : 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7802 : : &iter->start->where);
7803 : 3996 : if (iter->var->ts.kind != iter->start->ts.kind)
7804 : 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
7805 : :
7806 : 3996 : if (gfc_resolve_expr (iter->end)
7807 : 3996 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
7808 : 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7809 : : &iter->end->where);
7810 : 3996 : if (iter->var->ts.kind != iter->end->ts.kind)
7811 : 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
7812 : :
7813 : 3996 : if (gfc_resolve_expr (iter->stride))
7814 : : {
7815 : 3996 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
7816 : 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
7817 : : &iter->stride->where, "INTEGER");
7818 : :
7819 : 3996 : if (iter->stride->expr_type == EXPR_CONSTANT
7820 : 3993 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
7821 : 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
7822 : : &iter->stride->where);
7823 : : }
7824 : 3996 : if (iter->var->ts.kind != iter->stride->ts.kind)
7825 : 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
7826 : : }
7827 : :
7828 : 6063 : for (iter = it; iter; iter = iter->next)
7829 : 10852 : for (iter2 = iter; iter2; iter2 = iter2->next)
7830 : : {
7831 : 6856 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
7832 : 6854 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
7833 : 13708 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
7834 : 6 : gfc_error ("FORALL index %qs may not appear in triplet "
7835 : 6 : "specification at %L", iter->var->symtree->name,
7836 : 6 : &iter2->start->where);
7837 : : }
7838 : 2067 : }
7839 : :
7840 : :
7841 : : /* Given a pointer to a symbol that is a derived type, see if it's
7842 : : inaccessible, i.e. if it's defined in another module and the components are
7843 : : PRIVATE. The search is recursive if necessary. Returns zero if no
7844 : : inaccessible components are found, nonzero otherwise. */
7845 : :
7846 : : static bool
7847 : 1299 : derived_inaccessible (gfc_symbol *sym)
7848 : : {
7849 : 1299 : gfc_component *c;
7850 : :
7851 : 1299 : if (sym->attr.use_assoc && sym->attr.private_comp)
7852 : : return 1;
7853 : :
7854 : 3871 : for (c = sym->components; c; c = c->next)
7855 : : {
7856 : : /* Prevent an infinite loop through this function. */
7857 : 2585 : if (c->ts.type == BT_DERIVED
7858 : 282 : && (c->attr.pointer || c->attr.allocatable)
7859 : 72 : && sym == c->ts.u.derived)
7860 : 72 : continue;
7861 : :
7862 : 2513 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
7863 : : return 1;
7864 : : }
7865 : :
7866 : : return 0;
7867 : : }
7868 : :
7869 : :
7870 : : /* Resolve the argument of a deallocate expression. The expression must be
7871 : : a pointer or a full array. */
7872 : :
7873 : : static bool
7874 : 7231 : resolve_deallocate_expr (gfc_expr *e)
7875 : : {
7876 : 7231 : symbol_attribute attr;
7877 : 7231 : int allocatable, pointer;
7878 : 7231 : gfc_ref *ref;
7879 : 7231 : gfc_symbol *sym;
7880 : 7231 : gfc_component *c;
7881 : 7231 : bool unlimited;
7882 : :
7883 : 7231 : if (!gfc_resolve_expr (e))
7884 : : return false;
7885 : :
7886 : 7231 : if (e->expr_type != EXPR_VARIABLE)
7887 : 0 : goto bad;
7888 : :
7889 : 7231 : sym = e->symtree->n.sym;
7890 : 7231 : unlimited = UNLIMITED_POLY(sym);
7891 : :
7892 : 7231 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
7893 : : {
7894 : 1249 : allocatable = CLASS_DATA (sym)->attr.allocatable;
7895 : 1249 : pointer = CLASS_DATA (sym)->attr.class_pointer;
7896 : : }
7897 : : else
7898 : : {
7899 : 5982 : allocatable = sym->attr.allocatable;
7900 : 5982 : pointer = sym->attr.pointer;
7901 : : }
7902 : 14270 : for (ref = e->ref; ref; ref = ref->next)
7903 : : {
7904 : 7039 : switch (ref->type)
7905 : : {
7906 : 5335 : case REF_ARRAY:
7907 : 5335 : if (ref->u.ar.type != AR_FULL
7908 : 5535 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
7909 : 200 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
7910 : : allocatable = 0;
7911 : : break;
7912 : :
7913 : 1704 : case REF_COMPONENT:
7914 : 1704 : c = ref->u.c.component;
7915 : 1704 : if (c->ts.type == BT_CLASS)
7916 : : {
7917 : 272 : allocatable = CLASS_DATA (c)->attr.allocatable;
7918 : 272 : pointer = CLASS_DATA (c)->attr.class_pointer;
7919 : : }
7920 : : else
7921 : : {
7922 : 1432 : allocatable = c->attr.allocatable;
7923 : 1432 : pointer = c->attr.pointer;
7924 : : }
7925 : : break;
7926 : :
7927 : : case REF_SUBSTRING:
7928 : : case REF_INQUIRY:
7929 : 361 : allocatable = 0;
7930 : : break;
7931 : : }
7932 : : }
7933 : :
7934 : 7231 : attr = gfc_expr_attr (e);
7935 : :
7936 : 7231 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
7937 : : {
7938 : 3 : bad:
7939 : 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7940 : : &e->where);
7941 : 3 : return false;
7942 : : }
7943 : :
7944 : : /* F2008, C644. */
7945 : 7228 : if (gfc_is_coindexed (e))
7946 : : {
7947 : 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
7948 : 1 : return false;
7949 : : }
7950 : :
7951 : 7227 : if (pointer
7952 : 9467 : && !gfc_check_vardef_context (e, true, true, false,
7953 : 2240 : _("DEALLOCATE object")))
7954 : : return false;
7955 : 7225 : if (!gfc_check_vardef_context (e, false, true, false,
7956 : 7225 : _("DEALLOCATE object")))
7957 : : return false;
7958 : :
7959 : : return true;
7960 : : }
7961 : :
7962 : :
7963 : : /* Returns true if the expression e contains a reference to the symbol sym. */
7964 : : static bool
7965 : 40381 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
7966 : : {
7967 : 40381 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
7968 : 2060 : return true;
7969 : :
7970 : : return false;
7971 : : }
7972 : :
7973 : : bool
7974 : 34079 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
7975 : : {
7976 : 34079 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
7977 : : }
7978 : :
7979 : :
7980 : : /* Given the expression node e for an allocatable/pointer of derived type to be
7981 : : allocated, get the expression node to be initialized afterwards (needed for
7982 : : derived types with default initializers, and derived types with allocatable
7983 : : components that need nullification.) */
7984 : :
7985 : : gfc_expr *
7986 : 4958 : gfc_expr_to_initialize (gfc_expr *e)
7987 : : {
7988 : 4958 : gfc_expr *result;
7989 : 4958 : gfc_ref *ref;
7990 : 4958 : int i;
7991 : :
7992 : 4958 : result = gfc_copy_expr (e);
7993 : :
7994 : : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7995 : 9956 : for (ref = result->ref; ref; ref = ref->next)
7996 : 7791 : if (ref->type == REF_ARRAY && ref->next == NULL)
7997 : : {
7998 : 2793 : if (ref->u.ar.dimen == 0
7999 : 62 : && ref->u.ar.as && ref->u.ar.as->corank)
8000 : : return result;
8001 : :
8002 : 2731 : ref->u.ar.type = AR_FULL;
8003 : :
8004 : 6080 : for (i = 0; i < ref->u.ar.dimen; i++)
8005 : 3349 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
8006 : :
8007 : : break;
8008 : : }
8009 : :
8010 : 4896 : gfc_free_shape (&result->shape, result->rank);
8011 : :
8012 : : /* Recalculate rank, shape, etc. */
8013 : 4896 : gfc_resolve_expr (result);
8014 : 4896 : return result;
8015 : : }
8016 : :
8017 : :
8018 : : /* If the last ref of an expression is an array ref, return a copy of the
8019 : : expression with that one removed. Otherwise, a copy of the original
8020 : : expression. This is used for allocate-expressions and pointer assignment
8021 : : LHS, where there may be an array specification that needs to be stripped
8022 : : off when using gfc_check_vardef_context. */
8023 : :
8024 : : static gfc_expr*
8025 : 24090 : remove_last_array_ref (gfc_expr* e)
8026 : : {
8027 : 24090 : gfc_expr* e2;
8028 : 24090 : gfc_ref** r;
8029 : :
8030 : 24090 : e2 = gfc_copy_expr (e);
8031 : 30600 : for (r = &e2->ref; *r; r = &(*r)->next)
8032 : 20153 : if ((*r)->type == REF_ARRAY && !(*r)->next)
8033 : : {
8034 : 13643 : gfc_free_ref_list (*r);
8035 : 13643 : *r = NULL;
8036 : 13643 : break;
8037 : : }
8038 : :
8039 : 24090 : return e2;
8040 : : }
8041 : :
8042 : :
8043 : : /* Used in resolve_allocate_expr to check that a allocation-object and
8044 : : a source-expr are conformable. This does not catch all possible
8045 : : cases; in particular a runtime checking is needed. */
8046 : :
8047 : : static bool
8048 : 1704 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
8049 : : {
8050 : 1704 : gfc_ref *tail;
8051 : 2371 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
8052 : :
8053 : : /* First compare rank. */
8054 : 1704 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
8055 : 2 : || (!tail && e1->rank != e2->rank))
8056 : : {
8057 : 4 : gfc_error ("Source-expr at %L must be scalar or have the "
8058 : : "same rank as the allocate-object at %L",
8059 : : &e1->where, &e2->where);
8060 : 4 : return false;
8061 : : }
8062 : :
8063 : 1700 : if (e1->shape)
8064 : : {
8065 : 1232 : int i;
8066 : 1232 : mpz_t s;
8067 : :
8068 : 1232 : mpz_init (s);
8069 : :
8070 : 2863 : for (i = 0; i < e1->rank; i++)
8071 : : {
8072 : 1238 : if (tail->u.ar.start[i] == NULL)
8073 : : break;
8074 : :
8075 : 399 : if (tail->u.ar.end[i])
8076 : : {
8077 : 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
8078 : 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
8079 : 54 : mpz_add_ui (s, s, 1);
8080 : : }
8081 : : else
8082 : : {
8083 : 345 : mpz_set (s, tail->u.ar.start[i]->value.integer);
8084 : : }
8085 : :
8086 : 399 : if (mpz_cmp (e1->shape[i], s) != 0)
8087 : : {
8088 : 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
8089 : : "have the same shape", &e1->where, &e2->where);
8090 : 0 : mpz_clear (s);
8091 : 0 : return false;
8092 : : }
8093 : : }
8094 : :
8095 : 1232 : mpz_clear (s);
8096 : : }
8097 : :
8098 : : return true;
8099 : : }
8100 : :
8101 : :
8102 : : /* Resolve the expression in an ALLOCATE statement, doing the additional
8103 : : checks to see whether the expression is OK or not. The expression must
8104 : : have a trailing array reference that gives the size of the array. */
8105 : :
8106 : : static bool
8107 : 14686 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
8108 : : {
8109 : 14686 : int i, pointer, allocatable, dimension, is_abstract;
8110 : 14686 : int codimension;
8111 : 14686 : bool coindexed;
8112 : 14686 : bool unlimited;
8113 : 14686 : symbol_attribute attr;
8114 : 14686 : gfc_ref *ref, *ref2;
8115 : 14686 : gfc_expr *e2;
8116 : 14686 : gfc_array_ref *ar;
8117 : 14686 : gfc_symbol *sym = NULL;
8118 : 14686 : gfc_alloc *a;
8119 : 14686 : gfc_component *c;
8120 : 14686 : bool t;
8121 : :
8122 : : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
8123 : : checking of coarrays. */
8124 : 18561 : for (ref = e->ref; ref; ref = ref->next)
8125 : 14717 : if (ref->next == NULL)
8126 : : break;
8127 : :
8128 : 14686 : if (ref && ref->type == REF_ARRAY)
8129 : 9794 : ref->u.ar.in_allocate = true;
8130 : :
8131 : 14686 : if (!gfc_resolve_expr (e))
8132 : 1 : goto failure;
8133 : :
8134 : : /* Make sure the expression is allocatable or a pointer. If it is
8135 : : pointer, the next-to-last reference must be a pointer. */
8136 : :
8137 : 14685 : ref2 = NULL;
8138 : 14685 : if (e->symtree)
8139 : 14685 : sym = e->symtree->n.sym;
8140 : :
8141 : : /* Check whether ultimate component is abstract and CLASS. */
8142 : 29370 : is_abstract = 0;
8143 : :
8144 : : /* Is the allocate-object unlimited polymorphic? */
8145 : 14685 : unlimited = UNLIMITED_POLY(e);
8146 : :
8147 : 14685 : if (e->expr_type != EXPR_VARIABLE)
8148 : : {
8149 : 0 : allocatable = 0;
8150 : 0 : attr = gfc_expr_attr (e);
8151 : 0 : pointer = attr.pointer;
8152 : 0 : dimension = attr.dimension;
8153 : 0 : codimension = attr.codimension;
8154 : : }
8155 : : else
8156 : : {
8157 : 14685 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
8158 : : {
8159 : 3131 : allocatable = CLASS_DATA (sym)->attr.allocatable;
8160 : 3131 : pointer = CLASS_DATA (sym)->attr.class_pointer;
8161 : 3131 : dimension = CLASS_DATA (sym)->attr.dimension;
8162 : 3131 : codimension = CLASS_DATA (sym)->attr.codimension;
8163 : 3131 : is_abstract = CLASS_DATA (sym)->attr.abstract;
8164 : : }
8165 : : else
8166 : : {
8167 : 11554 : allocatable = sym->attr.allocatable;
8168 : 11554 : pointer = sym->attr.pointer;
8169 : 11554 : dimension = sym->attr.dimension;
8170 : 11554 : codimension = sym->attr.codimension;
8171 : : }
8172 : :
8173 : 14685 : coindexed = false;
8174 : :
8175 : 29396 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
8176 : : {
8177 : 14713 : switch (ref->type)
8178 : : {
8179 : 11030 : case REF_ARRAY:
8180 : 11030 : if (ref->u.ar.codimen > 0)
8181 : : {
8182 : 631 : int n;
8183 : 920 : for (n = ref->u.ar.dimen;
8184 : 920 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
8185 : 668 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
8186 : : {
8187 : : coindexed = true;
8188 : : break;
8189 : : }
8190 : : }
8191 : :
8192 : 11030 : if (ref->next != NULL)
8193 : 1238 : pointer = 0;
8194 : : break;
8195 : :
8196 : 3683 : case REF_COMPONENT:
8197 : : /* F2008, C644. */
8198 : 3683 : if (coindexed)
8199 : : {
8200 : 2 : gfc_error ("Coindexed allocatable object at %L",
8201 : : &e->where);
8202 : 2 : goto failure;
8203 : : }
8204 : :
8205 : 3681 : c = ref->u.c.component;
8206 : 3681 : if (c->ts.type == BT_CLASS)
8207 : : {
8208 : 910 : allocatable = CLASS_DATA (c)->attr.allocatable;
8209 : 910 : pointer = CLASS_DATA (c)->attr.class_pointer;
8210 : 910 : dimension = CLASS_DATA (c)->attr.dimension;
8211 : 910 : codimension = CLASS_DATA (c)->attr.codimension;
8212 : 910 : is_abstract = CLASS_DATA (c)->attr.abstract;
8213 : : }
8214 : : else
8215 : : {
8216 : 2771 : allocatable = c->attr.allocatable;
8217 : 2771 : pointer = c->attr.pointer;
8218 : 2771 : dimension = c->attr.dimension;
8219 : 2771 : codimension = c->attr.codimension;
8220 : 2771 : is_abstract = c->attr.abstract;
8221 : : }
8222 : : break;
8223 : :
8224 : 0 : case REF_SUBSTRING:
8225 : 0 : case REF_INQUIRY:
8226 : 0 : allocatable = 0;
8227 : 0 : pointer = 0;
8228 : 0 : break;
8229 : : }
8230 : : }
8231 : : }
8232 : :
8233 : : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
8234 : : pointer or an allocatable variable. */
8235 : 14683 : if (allocatable == 0 && pointer == 0)
8236 : : {
8237 : 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8238 : : &e->where);
8239 : 4 : goto failure;
8240 : : }
8241 : :
8242 : : /* Some checks for the SOURCE tag. */
8243 : 14679 : if (code->expr3)
8244 : : {
8245 : : /* Check F03:C631. */
8246 : 3285 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
8247 : : {
8248 : 10 : gfc_error ("Type of entity at %L is type incompatible with "
8249 : 10 : "source-expr at %L", &e->where, &code->expr3->where);
8250 : 10 : goto failure;
8251 : : }
8252 : :
8253 : : /* Check F03:C632 and restriction following Note 6.18. */
8254 : 3275 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
8255 : 4 : goto failure;
8256 : :
8257 : : /* Check F03:C633. */
8258 : 3271 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
8259 : : {
8260 : 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
8261 : : "shall have the same kind type parameter",
8262 : : &e->where, &code->expr3->where);
8263 : 1 : goto failure;
8264 : : }
8265 : :
8266 : : /* Check F2008, C642. */
8267 : 3270 : if (code->expr3->ts.type == BT_DERIVED
8268 : 3270 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
8269 : 1116 : || (code->expr3->ts.u.derived->from_intmod
8270 : : == INTMOD_ISO_FORTRAN_ENV
8271 : 1116 : && code->expr3->ts.u.derived->intmod_sym_id
8272 : : == ISOFORTRAN_LOCK_TYPE)))
8273 : : {
8274 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
8275 : : "LOCK_TYPE nor have a LOCK_TYPE component if "
8276 : : "allocate-object at %L is a coarray",
8277 : 0 : &code->expr3->where, &e->where);
8278 : 0 : goto failure;
8279 : : }
8280 : :
8281 : : /* Check TS18508, C702/C703. */
8282 : 3270 : if (code->expr3->ts.type == BT_DERIVED
8283 : 4386 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
8284 : 1116 : || (code->expr3->ts.u.derived->from_intmod
8285 : : == INTMOD_ISO_FORTRAN_ENV
8286 : 1116 : && code->expr3->ts.u.derived->intmod_sym_id
8287 : : == ISOFORTRAN_EVENT_TYPE)))
8288 : : {
8289 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
8290 : : "EVENT_TYPE nor have a EVENT_TYPE component if "
8291 : : "allocate-object at %L is a coarray",
8292 : 0 : &code->expr3->where, &e->where);
8293 : 0 : goto failure;
8294 : : }
8295 : : }
8296 : :
8297 : : /* Check F08:C629. */
8298 : 14664 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
8299 : 133 : && !code->expr3)
8300 : : {
8301 : 2 : gcc_assert (e->ts.type == BT_CLASS);
8302 : 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
8303 : : "type-spec or source-expr", sym->name, &e->where);
8304 : 2 : goto failure;
8305 : : }
8306 : :
8307 : : /* Check F08:C632. */
8308 : 14662 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
8309 : 56 : && !UNLIMITED_POLY (e))
8310 : : {
8311 : 32 : int cmp;
8312 : :
8313 : 32 : if (!e->ts.u.cl->length)
8314 : 13 : goto failure;
8315 : :
8316 : 38 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
8317 : 19 : code->ext.alloc.ts.u.cl->length);
8318 : 19 : if (cmp == 1 || cmp == -1 || cmp == -3)
8319 : : {
8320 : 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
8321 : : "character-length parameter as in the declaration",
8322 : : sym->name, &e->where);
8323 : 2 : goto failure;
8324 : : }
8325 : : }
8326 : :
8327 : : /* In the variable definition context checks, gfc_expr_attr is used
8328 : : on the expression. This is fooled by the array specification
8329 : : present in e, thus we have to eliminate that one temporarily. */
8330 : 14647 : e2 = remove_last_array_ref (e);
8331 : 14647 : t = true;
8332 : 14647 : if (t && pointer)
8333 : 3604 : t = gfc_check_vardef_context (e2, true, true, false,
8334 : 3604 : _("ALLOCATE object"));
8335 : 3604 : if (t)
8336 : 14639 : t = gfc_check_vardef_context (e2, false, true, false,
8337 : 14639 : _("ALLOCATE object"));
8338 : 14647 : gfc_free_expr (e2);
8339 : 14647 : if (!t)
8340 : 11 : goto failure;
8341 : :
8342 : 14636 : code->ext.alloc.expr3_not_explicit = 0;
8343 : 14636 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
8344 : 1482 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
8345 : : {
8346 : : /* For class arrays, the initialization with SOURCE is done
8347 : : using _copy and trans_call. It is convenient to exploit that
8348 : : when the allocated type is different from the declared type but
8349 : : no SOURCE exists by setting expr3. */
8350 : 273 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
8351 : 273 : code->ext.alloc.expr3_not_explicit = 1;
8352 : : }
8353 : 14363 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
8354 : 2209 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8355 : 2209 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8356 : : {
8357 : : /* We have to zero initialize the integer variable. */
8358 : 1 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
8359 : 1 : code->ext.alloc.expr3_not_explicit = 1;
8360 : : }
8361 : :
8362 : 14636 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
8363 : : {
8364 : : /* Make sure the vtab symbol is present when
8365 : : the module variables are generated. */
8366 : 2767 : gfc_typespec ts = e->ts;
8367 : 2767 : if (code->expr3)
8368 : 1228 : ts = code->expr3->ts;
8369 : 1539 : else if (code->ext.alloc.ts.type == BT_DERIVED)
8370 : 664 : ts = code->ext.alloc.ts;
8371 : :
8372 : : /* Finding the vtab also publishes the type's symbol. Therefore this
8373 : : statement is necessary. */
8374 : 2767 : gfc_find_derived_vtab (ts.u.derived);
8375 : 2767 : }
8376 : 11869 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
8377 : : {
8378 : : /* Again, make sure the vtab symbol is present when
8379 : : the module variables are generated. */
8380 : 406 : gfc_typespec *ts = NULL;
8381 : 406 : if (code->expr3)
8382 : 322 : ts = &code->expr3->ts;
8383 : : else
8384 : 84 : ts = &code->ext.alloc.ts;
8385 : :
8386 : 406 : gcc_assert (ts);
8387 : :
8388 : : /* Finding the vtab also publishes the type's symbol. Therefore this
8389 : : statement is necessary. */
8390 : 406 : gfc_find_vtab (ts);
8391 : : }
8392 : :
8393 : 14636 : if (dimension == 0 && codimension == 0)
8394 : 4856 : goto success;
8395 : :
8396 : : /* Make sure the last reference node is an array specification. */
8397 : :
8398 : 9780 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
8399 : 8702 : || (dimension && ref2->u.ar.dimen == 0))
8400 : : {
8401 : : /* F08:C633. */
8402 : 1078 : if (code->expr3)
8403 : : {
8404 : 1077 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
8405 : : "in ALLOCATE statement at %L", &e->where))
8406 : 0 : goto failure;
8407 : 1077 : if (code->expr3->rank != 0)
8408 : 1076 : *array_alloc_wo_spec = true;
8409 : : else
8410 : : {
8411 : 1 : gfc_error ("Array specification or array-valued SOURCE= "
8412 : : "expression required in ALLOCATE statement at %L",
8413 : : &e->where);
8414 : 1 : goto failure;
8415 : : }
8416 : : }
8417 : : else
8418 : : {
8419 : 1 : gfc_error ("Array specification required in ALLOCATE statement "
8420 : : "at %L", &e->where);
8421 : 1 : goto failure;
8422 : : }
8423 : : }
8424 : :
8425 : : /* Make sure that the array section reference makes sense in the
8426 : : context of an ALLOCATE specification. */
8427 : :
8428 : 9778 : ar = &ref2->u.ar;
8429 : :
8430 : 9778 : if (codimension)
8431 : 902 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
8432 : : {
8433 : 536 : switch (ar->dimen_type[i])
8434 : : {
8435 : 2 : case DIMEN_THIS_IMAGE:
8436 : 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
8437 : : "at %L", &e->where);
8438 : 2 : goto failure;
8439 : :
8440 : 83 : case DIMEN_RANGE:
8441 : : /* F2018:R937:
8442 : : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8443 : : */
8444 : 83 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
8445 : : {
8446 : 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
8447 : : "at %L", &e->where);
8448 : 8 : goto failure;
8449 : : }
8450 : 75 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
8451 : : {
8452 : 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
8453 : 2 : &ar->start[i]->where);
8454 : 2 : goto failure;
8455 : : }
8456 : : break;
8457 : :
8458 : 85 : case DIMEN_ELEMENT:
8459 : 85 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
8460 : : {
8461 : 77 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
8462 : 77 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
8463 : : {
8464 : 1 : gfc_error ("Upper cobound is less than lower cobound "
8465 : : "of 1 at %L", &ar->start[i]->where);
8466 : 1 : goto failure;
8467 : : }
8468 : : }
8469 : : break;
8470 : :
8471 : : case DIMEN_STAR:
8472 : : break;
8473 : :
8474 : 0 : default:
8475 : 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
8476 : : &e->where);
8477 : 0 : goto failure;
8478 : :
8479 : : }
8480 : : }
8481 : 22797 : for (i = 0; i < ar->dimen; i++)
8482 : : {
8483 : 13034 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
8484 : 10687 : goto check_symbols;
8485 : :
8486 : 2347 : switch (ar->dimen_type[i])
8487 : : {
8488 : : case DIMEN_ELEMENT:
8489 : : break;
8490 : :
8491 : 2166 : case DIMEN_RANGE:
8492 : 2166 : if (ar->start[i] != NULL
8493 : 2166 : && ar->end[i] != NULL
8494 : 2165 : && ar->stride[i] == NULL)
8495 : : break;
8496 : :
8497 : : /* Fall through. */
8498 : :
8499 : 1 : case DIMEN_UNKNOWN:
8500 : 1 : case DIMEN_VECTOR:
8501 : 1 : case DIMEN_STAR:
8502 : 1 : case DIMEN_THIS_IMAGE:
8503 : 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
8504 : : &e->where);
8505 : 1 : goto failure;
8506 : : }
8507 : :
8508 : 2165 : check_symbols:
8509 : 34696 : for (a = code->ext.alloc.list; a; a = a->next)
8510 : : {
8511 : 21664 : sym = a->expr->symtree->n.sym;
8512 : :
8513 : : /* TODO - check derived type components. */
8514 : 21664 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
8515 : 8444 : continue;
8516 : :
8517 : 13220 : if ((ar->start[i] != NULL
8518 : 12688 : && gfc_find_sym_in_expr (sym, ar->start[i]))
8519 : 25907 : || (ar->end[i] != NULL
8520 : 2313 : && gfc_find_sym_in_expr (sym, ar->end[i])))
8521 : : {
8522 : 1 : gfc_error ("%qs must not appear in the array specification at "
8523 : : "%L in the same ALLOCATE statement where it is "
8524 : : "itself allocated", sym->name, &ar->where);
8525 : 1 : goto failure;
8526 : : }
8527 : : }
8528 : : }
8529 : :
8530 : 9919 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
8531 : : {
8532 : 677 : if (ar->dimen_type[i] == DIMEN_ELEMENT
8533 : 521 : || ar->dimen_type[i] == DIMEN_RANGE)
8534 : : {
8535 : 156 : if (i == (ar->dimen + ar->codimen - 1))
8536 : : {
8537 : 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
8538 : : "statement at %L", &e->where);
8539 : 0 : goto failure;
8540 : : }
8541 : 156 : continue;
8542 : : }
8543 : :
8544 : 365 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
8545 : 365 : && ar->stride[i] == NULL)
8546 : : break;
8547 : :
8548 : 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8549 : : &e->where);
8550 : 0 : goto failure;
8551 : : }
8552 : :
8553 : 9763 : success:
8554 : : return true;
8555 : :
8556 : : failure:
8557 : : return false;
8558 : : }
8559 : :
8560 : :
8561 : : static void
8562 : 17461 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
8563 : : {
8564 : 17461 : gfc_expr *stat, *errmsg, *pe, *qe;
8565 : 17461 : gfc_alloc *a, *p, *q;
8566 : :
8567 : 17461 : stat = code->expr1;
8568 : 17461 : errmsg = code->expr2;
8569 : :
8570 : : /* Check the stat variable. */
8571 : 17461 : if (stat)
8572 : : {
8573 : 614 : if (!gfc_check_vardef_context (stat, false, false, false,
8574 : 614 : _("STAT variable")))
8575 : 8 : goto done_stat;
8576 : :
8577 : 606 : if (stat->ts.type != BT_INTEGER
8578 : 597 : || stat->rank > 0)
8579 : 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8580 : : "variable", &stat->where);
8581 : :
8582 : 606 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
8583 : 0 : goto done_stat;
8584 : :
8585 : : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8586 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8587 : : */
8588 : 1257 : for (p = code->ext.alloc.list; p; p = p->next)
8589 : 658 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
8590 : : {
8591 : 9 : gfc_ref *ref1, *ref2;
8592 : 9 : bool found = true;
8593 : :
8594 : 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
8595 : 7 : ref1 = ref1->next, ref2 = ref2->next)
8596 : : {
8597 : 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8598 : 5 : continue;
8599 : 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
8600 : : {
8601 : : found = false;
8602 : : break;
8603 : : }
8604 : : }
8605 : :
8606 : 9 : if (found)
8607 : : {
8608 : 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
8609 : : "the same %s statement", &stat->where, fcn, fcn);
8610 : 7 : break;
8611 : : }
8612 : : }
8613 : : }
8614 : :
8615 : 16847 : done_stat:
8616 : :
8617 : : /* Check the errmsg variable. */
8618 : 17461 : if (errmsg)
8619 : : {
8620 : 146 : if (!stat)
8621 : 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8622 : : &errmsg->where);
8623 : :
8624 : 146 : if (!gfc_check_vardef_context (errmsg, false, false, false,
8625 : 146 : _("ERRMSG variable")))
8626 : 6 : goto done_errmsg;
8627 : :
8628 : : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8629 : : F18:R930 errmsg-variable is scalar-default-char-variable
8630 : : F18:R906 default-char-variable is variable
8631 : : F18:C906 default-char-variable shall be default character. */
8632 : 140 : if (errmsg->ts.type != BT_CHARACTER
8633 : 138 : || errmsg->rank > 0
8634 : 137 : || errmsg->ts.kind != gfc_default_character_kind)
8635 : 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8636 : : "variable", &errmsg->where);
8637 : :
8638 : 140 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
8639 : 0 : goto done_errmsg;
8640 : :
8641 : : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8642 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8643 : : */
8644 : 278 : for (p = code->ext.alloc.list; p; p = p->next)
8645 : 143 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
8646 : : {
8647 : 9 : gfc_ref *ref1, *ref2;
8648 : 9 : bool found = true;
8649 : :
8650 : 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
8651 : 7 : ref1 = ref1->next, ref2 = ref2->next)
8652 : : {
8653 : 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8654 : 4 : continue;
8655 : 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
8656 : : {
8657 : : found = false;
8658 : : break;
8659 : : }
8660 : : }
8661 : :
8662 : 9 : if (found)
8663 : : {
8664 : 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
8665 : : "the same %s statement", &errmsg->where, fcn, fcn);
8666 : 5 : break;
8667 : : }
8668 : : }
8669 : : }
8670 : :
8671 : 17315 : done_errmsg:
8672 : :
8673 : : /* Check that an allocate-object appears only once in the statement. */
8674 : :
8675 : 39378 : for (p = code->ext.alloc.list; p; p = p->next)
8676 : : {
8677 : 21917 : pe = p->expr;
8678 : 29750 : for (q = p->next; q; q = q->next)
8679 : : {
8680 : 7833 : qe = q->expr;
8681 : 7833 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
8682 : : {
8683 : : /* This is a potential collision. */
8684 : 1903 : gfc_ref *pr = pe->ref;
8685 : 1903 : gfc_ref *qr = qe->ref;
8686 : :
8687 : : /* Follow the references until
8688 : : a) They start to differ, in which case there is no error;
8689 : : you can deallocate a%b and a%c in a single statement
8690 : : b) Both of them stop, which is an error
8691 : : c) One of them stops, which is also an error. */
8692 : 3643 : while (1)
8693 : : {
8694 : 2773 : if (pr == NULL && qr == NULL)
8695 : : {
8696 : 7 : gfc_error ("Allocate-object at %L also appears at %L",
8697 : : &pe->where, &qe->where);
8698 : 7 : break;
8699 : : }
8700 : 2766 : else if (pr != NULL && qr == NULL)
8701 : : {
8702 : 2 : gfc_error ("Allocate-object at %L is subobject of"
8703 : : " object at %L", &pe->where, &qe->where);
8704 : 2 : break;
8705 : : }
8706 : 2764 : else if (pr == NULL && qr != NULL)
8707 : : {
8708 : 2 : gfc_error ("Allocate-object at %L is subobject of"
8709 : : " object at %L", &qe->where, &pe->where);
8710 : 2 : break;
8711 : : }
8712 : : /* Here, pr != NULL && qr != NULL */
8713 : 2762 : gcc_assert(pr->type == qr->type);
8714 : 2762 : if (pr->type == REF_ARRAY)
8715 : : {
8716 : : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8717 : : which are legal. */
8718 : 897 : gcc_assert (qr->type == REF_ARRAY);
8719 : :
8720 : 897 : if (pr->next && qr->next)
8721 : : {
8722 : : int i;
8723 : : gfc_array_ref *par = &(pr->u.ar);
8724 : : gfc_array_ref *qar = &(qr->u.ar);
8725 : :
8726 : 1528 : for (i=0; i<par->dimen; i++)
8727 : : {
8728 : 738 : if ((par->start[i] != NULL
8729 : 0 : || qar->start[i] != NULL)
8730 : 738 : && gfc_dep_compare_expr (par->start[i],
8731 : : qar->start[i]) != 0)
8732 : 96 : goto break_label;
8733 : : }
8734 : : }
8735 : : }
8736 : : else
8737 : : {
8738 : 1865 : if (pr->u.c.component->name != qr->u.c.component->name)
8739 : : break;
8740 : : }
8741 : :
8742 : 870 : pr = pr->next;
8743 : 870 : qr = qr->next;
8744 : 870 : }
8745 : 7833 : break_label:
8746 : : ;
8747 : : }
8748 : : }
8749 : : }
8750 : :
8751 : 17461 : if (strcmp (fcn, "ALLOCATE") == 0)
8752 : : {
8753 : 12055 : bool arr_alloc_wo_spec = false;
8754 : :
8755 : : /* Resolving the expr3 in the loop over all objects to allocate would
8756 : : execute loop invariant code for each loop item. Therefore do it just
8757 : : once here. */
8758 : 12055 : if (code->expr3 && code->expr3->mold
8759 : 250 : && code->expr3->ts.type == BT_DERIVED)
8760 : : {
8761 : : /* Default initialization via MOLD (non-polymorphic). */
8762 : 20 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
8763 : 20 : if (rhs != NULL)
8764 : : {
8765 : 7 : gfc_resolve_expr (rhs);
8766 : 7 : gfc_free_expr (code->expr3);
8767 : 7 : code->expr3 = rhs;
8768 : : }
8769 : : }
8770 : 26741 : for (a = code->ext.alloc.list; a; a = a->next)
8771 : 14686 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
8772 : :
8773 : 12055 : if (arr_alloc_wo_spec && code->expr3)
8774 : : {
8775 : : /* Mark the allocate to have to take the array specification
8776 : : from the expr3. */
8777 : 1070 : code->ext.alloc.arr_spec_from_expr3 = 1;
8778 : : }
8779 : : }
8780 : : else
8781 : : {
8782 : 12637 : for (a = code->ext.alloc.list; a; a = a->next)
8783 : 7231 : resolve_deallocate_expr (a->expr);
8784 : : }
8785 : 17461 : }
8786 : :
8787 : :
8788 : : /************ SELECT CASE resolution subroutines ************/
8789 : :
8790 : : /* Callback function for our mergesort variant. Determines interval
8791 : : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8792 : : op1 > op2. Assumes we're not dealing with the default case.
8793 : : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8794 : : There are nine situations to check. */
8795 : :
8796 : : static int
8797 : 1376 : compare_cases (const gfc_case *op1, const gfc_case *op2)
8798 : : {
8799 : 1376 : int retval;
8800 : :
8801 : 1376 : if (op1->low == NULL) /* op1 = (:L) */
8802 : : {
8803 : : /* op2 = (:N), so overlap. */
8804 : 52 : retval = 0;
8805 : : /* op2 = (M:) or (M:N), L < M */
8806 : 52 : if (op2->low != NULL
8807 : 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8808 : : retval = -1;
8809 : : }
8810 : 1324 : else if (op1->high == NULL) /* op1 = (K:) */
8811 : : {
8812 : : /* op2 = (M:), so overlap. */
8813 : 10 : retval = 0;
8814 : : /* op2 = (:N) or (M:N), K > N */
8815 : 10 : if (op2->high != NULL
8816 : 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8817 : : retval = 1;
8818 : : }
8819 : : else /* op1 = (K:L) */
8820 : : {
8821 : 1314 : if (op2->low == NULL) /* op2 = (:N), K > N */
8822 : 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8823 : 18 : ? 1 : 0;
8824 : 1296 : else if (op2->high == NULL) /* op2 = (M:), L < M */
8825 : 10 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8826 : 10 : ? -1 : 0;
8827 : : else /* op2 = (M:N) */
8828 : : {
8829 : 1286 : retval = 0;
8830 : : /* L < M */
8831 : 1286 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8832 : : retval = -1;
8833 : : /* K > N */
8834 : 329 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8835 : 355 : retval = 1;
8836 : : }
8837 : : }
8838 : :
8839 : 1376 : return retval;
8840 : : }
8841 : :
8842 : :
8843 : : /* Merge-sort a double linked case list, detecting overlap in the
8844 : : process. LIST is the head of the double linked case list before it
8845 : : is sorted. Returns the head of the sorted list if we don't see any
8846 : : overlap, or NULL otherwise. */
8847 : :
8848 : : static gfc_case *
8849 : 649 : check_case_overlap (gfc_case *list)
8850 : : {
8851 : 649 : gfc_case *p, *q, *e, *tail;
8852 : 649 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
8853 : :
8854 : : /* If the passed list was empty, return immediately. */
8855 : 649 : if (!list)
8856 : : return NULL;
8857 : :
8858 : : overlap_seen = 0;
8859 : : insize = 1;
8860 : :
8861 : : /* Loop unconditionally. The only exit from this loop is a return
8862 : : statement, when we've finished sorting the case list. */
8863 : 1277 : for (;;)
8864 : : {
8865 : 963 : p = list;
8866 : 963 : list = NULL;
8867 : 963 : tail = NULL;
8868 : :
8869 : : /* Count the number of merges we do in this pass. */
8870 : 963 : nmerges = 0;
8871 : :
8872 : : /* Loop while there exists a merge to be done. */
8873 : 2361 : while (p)
8874 : : {
8875 : 1398 : int i;
8876 : :
8877 : : /* Count this merge. */
8878 : 1398 : nmerges++;
8879 : :
8880 : : /* Cut the list in two pieces by stepping INSIZE places
8881 : : forward in the list, starting from P. */
8882 : 1398 : psize = 0;
8883 : 1398 : q = p;
8884 : 2838 : for (i = 0; i < insize; i++)
8885 : : {
8886 : 1979 : psize++;
8887 : 1979 : q = q->right;
8888 : 1979 : if (!q)
8889 : : break;
8890 : : }
8891 : : qsize = insize;
8892 : :
8893 : : /* Now we have two lists. Merge them! */
8894 : 4440 : while (psize > 0 || (qsize > 0 && q != NULL))
8895 : : {
8896 : : /* See from which the next case to merge comes from. */
8897 : 708 : if (psize == 0)
8898 : : {
8899 : : /* P is empty so the next case must come from Q. */
8900 : 708 : e = q;
8901 : 708 : q = q->right;
8902 : 708 : qsize--;
8903 : : }
8904 : 2334 : else if (qsize == 0 || q == NULL)
8905 : : {
8906 : : /* Q is empty. */
8907 : 958 : e = p;
8908 : 958 : p = p->right;
8909 : 958 : psize--;
8910 : : }
8911 : : else
8912 : : {
8913 : 1376 : cmp = compare_cases (p, q);
8914 : 1376 : if (cmp < 0)
8915 : : {
8916 : : /* The whole case range for P is less than the
8917 : : one for Q. */
8918 : 1017 : e = p;
8919 : 1017 : p = p->right;
8920 : 1017 : psize--;
8921 : : }
8922 : 359 : else if (cmp > 0)
8923 : : {
8924 : : /* The whole case range for Q is greater than
8925 : : the case range for P. */
8926 : 355 : e = q;
8927 : 355 : q = q->right;
8928 : 355 : qsize--;
8929 : : }
8930 : : else
8931 : : {
8932 : : /* The cases overlap, or they are the same
8933 : : element in the list. Either way, we must
8934 : : issue an error and get the next case from P. */
8935 : : /* FIXME: Sort P and Q by line number. */
8936 : 4 : gfc_error ("CASE label at %L overlaps with CASE "
8937 : : "label at %L", &p->where, &q->where);
8938 : 4 : overlap_seen = 1;
8939 : 4 : e = p;
8940 : 4 : p = p->right;
8941 : 4 : psize--;
8942 : : }
8943 : : }
8944 : :
8945 : : /* Add the next element to the merged list. */
8946 : 3042 : if (tail)
8947 : 2079 : tail->right = e;
8948 : : else
8949 : : list = e;
8950 : 3042 : e->left = tail;
8951 : 3042 : tail = e;
8952 : : }
8953 : :
8954 : : /* P has now stepped INSIZE places along, and so has Q. So
8955 : : they're the same. */
8956 : : p = q;
8957 : : }
8958 : 963 : tail->right = NULL;
8959 : :
8960 : : /* If we have done only one merge or none at all, we've
8961 : : finished sorting the cases. */
8962 : 963 : if (nmerges <= 1)
8963 : : {
8964 : 649 : if (!overlap_seen)
8965 : : return list;
8966 : : else
8967 : : return NULL;
8968 : : }
8969 : :
8970 : : /* Otherwise repeat, merging lists twice the size. */
8971 : 314 : insize *= 2;
8972 : 314 : }
8973 : : }
8974 : :
8975 : :
8976 : : /* Check to see if an expression is suitable for use in a CASE statement.
8977 : : Makes sure that all case expressions are scalar constants of the same
8978 : : type. Return false if anything is wrong. */
8979 : :
8980 : : static bool
8981 : 3101 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
8982 : : {
8983 : 3101 : if (e == NULL) return true;
8984 : :
8985 : 3008 : if (e->ts.type != case_expr->ts.type)
8986 : : {
8987 : 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
8988 : : &e->where, gfc_basic_typename (case_expr->ts.type));
8989 : 4 : return false;
8990 : : }
8991 : :
8992 : : /* C805 (R808) For a given case-construct, each case-value shall be of
8993 : : the same type as case-expr. For character type, length differences
8994 : : are allowed, but the kind type parameters shall be the same. */
8995 : :
8996 : 3004 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
8997 : : {
8998 : 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
8999 : : &e->where, case_expr->ts.kind);
9000 : 4 : return false;
9001 : : }
9002 : :
9003 : : /* Convert the case value kind to that of case expression kind,
9004 : : if needed */
9005 : :
9006 : 3000 : if (e->ts.kind != case_expr->ts.kind)
9007 : 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
9008 : :
9009 : 3000 : if (e->rank != 0)
9010 : : {
9011 : 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
9012 : : &e->where);
9013 : 0 : return false;
9014 : : }
9015 : :
9016 : : return true;
9017 : : }
9018 : :
9019 : :
9020 : : /* Given a completely parsed select statement, we:
9021 : :
9022 : : - Validate all expressions and code within the SELECT.
9023 : : - Make sure that the selection expression is not of the wrong type.
9024 : : - Make sure that no case ranges overlap.
9025 : : - Eliminate unreachable cases and unreachable code resulting from
9026 : : removing case labels.
9027 : :
9028 : : The standard does allow unreachable cases, e.g. CASE (5:3). But
9029 : : they are a hassle for code generation, and to prevent that, we just
9030 : : cut them out here. This is not necessary for overlapping cases
9031 : : because they are illegal and we never even try to generate code.
9032 : :
9033 : : We have the additional caveat that a SELECT construct could have
9034 : : been a computed GOTO in the source code. Fortunately we can fairly
9035 : : easily work around that here: The case_expr for a "real" SELECT CASE
9036 : : is in code->expr1, but for a computed GOTO it is in code->expr2. All
9037 : : we have to do is make sure that the case_expr is a scalar integer
9038 : : expression. */
9039 : :
9040 : : static void
9041 : 690 : resolve_select (gfc_code *code, bool select_type)
9042 : : {
9043 : 690 : gfc_code *body;
9044 : 690 : gfc_expr *case_expr;
9045 : 690 : gfc_case *cp, *default_case, *tail, *head;
9046 : 690 : int seen_unreachable;
9047 : 690 : int seen_logical;
9048 : 690 : int ncases;
9049 : 690 : bt type;
9050 : 690 : bool t;
9051 : :
9052 : 690 : if (code->expr1 == NULL)
9053 : : {
9054 : : /* This was actually a computed GOTO statement. */
9055 : 5 : case_expr = code->expr2;
9056 : 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
9057 : 3 : gfc_error ("Selection expression in computed GOTO statement "
9058 : : "at %L must be a scalar integer expression",
9059 : : &case_expr->where);
9060 : :
9061 : : /* Further checking is not necessary because this SELECT was built
9062 : : by the compiler, so it should always be OK. Just move the
9063 : : case_expr from expr2 to expr so that we can handle computed
9064 : : GOTOs as normal SELECTs from here on. */
9065 : 5 : code->expr1 = code->expr2;
9066 : 5 : code->expr2 = NULL;
9067 : 5 : return;
9068 : : }
9069 : :
9070 : 685 : case_expr = code->expr1;
9071 : 685 : type = case_expr->ts.type;
9072 : :
9073 : : /* F08:C830. */
9074 : 685 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
9075 : : {
9076 : 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
9077 : : &case_expr->where, gfc_typename (case_expr));
9078 : :
9079 : : /* Punt. Going on here just produce more garbage error messages. */
9080 : 0 : return;
9081 : : }
9082 : :
9083 : : /* F08:R842. */
9084 : 685 : if (!select_type && case_expr->rank != 0)
9085 : : {
9086 : 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
9087 : : "expression", &case_expr->where);
9088 : :
9089 : : /* Punt. */
9090 : 1 : return;
9091 : : }
9092 : :
9093 : : /* Raise a warning if an INTEGER case value exceeds the range of
9094 : : the case-expr. Later, all expressions will be promoted to the
9095 : : largest kind of all case-labels. */
9096 : :
9097 : 684 : if (type == BT_INTEGER)
9098 : 1832 : for (body = code->block; body; body = body->block)
9099 : 2664 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
9100 : : {
9101 : 1368 : if (cp->low
9102 : 1368 : && gfc_check_integer_range (cp->low->value.integer,
9103 : : case_expr->ts.kind) != ARITH_OK)
9104 : 6 : gfc_warning (0, "Expression in CASE statement at %L is "
9105 : 6 : "not in the range of %s", &cp->low->where,
9106 : : gfc_typename (case_expr));
9107 : :
9108 : 1368 : if (cp->high
9109 : 1082 : && cp->low != cp->high
9110 : 1476 : && gfc_check_integer_range (cp->high->value.integer,
9111 : : case_expr->ts.kind) != ARITH_OK)
9112 : 0 : gfc_warning (0, "Expression in CASE statement at %L is "
9113 : 0 : "not in the range of %s", &cp->high->where,
9114 : : gfc_typename (case_expr));
9115 : : }
9116 : :
9117 : : /* PR 19168 has a long discussion concerning a mismatch of the kinds
9118 : : of the SELECT CASE expression and its CASE values. Walk the lists
9119 : : of case values, and if we find a mismatch, promote case_expr to
9120 : : the appropriate kind. */
9121 : :
9122 : 684 : if (type == BT_LOGICAL || type == BT_INTEGER)
9123 : : {
9124 : 2018 : for (body = code->block; body; body = body->block)
9125 : : {
9126 : : /* Walk the case label list. */
9127 : 2925 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
9128 : : {
9129 : : /* Intercept the DEFAULT case. It does not have a kind. */
9130 : 1503 : if (cp->low == NULL && cp->high == NULL)
9131 : 294 : continue;
9132 : :
9133 : : /* Unreachable case ranges are discarded, so ignore. */
9134 : 1164 : if (cp->low != NULL && cp->high != NULL
9135 : 1116 : && cp->low != cp->high
9136 : 1274 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
9137 : 33 : continue;
9138 : :
9139 : 1176 : if (cp->low != NULL
9140 : 1176 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
9141 : 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
9142 : :
9143 : 1176 : if (cp->high != NULL
9144 : 1176 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
9145 : 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
9146 : : }
9147 : : }
9148 : : }
9149 : :
9150 : : /* Assume there is no DEFAULT case. */
9151 : 684 : default_case = NULL;
9152 : 684 : head = tail = NULL;
9153 : 684 : ncases = 0;
9154 : 684 : seen_logical = 0;
9155 : :
9156 : 2403 : for (body = code->block; body; body = body->block)
9157 : : {
9158 : : /* Assume the CASE list is OK, and all CASE labels can be matched. */
9159 : 1719 : t = true;
9160 : 1719 : seen_unreachable = 0;
9161 : :
9162 : : /* Walk the case label list, making sure that all case labels
9163 : : are legal. */
9164 : 3630 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
9165 : : {
9166 : : /* Count the number of cases in the whole construct. */
9167 : 1922 : ncases++;
9168 : :
9169 : : /* Intercept the DEFAULT case. */
9170 : 1922 : if (cp->low == NULL && cp->high == NULL)
9171 : : {
9172 : 368 : if (default_case != NULL)
9173 : : {
9174 : 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
9175 : : "by a second DEFAULT CASE at %L",
9176 : : &default_case->where, &cp->where);
9177 : 0 : t = false;
9178 : 0 : break;
9179 : : }
9180 : : else
9181 : : {
9182 : 368 : default_case = cp;
9183 : 368 : continue;
9184 : : }
9185 : : }
9186 : :
9187 : : /* Deal with single value cases and case ranges. Errors are
9188 : : issued from the validation function. */
9189 : 1554 : if (!validate_case_label_expr (cp->low, case_expr)
9190 : 1554 : || !validate_case_label_expr (cp->high, case_expr))
9191 : : {
9192 : : t = false;
9193 : : break;
9194 : : }
9195 : :
9196 : 1546 : if (type == BT_LOGICAL
9197 : 78 : && ((cp->low == NULL || cp->high == NULL)
9198 : 76 : || cp->low != cp->high))
9199 : : {
9200 : 2 : gfc_error ("Logical range in CASE statement at %L is not "
9201 : : "allowed",
9202 : 1 : cp->low ? &cp->low->where : &cp->high->where);
9203 : 2 : t = false;
9204 : 2 : break;
9205 : : }
9206 : :
9207 : 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
9208 : : {
9209 : 76 : int value;
9210 : 76 : value = cp->low->value.logical == 0 ? 2 : 1;
9211 : 76 : if (value & seen_logical)
9212 : : {
9213 : 1 : gfc_error ("Constant logical value in CASE statement "
9214 : : "is repeated at %L",
9215 : : &cp->low->where);
9216 : 1 : t = false;
9217 : 1 : break;
9218 : : }
9219 : 75 : seen_logical |= value;
9220 : : }
9221 : :
9222 : 1499 : if (cp->low != NULL && cp->high != NULL
9223 : 1452 : && cp->low != cp->high
9224 : 1665 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
9225 : : {
9226 : 35 : if (warn_surprising)
9227 : 1 : gfc_warning (OPT_Wsurprising,
9228 : : "Range specification at %L can never be matched",
9229 : : &cp->where);
9230 : :
9231 : 35 : cp->unreachable = 1;
9232 : 35 : seen_unreachable = 1;
9233 : : }
9234 : : else
9235 : : {
9236 : : /* If the case range can be matched, it can also overlap with
9237 : : other cases. To make sure it does not, we put it in a
9238 : : double linked list here. We sort that with a merge sort
9239 : : later on to detect any overlapping cases. */
9240 : 1508 : if (!head)
9241 : : {
9242 : 649 : head = tail = cp;
9243 : 649 : head->right = head->left = NULL;
9244 : : }
9245 : : else
9246 : : {
9247 : 859 : tail->right = cp;
9248 : 859 : tail->right->left = tail;
9249 : 859 : tail = tail->right;
9250 : 859 : tail->right = NULL;
9251 : : }
9252 : : }
9253 : : }
9254 : :
9255 : : /* It there was a failure in the previous case label, give up
9256 : : for this case label list. Continue with the next block. */
9257 : 1719 : if (!t)
9258 : 11 : continue;
9259 : :
9260 : : /* See if any case labels that are unreachable have been seen.
9261 : : If so, we eliminate them. This is a bit of a kludge because
9262 : : the case lists for a single case statement (label) is a
9263 : : single forward linked lists. */
9264 : 1708 : if (seen_unreachable)
9265 : : {
9266 : : /* Advance until the first case in the list is reachable. */
9267 : 69 : while (body->ext.block.case_list != NULL
9268 : 69 : && body->ext.block.case_list->unreachable)
9269 : : {
9270 : 34 : gfc_case *n = body->ext.block.case_list;
9271 : 34 : body->ext.block.case_list = body->ext.block.case_list->next;
9272 : 34 : n->next = NULL;
9273 : 34 : gfc_free_case_list (n);
9274 : : }
9275 : :
9276 : : /* Strip all other unreachable cases. */
9277 : 35 : if (body->ext.block.case_list)
9278 : : {
9279 : 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
9280 : : {
9281 : 1 : if (cp->next->unreachable)
9282 : : {
9283 : 1 : gfc_case *n = cp->next;
9284 : 1 : cp->next = cp->next->next;
9285 : 1 : n->next = NULL;
9286 : 1 : gfc_free_case_list (n);
9287 : : }
9288 : : }
9289 : : }
9290 : : }
9291 : : }
9292 : :
9293 : : /* See if there were overlapping cases. If the check returns NULL,
9294 : : there was overlap. In that case we don't do anything. If head
9295 : : is non-NULL, we prepend the DEFAULT case. The sorted list can
9296 : : then used during code generation for SELECT CASE constructs with
9297 : : a case expression of a CHARACTER type. */
9298 : 684 : if (head)
9299 : : {
9300 : 649 : head = check_case_overlap (head);
9301 : :
9302 : : /* Prepend the default_case if it is there. */
9303 : 649 : if (head != NULL && default_case)
9304 : : {
9305 : 351 : default_case->left = NULL;
9306 : 351 : default_case->right = head;
9307 : 351 : head->left = default_case;
9308 : : }
9309 : : }
9310 : :
9311 : : /* Eliminate dead blocks that may be the result if we've seen
9312 : : unreachable case labels for a block. */
9313 : 2369 : for (body = code; body && body->block; body = body->block)
9314 : : {
9315 : 1685 : if (body->block->ext.block.case_list == NULL)
9316 : : {
9317 : : /* Cut the unreachable block from the code chain. */
9318 : 34 : gfc_code *c = body->block;
9319 : 34 : body->block = c->block;
9320 : :
9321 : : /* Kill the dead block, but not the blocks below it. */
9322 : 34 : c->block = NULL;
9323 : 34 : gfc_free_statements (c);
9324 : : }
9325 : : }
9326 : :
9327 : : /* More than two cases is legal but insane for logical selects.
9328 : : Issue a warning for it. */
9329 : 684 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
9330 : 0 : gfc_warning (OPT_Wsurprising,
9331 : : "Logical SELECT CASE block at %L has more that two cases",
9332 : : &code->loc);
9333 : : }
9334 : :
9335 : :
9336 : : /* Check if a derived type is extensible. */
9337 : :
9338 : : bool
9339 : 21287 : gfc_type_is_extensible (gfc_symbol *sym)
9340 : : {
9341 : 21287 : return !(sym->attr.is_bind_c || sym->attr.sequence
9342 : 21271 : || (sym->attr.is_class
9343 : 1824 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
9344 : : }
9345 : :
9346 : :
9347 : : static void
9348 : : resolve_types (gfc_namespace *ns);
9349 : :
9350 : : /* Resolve an associate-name: Resolve target and ensure the type-spec is
9351 : : correct as well as possibly the array-spec. */
9352 : :
9353 : : static void
9354 : 11484 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
9355 : : {
9356 : 11484 : gfc_expr* target;
9357 : 11484 : bool parentheses = false;
9358 : :
9359 : 11484 : gcc_assert (sym->assoc);
9360 : 11484 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
9361 : :
9362 : : /* If this is for SELECT TYPE, the target may not yet be set. In that
9363 : : case, return. Resolution will be called later manually again when
9364 : : this is done. */
9365 : 11484 : target = sym->assoc->target;
9366 : 11484 : if (!target)
9367 : : return;
9368 : 6773 : gcc_assert (!sym->assoc->dangling);
9369 : :
9370 : 6773 : if (target->expr_type == EXPR_OP
9371 : 191 : && target->value.op.op == INTRINSIC_PARENTHESES
9372 : 35 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
9373 : : {
9374 : 16 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
9375 : 16 : gfc_free_expr (target);
9376 : 16 : target = sym->assoc->target;
9377 : 16 : parentheses = true;
9378 : : }
9379 : :
9380 : 6773 : if (resolve_target && !gfc_resolve_expr (target))
9381 : : return;
9382 : :
9383 : : /* For variable targets, we get some attributes from the target. */
9384 : 6767 : if (target->expr_type == EXPR_VARIABLE)
9385 : : {
9386 : 5982 : gfc_symbol *tsym, *dsym;
9387 : :
9388 : 5982 : gcc_assert (target->symtree);
9389 : 5982 : tsym = target->symtree->n.sym;
9390 : :
9391 : 5982 : if (gfc_expr_attr (target).proc_pointer)
9392 : : {
9393 : 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
9394 : : tsym->name, &target->where);
9395 : 0 : return;
9396 : : }
9397 : :
9398 : 73 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
9399 : 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
9400 : 5983 : && dsym->attr.flavor == FL_DERIVED)
9401 : : {
9402 : 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
9403 : : tsym->name, &target->where);
9404 : 1 : return;
9405 : : }
9406 : :
9407 : 5981 : if (tsym->attr.flavor == FL_PROCEDURE)
9408 : : {
9409 : 72 : bool is_error = true;
9410 : 72 : if (tsym->attr.function && tsym->result == tsym)
9411 : 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
9412 : 137 : if (tsym == ns->proc_name)
9413 : : {
9414 : : is_error = false;
9415 : : break;
9416 : : }
9417 : 64 : if (is_error)
9418 : : {
9419 : 12 : gfc_error ("Associating entity %qs at %L is a procedure name",
9420 : : tsym->name, &target->where);
9421 : 12 : return;
9422 : : }
9423 : : }
9424 : :
9425 : 5969 : sym->attr.asynchronous = tsym->attr.asynchronous;
9426 : 5969 : sym->attr.volatile_ = tsym->attr.volatile_;
9427 : :
9428 : 11938 : sym->attr.target = tsym->attr.target
9429 : 5969 : || gfc_expr_attr (target).pointer;
9430 : 5969 : if (is_subref_array (target))
9431 : 358 : sym->attr.subref_array_pointer = 1;
9432 : : }
9433 : 785 : else if (target->ts.type == BT_PROCEDURE)
9434 : : {
9435 : 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
9436 : : &target->where);
9437 : 0 : return;
9438 : : }
9439 : :
9440 : 6754 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
9441 : : {
9442 : : /* By now, the type of the target has been fixed up. */
9443 : 270 : symbol_attribute attr;
9444 : :
9445 : 270 : if (sym->ts.type == BT_DERIVED
9446 : 144 : && target->ts.type == BT_CLASS
9447 : 30 : && !UNLIMITED_POLY (target))
9448 : : {
9449 : : /* Inferred to be derived type but the target has type class. */
9450 : 30 : sym->ts = CLASS_DATA (target)->ts;
9451 : 30 : if (!sym->as)
9452 : 30 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
9453 : 30 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
9454 : 30 : sym->attr.dimension = target->rank ? 1 : 0;
9455 : 30 : gfc_change_class (&sym->ts, &attr, sym->as,
9456 : : target->rank, gfc_get_corank (target));
9457 : 30 : sym->as = NULL;
9458 : : }
9459 : 240 : else if (target->ts.type == BT_DERIVED
9460 : 114 : && target->symtree && target->symtree->n.sym
9461 : 102 : && target->symtree->n.sym->ts.type == BT_CLASS
9462 : 0 : && IS_INFERRED_TYPE (target)
9463 : 0 : && target->ref && target->ref->next
9464 : 0 : && target->ref->next->type == REF_ARRAY
9465 : 0 : && !target->ref->next->next)
9466 : : {
9467 : : /* A inferred type selector whose symbol has been determined to be
9468 : : a class array but which only has an array reference. Change the
9469 : : associate name and the selector to class type. */
9470 : 0 : sym->ts = target->ts;
9471 : 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
9472 : 0 : sym->attr.dimension = target->rank ? 1 : 0;
9473 : 0 : gfc_change_class (&sym->ts, &attr, sym->as,
9474 : : target->rank, gfc_get_corank (target));
9475 : 0 : sym->as = NULL;
9476 : 0 : target->ts = sym->ts;
9477 : : }
9478 : 240 : else if ((target->ts.type == BT_DERIVED)
9479 : 126 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
9480 : 60 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
9481 : : /* Confirmed to be either a derived type or misidentified to be a
9482 : : scalar class object, when the selector is a class array. */
9483 : 120 : sym->ts = target->ts;
9484 : : }
9485 : :
9486 : :
9487 : 6754 : if (target->expr_type == EXPR_NULL)
9488 : : {
9489 : 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
9490 : 1 : return;
9491 : : }
9492 : 6753 : else if (target->ts.type == BT_UNKNOWN)
9493 : : {
9494 : 2 : gfc_error ("Selector at %L has no type", &target->where);
9495 : 2 : return;
9496 : : }
9497 : :
9498 : : /* Get type if this was not already set. Note that it can be
9499 : : some other type than the target in case this is a SELECT TYPE
9500 : : selector! So we must not update when the type is already there. */
9501 : 6751 : if (sym->ts.type == BT_UNKNOWN)
9502 : 190 : sym->ts = target->ts;
9503 : :
9504 : 6751 : gcc_assert (sym->ts.type != BT_UNKNOWN);
9505 : :
9506 : : /* See if this is a valid association-to-variable. */
9507 : 13502 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
9508 : 5969 : && !parentheses
9509 : 5954 : && !gfc_has_vector_subscript (target))
9510 : 6787 : || gfc_is_ptr_fcn (target));
9511 : :
9512 : : /* Finally resolve if this is an array or not. */
9513 : 6751 : if (target->expr_type == EXPR_FUNCTION
9514 : 394 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
9515 : : {
9516 : 278 : gfc_expression_rank (target);
9517 : 278 : if (target->ts.type == BT_DERIVED
9518 : 129 : && !sym->as
9519 : 63 : && target->symtree->n.sym->as)
9520 : : {
9521 : 24 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
9522 : 24 : sym->attr.dimension = 1;
9523 : : }
9524 : 254 : else if (target->ts.type == BT_CLASS
9525 : 149 : && CLASS_DATA (target)->as)
9526 : : {
9527 : 109 : target->rank = CLASS_DATA (target)->as->rank;
9528 : 109 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
9529 : : {
9530 : 0 : sym->ts = target->ts;
9531 : 0 : sym->attr.dimension = 0;
9532 : : }
9533 : : }
9534 : : }
9535 : :
9536 : :
9537 : 6751 : if (sym->attr.dimension && target->rank == 0)
9538 : : {
9539 : : /* primary.cc makes the assumption that a reference to an associate
9540 : : name followed by a left parenthesis is an array reference. */
9541 : 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
9542 : : {
9543 : 12 : gfc_expression_rank (sym->assoc->target);
9544 : 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
9545 : 12 : if (!sym->attr.dimension && sym->as)
9546 : 0 : sym->as = NULL;
9547 : : }
9548 : :
9549 : 17 : if (sym->attr.dimension && target->rank == 0)
9550 : : {
9551 : 5 : if (sym->ts.type != BT_CHARACTER)
9552 : 5 : gfc_error ("Associate-name %qs at %L is used as array",
9553 : : sym->name, &sym->declared_at);
9554 : 5 : sym->attr.dimension = 0;
9555 : 5 : return;
9556 : : }
9557 : : }
9558 : :
9559 : : /* We cannot deal with class selectors that need temporaries. */
9560 : 6746 : if (target->ts.type == BT_CLASS
9561 : 6746 : && gfc_ref_needs_temporary_p (target->ref))
9562 : : {
9563 : 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
9564 : : "yet implemented", &target->where);
9565 : 1 : return;
9566 : : }
9567 : :
9568 : 6745 : if (target->ts.type == BT_CLASS)
9569 : 2416 : gfc_fix_class_refs (target);
9570 : :
9571 : 6745 : if (target->rank != 0 && !sym->attr.select_rank_temporary)
9572 : : {
9573 : 2359 : gfc_array_spec *as;
9574 : : /* The rank may be incorrectly guessed at parsing, therefore make sure
9575 : : it is corrected now. */
9576 : 2359 : if (sym->ts.type != BT_CLASS && !sym->as)
9577 : : {
9578 : 91 : if (!sym->as)
9579 : 91 : sym->as = gfc_get_array_spec ();
9580 : 91 : as = sym->as;
9581 : 91 : as->rank = target->rank;
9582 : 91 : as->type = AS_DEFERRED;
9583 : 91 : as->corank = gfc_get_corank (target);
9584 : 91 : sym->attr.dimension = 1;
9585 : 91 : if (as->corank != 0)
9586 : 0 : sym->attr.codimension = 1;
9587 : : }
9588 : 2268 : else if (sym->ts.type == BT_CLASS
9589 : 502 : && CLASS_DATA (sym) && !CLASS_DATA (sym)->as)
9590 : : {
9591 : 0 : if (!CLASS_DATA (sym)->as)
9592 : 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
9593 : 0 : as = CLASS_DATA (sym)->as;
9594 : 0 : as->rank = target->rank;
9595 : 0 : as->type = AS_DEFERRED;
9596 : 0 : as->corank = gfc_get_corank (target);
9597 : 0 : CLASS_DATA (sym)->attr.dimension = 1;
9598 : 0 : if (as->corank != 0)
9599 : 0 : CLASS_DATA (sym)->attr.codimension = 1;
9600 : : }
9601 : : }
9602 : 4386 : else if (!sym->attr.select_rank_temporary)
9603 : : {
9604 : : /* target's rank is 0, but the type of the sym is still array valued,
9605 : : which has to be corrected. */
9606 : 3036 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
9607 : 616 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
9608 : : {
9609 : 1 : gfc_array_spec *as;
9610 : 1 : symbol_attribute attr;
9611 : : /* The associated variable's type is still the array type
9612 : : correct this now. */
9613 : 1 : gfc_typespec *ts = &target->ts;
9614 : 1 : gfc_ref *ref;
9615 : :
9616 : 3 : for (ref = target->ref; ref != NULL; ref = ref->next)
9617 : : {
9618 : 2 : switch (ref->type)
9619 : : {
9620 : 1 : case REF_COMPONENT:
9621 : 1 : ts = &ref->u.c.component->ts;
9622 : 1 : break;
9623 : 1 : case REF_ARRAY:
9624 : 1 : if (ts->type == BT_CLASS)
9625 : 0 : ts = &ts->u.derived->components->ts;
9626 : : break;
9627 : : default:
9628 : : break;
9629 : : }
9630 : : }
9631 : : /* Create a scalar instance of the current class type. Because the
9632 : : rank of a class array goes into its name, the type has to be
9633 : : rebuilt. The alternative of (re-)setting just the attributes
9634 : : and as in the current type, destroys the type also in other
9635 : : places. */
9636 : 1 : as = NULL;
9637 : 1 : sym->ts = *ts;
9638 : 1 : sym->ts.type = BT_CLASS;
9639 : 1 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
9640 : 1 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
9641 : 1 : sym->as = NULL;
9642 : : }
9643 : : }
9644 : :
9645 : : /* Mark this as an associate variable. */
9646 : 6745 : sym->attr.associate_var = 1;
9647 : :
9648 : : /* Fix up the type-spec for CHARACTER types. */
9649 : 6745 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
9650 : : {
9651 : 383 : if (!sym->ts.u.cl)
9652 : 96 : sym->ts.u.cl = target->ts.u.cl;
9653 : :
9654 : 383 : if (sym->ts.deferred
9655 : 177 : && sym->ts.u.cl == target->ts.u.cl)
9656 : : {
9657 : 104 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9658 : 104 : sym->ts.deferred = 1;
9659 : : }
9660 : :
9661 : 383 : if (!sym->ts.u.cl->length
9662 : 273 : && !sym->ts.deferred
9663 : 96 : && target->expr_type == EXPR_CONSTANT)
9664 : : {
9665 : 24 : sym->ts.u.cl->length =
9666 : 24 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
9667 : : target->value.character.length);
9668 : : }
9669 : 359 : else if ((!sym->ts.u.cl->length
9670 : 110 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9671 : 249 : && target->expr_type != EXPR_VARIABLE)
9672 : : {
9673 : 110 : if (!sym->ts.deferred)
9674 : : {
9675 : 24 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9676 : 24 : sym->ts.deferred = 1;
9677 : : }
9678 : :
9679 : : /* This is reset in trans-stmt.cc after the assignment
9680 : : of the target expression to the associate name. */
9681 : 110 : sym->attr.allocatable = 1;
9682 : : }
9683 : : }
9684 : :
9685 : 6745 : if (sym->ts.type == BT_CLASS
9686 : 1247 : && IS_INFERRED_TYPE (target)
9687 : 12 : && target->ts.type == BT_DERIVED
9688 : 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
9689 : 0 : && target->ref && target->ref->next && !target->ref->next->next
9690 : 0 : && target->ref->next->type == REF_ARRAY)
9691 : 0 : target->ts = target->symtree->n.sym->ts;
9692 : :
9693 : : /* If the target is a good class object, so is the associate variable. */
9694 : 6745 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
9695 : 640 : sym->attr.class_ok = 1;
9696 : : }
9697 : :
9698 : :
9699 : : /* Ensure that SELECT TYPE expressions have the correct rank and a full
9700 : : array reference, where necessary. The symbols are artificial and so
9701 : : the dimension attribute and arrayspec can also be set. In addition,
9702 : : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9703 : : This is corrected here as well.*/
9704 : :
9705 : : static void
9706 : 1456 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
9707 : : int rank, gfc_ref *ref)
9708 : : {
9709 : 1456 : gfc_ref *nref = (*expr1)->ref;
9710 : 1456 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
9711 : 1456 : gfc_symbol *sym2;
9712 : 1456 : gfc_expr *selector = gfc_copy_expr (expr2);
9713 : :
9714 : 1456 : (*expr1)->rank = rank;
9715 : 1456 : if (selector)
9716 : : {
9717 : 277 : gfc_resolve_expr (selector);
9718 : 277 : if (selector->expr_type == EXPR_OP
9719 : 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
9720 : 2 : sym2 = selector->value.op.op1->symtree->n.sym;
9721 : 275 : else if (selector->expr_type == EXPR_VARIABLE
9722 : 7 : || selector->expr_type == EXPR_FUNCTION)
9723 : 275 : sym2 = selector->symtree->n.sym;
9724 : : else
9725 : 0 : gcc_unreachable ();
9726 : : }
9727 : : else
9728 : : sym2 = NULL;
9729 : :
9730 : 1456 : if (sym1->ts.type == BT_CLASS)
9731 : : {
9732 : 1456 : if ((*expr1)->ts.type != BT_CLASS)
9733 : 13 : (*expr1)->ts = sym1->ts;
9734 : :
9735 : 1456 : CLASS_DATA (sym1)->attr.dimension = 1;
9736 : 1456 : if (CLASS_DATA (sym1)->as == NULL && sym2)
9737 : 1 : CLASS_DATA (sym1)->as
9738 : 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
9739 : : }
9740 : : else
9741 : : {
9742 : 0 : sym1->attr.dimension = 1;
9743 : 0 : if (sym1->as == NULL && sym2)
9744 : 0 : sym1->as = gfc_copy_array_spec (sym2->as);
9745 : : }
9746 : :
9747 : 2629 : for (; nref; nref = nref->next)
9748 : 2352 : if (nref->next == NULL)
9749 : : break;
9750 : :
9751 : 1456 : if (ref && nref && nref->type != REF_ARRAY)
9752 : 6 : nref->next = gfc_copy_ref (ref);
9753 : 1450 : else if (ref && !nref)
9754 : 268 : (*expr1)->ref = gfc_copy_ref (ref);
9755 : 1456 : }
9756 : :
9757 : :
9758 : : static gfc_expr *
9759 : 6007 : build_loc_call (gfc_expr *sym_expr)
9760 : : {
9761 : 6007 : gfc_expr *loc_call;
9762 : 6007 : loc_call = gfc_get_expr ();
9763 : 6007 : loc_call->expr_type = EXPR_FUNCTION;
9764 : 6007 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
9765 : 6007 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
9766 : 6007 : loc_call->symtree->n.sym->attr.intrinsic = 1;
9767 : 6007 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
9768 : 6007 : gfc_commit_symbol (loc_call->symtree->n.sym);
9769 : 6007 : loc_call->ts.type = BT_INTEGER;
9770 : 6007 : loc_call->ts.kind = gfc_index_integer_kind;
9771 : 6007 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
9772 : 6007 : loc_call->value.function.actual = gfc_get_actual_arglist ();
9773 : 6007 : loc_call->value.function.actual->expr = sym_expr;
9774 : 6007 : loc_call->where = sym_expr->where;
9775 : 6007 : return loc_call;
9776 : : }
9777 : :
9778 : : /* Resolve a SELECT TYPE statement. */
9779 : :
9780 : : static void
9781 : 2681 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
9782 : : {
9783 : 2681 : gfc_symbol *selector_type;
9784 : 2681 : gfc_code *body, *new_st, *if_st, *tail;
9785 : 2681 : gfc_code *class_is = NULL, *default_case = NULL;
9786 : 2681 : gfc_case *c;
9787 : 2681 : gfc_symtree *st;
9788 : 2681 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
9789 : 2681 : gfc_namespace *ns;
9790 : 2681 : int error = 0;
9791 : 2681 : int rank = 0;
9792 : 2681 : gfc_ref* ref = NULL;
9793 : 2681 : gfc_expr *selector_expr = NULL;
9794 : :
9795 : 2681 : ns = code->ext.block.ns;
9796 : 2681 : gfc_resolve (ns);
9797 : :
9798 : : /* Check for F03:C813. */
9799 : 2681 : if (code->expr1->ts.type != BT_CLASS
9800 : 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
9801 : : {
9802 : 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9803 : : "at %L", &code->loc);
9804 : 34 : return;
9805 : : }
9806 : :
9807 : 2668 : if (!code->expr1->symtree->n.sym->attr.class_ok)
9808 : : return;
9809 : :
9810 : 2666 : if (code->expr2)
9811 : : {
9812 : 580 : gfc_ref *ref2 = NULL;
9813 : 1365 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
9814 : 785 : if (ref->type == REF_COMPONENT
9815 : 412 : && ref->u.c.component->ts.type == BT_CLASS)
9816 : 785 : ref2 = ref;
9817 : :
9818 : 580 : if (ref2)
9819 : : {
9820 : 332 : if (code->expr1->symtree->n.sym->attr.untyped)
9821 : 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
9822 : 332 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
9823 : : }
9824 : : else
9825 : : {
9826 : 248 : if (code->expr1->symtree->n.sym->attr.untyped)
9827 : 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
9828 : : /* Sometimes the selector expression is given the typespec of the
9829 : : '_data' field, which is logical enough but inappropriate here. */
9830 : 248 : if (code->expr2->ts.type == BT_DERIVED
9831 : 67 : && code->expr2->symtree
9832 : 67 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
9833 : 67 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
9834 : 248 : selector_type = CLASS_DATA (code->expr2)
9835 : 248 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
9836 : : }
9837 : :
9838 : 580 : if (code->expr2->rank
9839 : 277 : && code->expr1->ts.type == BT_CLASS
9840 : 270 : && CLASS_DATA (code->expr1)->as)
9841 : 263 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
9842 : :
9843 : : /* F2008: C803 The selector expression must not be coindexed. */
9844 : 580 : if (gfc_is_coindexed (code->expr2))
9845 : : {
9846 : 1 : gfc_error ("Selector at %L must not be coindexed",
9847 : 1 : &code->expr2->where);
9848 : 1 : return;
9849 : : }
9850 : :
9851 : : }
9852 : : else
9853 : : {
9854 : 2086 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
9855 : :
9856 : 2086 : if (gfc_is_coindexed (code->expr1))
9857 : : {
9858 : 0 : gfc_error ("Selector at %L must not be coindexed",
9859 : 0 : &code->expr1->where);
9860 : 0 : return;
9861 : : }
9862 : : }
9863 : :
9864 : : /* Loop over TYPE IS / CLASS IS cases. */
9865 : 7434 : for (body = code->block; body; body = body->block)
9866 : : {
9867 : 4770 : c = body->ext.block.case_list;
9868 : :
9869 : 4770 : if (!error)
9870 : : {
9871 : : /* Check for repeated cases. */
9872 : 7398 : for (tail = code->block; tail; tail = tail->block)
9873 : : {
9874 : 7398 : gfc_case *d = tail->ext.block.case_list;
9875 : 7398 : if (tail == body)
9876 : : break;
9877 : :
9878 : 2637 : if (c->ts.type == d->ts.type
9879 : 506 : && ((c->ts.type == BT_DERIVED
9880 : 414 : && c->ts.u.derived && d->ts.u.derived
9881 : 414 : && !strcmp (c->ts.u.derived->name,
9882 : : d->ts.u.derived->name))
9883 : 505 : || c->ts.type == BT_UNKNOWN
9884 : 505 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9885 : 49 : && c->ts.kind == d->ts.kind)))
9886 : : {
9887 : 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9888 : : &c->where, &d->where);
9889 : 1 : return;
9890 : : }
9891 : : }
9892 : : }
9893 : :
9894 : : /* Check F03:C815. */
9895 : 2929 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9896 : 2127 : && selector_type
9897 : 2125 : && !selector_type->attr.unlimited_polymorphic
9898 : 6649 : && !gfc_type_is_extensible (c->ts.u.derived))
9899 : : {
9900 : 1 : gfc_error ("Derived type %qs at %L must be extensible",
9901 : 1 : c->ts.u.derived->name, &c->where);
9902 : 1 : error++;
9903 : 1 : continue;
9904 : : }
9905 : :
9906 : : /* Check F03:C816. */
9907 : 4774 : if (c->ts.type != BT_UNKNOWN
9908 : 3358 : && selector_type && !selector_type->attr.unlimited_polymorphic
9909 : 6651 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
9910 : 1879 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
9911 : : {
9912 : 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9913 : 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
9914 : 2 : c->ts.u.derived->name, &c->where, selector_type->name);
9915 : : else
9916 : 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
9917 : : gfc_basic_typename (c->ts.type), &c->where);
9918 : 6 : error++;
9919 : 6 : continue;
9920 : : }
9921 : :
9922 : : /* Check F03:C814. */
9923 : 4762 : if (c->ts.type == BT_CHARACTER
9924 : 643 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
9925 : : {
9926 : 0 : gfc_error ("The type-spec at %L shall specify that each length "
9927 : : "type parameter is assumed", &c->where);
9928 : 0 : error++;
9929 : 0 : continue;
9930 : : }
9931 : :
9932 : : /* Intercept the DEFAULT case. */
9933 : 4762 : if (c->ts.type == BT_UNKNOWN)
9934 : : {
9935 : : /* Check F03:C818. */
9936 : 1410 : if (default_case)
9937 : : {
9938 : 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
9939 : : "by a second DEFAULT CASE at %L",
9940 : 1 : &default_case->ext.block.case_list->where, &c->where);
9941 : 1 : error++;
9942 : 1 : continue;
9943 : : }
9944 : :
9945 : : default_case = body;
9946 : : }
9947 : : }
9948 : :
9949 : 2664 : if (error > 0)
9950 : : return;
9951 : :
9952 : : /* Transform SELECT TYPE statement to BLOCK and associate selector to
9953 : : target if present. If there are any EXIT statements referring to the
9954 : : SELECT TYPE construct, this is no problem because the gfc_code
9955 : : reference stays the same and EXIT is equally possible from the BLOCK
9956 : : it is changed to. */
9957 : 2661 : code->op = EXEC_BLOCK;
9958 : 2661 : if (code->expr2)
9959 : : {
9960 : 579 : gfc_association_list* assoc;
9961 : :
9962 : 579 : assoc = gfc_get_association_list ();
9963 : 579 : assoc->st = code->expr1->symtree;
9964 : 579 : assoc->target = gfc_copy_expr (code->expr2);
9965 : 579 : assoc->target->where = code->expr2->where;
9966 : : /* assoc->variable will be set by resolve_assoc_var. */
9967 : :
9968 : 579 : code->ext.block.assoc = assoc;
9969 : 579 : code->expr1->symtree->n.sym->assoc = assoc;
9970 : :
9971 : 579 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
9972 : : }
9973 : : else
9974 : 2082 : code->ext.block.assoc = NULL;
9975 : :
9976 : : /* Ensure that the selector rank and arrayspec are available to
9977 : : correct expressions in which they might be missing. */
9978 : 2661 : if (code->expr2 && code->expr2->rank)
9979 : : {
9980 : 277 : rank = code->expr2->rank;
9981 : 532 : for (ref = code->expr2->ref; ref; ref = ref->next)
9982 : 523 : if (ref->next == NULL)
9983 : : break;
9984 : 277 : if (ref && ref->type == REF_ARRAY)
9985 : 268 : ref = gfc_copy_ref (ref);
9986 : :
9987 : : /* Fixup expr1 if necessary. */
9988 : 277 : if (rank)
9989 : 277 : fixup_array_ref (&code->expr1, code->expr2, rank, ref);
9990 : : }
9991 : 2384 : else if (code->expr1->rank)
9992 : : {
9993 : 721 : rank = code->expr1->rank;
9994 : 721 : for (ref = code->expr1->ref; ref; ref = ref->next)
9995 : 721 : if (ref->next == NULL)
9996 : : break;
9997 : 721 : if (ref && ref->type == REF_ARRAY)
9998 : 721 : ref = gfc_copy_ref (ref);
9999 : : }
10000 : :
10001 : : /* Add EXEC_SELECT to switch on type. */
10002 : 2661 : new_st = gfc_get_code (code->op);
10003 : 2661 : new_st->expr1 = code->expr1;
10004 : 2661 : new_st->expr2 = code->expr2;
10005 : 2661 : new_st->block = code->block;
10006 : 2661 : code->expr1 = code->expr2 = NULL;
10007 : 2661 : code->block = NULL;
10008 : 2661 : if (!ns->code)
10009 : 2661 : ns->code = new_st;
10010 : : else
10011 : 0 : ns->code->next = new_st;
10012 : 2661 : code = new_st;
10013 : 2661 : code->op = EXEC_SELECT_TYPE;
10014 : :
10015 : : /* Use the intrinsic LOC function to generate an integer expression
10016 : : for the vtable of the selector. Note that the rank of the selector
10017 : : expression has to be set to zero. */
10018 : 2661 : gfc_add_vptr_component (code->expr1);
10019 : 2661 : code->expr1->rank = 0;
10020 : 2661 : code->expr1 = build_loc_call (code->expr1);
10021 : 2661 : selector_expr = code->expr1->value.function.actual->expr;
10022 : :
10023 : : /* Loop over TYPE IS / CLASS IS cases. */
10024 : 7415 : for (body = code->block; body; body = body->block)
10025 : : {
10026 : 4754 : gfc_symbol *vtab;
10027 : 4754 : gfc_expr *e;
10028 : 4754 : c = body->ext.block.case_list;
10029 : :
10030 : : /* Generate an index integer expression for address of the
10031 : : TYPE/CLASS vtable and store it in c->low. The hash expression
10032 : : is stored in c->high and is used to resolve intrinsic cases. */
10033 : 4754 : if (c->ts.type != BT_UNKNOWN)
10034 : : {
10035 : 3346 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10036 : : {
10037 : 2118 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
10038 : 2118 : gcc_assert (vtab);
10039 : 2118 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
10040 : 2118 : c->ts.u.derived->hash_value);
10041 : : }
10042 : : else
10043 : : {
10044 : 1228 : vtab = gfc_find_vtab (&c->ts);
10045 : 1228 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
10046 : 1228 : e = CLASS_DATA (vtab)->initializer;
10047 : 1228 : c->high = gfc_copy_expr (e);
10048 : 1228 : if (c->high->ts.kind != gfc_integer_4_kind)
10049 : : {
10050 : 1 : gfc_typespec ts;
10051 : 1 : ts.kind = gfc_integer_4_kind;
10052 : 1 : ts.type = BT_INTEGER;
10053 : 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
10054 : : }
10055 : : }
10056 : :
10057 : 3346 : e = gfc_lval_expr_from_sym (vtab);
10058 : 3346 : c->low = build_loc_call (e);
10059 : : }
10060 : : else
10061 : 1408 : continue;
10062 : :
10063 : : /* Associate temporary to selector. This should only be done
10064 : : when this case is actually true, so build a new ASSOCIATE
10065 : : that does precisely this here (instead of using the
10066 : : 'global' one). */
10067 : :
10068 : 3346 : if (c->ts.type == BT_CLASS)
10069 : 285 : sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
10070 : 3061 : else if (c->ts.type == BT_DERIVED)
10071 : 1833 : sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
10072 : 1228 : else if (c->ts.type == BT_CHARACTER)
10073 : : {
10074 : 643 : HOST_WIDE_INT charlen = 0;
10075 : 643 : if (c->ts.u.cl && c->ts.u.cl->length
10076 : 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10077 : 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
10078 : 643 : snprintf (name, sizeof (name),
10079 : : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
10080 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
10081 : : }
10082 : : else
10083 : 585 : sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
10084 : : c->ts.kind);
10085 : :
10086 : 3346 : st = gfc_find_symtree (ns->sym_root, name);
10087 : 3346 : gcc_assert (st->n.sym->assoc);
10088 : 3346 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
10089 : 3346 : st->n.sym->assoc->target->where = selector_expr->where;
10090 : 3346 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
10091 : : {
10092 : 3061 : gfc_add_data_component (st->n.sym->assoc->target);
10093 : : /* Fixup the target expression if necessary. */
10094 : 3061 : if (rank)
10095 : 1179 : fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
10096 : : }
10097 : :
10098 : 3346 : new_st = gfc_get_code (EXEC_BLOCK);
10099 : 3346 : new_st->ext.block.ns = gfc_build_block_ns (ns);
10100 : 3346 : new_st->ext.block.ns->code = body->next;
10101 : 3346 : body->next = new_st;
10102 : :
10103 : : /* Chain in the new list only if it is marked as dangling. Otherwise
10104 : : there is a CASE label overlap and this is already used. Just ignore,
10105 : : the error is diagnosed elsewhere. */
10106 : 3346 : if (st->n.sym->assoc->dangling)
10107 : : {
10108 : 3345 : new_st->ext.block.assoc = st->n.sym->assoc;
10109 : 3345 : st->n.sym->assoc->dangling = 0;
10110 : : }
10111 : :
10112 : 3346 : resolve_assoc_var (st->n.sym, false);
10113 : : }
10114 : :
10115 : : /* Take out CLASS IS cases for separate treatment. */
10116 : : body = code;
10117 : 7415 : while (body && body->block)
10118 : : {
10119 : 4754 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
10120 : : {
10121 : : /* Add to class_is list. */
10122 : 285 : if (class_is == NULL)
10123 : : {
10124 : 254 : class_is = body->block;
10125 : 254 : tail = class_is;
10126 : : }
10127 : : else
10128 : : {
10129 : 43 : for (tail = class_is; tail->block; tail = tail->block) ;
10130 : 31 : tail->block = body->block;
10131 : 31 : tail = tail->block;
10132 : : }
10133 : : /* Remove from EXEC_SELECT list. */
10134 : 285 : body->block = body->block->block;
10135 : 285 : tail->block = NULL;
10136 : : }
10137 : : else
10138 : : body = body->block;
10139 : : }
10140 : :
10141 : 2661 : if (class_is)
10142 : : {
10143 : 254 : gfc_symbol *vtab;
10144 : :
10145 : 254 : if (!default_case)
10146 : : {
10147 : : /* Add a default case to hold the CLASS IS cases. */
10148 : 276 : for (tail = code; tail->block; tail = tail->block) ;
10149 : 168 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
10150 : 168 : tail = tail->block;
10151 : 168 : tail->ext.block.case_list = gfc_get_case ();
10152 : 168 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
10153 : 168 : tail->next = NULL;
10154 : 168 : default_case = tail;
10155 : : }
10156 : :
10157 : : /* More than one CLASS IS block? */
10158 : 254 : if (class_is->block)
10159 : : {
10160 : 37 : gfc_code **c1,*c2;
10161 : 37 : bool swapped;
10162 : : /* Sort CLASS IS blocks by extension level. */
10163 : 36 : do
10164 : : {
10165 : 37 : swapped = false;
10166 : 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
10167 : : {
10168 : 61 : c2 = (*c1)->block;
10169 : : /* F03:C817 (check for doubles). */
10170 : 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
10171 : 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
10172 : : {
10173 : 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
10174 : : "statement at %L",
10175 : : &c2->ext.block.case_list->where);
10176 : 1 : return;
10177 : : }
10178 : 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
10179 : 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
10180 : : {
10181 : : /* Swap. */
10182 : 24 : (*c1)->block = c2->block;
10183 : 24 : c2->block = *c1;
10184 : 24 : *c1 = c2;
10185 : 24 : swapped = true;
10186 : : }
10187 : : }
10188 : : }
10189 : : while (swapped);
10190 : : }
10191 : :
10192 : : /* Generate IF chain. */
10193 : 253 : if_st = gfc_get_code (EXEC_IF);
10194 : 253 : new_st = if_st;
10195 : 536 : for (body = class_is; body; body = body->block)
10196 : : {
10197 : 283 : new_st->block = gfc_get_code (EXEC_IF);
10198 : 283 : new_st = new_st->block;
10199 : : /* Set up IF condition: Call _gfortran_is_extension_of. */
10200 : 283 : new_st->expr1 = gfc_get_expr ();
10201 : 283 : new_st->expr1->expr_type = EXPR_FUNCTION;
10202 : 283 : new_st->expr1->ts.type = BT_LOGICAL;
10203 : 283 : new_st->expr1->ts.kind = 4;
10204 : 283 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
10205 : 283 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
10206 : 283 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
10207 : : /* Set up arguments. */
10208 : 283 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
10209 : 283 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
10210 : 283 : new_st->expr1->value.function.actual->expr->where = code->loc;
10211 : 283 : new_st->expr1->where = code->loc;
10212 : 283 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
10213 : 283 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
10214 : 283 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
10215 : 283 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
10216 : 283 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
10217 : 283 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
10218 : : /* Set up types in formal arg list. */
10219 : 283 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
10220 : 283 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
10221 : 283 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
10222 : 283 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
10223 : :
10224 : 283 : new_st->next = body->next;
10225 : : }
10226 : 253 : if (default_case->next)
10227 : : {
10228 : 86 : new_st->block = gfc_get_code (EXEC_IF);
10229 : 86 : new_st = new_st->block;
10230 : 86 : new_st->next = default_case->next;
10231 : : }
10232 : :
10233 : : /* Replace CLASS DEFAULT code by the IF chain. */
10234 : 253 : default_case->next = if_st;
10235 : : }
10236 : :
10237 : : /* Resolve the internal code. This cannot be done earlier because
10238 : : it requires that the sym->assoc of selectors is set already. */
10239 : 2660 : gfc_current_ns = ns;
10240 : 2660 : gfc_resolve_blocks (code->block, gfc_current_ns);
10241 : 2660 : gfc_current_ns = old_ns;
10242 : :
10243 : 2660 : free (ref);
10244 : : }
10245 : :
10246 : :
10247 : : /* Resolve a SELECT RANK statement. */
10248 : :
10249 : : static void
10250 : 1005 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
10251 : : {
10252 : 1005 : gfc_namespace *ns;
10253 : 1005 : gfc_code *body, *new_st, *tail;
10254 : 1005 : gfc_case *c;
10255 : 1005 : char tname[GFC_MAX_SYMBOL_LEN + 7];
10256 : 1005 : char name[2 * GFC_MAX_SYMBOL_LEN];
10257 : 1005 : gfc_symtree *st;
10258 : 1005 : gfc_expr *selector_expr = NULL;
10259 : 1005 : int case_value;
10260 : 1005 : HOST_WIDE_INT charlen = 0;
10261 : :
10262 : 1005 : ns = code->ext.block.ns;
10263 : 1005 : gfc_resolve (ns);
10264 : :
10265 : 1005 : code->op = EXEC_BLOCK;
10266 : 1005 : if (code->expr2)
10267 : : {
10268 : 42 : gfc_association_list* assoc;
10269 : :
10270 : 42 : assoc = gfc_get_association_list ();
10271 : 42 : assoc->st = code->expr1->symtree;
10272 : 42 : assoc->target = gfc_copy_expr (code->expr2);
10273 : 42 : assoc->target->where = code->expr2->where;
10274 : : /* assoc->variable will be set by resolve_assoc_var. */
10275 : :
10276 : 42 : code->ext.block.assoc = assoc;
10277 : 42 : code->expr1->symtree->n.sym->assoc = assoc;
10278 : :
10279 : 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
10280 : : }
10281 : : else
10282 : 963 : code->ext.block.assoc = NULL;
10283 : :
10284 : : /* Loop over RANK cases. Note that returning on the errors causes a
10285 : : cascade of further errors because the case blocks do not compile
10286 : : correctly. */
10287 : 3274 : for (body = code->block; body; body = body->block)
10288 : : {
10289 : 2269 : c = body->ext.block.case_list;
10290 : 2269 : if (c->low)
10291 : 1350 : case_value = (int) mpz_get_si (c->low->value.integer);
10292 : : else
10293 : : case_value = -2;
10294 : :
10295 : : /* Check for repeated cases. */
10296 : 5776 : for (tail = code->block; tail; tail = tail->block)
10297 : : {
10298 : 5776 : gfc_case *d = tail->ext.block.case_list;
10299 : 5776 : int case_value2;
10300 : :
10301 : 5776 : if (tail == body)
10302 : : break;
10303 : :
10304 : : /* Check F2018: C1153. */
10305 : 3507 : if (!c->low && !d->low)
10306 : 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
10307 : : &c->where, &d->where);
10308 : :
10309 : 3507 : if (!c->low || !d->low)
10310 : 1253 : continue;
10311 : :
10312 : : /* Check F2018: C1153. */
10313 : 2254 : case_value2 = (int) mpz_get_si (d->low->value.integer);
10314 : 2254 : if ((case_value == case_value2) && case_value == -1)
10315 : 1 : gfc_error ("RANK (*) at %L is repeated at %L",
10316 : : &c->where, &d->where);
10317 : 2253 : else if (case_value == case_value2)
10318 : 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
10319 : : case_value, &c->where, &d->where);
10320 : : }
10321 : :
10322 : 2269 : if (!c->low)
10323 : 919 : continue;
10324 : :
10325 : : /* Check F2018: C1155. */
10326 : 1350 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
10327 : 1348 : || gfc_expr_attr (code->expr1).pointer))
10328 : 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
10329 : 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
10330 : : }
10331 : :
10332 : : /* Add EXEC_SELECT to switch on rank. */
10333 : 1005 : new_st = gfc_get_code (code->op);
10334 : 1005 : new_st->expr1 = code->expr1;
10335 : 1005 : new_st->expr2 = code->expr2;
10336 : 1005 : new_st->block = code->block;
10337 : 1005 : code->expr1 = code->expr2 = NULL;
10338 : 1005 : code->block = NULL;
10339 : 1005 : if (!ns->code)
10340 : 1005 : ns->code = new_st;
10341 : : else
10342 : 0 : ns->code->next = new_st;
10343 : 1005 : code = new_st;
10344 : 1005 : code->op = EXEC_SELECT_RANK;
10345 : :
10346 : 1005 : selector_expr = code->expr1;
10347 : :
10348 : : /* Loop over SELECT RANK cases. */
10349 : 3274 : for (body = code->block; body; body = body->block)
10350 : : {
10351 : 2269 : c = body->ext.block.case_list;
10352 : 2269 : int case_value;
10353 : :
10354 : : /* Pass on the default case. */
10355 : 2269 : if (c->low == NULL)
10356 : 919 : continue;
10357 : :
10358 : : /* Associate temporary to selector. This should only be done
10359 : : when this case is actually true, so build a new ASSOCIATE
10360 : : that does precisely this here (instead of using the
10361 : : 'global' one). */
10362 : 1350 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
10363 : 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10364 : 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
10365 : :
10366 : 1350 : if (c->ts.type == BT_CLASS)
10367 : 124 : sprintf (tname, "class_%s", c->ts.u.derived->name);
10368 : 1226 : else if (c->ts.type == BT_DERIVED)
10369 : 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
10370 : 1116 : else if (c->ts.type != BT_CHARACTER)
10371 : 557 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
10372 : : else
10373 : 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
10374 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
10375 : :
10376 : 1350 : case_value = (int) mpz_get_si (c->low->value.integer);
10377 : 1350 : if (case_value >= 0)
10378 : 1317 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
10379 : : else
10380 : 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
10381 : :
10382 : 1350 : st = gfc_find_symtree (ns->sym_root, name);
10383 : 1350 : gcc_assert (st->n.sym->assoc);
10384 : :
10385 : 1350 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
10386 : 1350 : st->n.sym->assoc->target->where = selector_expr->where;
10387 : :
10388 : 1350 : new_st = gfc_get_code (EXEC_BLOCK);
10389 : 1350 : new_st->ext.block.ns = gfc_build_block_ns (ns);
10390 : 1350 : new_st->ext.block.ns->code = body->next;
10391 : 1350 : body->next = new_st;
10392 : :
10393 : : /* Chain in the new list only if it is marked as dangling. Otherwise
10394 : : there is a CASE label overlap and this is already used. Just ignore,
10395 : : the error is diagnosed elsewhere. */
10396 : 1350 : if (st->n.sym->assoc->dangling)
10397 : : {
10398 : 1348 : new_st->ext.block.assoc = st->n.sym->assoc;
10399 : 1348 : st->n.sym->assoc->dangling = 0;
10400 : : }
10401 : :
10402 : 1350 : resolve_assoc_var (st->n.sym, false);
10403 : : }
10404 : :
10405 : 1005 : gfc_current_ns = ns;
10406 : 1005 : gfc_resolve_blocks (code->block, gfc_current_ns);
10407 : 1005 : gfc_current_ns = old_ns;
10408 : 1005 : }
10409 : :
10410 : :
10411 : : /* Resolve a transfer statement. This is making sure that:
10412 : : -- a derived type being transferred has only non-pointer components
10413 : : -- a derived type being transferred doesn't have private components, unless
10414 : : it's being transferred from the module where the type was defined
10415 : : -- we're not trying to transfer a whole assumed size array. */
10416 : :
10417 : : static void
10418 : 43923 : resolve_transfer (gfc_code *code)
10419 : : {
10420 : 43923 : gfc_symbol *sym, *derived;
10421 : 43923 : gfc_ref *ref;
10422 : 43923 : gfc_expr *exp;
10423 : 43923 : bool write = false;
10424 : 43923 : bool formatted = false;
10425 : 43923 : gfc_dt *dt = code->ext.dt;
10426 : 43923 : gfc_symbol *dtio_sub = NULL;
10427 : :
10428 : 43923 : exp = code->expr1;
10429 : :
10430 : 87852 : while (exp != NULL && exp->expr_type == EXPR_OP
10431 : 44807 : && exp->value.op.op == INTRINSIC_PARENTHESES)
10432 : 6 : exp = exp->value.op.op1;
10433 : :
10434 : 43923 : if (exp && exp->expr_type == EXPR_NULL
10435 : 2 : && code->ext.dt)
10436 : : {
10437 : 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
10438 : : &exp->where);
10439 : 2 : return;
10440 : : }
10441 : :
10442 : : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
10443 : : && exp->expr_type != EXPR_FUNCTION
10444 : : && exp->expr_type != EXPR_ARRAY
10445 : : && exp->expr_type != EXPR_STRUCTURE))
10446 : : return;
10447 : :
10448 : : /* If we are reading, the variable will be changed. Note that
10449 : : code->ext.dt may be NULL if the TRANSFER is related to
10450 : : an INQUIRE statement -- but in this case, we are not reading, either. */
10451 : 23720 : if (dt && dt->dt_io_kind->value.iokind == M_READ
10452 : 30915 : && !gfc_check_vardef_context (exp, false, false, false,
10453 : 7047 : _("item in READ")))
10454 : : return;
10455 : :
10456 : 23864 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
10457 : 23864 : || exp->expr_type == EXPR_FUNCTION
10458 : 19756 : || exp->expr_type == EXPR_ARRAY
10459 : 43620 : ? &exp->ts : &exp->symtree->n.sym->ts;
10460 : :
10461 : : /* Go to actual component transferred. */
10462 : 31041 : for (ref = exp->ref; ref; ref = ref->next)
10463 : 7177 : if (ref->type == REF_COMPONENT)
10464 : 2122 : ts = &ref->u.c.component->ts;
10465 : :
10466 : 23864 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
10467 : 23716 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
10468 : : {
10469 : 697 : derived = ts->u.derived;
10470 : :
10471 : : /* Determine when to use the formatted DTIO procedure. */
10472 : 697 : if (dt && (dt->format_expr || dt->format_label))
10473 : 622 : formatted = true;
10474 : :
10475 : 697 : write = dt->dt_io_kind->value.iokind == M_WRITE
10476 : 697 : || dt->dt_io_kind->value.iokind == M_PRINT;
10477 : 697 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
10478 : :
10479 : 697 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
10480 : : {
10481 : 413 : dt->udtio = exp;
10482 : 413 : sym = exp->symtree->n.sym->ns->proc_name;
10483 : : /* Check to see if this is a nested DTIO call, with the
10484 : : dummy as the io-list object. */
10485 : 413 : if (sym && sym == dtio_sub && sym->formal
10486 : 30 : && sym->formal->sym == exp->symtree->n.sym
10487 : 30 : && exp->ref == NULL)
10488 : : {
10489 : 0 : if (!sym->attr.recursive)
10490 : : {
10491 : 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
10492 : : sym->name, &sym->declared_at);
10493 : 0 : return;
10494 : : }
10495 : : }
10496 : : }
10497 : : }
10498 : :
10499 : 23864 : if (ts->type == BT_CLASS && dtio_sub == NULL)
10500 : : {
10501 : 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10502 : : "it is processed by a defined input/output procedure",
10503 : : &code->loc);
10504 : 3 : return;
10505 : : }
10506 : :
10507 : 23861 : if (ts->type == BT_DERIVED)
10508 : : {
10509 : : /* Check that transferred derived type doesn't contain POINTER
10510 : : components unless it is processed by a defined input/output
10511 : : procedure". */
10512 : 665 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
10513 : : {
10514 : 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
10515 : : "components unless it is processed by a defined "
10516 : : "input/output procedure", &code->loc);
10517 : 2 : return;
10518 : : }
10519 : :
10520 : : /* F08:C935. */
10521 : 663 : if (ts->u.derived->attr.proc_pointer_comp)
10522 : : {
10523 : 2 : gfc_error ("Data transfer element at %L cannot have "
10524 : : "procedure pointer components", &code->loc);
10525 : 2 : return;
10526 : : }
10527 : :
10528 : 661 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
10529 : : {
10530 : 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10531 : : "components unless it is processed by a defined "
10532 : : "input/output procedure", &code->loc);
10533 : 6 : return;
10534 : : }
10535 : :
10536 : : /* C_PTR and C_FUNPTR have private components which means they cannot
10537 : : be printed. However, if -std=gnu and not -pedantic, allow
10538 : : the component to be printed to help debugging. */
10539 : 655 : if (ts->u.derived->ts.f90_type == BT_VOID)
10540 : : {
10541 : 27 : if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
10542 : : "cannot have PRIVATE components", &code->loc))
10543 : : return;
10544 : : }
10545 : 628 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
10546 : : {
10547 : 4 : gfc_error ("Data transfer element at %L cannot have "
10548 : : "PRIVATE components unless it is processed by "
10549 : : "a defined input/output procedure", &code->loc);
10550 : 4 : return;
10551 : : }
10552 : : }
10553 : :
10554 : 23843 : if (exp->expr_type == EXPR_STRUCTURE)
10555 : : return;
10556 : :
10557 : 23791 : if (exp->expr_type == EXPR_ARRAY)
10558 : : return;
10559 : :
10560 : 23411 : sym = exp->symtree->n.sym;
10561 : :
10562 : 23411 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
10563 : 75 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
10564 : : {
10565 : 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
10566 : : "an assumed-size array", &code->loc);
10567 : 1 : return;
10568 : : }
10569 : : }
10570 : :
10571 : :
10572 : : /*********** Toplevel code resolution subroutines ***********/
10573 : :
10574 : : /* Find the set of labels that are reachable from this block. We also
10575 : : record the last statement in each block. */
10576 : :
10577 : : static void
10578 : 578233 : find_reachable_labels (gfc_code *block)
10579 : : {
10580 : 578233 : gfc_code *c;
10581 : :
10582 : 578233 : if (!block)
10583 : : return;
10584 : :
10585 : 367405 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
10586 : :
10587 : : /* Collect labels in this block. We don't keep those corresponding
10588 : : to END {IF|SELECT}, these are checked in resolve_branch by going
10589 : : up through the code_stack. */
10590 : 1274487 : for (c = block; c; c = c->next)
10591 : : {
10592 : 907082 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
10593 : 3571 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
10594 : : }
10595 : :
10596 : : /* Merge with labels from parent block. */
10597 : 367405 : if (cs_base->prev)
10598 : : {
10599 : 300165 : gcc_assert (cs_base->prev->reachable_labels);
10600 : 300165 : bitmap_ior_into (cs_base->reachable_labels,
10601 : : cs_base->prev->reachable_labels);
10602 : : }
10603 : : }
10604 : :
10605 : :
10606 : : static void
10607 : 136 : resolve_lock_unlock_event (gfc_code *code)
10608 : : {
10609 : 136 : if (code->expr1->expr_type == EXPR_FUNCTION
10610 : 22 : && code->expr1->value.function.isym
10611 : 22 : && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
10612 : 22 : remove_caf_get_intrinsic (code->expr1);
10613 : :
10614 : 136 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
10615 : 136 : && (code->expr1->ts.type != BT_DERIVED
10616 : 95 : || code->expr1->expr_type != EXPR_VARIABLE
10617 : 95 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
10618 : 95 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
10619 : 94 : || code->expr1->rank != 0
10620 : 124 : || (!gfc_is_coarray (code->expr1) &&
10621 : 31 : !gfc_is_coindexed (code->expr1))))
10622 : 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10623 : 4 : &code->expr1->where);
10624 : 132 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
10625 : 39 : && (code->expr1->ts.type != BT_DERIVED
10626 : 39 : || code->expr1->expr_type != EXPR_VARIABLE
10627 : 39 : || code->expr1->ts.u.derived->from_intmod
10628 : : != INTMOD_ISO_FORTRAN_ENV
10629 : 39 : || code->expr1->ts.u.derived->intmod_sym_id
10630 : : != ISOFORTRAN_EVENT_TYPE
10631 : 39 : || code->expr1->rank != 0))
10632 : 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10633 : : &code->expr1->where);
10634 : 23 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
10635 : 143 : && !gfc_is_coindexed (code->expr1))
10636 : 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10637 : 0 : &code->expr1->where);
10638 : 132 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
10639 : 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
10640 : 0 : "coindexed", &code->expr1->where);
10641 : :
10642 : : /* Check STAT. */
10643 : 136 : if (code->expr2
10644 : 38 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
10645 : 38 : || code->expr2->expr_type != EXPR_VARIABLE))
10646 : 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10647 : : &code->expr2->where);
10648 : :
10649 : 136 : if (code->expr2
10650 : 174 : && !gfc_check_vardef_context (code->expr2, false, false, false,
10651 : 38 : _("STAT variable")))
10652 : : return;
10653 : :
10654 : : /* Check ERRMSG. */
10655 : 136 : if (code->expr3
10656 : 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
10657 : 2 : || code->expr3->expr_type != EXPR_VARIABLE))
10658 : 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10659 : : &code->expr3->where);
10660 : :
10661 : 136 : if (code->expr3
10662 : 138 : && !gfc_check_vardef_context (code->expr3, false, false, false,
10663 : 2 : _("ERRMSG variable")))
10664 : : return;
10665 : :
10666 : : /* Check for LOCK the ACQUIRED_LOCK. */
10667 : 136 : if (code->op != EXEC_EVENT_WAIT && code->expr4
10668 : 16 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
10669 : 16 : || code->expr4->expr_type != EXPR_VARIABLE))
10670 : 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10671 : : "variable", &code->expr4->where);
10672 : :
10673 : 120 : if (code->op != EXEC_EVENT_WAIT && code->expr4
10674 : 152 : && !gfc_check_vardef_context (code->expr4, false, false, false,
10675 : 16 : _("ACQUIRED_LOCK variable")))
10676 : : return;
10677 : :
10678 : : /* Check for EVENT WAIT the UNTIL_COUNT. */
10679 : 136 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
10680 : : {
10681 : 24 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
10682 : 24 : || code->expr4->rank != 0)
10683 : 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10684 : 0 : "expression", &code->expr4->where);
10685 : : }
10686 : : }
10687 : :
10688 : :
10689 : : static void
10690 : 33 : resolve_critical (gfc_code *code)
10691 : : {
10692 : 33 : gfc_symtree *symtree;
10693 : 33 : gfc_symbol *lock_type;
10694 : 33 : char name[GFC_MAX_SYMBOL_LEN];
10695 : 33 : static int serial = 0;
10696 : :
10697 : 33 : if (flag_coarray != GFC_FCOARRAY_LIB)
10698 : 28 : return;
10699 : :
10700 : 5 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10701 : : GFC_PREFIX ("lock_type"));
10702 : 5 : if (symtree)
10703 : 2 : lock_type = symtree->n.sym;
10704 : : else
10705 : : {
10706 : 3 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
10707 : : false) != 0)
10708 : 0 : gcc_unreachable ();
10709 : 3 : lock_type = symtree->n.sym;
10710 : 3 : lock_type->attr.flavor = FL_DERIVED;
10711 : 3 : lock_type->attr.zero_comp = 1;
10712 : 3 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
10713 : 3 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
10714 : : }
10715 : :
10716 : 5 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
10717 : 5 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
10718 : 0 : gcc_unreachable ();
10719 : :
10720 : 5 : code->resolved_sym = symtree->n.sym;
10721 : 5 : symtree->n.sym->attr.flavor = FL_VARIABLE;
10722 : 5 : symtree->n.sym->attr.referenced = 1;
10723 : 5 : symtree->n.sym->attr.artificial = 1;
10724 : 5 : symtree->n.sym->attr.codimension = 1;
10725 : 5 : symtree->n.sym->ts.type = BT_DERIVED;
10726 : 5 : symtree->n.sym->ts.u.derived = lock_type;
10727 : 5 : symtree->n.sym->as = gfc_get_array_spec ();
10728 : 5 : symtree->n.sym->as->corank = 1;
10729 : 5 : symtree->n.sym->as->type = AS_EXPLICIT;
10730 : 5 : symtree->n.sym->as->cotype = AS_EXPLICIT;
10731 : 5 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
10732 : : NULL, 1);
10733 : 5 : gfc_commit_symbols();
10734 : : }
10735 : :
10736 : :
10737 : : static void
10738 : 745 : resolve_sync (gfc_code *code)
10739 : : {
10740 : : /* Check imageset. The * case matches expr1 == NULL. */
10741 : 745 : if (code->expr1)
10742 : : {
10743 : 48 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
10744 : 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10745 : : "INTEGER expression", &code->expr1->where);
10746 : 48 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
10747 : 23 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
10748 : 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
10749 : : &code->expr1->where);
10750 : 47 : else if (code->expr1->expr_type == EXPR_ARRAY
10751 : 47 : && gfc_simplify_expr (code->expr1, 0))
10752 : : {
10753 : 18 : gfc_constructor *cons;
10754 : 18 : cons = gfc_constructor_first (code->expr1->value.constructor);
10755 : 54 : for (; cons; cons = gfc_constructor_next (cons))
10756 : 18 : if (cons->expr->expr_type == EXPR_CONSTANT
10757 : 18 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
10758 : 0 : gfc_error ("Imageset argument at %L must between 1 and "
10759 : : "num_images()", &cons->expr->where);
10760 : : }
10761 : : }
10762 : :
10763 : : /* Check STAT. */
10764 : 745 : gfc_resolve_expr (code->expr2);
10765 : 745 : if (code->expr2)
10766 : : {
10767 : 84 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
10768 : 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10769 : : &code->expr2->where);
10770 : : else
10771 : 83 : gfc_check_vardef_context (code->expr2, false, false, false,
10772 : 83 : _("STAT variable"));
10773 : : }
10774 : :
10775 : : /* Check ERRMSG. */
10776 : 745 : gfc_resolve_expr (code->expr3);
10777 : 745 : if (code->expr3)
10778 : : {
10779 : 75 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
10780 : 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10781 : : &code->expr3->where);
10782 : : else
10783 : 71 : gfc_check_vardef_context (code->expr3, false, false, false,
10784 : 71 : _("ERRMSG variable"));
10785 : : }
10786 : 745 : }
10787 : :
10788 : :
10789 : : /* Given a branch to a label, see if the branch is conforming.
10790 : : The code node describes where the branch is located. */
10791 : :
10792 : : static void
10793 : 102439 : resolve_branch (gfc_st_label *label, gfc_code *code)
10794 : : {
10795 : 102439 : code_stack *stack;
10796 : :
10797 : 102439 : if (label == NULL)
10798 : : return;
10799 : :
10800 : : /* Step one: is this a valid branching target? */
10801 : :
10802 : 2440 : if (label->defined == ST_LABEL_UNKNOWN)
10803 : : {
10804 : 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
10805 : : &code->loc);
10806 : 4 : return;
10807 : : }
10808 : :
10809 : 2436 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
10810 : : {
10811 : 4 : gfc_error ("Statement at %L is not a valid branch target statement "
10812 : : "for the branch statement at %L", &label->where, &code->loc);
10813 : 4 : return;
10814 : : }
10815 : :
10816 : : /* Step two: make sure this branch is not a branch to itself ;-) */
10817 : :
10818 : 2432 : if (code->here == label)
10819 : : {
10820 : 0 : gfc_warning (0,
10821 : : "Branch at %L may result in an infinite loop", &code->loc);
10822 : 0 : return;
10823 : : }
10824 : :
10825 : : /* Step three: See if the label is in the same block as the
10826 : : branching statement. The hard work has been done by setting up
10827 : : the bitmap reachable_labels. */
10828 : :
10829 : 2432 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
10830 : : {
10831 : : /* Check now whether there is a CRITICAL construct; if so, check
10832 : : whether the label is still visible outside of the CRITICAL block,
10833 : : which is invalid. */
10834 : 6184 : for (stack = cs_base; stack; stack = stack->prev)
10835 : : {
10836 : 3820 : if (stack->current->op == EXEC_CRITICAL
10837 : 3820 : && bitmap_bit_p (stack->reachable_labels, label->value))
10838 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10839 : : "label at %L", &code->loc, &label->where);
10840 : 3818 : else if (stack->current->op == EXEC_DO_CONCURRENT
10841 : 3818 : && bitmap_bit_p (stack->reachable_labels, label->value))
10842 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10843 : : "for label at %L", &code->loc, &label->where);
10844 : : }
10845 : :
10846 : : return;
10847 : : }
10848 : :
10849 : : /* Step four: If we haven't found the label in the bitmap, it may
10850 : : still be the label of the END of the enclosing block, in which
10851 : : case we find it by going up the code_stack. */
10852 : :
10853 : 167 : for (stack = cs_base; stack; stack = stack->prev)
10854 : : {
10855 : 131 : if (stack->current->next && stack->current->next->here == label)
10856 : : break;
10857 : 101 : if (stack->current->op == EXEC_CRITICAL)
10858 : : {
10859 : : /* Note: A label at END CRITICAL does not leave the CRITICAL
10860 : : construct as END CRITICAL is still part of it. */
10861 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10862 : : " at %L", &code->loc, &label->where);
10863 : 2 : return;
10864 : : }
10865 : 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
10866 : : {
10867 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10868 : : "label at %L", &code->loc, &label->where);
10869 : 0 : return;
10870 : : }
10871 : : }
10872 : :
10873 : 66 : if (stack)
10874 : : {
10875 : 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
10876 : : return;
10877 : : }
10878 : :
10879 : : /* The label is not in an enclosing block, so illegal. This was
10880 : : allowed in Fortran 66, so we allow it as extension. No
10881 : : further checks are necessary in this case. */
10882 : 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
10883 : : "as the GOTO statement at %L", &label->where,
10884 : : &code->loc);
10885 : 36 : return;
10886 : : }
10887 : :
10888 : :
10889 : : /* Check whether EXPR1 has the same shape as EXPR2. */
10890 : :
10891 : : static bool
10892 : 1461 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
10893 : : {
10894 : 1461 : mpz_t shape[GFC_MAX_DIMENSIONS];
10895 : 1461 : mpz_t shape2[GFC_MAX_DIMENSIONS];
10896 : 1461 : bool result = false;
10897 : 1461 : int i;
10898 : :
10899 : : /* Compare the rank. */
10900 : 1461 : if (expr1->rank != expr2->rank)
10901 : : return result;
10902 : :
10903 : : /* Compare the size of each dimension. */
10904 : 2795 : for (i=0; i<expr1->rank; i++)
10905 : : {
10906 : 1484 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
10907 : 150 : goto ignore;
10908 : :
10909 : 1334 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
10910 : 0 : goto ignore;
10911 : :
10912 : 1334 : if (mpz_cmp (shape[i], shape2[i]))
10913 : 0 : goto over;
10914 : : }
10915 : :
10916 : : /* When either of the two expression is an assumed size array, we
10917 : : ignore the comparison of dimension sizes. */
10918 : 1311 : ignore:
10919 : : result = true;
10920 : :
10921 : 1461 : over:
10922 : 1461 : gfc_clear_shape (shape, i);
10923 : 1461 : gfc_clear_shape (shape2, i);
10924 : 1461 : return result;
10925 : : }
10926 : :
10927 : :
10928 : : /* Check whether a WHERE assignment target or a WHERE mask expression
10929 : : has the same shape as the outmost WHERE mask expression. */
10930 : :
10931 : : static void
10932 : 506 : resolve_where (gfc_code *code, gfc_expr *mask)
10933 : : {
10934 : 506 : gfc_code *cblock;
10935 : 506 : gfc_code *cnext;
10936 : 506 : gfc_expr *e = NULL;
10937 : :
10938 : 506 : cblock = code->block;
10939 : :
10940 : : /* Store the first WHERE mask-expr of the WHERE statement or construct.
10941 : : In case of nested WHERE, only the outmost one is stored. */
10942 : 506 : if (mask == NULL) /* outmost WHERE */
10943 : 450 : e = cblock->expr1;
10944 : : else /* inner WHERE */
10945 : 506 : e = mask;
10946 : :
10947 : 1381 : while (cblock)
10948 : : {
10949 : 875 : if (cblock->expr1)
10950 : : {
10951 : : /* Check if the mask-expr has a consistent shape with the
10952 : : outmost WHERE mask-expr. */
10953 : 711 : if (!resolve_where_shape (cblock->expr1, e))
10954 : 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
10955 : 0 : &cblock->expr1->where);
10956 : : }
10957 : :
10958 : : /* the assignment statement of a WHERE statement, or the first
10959 : : statement in where-body-construct of a WHERE construct */
10960 : 875 : cnext = cblock->next;
10961 : 1727 : while (cnext)
10962 : : {
10963 : 852 : switch (cnext->op)
10964 : : {
10965 : : /* WHERE assignment statement */
10966 : 750 : case EXEC_ASSIGN:
10967 : :
10968 : : /* Check shape consistent for WHERE assignment target. */
10969 : 750 : if (e && !resolve_where_shape (cnext->expr1, e))
10970 : 0 : gfc_error ("WHERE assignment target at %L has "
10971 : 0 : "inconsistent shape", &cnext->expr1->where);
10972 : :
10973 : 750 : if (cnext->op == EXEC_ASSIGN
10974 : 750 : && gfc_may_be_finalized (cnext->expr1->ts))
10975 : 0 : cnext->expr1->must_finalize = 1;
10976 : :
10977 : : break;
10978 : :
10979 : :
10980 : 46 : case EXEC_ASSIGN_CALL:
10981 : 46 : resolve_call (cnext);
10982 : 46 : if (!cnext->resolved_sym->attr.elemental)
10983 : 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10984 : 2 : &cnext->ext.actual->expr->where);
10985 : : break;
10986 : :
10987 : : /* WHERE or WHERE construct is part of a where-body-construct */
10988 : 56 : case EXEC_WHERE:
10989 : 56 : resolve_where (cnext, e);
10990 : 56 : break;
10991 : :
10992 : 0 : default:
10993 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
10994 : : &cnext->loc);
10995 : : }
10996 : : /* the next statement within the same where-body-construct */
10997 : 852 : cnext = cnext->next;
10998 : : }
10999 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
11000 : 875 : cblock = cblock->block;
11001 : : }
11002 : 506 : }
11003 : :
11004 : :
11005 : : /* Resolve assignment in FORALL construct.
11006 : : NVAR is the number of FORALL index variables, and VAR_EXPR records the
11007 : : FORALL index variables. */
11008 : :
11009 : : static void
11010 : 1951 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
11011 : : {
11012 : 1951 : int n;
11013 : :
11014 : 5900 : for (n = 0; n < nvar; n++)
11015 : : {
11016 : 3949 : gfc_symbol *forall_index;
11017 : :
11018 : 3949 : forall_index = var_expr[n]->symtree->n.sym;
11019 : :
11020 : : /* Check whether the assignment target is one of the FORALL index
11021 : : variable. */
11022 : 3949 : if ((code->expr1->expr_type == EXPR_VARIABLE)
11023 : 3949 : && (code->expr1->symtree->n.sym == forall_index))
11024 : 0 : gfc_error ("Assignment to a FORALL index variable at %L",
11025 : : &code->expr1->where);
11026 : : else
11027 : : {
11028 : : /* If one of the FORALL index variables doesn't appear in the
11029 : : assignment variable, then there could be a many-to-one
11030 : : assignment. Emit a warning rather than an error because the
11031 : : mask could be resolving this problem. */
11032 : 3949 : if (!find_forall_index (code->expr1, forall_index, 0))
11033 : 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
11034 : : "left side of the assignment at %L and so might "
11035 : : "cause multiple assignment to this object",
11036 : 0 : var_expr[n]->symtree->name, &code->expr1->where);
11037 : : }
11038 : : }
11039 : 1951 : }
11040 : :
11041 : :
11042 : : /* Resolve WHERE statement in FORALL construct. */
11043 : :
11044 : : static void
11045 : 46 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
11046 : : gfc_expr **var_expr)
11047 : : {
11048 : 46 : gfc_code *cblock;
11049 : 46 : gfc_code *cnext;
11050 : :
11051 : 46 : cblock = code->block;
11052 : 111 : while (cblock)
11053 : : {
11054 : : /* the assignment statement of a WHERE statement, or the first
11055 : : statement in where-body-construct of a WHERE construct */
11056 : 65 : cnext = cblock->next;
11057 : 130 : while (cnext)
11058 : : {
11059 : 65 : switch (cnext->op)
11060 : : {
11061 : : /* WHERE assignment statement */
11062 : 65 : case EXEC_ASSIGN:
11063 : 65 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
11064 : :
11065 : 65 : if (cnext->op == EXEC_ASSIGN
11066 : 65 : && gfc_may_be_finalized (cnext->expr1->ts))
11067 : 0 : cnext->expr1->must_finalize = 1;
11068 : :
11069 : : break;
11070 : :
11071 : : /* WHERE operator assignment statement */
11072 : 0 : case EXEC_ASSIGN_CALL:
11073 : 0 : resolve_call (cnext);
11074 : 0 : if (!cnext->resolved_sym->attr.elemental)
11075 : 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
11076 : 0 : &cnext->ext.actual->expr->where);
11077 : : break;
11078 : :
11079 : : /* WHERE or WHERE construct is part of a where-body-construct */
11080 : 0 : case EXEC_WHERE:
11081 : 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
11082 : 0 : break;
11083 : :
11084 : 0 : default:
11085 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
11086 : : &cnext->loc);
11087 : : }
11088 : : /* the next statement within the same where-body-construct */
11089 : 65 : cnext = cnext->next;
11090 : : }
11091 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
11092 : 65 : cblock = cblock->block;
11093 : : }
11094 : 46 : }
11095 : :
11096 : :
11097 : : /* Traverse the FORALL body to check whether the following errors exist:
11098 : : 1. For assignment, check if a many-to-one assignment happens.
11099 : : 2. For WHERE statement, check the WHERE body to see if there is any
11100 : : many-to-one assignment. */
11101 : :
11102 : : static void
11103 : 2002 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
11104 : : {
11105 : 2002 : gfc_code *c;
11106 : :
11107 : 2002 : c = code->block->next;
11108 : 4017 : while (c)
11109 : : {
11110 : 2015 : switch (c->op)
11111 : : {
11112 : 1886 : case EXEC_ASSIGN:
11113 : 1886 : case EXEC_POINTER_ASSIGN:
11114 : 1886 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
11115 : :
11116 : 1886 : if (c->op == EXEC_ASSIGN
11117 : 1886 : && gfc_may_be_finalized (c->expr1->ts))
11118 : 0 : c->expr1->must_finalize = 1;
11119 : :
11120 : : break;
11121 : :
11122 : 0 : case EXEC_ASSIGN_CALL:
11123 : 0 : resolve_call (c);
11124 : 0 : break;
11125 : :
11126 : : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
11127 : : there is no need to handle it here. */
11128 : : case EXEC_FORALL:
11129 : : break;
11130 : 46 : case EXEC_WHERE:
11131 : 46 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
11132 : 46 : break;
11133 : : default:
11134 : : break;
11135 : : }
11136 : : /* The next statement in the FORALL body. */
11137 : 2015 : c = c->next;
11138 : : }
11139 : 2002 : }
11140 : :
11141 : :
11142 : : /* Counts the number of iterators needed inside a forall construct, including
11143 : : nested forall constructs. This is used to allocate the needed memory
11144 : : in gfc_resolve_forall. */
11145 : :
11146 : : static int
11147 : 2002 : gfc_count_forall_iterators (gfc_code *code)
11148 : : {
11149 : 2002 : int max_iters, sub_iters, current_iters;
11150 : 2002 : gfc_forall_iterator *fa;
11151 : :
11152 : 2002 : gcc_assert(code->op == EXEC_FORALL);
11153 : 2002 : max_iters = 0;
11154 : 2002 : current_iters = 0;
11155 : :
11156 : 5912 : for (fa = code->ext.forall_iterator; fa; fa = fa->next)
11157 : 3910 : current_iters ++;
11158 : :
11159 : 2002 : code = code->block->next;
11160 : :
11161 : 4017 : while (code)
11162 : : {
11163 : 2015 : if (code->op == EXEC_FORALL)
11164 : : {
11165 : 83 : sub_iters = gfc_count_forall_iterators (code);
11166 : 83 : if (sub_iters > max_iters)
11167 : 2015 : max_iters = sub_iters;
11168 : : }
11169 : 2015 : code = code->next;
11170 : : }
11171 : :
11172 : 2002 : return current_iters + max_iters;
11173 : : }
11174 : :
11175 : :
11176 : : /* Given a FORALL construct, first resolve the FORALL iterator, then call
11177 : : gfc_resolve_forall_body to resolve the FORALL body. */
11178 : :
11179 : : static void
11180 : 2002 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
11181 : : {
11182 : 2002 : static gfc_expr **var_expr;
11183 : 2002 : static int total_var = 0;
11184 : 2002 : static int nvar = 0;
11185 : 2002 : int i, old_nvar, tmp;
11186 : 2002 : gfc_forall_iterator *fa;
11187 : :
11188 : 2002 : old_nvar = nvar;
11189 : :
11190 : 2002 : if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
11191 : : return;
11192 : :
11193 : : /* Start to resolve a FORALL construct */
11194 : 2002 : if (forall_save == 0)
11195 : : {
11196 : : /* Count the total number of FORALL indices in the nested FORALL
11197 : : construct in order to allocate the VAR_EXPR with proper size. */
11198 : 1919 : total_var = gfc_count_forall_iterators (code);
11199 : :
11200 : : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
11201 : 1919 : var_expr = XCNEWVEC (gfc_expr *, total_var);
11202 : : }
11203 : :
11204 : : /* The information about FORALL iterator, including FORALL indices start, end
11205 : : and stride. An outer FORALL indice cannot appear in start, end or stride. */
11206 : 5912 : for (fa = code->ext.forall_iterator; fa; fa = fa->next)
11207 : : {
11208 : : /* Fortran 20008: C738 (R753). */
11209 : 3910 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
11210 : : {
11211 : 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
11212 : : "of type integer", &fa->var->where);
11213 : 2 : continue;
11214 : : }
11215 : :
11216 : : /* Check if any outer FORALL index name is the same as the current
11217 : : one. */
11218 : 6911 : for (i = 0; i < nvar; i++)
11219 : : {
11220 : 3003 : if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
11221 : 0 : gfc_error ("An outer FORALL construct already has an index "
11222 : : "with this name %L", &fa->var->where);
11223 : : }
11224 : :
11225 : : /* Record the current FORALL index. */
11226 : 3908 : var_expr[nvar] = gfc_copy_expr (fa->var);
11227 : :
11228 : 3908 : nvar++;
11229 : :
11230 : : /* No memory leak. */
11231 : 3908 : gcc_assert (nvar <= total_var);
11232 : : }
11233 : :
11234 : : /* Resolve the FORALL body. */
11235 : 2002 : gfc_resolve_forall_body (code, nvar, var_expr);
11236 : :
11237 : : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
11238 : 2002 : gfc_resolve_blocks (code->block, ns);
11239 : :
11240 : 2002 : tmp = nvar;
11241 : 2002 : nvar = old_nvar;
11242 : : /* Free only the VAR_EXPRs allocated in this frame. */
11243 : 5910 : for (i = nvar; i < tmp; i++)
11244 : 3908 : gfc_free_expr (var_expr[i]);
11245 : :
11246 : 2002 : if (nvar == 0)
11247 : : {
11248 : : /* We are in the outermost FORALL construct. */
11249 : 1919 : gcc_assert (forall_save == 0);
11250 : :
11251 : : /* VAR_EXPR is not needed any more. */
11252 : 1919 : free (var_expr);
11253 : 1919 : total_var = 0;
11254 : : }
11255 : : }
11256 : :
11257 : :
11258 : : /* Resolve a BLOCK construct statement. */
11259 : :
11260 : : static void
11261 : 7031 : resolve_block_construct (gfc_code* code)
11262 : : {
11263 : 7031 : gfc_namespace *ns = code->ext.block.ns;
11264 : :
11265 : : /* For an ASSOCIATE block, the associations (and their targets) are already
11266 : : resolved during resolve_symbol. Resolve the BLOCK's namespace. */
11267 : 0 : gfc_resolve (ns);
11268 : 7031 : }
11269 : :
11270 : :
11271 : : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
11272 : : DO code nodes. */
11273 : :
11274 : : void
11275 : 284607 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
11276 : : {
11277 : 284607 : bool t;
11278 : :
11279 : 579959 : for (; b; b = b->block)
11280 : : {
11281 : 295352 : t = gfc_resolve_expr (b->expr1);
11282 : 295352 : if (!gfc_resolve_expr (b->expr2))
11283 : 0 : t = false;
11284 : :
11285 : 295352 : switch (b->op)
11286 : : {
11287 : 198067 : case EXEC_IF:
11288 : 198067 : if (t && b->expr1 != NULL
11289 : 194091 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
11290 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11291 : : &b->expr1->where);
11292 : : break;
11293 : :
11294 : 761 : case EXEC_WHERE:
11295 : 761 : if (t
11296 : 761 : && b->expr1 != NULL
11297 : 628 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
11298 : 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
11299 : : &b->expr1->where);
11300 : : break;
11301 : :
11302 : 76 : case EXEC_GOTO:
11303 : 76 : resolve_branch (b->label1, b);
11304 : 76 : break;
11305 : :
11306 : 0 : case EXEC_BLOCK:
11307 : 0 : resolve_block_construct (b);
11308 : 0 : break;
11309 : :
11310 : : case EXEC_SELECT:
11311 : : case EXEC_SELECT_TYPE:
11312 : : case EXEC_SELECT_RANK:
11313 : : case EXEC_FORALL:
11314 : : case EXEC_DO:
11315 : : case EXEC_DO_WHILE:
11316 : : case EXEC_DO_CONCURRENT:
11317 : : case EXEC_CRITICAL:
11318 : : case EXEC_READ:
11319 : : case EXEC_WRITE:
11320 : : case EXEC_IOLENGTH:
11321 : : case EXEC_WAIT:
11322 : : break;
11323 : :
11324 : 2683 : case EXEC_OMP_ATOMIC:
11325 : 2683 : case EXEC_OACC_ATOMIC:
11326 : 2683 : {
11327 : : /* Verify this before calling gfc_resolve_code, which might
11328 : : change it. */
11329 : 2683 : gcc_assert (b->op == EXEC_OMP_ATOMIC
11330 : : || (b->next && b->next->op == EXEC_ASSIGN));
11331 : : }
11332 : : break;
11333 : :
11334 : : case EXEC_OACC_PARALLEL_LOOP:
11335 : : case EXEC_OACC_PARALLEL:
11336 : : case EXEC_OACC_KERNELS_LOOP:
11337 : : case EXEC_OACC_KERNELS:
11338 : : case EXEC_OACC_SERIAL_LOOP:
11339 : : case EXEC_OACC_SERIAL:
11340 : : case EXEC_OACC_DATA:
11341 : : case EXEC_OACC_HOST_DATA:
11342 : : case EXEC_OACC_LOOP:
11343 : : case EXEC_OACC_UPDATE:
11344 : : case EXEC_OACC_WAIT:
11345 : : case EXEC_OACC_CACHE:
11346 : : case EXEC_OACC_ENTER_DATA:
11347 : : case EXEC_OACC_EXIT_DATA:
11348 : : case EXEC_OACC_ROUTINE:
11349 : : case EXEC_OMP_ALLOCATE:
11350 : : case EXEC_OMP_ALLOCATORS:
11351 : : case EXEC_OMP_ASSUME:
11352 : : case EXEC_OMP_CRITICAL:
11353 : : case EXEC_OMP_DISTRIBUTE:
11354 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11355 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11356 : : case EXEC_OMP_DISTRIBUTE_SIMD:
11357 : : case EXEC_OMP_DO:
11358 : : case EXEC_OMP_DO_SIMD:
11359 : : case EXEC_OMP_ERROR:
11360 : : case EXEC_OMP_LOOP:
11361 : : case EXEC_OMP_MASKED:
11362 : : case EXEC_OMP_MASKED_TASKLOOP:
11363 : : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11364 : : case EXEC_OMP_MASTER:
11365 : : case EXEC_OMP_MASTER_TASKLOOP:
11366 : : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11367 : : case EXEC_OMP_ORDERED:
11368 : : case EXEC_OMP_PARALLEL:
11369 : : case EXEC_OMP_PARALLEL_DO:
11370 : : case EXEC_OMP_PARALLEL_DO_SIMD:
11371 : : case EXEC_OMP_PARALLEL_LOOP:
11372 : : case EXEC_OMP_PARALLEL_MASKED:
11373 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11374 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11375 : : case EXEC_OMP_PARALLEL_MASTER:
11376 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11377 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11378 : : case EXEC_OMP_PARALLEL_SECTIONS:
11379 : : case EXEC_OMP_PARALLEL_WORKSHARE:
11380 : : case EXEC_OMP_SECTIONS:
11381 : : case EXEC_OMP_SIMD:
11382 : : case EXEC_OMP_SCOPE:
11383 : : case EXEC_OMP_SINGLE:
11384 : : case EXEC_OMP_TARGET:
11385 : : case EXEC_OMP_TARGET_DATA:
11386 : : case EXEC_OMP_TARGET_ENTER_DATA:
11387 : : case EXEC_OMP_TARGET_EXIT_DATA:
11388 : : case EXEC_OMP_TARGET_PARALLEL:
11389 : : case EXEC_OMP_TARGET_PARALLEL_DO:
11390 : : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11391 : : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11392 : : case EXEC_OMP_TARGET_SIMD:
11393 : : case EXEC_OMP_TARGET_TEAMS:
11394 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11395 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11396 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11397 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11398 : : case EXEC_OMP_TARGET_TEAMS_LOOP:
11399 : : case EXEC_OMP_TARGET_UPDATE:
11400 : : case EXEC_OMP_TASK:
11401 : : case EXEC_OMP_TASKGROUP:
11402 : : case EXEC_OMP_TASKLOOP:
11403 : : case EXEC_OMP_TASKLOOP_SIMD:
11404 : : case EXEC_OMP_TASKWAIT:
11405 : : case EXEC_OMP_TASKYIELD:
11406 : : case EXEC_OMP_TEAMS:
11407 : : case EXEC_OMP_TEAMS_DISTRIBUTE:
11408 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11409 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11410 : : case EXEC_OMP_TEAMS_LOOP:
11411 : : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11412 : : case EXEC_OMP_WORKSHARE:
11413 : : break;
11414 : :
11415 : 0 : default:
11416 : 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
11417 : : }
11418 : :
11419 : 295352 : gfc_resolve_code (b->next, ns);
11420 : : }
11421 : 284607 : }
11422 : :
11423 : :
11424 : : /* Does everything to resolve an ordinary assignment. Returns true
11425 : : if this is an interface assignment. */
11426 : : static bool
11427 : 174408 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
11428 : : {
11429 : 174408 : bool rval = false;
11430 : 174408 : gfc_expr *lhs;
11431 : 174408 : gfc_expr *rhs;
11432 : 174408 : int n;
11433 : 174408 : gfc_ref *ref;
11434 : 174408 : symbol_attribute attr;
11435 : :
11436 : 174408 : if (gfc_extend_assign (code, ns))
11437 : : {
11438 : 727 : gfc_expr** rhsptr;
11439 : :
11440 : 727 : if (code->op == EXEC_ASSIGN_CALL)
11441 : : {
11442 : 335 : lhs = code->ext.actual->expr;
11443 : 335 : rhsptr = &code->ext.actual->next->expr;
11444 : : }
11445 : : else
11446 : : {
11447 : 392 : gfc_actual_arglist* args;
11448 : 392 : gfc_typebound_proc* tbp;
11449 : :
11450 : 392 : gcc_assert (code->op == EXEC_COMPCALL);
11451 : :
11452 : 392 : args = code->expr1->value.compcall.actual;
11453 : 392 : lhs = args->expr;
11454 : 392 : rhsptr = &args->next->expr;
11455 : :
11456 : 392 : tbp = code->expr1->value.compcall.tbp;
11457 : 392 : gcc_assert (!tbp->is_generic);
11458 : : }
11459 : :
11460 : : /* Make a temporary rhs when there is a default initializer
11461 : : and rhs is the same symbol as the lhs. */
11462 : 727 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
11463 : 356 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
11464 : 303 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
11465 : 882 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
11466 : 24 : *rhsptr = gfc_get_parentheses (*rhsptr);
11467 : :
11468 : 727 : return true;
11469 : : }
11470 : :
11471 : 173681 : lhs = code->expr1;
11472 : 173681 : rhs = code->expr2;
11473 : :
11474 : 173681 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
11475 : 156583 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
11476 : 19073 : && !lhs->symtree->n.sym->attr.proc_pointer
11477 : 192754 : && gfc_expr_attr (lhs).proc_pointer)
11478 : : {
11479 : 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
11480 : : "pointer component",
11481 : : &lhs->where);
11482 : 1 : return false;
11483 : : }
11484 : :
11485 : 219319 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
11486 : 141954 : && rhs->ts.type == BT_CHARACTER
11487 : 174073 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
11488 : : {
11489 : : /* Use of -fdec-char-conversions allows assignment of character data
11490 : : to non-character variables. This not permitted for nonconstant
11491 : : strings. */
11492 : 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
11493 : : gfc_typename (lhs), &rhs->where);
11494 : 29 : return false;
11495 : : }
11496 : :
11497 : : /* Handle the case of a BOZ literal on the RHS. */
11498 : 173651 : if (rhs->ts.type == BT_BOZ)
11499 : : {
11500 : 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11501 : : "statement value nor an actual argument of "
11502 : : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
11503 : : &rhs->where))
11504 : : return false;
11505 : :
11506 : 1 : switch (lhs->ts.type)
11507 : : {
11508 : 0 : case BT_INTEGER:
11509 : 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
11510 : : return false;
11511 : : break;
11512 : 1 : case BT_REAL:
11513 : 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
11514 : : return false;
11515 : : break;
11516 : 0 : default:
11517 : 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
11518 : 0 : return false;
11519 : : }
11520 : : }
11521 : :
11522 : 173649 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
11523 : : {
11524 : 64 : HOST_WIDE_INT llen = 0, rlen = 0;
11525 : 64 : if (lhs->ts.u.cl != NULL
11526 : 64 : && lhs->ts.u.cl->length != NULL
11527 : 53 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11528 : 53 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
11529 : :
11530 : 64 : if (rhs->expr_type == EXPR_CONSTANT)
11531 : 26 : rlen = rhs->value.character.length;
11532 : :
11533 : 38 : else if (rhs->ts.u.cl != NULL
11534 : 38 : && rhs->ts.u.cl->length != NULL
11535 : 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11536 : 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
11537 : :
11538 : 64 : if (rlen && llen && rlen > llen)
11539 : 28 : gfc_warning_now (OPT_Wcharacter_truncation,
11540 : : "CHARACTER expression will be truncated "
11541 : : "in assignment (%wd/%wd) at %L",
11542 : : llen, rlen, &code->loc);
11543 : : }
11544 : :
11545 : : /* Ensure that a vector index expression for the lvalue is evaluated
11546 : : to a temporary if the lvalue symbol is referenced in it. */
11547 : 173649 : if (lhs->rank)
11548 : : {
11549 : 89432 : for (ref = lhs->ref; ref; ref= ref->next)
11550 : 47578 : if (ref->type == REF_ARRAY)
11551 : : {
11552 : 101144 : for (n = 0; n < ref->u.ar.dimen; n++)
11553 : 57881 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
11554 : 57881 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
11555 : : ref->u.ar.start[n]))
11556 : 24 : ref->u.ar.start[n]
11557 : 24 : = gfc_get_parentheses (ref->u.ar.start[n]);
11558 : : }
11559 : : }
11560 : :
11561 : 173649 : if (gfc_pure (NULL))
11562 : : {
11563 : 3002 : if (lhs->ts.type == BT_DERIVED
11564 : 81 : && lhs->expr_type == EXPR_VARIABLE
11565 : 81 : && lhs->ts.u.derived->attr.pointer_comp
11566 : 4 : && rhs->expr_type == EXPR_VARIABLE
11567 : 3005 : && (gfc_impure_variable (rhs->symtree->n.sym)
11568 : 2 : || gfc_is_coindexed (rhs)))
11569 : : {
11570 : : /* F2008, C1283. */
11571 : 2 : if (gfc_is_coindexed (rhs))
11572 : 1 : gfc_error ("Coindexed expression at %L is assigned to "
11573 : : "a derived type variable with a POINTER "
11574 : : "component in a PURE procedure",
11575 : : &rhs->where);
11576 : : else
11577 : : /* F2008, C1283 (4). */
11578 : 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11579 : : "shall not be used as the expr at %L of an intrinsic "
11580 : : "assignment statement in which the variable is of a "
11581 : : "derived type if the derived type has a pointer "
11582 : : "component at any level of component selection.",
11583 : : &rhs->where);
11584 : 2 : return rval;
11585 : : }
11586 : :
11587 : : /* Fortran 2008, C1283. */
11588 : 3000 : if (gfc_is_coindexed (lhs))
11589 : : {
11590 : 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
11591 : : "procedure", &rhs->where);
11592 : 1 : return rval;
11593 : : }
11594 : : }
11595 : :
11596 : 173646 : if (gfc_implicit_pure (NULL))
11597 : : {
11598 : 6665 : if (lhs->expr_type == EXPR_VARIABLE
11599 : 6665 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
11600 : 4748 : && lhs->symtree->n.sym->ns != gfc_current_ns)
11601 : 231 : gfc_unset_implicit_pure (NULL);
11602 : :
11603 : 6665 : if (lhs->ts.type == BT_DERIVED
11604 : 269 : && lhs->expr_type == EXPR_VARIABLE
11605 : 269 : && lhs->ts.u.derived->attr.pointer_comp
11606 : 1 : && rhs->expr_type == EXPR_VARIABLE
11607 : 6666 : && (gfc_impure_variable (rhs->symtree->n.sym)
11608 : 1 : || gfc_is_coindexed (rhs)))
11609 : 0 : gfc_unset_implicit_pure (NULL);
11610 : :
11611 : : /* Fortran 2008, C1283. */
11612 : 6665 : if (gfc_is_coindexed (lhs))
11613 : 0 : gfc_unset_implicit_pure (NULL);
11614 : : }
11615 : :
11616 : : /* F2008, 7.2.1.2. */
11617 : 173646 : attr = gfc_expr_attr (lhs);
11618 : 173646 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
11619 : : {
11620 : 571 : if (attr.codimension)
11621 : : {
11622 : 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
11623 : : "permitted", &lhs->where);
11624 : 1 : return false;
11625 : : }
11626 : 570 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
11627 : : "polymorphic variable at %L", &lhs->where))
11628 : : return false;
11629 : 569 : if (!flag_realloc_lhs)
11630 : : {
11631 : 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
11632 : : "requires %<-frealloc-lhs%>", &lhs->where);
11633 : 1 : return false;
11634 : : }
11635 : : }
11636 : 173075 : else if (lhs->ts.type == BT_CLASS)
11637 : : {
11638 : 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11639 : : "assignment at %L - check that there is a matching specific "
11640 : : "subroutine for %<=%> operator", &lhs->where);
11641 : 9 : return false;
11642 : : }
11643 : :
11644 : 173634 : bool lhs_coindexed = gfc_is_coindexed (lhs);
11645 : :
11646 : : /* F2008, Section 7.2.1.2. */
11647 : 173634 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
11648 : : {
11649 : 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
11650 : : "component in assignment at %L", &lhs->where);
11651 : 1 : return false;
11652 : : }
11653 : :
11654 : : /* Assign the 'data' of a class object to a derived type. */
11655 : 173633 : if (lhs->ts.type == BT_DERIVED
11656 : 6065 : && rhs->ts.type == BT_CLASS
11657 : 131 : && rhs->expr_type != EXPR_ARRAY)
11658 : 125 : gfc_add_data_component (rhs);
11659 : :
11660 : : /* Make sure there is a vtable and, in particular, a _copy for the
11661 : : rhs type. */
11662 : 173633 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
11663 : 349 : gfc_find_vtab (&rhs->ts);
11664 : :
11665 : 173633 : bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
11666 : 173633 : && (lhs_coindexed
11667 : 2288 : || (code->expr2->expr_type == EXPR_FUNCTION
11668 : 457 : && code->expr2->value.function.isym
11669 : 455 : && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
11670 : 185 : && (code->expr1->rank == 0 || code->expr2->rank != 0)
11671 : 177 : && !gfc_expr_attr (rhs).allocatable
11672 : 177 : && !gfc_has_vector_subscript (rhs)));
11673 : :
11674 : 173633 : gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
11675 : :
11676 : : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11677 : : Additionally, insert this code when the RHS is a CAF as we then use the
11678 : : GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
11679 : : the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11680 : : noncoindexed array and the RHS is a coindexed scalar, use the normal code
11681 : : path. */
11682 : 173633 : if (caf_convert_to_send)
11683 : : {
11684 : 550 : if (code->expr2->expr_type == EXPR_FUNCTION
11685 : 267 : && code->expr2->value.function.isym
11686 : 267 : && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
11687 : 267 : remove_caf_get_intrinsic (code->expr2);
11688 : 550 : code->op = EXEC_CALL;
11689 : 550 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
11690 : 550 : code->resolved_sym = code->symtree->n.sym;
11691 : 550 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
11692 : 550 : code->resolved_sym->attr.intrinsic = 1;
11693 : 550 : code->resolved_sym->attr.subroutine = 1;
11694 : 550 : code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11695 : 550 : gfc_commit_symbol (code->resolved_sym);
11696 : 550 : code->ext.actual = gfc_get_actual_arglist ();
11697 : 550 : code->ext.actual->expr = lhs;
11698 : 550 : code->ext.actual->next = gfc_get_actual_arglist ();
11699 : 550 : code->ext.actual->next->expr = rhs;
11700 : 550 : code->expr1 = NULL;
11701 : 550 : code->expr2 = NULL;
11702 : : }
11703 : :
11704 : : return false;
11705 : : }
11706 : :
11707 : :
11708 : : /* Add a component reference onto an expression. */
11709 : :
11710 : : static void
11711 : 615 : add_comp_ref (gfc_expr *e, gfc_component *c)
11712 : : {
11713 : 615 : gfc_ref **ref;
11714 : 615 : ref = &(e->ref);
11715 : 815 : while (*ref)
11716 : 200 : ref = &((*ref)->next);
11717 : 615 : *ref = gfc_get_ref ();
11718 : 615 : (*ref)->type = REF_COMPONENT;
11719 : 615 : (*ref)->u.c.sym = e->ts.u.derived;
11720 : 615 : (*ref)->u.c.component = c;
11721 : 615 : e->ts = c->ts;
11722 : :
11723 : : /* Add a full array ref, as necessary. */
11724 : 615 : if (c->as)
11725 : : {
11726 : 84 : gfc_add_full_array_ref (e, c->as);
11727 : 84 : e->rank = c->as->rank;
11728 : : }
11729 : 615 : }
11730 : :
11731 : :
11732 : : /* Build an assignment. Keep the argument 'op' for future use, so that
11733 : : pointer assignments can be made. */
11734 : :
11735 : : static gfc_code *
11736 : 763 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
11737 : : gfc_component *comp1, gfc_component *comp2, locus loc)
11738 : : {
11739 : 763 : gfc_code *this_code;
11740 : :
11741 : 763 : this_code = gfc_get_code (op);
11742 : 763 : this_code->next = NULL;
11743 : 763 : this_code->expr1 = gfc_copy_expr (expr1);
11744 : 763 : this_code->expr2 = gfc_copy_expr (expr2);
11745 : 763 : this_code->loc = loc;
11746 : 763 : if (comp1 && comp2)
11747 : : {
11748 : 263 : add_comp_ref (this_code->expr1, comp1);
11749 : 263 : add_comp_ref (this_code->expr2, comp2);
11750 : : }
11751 : :
11752 : 763 : return this_code;
11753 : : }
11754 : :
11755 : :
11756 : : /* Makes a temporary variable expression based on the characteristics of
11757 : : a given variable expression. */
11758 : :
11759 : : static gfc_expr*
11760 : 307 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
11761 : : {
11762 : 307 : static int serial = 0;
11763 : 307 : char name[GFC_MAX_SYMBOL_LEN];
11764 : 307 : gfc_symtree *tmp;
11765 : 307 : gfc_array_spec *as;
11766 : 307 : gfc_array_ref *aref;
11767 : 307 : gfc_ref *ref;
11768 : :
11769 : 307 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
11770 : 307 : gfc_get_sym_tree (name, ns, &tmp, false);
11771 : 307 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
11772 : :
11773 : 307 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
11774 : 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
11775 : : NULL,
11776 : : e->value.character.length);
11777 : :
11778 : 307 : as = NULL;
11779 : 307 : ref = NULL;
11780 : 307 : aref = NULL;
11781 : :
11782 : : /* Obtain the arrayspec for the temporary. */
11783 : 307 : if (e->rank && e->expr_type != EXPR_ARRAY
11784 : : && e->expr_type != EXPR_FUNCTION
11785 : : && e->expr_type != EXPR_OP)
11786 : : {
11787 : 40 : aref = gfc_find_array_ref (e);
11788 : 40 : if (e->expr_type == EXPR_VARIABLE
11789 : 40 : && e->symtree->n.sym->as == aref->as)
11790 : : as = aref->as;
11791 : : else
11792 : : {
11793 : 0 : for (ref = e->ref; ref; ref = ref->next)
11794 : 0 : if (ref->type == REF_COMPONENT
11795 : 0 : && ref->u.c.component->as == aref->as)
11796 : : {
11797 : : as = aref->as;
11798 : : break;
11799 : : }
11800 : : }
11801 : : }
11802 : :
11803 : : /* Add the attributes and the arrayspec to the temporary. */
11804 : 307 : tmp->n.sym->attr = gfc_expr_attr (e);
11805 : 307 : tmp->n.sym->attr.function = 0;
11806 : 307 : tmp->n.sym->attr.proc_pointer = 0;
11807 : 307 : tmp->n.sym->attr.result = 0;
11808 : 307 : tmp->n.sym->attr.flavor = FL_VARIABLE;
11809 : 307 : tmp->n.sym->attr.dummy = 0;
11810 : 307 : tmp->n.sym->attr.use_assoc = 0;
11811 : 307 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
11812 : :
11813 : :
11814 : 307 : if (as)
11815 : : {
11816 : 40 : tmp->n.sym->as = gfc_copy_array_spec (as);
11817 : 40 : if (!ref)
11818 : 40 : ref = e->ref;
11819 : 40 : if (as->type == AS_DEFERRED)
11820 : 34 : tmp->n.sym->attr.allocatable = 1;
11821 : : }
11822 : 267 : else if (e->rank && (e->expr_type == EXPR_ARRAY
11823 : 48 : || e->expr_type == EXPR_FUNCTION
11824 : 0 : || e->expr_type == EXPR_OP))
11825 : : {
11826 : 48 : tmp->n.sym->as = gfc_get_array_spec ();
11827 : 48 : tmp->n.sym->as->type = AS_DEFERRED;
11828 : 48 : tmp->n.sym->as->rank = e->rank;
11829 : 48 : tmp->n.sym->attr.allocatable = 1;
11830 : 48 : tmp->n.sym->attr.dimension = 1;
11831 : : }
11832 : : else
11833 : 219 : tmp->n.sym->attr.dimension = 0;
11834 : :
11835 : 307 : gfc_set_sym_referenced (tmp->n.sym);
11836 : 307 : gfc_commit_symbol (tmp->n.sym);
11837 : 307 : e = gfc_lval_expr_from_sym (tmp->n.sym);
11838 : :
11839 : : /* Should the lhs be a section, use its array ref for the
11840 : : temporary expression. */
11841 : 307 : if (aref && aref->type != AR_FULL)
11842 : : {
11843 : 6 : gfc_free_ref_list (e->ref);
11844 : 6 : e->ref = gfc_copy_ref (ref);
11845 : : }
11846 : 307 : return e;
11847 : : }
11848 : :
11849 : :
11850 : : /* Add one line of code to the code chain, making sure that 'head' and
11851 : : 'tail' are appropriately updated. */
11852 : :
11853 : : static void
11854 : 582 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
11855 : : {
11856 : 582 : gcc_assert (this_code);
11857 : 582 : if (*head == NULL)
11858 : 258 : *head = *tail = *this_code;
11859 : : else
11860 : 324 : *tail = gfc_append_code (*tail, *this_code);
11861 : 582 : *this_code = NULL;
11862 : 582 : }
11863 : :
11864 : :
11865 : : /* Generate a final call from a variable expression */
11866 : :
11867 : : static void
11868 : 56 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
11869 : : {
11870 : 56 : gfc_code *this_code;
11871 : 56 : gfc_expr *final_expr = NULL;
11872 : 56 : gfc_expr *size_expr;
11873 : 56 : gfc_expr *fini_coarray;
11874 : :
11875 : 56 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
11876 : 56 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
11877 : 50 : return;
11878 : :
11879 : : /* Now generate the finalizer call. */
11880 : 6 : this_code = gfc_get_code (EXEC_CALL);
11881 : 6 : this_code->symtree = final_expr->symtree;
11882 : 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
11883 : :
11884 : : //* Expression to be finalized */
11885 : 6 : this_code->ext.actual = gfc_get_actual_arglist ();
11886 : 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
11887 : :
11888 : : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
11889 : 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
11890 : 6 : size_expr = gfc_get_expr ();
11891 : 6 : size_expr->where = gfc_current_locus;
11892 : 6 : size_expr->expr_type = EXPR_OP;
11893 : 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
11894 : 6 : size_expr->value.op.op1
11895 : 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
11896 : : "storage_size", gfc_current_locus, 2,
11897 : 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
11898 : : gfc_get_int_expr (gfc_index_integer_kind,
11899 : : NULL, 0));
11900 : 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
11901 : : gfc_character_storage_size);
11902 : 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
11903 : 6 : size_expr->ts = size_expr->value.op.op1->ts;
11904 : 6 : this_code->ext.actual->next->expr = size_expr;
11905 : :
11906 : : /* fini_coarray */
11907 : 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
11908 : 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
11909 : : &tmp_expr->where);
11910 : 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
11911 : 6 : this_code->ext.actual->next->next->expr = fini_coarray;
11912 : :
11913 : 6 : add_code_to_chain (&this_code, head, tail);
11914 : :
11915 : : }
11916 : :
11917 : : /* Counts the potential number of part array references that would
11918 : : result from resolution of typebound defined assignments. */
11919 : :
11920 : :
11921 : : static int
11922 : 218 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
11923 : : {
11924 : 218 : gfc_component *c;
11925 : 218 : int c_depth = 0, t_depth;
11926 : :
11927 : 534 : for (c= derived->components; c; c = c->next)
11928 : : {
11929 : 316 : if ((!gfc_bt_struct (c->ts.type)
11930 : : || c->attr.pointer
11931 : 236 : || c->attr.allocatable
11932 : 235 : || c->attr.proc_pointer_comp
11933 : : || c->attr.class_pointer
11934 : 235 : || c->attr.proc_pointer)
11935 : 81 : && !c->attr.defined_assign_comp)
11936 : 81 : continue;
11937 : :
11938 : 235 : if (c->as && c_depth == 0)
11939 : 235 : c_depth = 1;
11940 : :
11941 : 235 : if (c->ts.u.derived->attr.defined_assign_comp)
11942 : 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
11943 : : c->as ? 1 : 0);
11944 : : else
11945 : : t_depth = 0;
11946 : :
11947 : 235 : c_depth = t_depth > c_depth ? t_depth : c_depth;
11948 : : }
11949 : 218 : return depth + c_depth;
11950 : : }
11951 : :
11952 : :
11953 : : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
11954 : : "An intrinsic assignment where the variable is of derived type is performed
11955 : : as if each component of the variable were assigned from the corresponding
11956 : : component of expr using pointer assignment (10.2.2) for each pointer
11957 : : component, defined assignment for each nonpointer nonallocatable component
11958 : : of a type that has a type-bound defined assignment consistent with the
11959 : : component, intrinsic assignment for each other nonpointer nonallocatable
11960 : : component, and intrinsic assignment for each allocated coarray component.
11961 : : For unallocated coarray components, the corresponding component of the
11962 : : variable shall be unallocated. For a noncoarray allocatable component the
11963 : : following sequence of operations is applied.
11964 : : (1) If the component of the variable is allocated, it is deallocated.
11965 : : (2) If the component of the value of expr is allocated, the
11966 : : corresponding component of the variable is allocated with the same
11967 : : dynamic type and type parameters as the component of the value of
11968 : : expr. If it is an array, it is allocated with the same bounds. The
11969 : : value of the component of the value of expr is then assigned to the
11970 : : corresponding component of the variable using defined assignment if
11971 : : the declared type of the component has a type-bound defined
11972 : : assignment consistent with the component, and intrinsic assignment
11973 : : for the dynamic type of that component otherwise."
11974 : :
11975 : : The pointer assignments are taken care of by the intrinsic assignment of the
11976 : : structure itself. This function recursively adds defined assignments where
11977 : : required. The recursion is accomplished by calling gfc_resolve_code.
11978 : :
11979 : : When the lhs in a defined assignment has intent INOUT or is intent OUT
11980 : : and the component of 'var' is finalizable, we need a temporary for the
11981 : : lhs. In pseudo-code for an assignment var = expr:
11982 : :
11983 : : ! Confine finalization of temporaries, as far as possible.
11984 : : Enclose the code for the assignment in a block
11985 : : ! Only call function 'expr' once.
11986 : : #if ('expr is not a constant or an variable)
11987 : : temp_expr = expr
11988 : : expr = temp_x
11989 : : ! Do the intrinsic assignment
11990 : : #if typeof ('var') has a typebound final subroutine
11991 : : finalize (var)
11992 : : var = expr
11993 : : ! Now do the component assignments
11994 : : #do over derived type components [%cmp]
11995 : : #if (cmp is a pointer of any kind)
11996 : : continue
11997 : : build the assignment
11998 : : resolve the code
11999 : : #if the code is a typebound assignment
12000 : : #if (arg1 is INOUT or finalizable OUT && !t1)
12001 : : t1 = var
12002 : : arg1 = t1
12003 : : deal with allocatation or not of var and this component
12004 : : #elseif the code is an assignment by itself
12005 : : #if this component does not need finalization
12006 : : delete code and continue
12007 : : #else
12008 : : remove the leading assignment
12009 : : #endif
12010 : : commit the code
12011 : : #if (t1 and (arg1 is INOUT or finalizable OUT))
12012 : : var%cmp = t1%cmp
12013 : : #enddo
12014 : : put all code chunks involving t1 to the top of the generated code
12015 : : insert the generated block in place of the original code
12016 : : */
12017 : :
12018 : : static bool
12019 : 331 : is_finalizable_type (gfc_typespec ts)
12020 : : {
12021 : 331 : gfc_component *c;
12022 : :
12023 : 331 : if (ts.type != BT_DERIVED)
12024 : : return false;
12025 : :
12026 : : /* (1) Check for FINAL subroutines. */
12027 : 331 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
12028 : : return true;
12029 : :
12030 : : /* (2) Check for components of finalizable type. */
12031 : 710 : for (c = ts.u.derived->components; c; c = c->next)
12032 : 421 : if (c->ts.type == BT_DERIVED
12033 : 218 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
12034 : 217 : && c->ts.u.derived->f2k_derived
12035 : 217 : && c->ts.u.derived->f2k_derived->finalizers)
12036 : : return true;
12037 : :
12038 : : return false;
12039 : : }
12040 : :
12041 : : /* The temporary assignments have to be put on top of the additional
12042 : : code to avoid the result being changed by the intrinsic assignment.
12043 : : */
12044 : : static int component_assignment_level = 0;
12045 : : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
12046 : : static bool finalizable_comp;
12047 : :
12048 : : static void
12049 : 163 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
12050 : : {
12051 : 163 : gfc_component *comp1, *comp2;
12052 : 163 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
12053 : 163 : gfc_code *tmp_code = NULL;
12054 : 163 : gfc_expr *t1 = NULL;
12055 : 163 : gfc_expr *tmp_expr = NULL;
12056 : 163 : int error_count, depth;
12057 : 163 : bool finalizable_lhs;
12058 : :
12059 : 163 : gfc_get_errors (NULL, &error_count);
12060 : :
12061 : : /* Filter out continuing processing after an error. */
12062 : 163 : if (error_count
12063 : 163 : || (*code)->expr1->ts.type != BT_DERIVED
12064 : 163 : || (*code)->expr2->ts.type != BT_DERIVED)
12065 : 115 : return;
12066 : :
12067 : : /* TODO: Handle more than one part array reference in assignments. */
12068 : 163 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
12069 : 163 : (*code)->expr1->rank ? 1 : 0);
12070 : 163 : if (depth > 1)
12071 : : {
12072 : 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
12073 : : "done because multiple part array references would "
12074 : : "occur in intermediate expressions.", &(*code)->loc);
12075 : 6 : return;
12076 : : }
12077 : :
12078 : 157 : if (!component_assignment_level)
12079 : 109 : finalizable_comp = true;
12080 : :
12081 : : /* Build a block so that function result temporaries are finalized
12082 : : locally on exiting the rather than enclosing scope. */
12083 : 157 : if (!component_assignment_level)
12084 : : {
12085 : 109 : ns = gfc_build_block_ns (ns);
12086 : 109 : tmp_code = gfc_get_code (EXEC_NOP);
12087 : 109 : *tmp_code = **code;
12088 : 109 : tmp_code->next = NULL;
12089 : 109 : (*code)->op = EXEC_BLOCK;
12090 : 109 : (*code)->ext.block.ns = ns;
12091 : 109 : (*code)->ext.block.assoc = NULL;
12092 : 109 : (*code)->expr1 = (*code)->expr2 = NULL;
12093 : 109 : ns->code = tmp_code;
12094 : 109 : code = &ns->code;
12095 : : }
12096 : :
12097 : 157 : component_assignment_level++;
12098 : :
12099 : 157 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
12100 : :
12101 : : /* Create a temporary so that functions get called only once. */
12102 : 157 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
12103 : 157 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
12104 : : {
12105 : : /* Assign the rhs to the temporary. */
12106 : 56 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
12107 : 112 : this_code = build_assignment (EXEC_ASSIGN,
12108 : : tmp_expr, (*code)->expr2,
12109 : 56 : NULL, NULL, (*code)->loc);
12110 : 56 : this_code->expr2->must_finalize = 1;
12111 : : /* Add the code and substitute the rhs expression. */
12112 : 56 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
12113 : 56 : gfc_free_expr ((*code)->expr2);
12114 : 56 : (*code)->expr2 = tmp_expr;
12115 : : }
12116 : :
12117 : : /* Do the intrinsic assignment. This is not needed if the lhs is one
12118 : : of the temporaries generated here, since the intrinsic assignment
12119 : : to the final result already does this. */
12120 : 157 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
12121 : : {
12122 : 157 : if (finalizable_lhs)
12123 : 18 : (*code)->expr1->must_finalize = 1;
12124 : 157 : this_code = build_assignment (EXEC_ASSIGN,
12125 : : (*code)->expr1, (*code)->expr2,
12126 : : NULL, NULL, (*code)->loc);
12127 : 157 : add_code_to_chain (&this_code, &head, &tail);
12128 : : }
12129 : :
12130 : 157 : comp1 = (*code)->expr1->ts.u.derived->components;
12131 : 157 : comp2 = (*code)->expr2->ts.u.derived->components;
12132 : :
12133 : 399 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
12134 : : {
12135 : 242 : bool inout = false;
12136 : 242 : bool finalizable_out = false;
12137 : :
12138 : : /* The intrinsic assignment does the right thing for pointers
12139 : : of all kinds and allocatable components. */
12140 : 242 : if (!gfc_bt_struct (comp1->ts.type)
12141 : : || comp1->attr.pointer
12142 : 175 : || comp1->attr.allocatable
12143 : 174 : || comp1->attr.proc_pointer_comp
12144 : : || comp1->attr.class_pointer
12145 : 174 : || comp1->attr.proc_pointer)
12146 : 68 : continue;
12147 : :
12148 : 348 : finalizable_comp = is_finalizable_type (comp1->ts)
12149 : 174 : && !finalizable_lhs;
12150 : :
12151 : : /* Make an assignment for this component. */
12152 : 348 : this_code = build_assignment (EXEC_ASSIGN,
12153 : : (*code)->expr1, (*code)->expr2,
12154 : 174 : comp1, comp2, (*code)->loc);
12155 : :
12156 : : /* Convert the assignment if there is a defined assignment for
12157 : : this type. Otherwise, using the call from gfc_resolve_code,
12158 : : recurse into its components. */
12159 : 174 : gfc_resolve_code (this_code, ns);
12160 : :
12161 : 174 : if (this_code->op == EXEC_ASSIGN_CALL)
12162 : : {
12163 : 120 : gfc_formal_arglist *dummy_args;
12164 : 120 : gfc_symbol *rsym;
12165 : : /* Check that there is a typebound defined assignment. If not,
12166 : : then this must be a module defined assignment. We cannot
12167 : : use the defined_assign_comp attribute here because it must
12168 : : be this derived type that has the defined assignment and not
12169 : : a parent type. */
12170 : 120 : if (!(comp1->ts.u.derived->f2k_derived
12171 : : && comp1->ts.u.derived->f2k_derived
12172 : 120 : ->tb_op[INTRINSIC_ASSIGN]))
12173 : : {
12174 : 1 : gfc_free_statements (this_code);
12175 : 1 : this_code = NULL;
12176 : 1 : continue;
12177 : : }
12178 : :
12179 : : /* If the first argument of the subroutine has intent INOUT
12180 : : a temporary must be generated and used instead. */
12181 : 119 : rsym = this_code->resolved_sym;
12182 : 119 : dummy_args = gfc_sym_get_dummy_args (rsym);
12183 : 220 : finalizable_out = gfc_may_be_finalized (comp1->ts)
12184 : 18 : && dummy_args
12185 : 137 : && dummy_args->sym->attr.intent == INTENT_OUT;
12186 : 220 : inout = dummy_args
12187 : 220 : && dummy_args->sym->attr.intent == INTENT_INOUT;
12188 : 119 : if ((inout || finalizable_out)
12189 : 89 : && !comp1->attr.allocatable)
12190 : : {
12191 : 89 : gfc_code *temp_code;
12192 : 89 : inout = true;
12193 : :
12194 : : /* Build the temporary required for the assignment and put
12195 : : it at the head of the generated code. */
12196 : 89 : if (!t1)
12197 : : {
12198 : 89 : gfc_namespace *tmp_ns = ns;
12199 : 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
12200 : 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
12201 : 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
12202 : 89 : t1->symtree->n.sym->attr.artificial = 1;
12203 : 178 : temp_code = build_assignment (EXEC_ASSIGN,
12204 : : t1, (*code)->expr1,
12205 : 89 : NULL, NULL, (*code)->loc);
12206 : :
12207 : : /* For allocatable LHS, check whether it is allocated. Note
12208 : : that allocatable components with defined assignment are
12209 : : not yet support. See PR 57696. */
12210 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
12211 : : {
12212 : 24 : gfc_code *block;
12213 : 24 : gfc_expr *e =
12214 : 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
12215 : 24 : block = gfc_get_code (EXEC_IF);
12216 : 24 : block->block = gfc_get_code (EXEC_IF);
12217 : 24 : block->block->expr1
12218 : 48 : = gfc_build_intrinsic_call (ns,
12219 : : GFC_ISYM_ALLOCATED, "allocated",
12220 : 24 : (*code)->loc, 1, e);
12221 : 24 : block->block->next = temp_code;
12222 : 24 : temp_code = block;
12223 : : }
12224 : 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
12225 : : }
12226 : :
12227 : : /* Replace the first actual arg with the component of the
12228 : : temporary. */
12229 : 89 : gfc_free_expr (this_code->ext.actual->expr);
12230 : 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
12231 : 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
12232 : :
12233 : : /* If the LHS variable is allocatable and wasn't allocated and
12234 : : the temporary is allocatable, pointer assign the address of
12235 : : the freshly allocated LHS to the temporary. */
12236 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
12237 : 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
12238 : : {
12239 : 18 : gfc_code *block;
12240 : 18 : gfc_expr *cond;
12241 : :
12242 : 18 : cond = gfc_get_expr ();
12243 : 18 : cond->ts.type = BT_LOGICAL;
12244 : 18 : cond->ts.kind = gfc_default_logical_kind;
12245 : 18 : cond->expr_type = EXPR_OP;
12246 : 18 : cond->where = (*code)->loc;
12247 : 18 : cond->value.op.op = INTRINSIC_NOT;
12248 : 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
12249 : : GFC_ISYM_ALLOCATED, "allocated",
12250 : 18 : (*code)->loc, 1, gfc_copy_expr (t1));
12251 : 18 : block = gfc_get_code (EXEC_IF);
12252 : 18 : block->block = gfc_get_code (EXEC_IF);
12253 : 18 : block->block->expr1 = cond;
12254 : 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
12255 : : t1, (*code)->expr1,
12256 : 18 : NULL, NULL, (*code)->loc);
12257 : 18 : add_code_to_chain (&block, &head, &tail);
12258 : : }
12259 : : }
12260 : : }
12261 : 54 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
12262 : : {
12263 : : /* Don't add intrinsic assignments since they are already
12264 : : effected by the intrinsic assignment of the structure, unless
12265 : : finalization is required. */
12266 : 6 : if (finalizable_comp)
12267 : 0 : this_code->expr1->must_finalize = 1;
12268 : : else
12269 : : {
12270 : 6 : gfc_free_statements (this_code);
12271 : 6 : this_code = NULL;
12272 : 6 : continue;
12273 : : }
12274 : : }
12275 : : else
12276 : : {
12277 : : /* Resolution has expanded an assignment of a derived type with
12278 : : defined assigned components. Remove the redundant, leading
12279 : : assignment. */
12280 : 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
12281 : 48 : gfc_code *tmp = this_code;
12282 : 48 : this_code = this_code->next;
12283 : 48 : tmp->next = NULL;
12284 : 48 : gfc_free_statements (tmp);
12285 : : }
12286 : :
12287 : 167 : add_code_to_chain (&this_code, &head, &tail);
12288 : :
12289 : 167 : if (t1 && (inout || finalizable_out))
12290 : : {
12291 : : /* Transfer the value to the final result. */
12292 : 178 : this_code = build_assignment (EXEC_ASSIGN,
12293 : : (*code)->expr1, t1,
12294 : 89 : comp1, comp2, (*code)->loc);
12295 : 89 : this_code->expr1->must_finalize = 0;
12296 : 89 : add_code_to_chain (&this_code, &head, &tail);
12297 : : }
12298 : : }
12299 : :
12300 : : /* Put the temporary assignments at the top of the generated code. */
12301 : 157 : if (tmp_head && component_assignment_level == 1)
12302 : : {
12303 : 101 : gfc_append_code (tmp_head, head);
12304 : 101 : head = tmp_head;
12305 : 101 : tmp_head = tmp_tail = NULL;
12306 : : }
12307 : :
12308 : : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
12309 : : not accidentally deallocated. Hence, nullify t1. */
12310 : 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
12311 : 246 : && gfc_expr_attr ((*code)->expr1).allocatable)
12312 : : {
12313 : 18 : gfc_code *block;
12314 : 18 : gfc_expr *cond;
12315 : 18 : gfc_expr *e;
12316 : :
12317 : 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
12318 : 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
12319 : 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
12320 : 18 : block = gfc_get_code (EXEC_IF);
12321 : 18 : block->block = gfc_get_code (EXEC_IF);
12322 : 18 : block->block->expr1 = cond;
12323 : 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
12324 : : t1, gfc_get_null_expr (&(*code)->loc),
12325 : 18 : NULL, NULL, (*code)->loc);
12326 : 18 : gfc_append_code (tail, block);
12327 : 18 : tail = block;
12328 : : }
12329 : :
12330 : 157 : component_assignment_level--;
12331 : :
12332 : : /* Make an explicit final call for the function result. */
12333 : 157 : if (tmp_expr)
12334 : 56 : generate_final_call (tmp_expr, &head, &tail);
12335 : :
12336 : 157 : if (tmp_code)
12337 : : {
12338 : 109 : ns->code = head;
12339 : 109 : return;
12340 : : }
12341 : :
12342 : : /* Now attach the remaining code chain to the input code. Step on
12343 : : to the end of the new code since resolution is complete. */
12344 : 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
12345 : 48 : tail->next = (*code)->next;
12346 : : /* Overwrite 'code' because this would place the intrinsic assignment
12347 : : before the temporary for the lhs is created. */
12348 : 48 : gfc_free_expr ((*code)->expr1);
12349 : 48 : gfc_free_expr ((*code)->expr2);
12350 : 48 : **code = *head;
12351 : 48 : if (head != tail)
12352 : 48 : free (head);
12353 : 48 : *code = tail;
12354 : : }
12355 : :
12356 : :
12357 : : /* F2008: Pointer function assignments are of the form:
12358 : : ptr_fcn (args) = expr
12359 : : This function breaks these assignments into two statements:
12360 : : temporary_pointer => ptr_fcn(args)
12361 : : temporary_pointer = expr */
12362 : :
12363 : : static bool
12364 : 174590 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
12365 : : {
12366 : 174590 : gfc_expr *tmp_ptr_expr;
12367 : 174590 : gfc_code *this_code;
12368 : 174590 : gfc_component *comp;
12369 : 174590 : gfc_symbol *s;
12370 : :
12371 : 174590 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
12372 : : return false;
12373 : :
12374 : : /* Even if standard does not support this feature, continue to build
12375 : : the two statements to avoid upsetting frontend_passes.c. */
12376 : 145 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
12377 : : "%L", &(*code)->loc);
12378 : :
12379 : 145 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
12380 : :
12381 : 145 : if (comp)
12382 : 6 : s = comp->ts.interface;
12383 : : else
12384 : 139 : s = (*code)->expr1->symtree->n.sym;
12385 : :
12386 : 145 : if (s == NULL || !s->result->attr.pointer)
12387 : : {
12388 : 5 : gfc_error ("The function result on the lhs of the assignment at "
12389 : : "%L must have the pointer attribute.",
12390 : 5 : &(*code)->expr1->where);
12391 : 5 : (*code)->op = EXEC_NOP;
12392 : 5 : return false;
12393 : : }
12394 : :
12395 : 140 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
12396 : :
12397 : : /* get_temp_from_expression is set up for ordinary assignments. To that
12398 : : end, where array bounds are not known, arrays are made allocatable.
12399 : : Change the temporary to a pointer here. */
12400 : 140 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
12401 : 140 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
12402 : 140 : tmp_ptr_expr->where = (*code)->loc;
12403 : :
12404 : 140 : this_code = build_assignment (EXEC_ASSIGN,
12405 : : tmp_ptr_expr, (*code)->expr2,
12406 : : NULL, NULL, (*code)->loc);
12407 : 140 : this_code->next = (*code)->next;
12408 : 140 : (*code)->next = this_code;
12409 : 140 : (*code)->op = EXEC_POINTER_ASSIGN;
12410 : 140 : (*code)->expr2 = (*code)->expr1;
12411 : 140 : (*code)->expr1 = tmp_ptr_expr;
12412 : :
12413 : 140 : return true;
12414 : : }
12415 : :
12416 : :
12417 : : /* Deferred character length assignments from an operator expression
12418 : : require a temporary because the character length of the lhs can
12419 : : change in the course of the assignment. */
12420 : :
12421 : : static bool
12422 : 173131 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
12423 : : {
12424 : 173131 : gfc_expr *tmp_expr;
12425 : 173131 : gfc_code *this_code;
12426 : :
12427 : 173131 : if (!((*code)->expr1->ts.type == BT_CHARACTER
12428 : 25007 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
12429 : 551 : && (*code)->expr2->ts.type == BT_CHARACTER
12430 : 550 : && (*code)->expr2->expr_type == EXPR_OP))
12431 : : return false;
12432 : :
12433 : 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
12434 : : return false;
12435 : :
12436 : 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
12437 : : return false;
12438 : :
12439 : 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
12440 : 22 : tmp_expr->where = (*code)->loc;
12441 : :
12442 : : /* A new charlen is required to ensure that the variable string
12443 : : length is different to that of the original lhs. */
12444 : 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
12445 : 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
12446 : 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
12447 : 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
12448 : :
12449 : 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
12450 : :
12451 : 22 : this_code = build_assignment (EXEC_ASSIGN,
12452 : 22 : (*code)->expr1,
12453 : : gfc_copy_expr (tmp_expr),
12454 : : NULL, NULL, (*code)->loc);
12455 : :
12456 : 22 : (*code)->expr1 = tmp_expr;
12457 : :
12458 : 22 : this_code->next = (*code)->next;
12459 : 22 : (*code)->next = this_code;
12460 : :
12461 : 22 : return true;
12462 : : }
12463 : :
12464 : :
12465 : : static bool
12466 : 51 : check_team (gfc_expr *team, const char *intrinsic)
12467 : : {
12468 : 51 : if (team->rank != 0
12469 : 50 : || team->ts.type != BT_DERIVED
12470 : 47 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12471 : 47 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
12472 : : {
12473 : 4 : gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
12474 : : "of type TEAM_TYPE", intrinsic, &team->where);
12475 : 4 : return false;
12476 : : }
12477 : :
12478 : : return true;
12479 : : }
12480 : :
12481 : :
12482 : : /* Given a block of code, recursively resolve everything pointed to by this
12483 : : code block. */
12484 : :
12485 : : void
12486 : 578233 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
12487 : : {
12488 : 578233 : int omp_workshare_save;
12489 : 578233 : int forall_save, do_concurrent_save;
12490 : 578233 : code_stack frame;
12491 : 578233 : bool t;
12492 : :
12493 : 578233 : frame.prev = cs_base;
12494 : 578233 : frame.head = code;
12495 : 578233 : cs_base = &frame;
12496 : :
12497 : 578233 : find_reachable_labels (code);
12498 : :
12499 : 1485475 : for (; code; code = code->next)
12500 : : {
12501 : 907243 : frame.current = code;
12502 : 907243 : forall_save = forall_flag;
12503 : 907243 : do_concurrent_save = gfc_do_concurrent_flag;
12504 : :
12505 : 907243 : if (code->op == EXEC_FORALL)
12506 : : {
12507 : 2002 : forall_flag = 1;
12508 : 2002 : gfc_resolve_forall (code, ns, forall_save);
12509 : 2002 : forall_flag = 2;
12510 : : }
12511 : 905241 : else if (code->block)
12512 : : {
12513 : 282601 : omp_workshare_save = -1;
12514 : 282601 : switch (code->op)
12515 : : {
12516 : 9266 : case EXEC_OACC_PARALLEL_LOOP:
12517 : 9266 : case EXEC_OACC_PARALLEL:
12518 : 9266 : case EXEC_OACC_KERNELS_LOOP:
12519 : 9266 : case EXEC_OACC_KERNELS:
12520 : 9266 : case EXEC_OACC_SERIAL_LOOP:
12521 : 9266 : case EXEC_OACC_SERIAL:
12522 : 9266 : case EXEC_OACC_DATA:
12523 : 9266 : case EXEC_OACC_HOST_DATA:
12524 : 9266 : case EXEC_OACC_LOOP:
12525 : 9266 : gfc_resolve_oacc_blocks (code, ns);
12526 : 9266 : break;
12527 : 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
12528 : 54 : omp_workshare_save = omp_workshare_flag;
12529 : 54 : omp_workshare_flag = 1;
12530 : 54 : gfc_resolve_omp_parallel_blocks (code, ns);
12531 : 54 : break;
12532 : 5415 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12533 : 5415 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12534 : 5415 : case EXEC_OMP_MASKED_TASKLOOP:
12535 : 5415 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12536 : 5415 : case EXEC_OMP_MASTER_TASKLOOP:
12537 : 5415 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12538 : 5415 : case EXEC_OMP_PARALLEL:
12539 : 5415 : case EXEC_OMP_PARALLEL_DO:
12540 : 5415 : case EXEC_OMP_PARALLEL_DO_SIMD:
12541 : 5415 : case EXEC_OMP_PARALLEL_LOOP:
12542 : 5415 : case EXEC_OMP_PARALLEL_MASKED:
12543 : 5415 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12544 : 5415 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12545 : 5415 : case EXEC_OMP_PARALLEL_MASTER:
12546 : 5415 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12547 : 5415 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12548 : 5415 : case EXEC_OMP_PARALLEL_SECTIONS:
12549 : 5415 : case EXEC_OMP_TARGET_PARALLEL:
12550 : 5415 : case EXEC_OMP_TARGET_PARALLEL_DO:
12551 : 5415 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12552 : 5415 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12553 : 5415 : case EXEC_OMP_TARGET_TEAMS:
12554 : 5415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12555 : 5415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12556 : 5415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12557 : 5415 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12558 : 5415 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12559 : 5415 : case EXEC_OMP_TASK:
12560 : 5415 : case EXEC_OMP_TASKLOOP:
12561 : 5415 : case EXEC_OMP_TASKLOOP_SIMD:
12562 : 5415 : case EXEC_OMP_TEAMS:
12563 : 5415 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12564 : 5415 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12565 : 5415 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12566 : 5415 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12567 : 5415 : case EXEC_OMP_TEAMS_LOOP:
12568 : 5415 : omp_workshare_save = omp_workshare_flag;
12569 : 5415 : omp_workshare_flag = 0;
12570 : 5415 : gfc_resolve_omp_parallel_blocks (code, ns);
12571 : 5415 : break;
12572 : 2230 : case EXEC_OMP_DISTRIBUTE:
12573 : 2230 : case EXEC_OMP_DISTRIBUTE_SIMD:
12574 : 2230 : case EXEC_OMP_DO:
12575 : 2230 : case EXEC_OMP_DO_SIMD:
12576 : 2230 : case EXEC_OMP_LOOP:
12577 : 2230 : case EXEC_OMP_SIMD:
12578 : 2230 : case EXEC_OMP_TARGET_SIMD:
12579 : 2230 : gfc_resolve_omp_do_blocks (code, ns);
12580 : 2230 : break;
12581 : : case EXEC_SELECT_TYPE:
12582 : : case EXEC_SELECT_RANK:
12583 : : /* Blocks are handled in resolve_select_type/rank because we
12584 : : have to transform the SELECT TYPE into ASSOCIATE first. */
12585 : : break;
12586 : 65 : case EXEC_DO_CONCURRENT:
12587 : 65 : gfc_do_concurrent_flag = 1;
12588 : 65 : gfc_resolve_blocks (code->block, ns);
12589 : 65 : gfc_do_concurrent_flag = 2;
12590 : 65 : break;
12591 : 39 : case EXEC_OMP_WORKSHARE:
12592 : 39 : omp_workshare_save = omp_workshare_flag;
12593 : 39 : omp_workshare_flag = 1;
12594 : : /* FALL THROUGH */
12595 : 261910 : default:
12596 : 261910 : gfc_resolve_blocks (code->block, ns);
12597 : 261910 : break;
12598 : : }
12599 : :
12600 : 278940 : if (omp_workshare_save != -1)
12601 : 5508 : omp_workshare_flag = omp_workshare_save;
12602 : : }
12603 : 622640 : start:
12604 : 907388 : t = true;
12605 : 907388 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
12606 : 906047 : t = gfc_resolve_expr (code->expr1);
12607 : 907388 : forall_flag = forall_save;
12608 : 907388 : gfc_do_concurrent_flag = do_concurrent_save;
12609 : :
12610 : 907388 : if (!gfc_resolve_expr (code->expr2))
12611 : 541 : t = false;
12612 : :
12613 : 907388 : if (code->op == EXEC_ALLOCATE
12614 : 907388 : && !gfc_resolve_expr (code->expr3))
12615 : : t = false;
12616 : :
12617 : 907388 : switch (code->op)
12618 : : {
12619 : : case EXEC_NOP:
12620 : : case EXEC_END_BLOCK:
12621 : : case EXEC_END_NESTED_BLOCK:
12622 : : case EXEC_CYCLE:
12623 : : case EXEC_PAUSE:
12624 : : break;
12625 : :
12626 : 179743 : case EXEC_STOP:
12627 : 179743 : case EXEC_ERROR_STOP:
12628 : 179743 : if (code->expr2 != NULL
12629 : 37 : && (code->expr2->ts.type != BT_LOGICAL
12630 : 37 : || code->expr2->rank != 0))
12631 : 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12632 : : &code->expr2->where);
12633 : : break;
12634 : :
12635 : : case EXEC_EXIT:
12636 : : case EXEC_CONTINUE:
12637 : : case EXEC_DT_END:
12638 : : case EXEC_ASSIGN_CALL:
12639 : : break;
12640 : :
12641 : 33 : case EXEC_CRITICAL:
12642 : 33 : resolve_critical (code);
12643 : 33 : break;
12644 : :
12645 : 745 : case EXEC_SYNC_ALL:
12646 : 745 : case EXEC_SYNC_IMAGES:
12647 : 745 : case EXEC_SYNC_MEMORY:
12648 : 745 : resolve_sync (code);
12649 : 745 : break;
12650 : :
12651 : 136 : case EXEC_LOCK:
12652 : 136 : case EXEC_UNLOCK:
12653 : 136 : case EXEC_EVENT_POST:
12654 : 136 : case EXEC_EVENT_WAIT:
12655 : 136 : resolve_lock_unlock_event (code);
12656 : 136 : break;
12657 : :
12658 : : case EXEC_FAIL_IMAGE:
12659 : : break;
12660 : :
12661 : 30 : case EXEC_FORM_TEAM:
12662 : 30 : if (code->expr1 != NULL
12663 : 30 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
12664 : 2 : gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12665 : : "a scalar INTEGER", &code->expr1->where);
12666 : 30 : check_team (code->expr2, "FORM TEAM");
12667 : 30 : break;
12668 : :
12669 : 20 : case EXEC_CHANGE_TEAM:
12670 : 20 : check_team (code->expr1, "CHANGE TEAM");
12671 : 20 : break;
12672 : :
12673 : : case EXEC_END_TEAM:
12674 : : break;
12675 : :
12676 : 1 : case EXEC_SYNC_TEAM:
12677 : 1 : check_team (code->expr1, "SYNC TEAM");
12678 : 1 : break;
12679 : :
12680 : 1418 : case EXEC_ENTRY:
12681 : : /* Keep track of which entry we are up to. */
12682 : 1418 : current_entry_id = code->ext.entry->id;
12683 : 1418 : break;
12684 : :
12685 : 450 : case EXEC_WHERE:
12686 : 450 : resolve_where (code, NULL);
12687 : 450 : break;
12688 : :
12689 : 1236 : case EXEC_GOTO:
12690 : 1236 : if (code->expr1 != NULL)
12691 : : {
12692 : 78 : if (code->expr1->expr_type != EXPR_VARIABLE
12693 : 76 : || code->expr1->ts.type != BT_INTEGER
12694 : 76 : || (code->expr1->ref
12695 : 1 : && code->expr1->ref->type == REF_ARRAY)
12696 : 75 : || code->expr1->symtree == NULL
12697 : 75 : || (code->expr1->symtree->n.sym
12698 : 75 : && (code->expr1->symtree->n.sym->attr.flavor
12699 : 75 : == FL_PARAMETER)))
12700 : 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
12701 : : "scalar INTEGER variable", &code->expr1->where);
12702 : 74 : else if (code->expr1->symtree->n.sym
12703 : 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
12704 : 1 : gfc_error ("Variable %qs has not been assigned a target "
12705 : : "label at %L", code->expr1->symtree->n.sym->name,
12706 : : &code->expr1->where);
12707 : : }
12708 : : else
12709 : 1158 : resolve_branch (code->label1, code);
12710 : : break;
12711 : :
12712 : 3002 : case EXEC_RETURN:
12713 : 3002 : if (code->expr1 != NULL
12714 : 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
12715 : 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
12716 : : "INTEGER return specifier", &code->expr1->where);
12717 : : break;
12718 : :
12719 : : case EXEC_INIT_ASSIGN:
12720 : : case EXEC_END_PROCEDURE:
12721 : : break;
12722 : :
12723 : 175165 : case EXEC_ASSIGN:
12724 : 175165 : if (!t)
12725 : : break;
12726 : :
12727 : 174590 : if (code->expr1->ts.type == BT_CLASS)
12728 : 686 : gfc_find_vtab (&code->expr2->ts);
12729 : :
12730 : : /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
12731 : : the LHS. */
12732 : 174590 : if (code->expr1->expr_type == EXPR_FUNCTION
12733 : 518 : && code->expr1->value.function.isym
12734 : 373 : && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
12735 : 373 : remove_caf_get_intrinsic (code->expr1);
12736 : :
12737 : : /* If this is a pointer function in an lvalue variable context,
12738 : : the new code will have to be resolved afresh. This is also the
12739 : : case with an error, where the code is transformed into NOP to
12740 : : prevent ICEs downstream. */
12741 : 174590 : if (resolve_ptr_fcn_assign (&code, ns)
12742 : 174590 : || code->op == EXEC_NOP)
12743 : 145 : goto start;
12744 : :
12745 : 174445 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
12746 : 174445 : _("assignment")))
12747 : : break;
12748 : :
12749 : 174408 : if (resolve_ordinary_assign (code, ns))
12750 : : {
12751 : 727 : if (omp_workshare_flag)
12752 : : {
12753 : 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12754 : 1 : "at %L", &code->loc);
12755 : 1 : break;
12756 : : }
12757 : 726 : if (code->op == EXEC_COMPCALL)
12758 : 392 : goto compcall;
12759 : : else
12760 : 334 : goto call;
12761 : : }
12762 : :
12763 : : /* Check for dependencies in deferred character length array
12764 : : assignments and generate a temporary, if necessary. */
12765 : 173681 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
12766 : : break;
12767 : :
12768 : : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
12769 : 173659 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
12770 : 6064 : && code->expr1->ts.u.derived
12771 : 6064 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
12772 : 163 : generate_component_assignments (&code, ns);
12773 : 173496 : else if (code->op == EXEC_ASSIGN)
12774 : : {
12775 : 172946 : if (gfc_may_be_finalized (code->expr1->ts))
12776 : 788 : code->expr1->must_finalize = 1;
12777 : 172946 : if (code->expr2->expr_type == EXPR_ARRAY
12778 : 172946 : && gfc_may_be_finalized (code->expr2->ts))
12779 : 43 : code->expr2->must_finalize = 1;
12780 : : }
12781 : :
12782 : : break;
12783 : :
12784 : 126 : case EXEC_LABEL_ASSIGN:
12785 : 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
12786 : 0 : gfc_error ("Label %d referenced at %L is never defined",
12787 : : code->label1->value, &code->label1->where);
12788 : 126 : if (t
12789 : 126 : && (code->expr1->expr_type != EXPR_VARIABLE
12790 : 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
12791 : 126 : || code->expr1->symtree->n.sym->ts.kind
12792 : 126 : != gfc_default_integer_kind
12793 : 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
12794 : 125 : || code->expr1->symtree->n.sym->as != NULL))
12795 : 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
12796 : : "default INTEGER variable", &code->expr1->where);
12797 : : break;
12798 : :
12799 : 9448 : case EXEC_POINTER_ASSIGN:
12800 : 9448 : {
12801 : 9448 : gfc_expr* e;
12802 : :
12803 : 9448 : if (!t)
12804 : : break;
12805 : :
12806 : : /* This is both a variable definition and pointer assignment
12807 : : context, so check both of them. For rank remapping, a final
12808 : : array ref may be present on the LHS and fool gfc_expr_attr
12809 : : used in gfc_check_vardef_context. Remove it. */
12810 : 9443 : e = remove_last_array_ref (code->expr1);
12811 : 18886 : t = gfc_check_vardef_context (e, true, false, false,
12812 : 9443 : _("pointer assignment"));
12813 : 9443 : if (t)
12814 : 9422 : t = gfc_check_vardef_context (e, false, false, false,
12815 : 9422 : _("pointer assignment"));
12816 : 9443 : gfc_free_expr (e);
12817 : :
12818 : 916552 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
12819 : :
12820 : 9310 : if (!t)
12821 : : break;
12822 : :
12823 : : /* Assigning a class object always is a regular assign. */
12824 : 9310 : if (code->expr2->ts.type == BT_CLASS
12825 : 469 : && code->expr1->ts.type == BT_CLASS
12826 : 384 : && CLASS_DATA (code->expr2)
12827 : 383 : && !CLASS_DATA (code->expr2)->attr.dimension
12828 : 9821 : && !(gfc_expr_attr (code->expr1).proc_pointer
12829 : 42 : && code->expr2->expr_type == EXPR_VARIABLE
12830 : 36 : && code->expr2->symtree->n.sym->attr.flavor
12831 : 36 : == FL_PROCEDURE))
12832 : 279 : code->op = EXEC_ASSIGN;
12833 : : break;
12834 : : }
12835 : :
12836 : 72 : case EXEC_ARITHMETIC_IF:
12837 : 72 : {
12838 : 72 : gfc_expr *e = code->expr1;
12839 : :
12840 : 72 : gfc_resolve_expr (e);
12841 : 72 : if (e->expr_type == EXPR_NULL)
12842 : 1 : gfc_error ("Invalid NULL at %L", &e->where);
12843 : :
12844 : 72 : if (t && (e->rank > 0
12845 : 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
12846 : 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
12847 : : "REAL or INTEGER expression", &e->where);
12848 : :
12849 : 72 : resolve_branch (code->label1, code);
12850 : 72 : resolve_branch (code->label2, code);
12851 : 72 : resolve_branch (code->label3, code);
12852 : : }
12853 : 72 : break;
12854 : :
12855 : 192233 : case EXEC_IF:
12856 : 192233 : if (t && code->expr1 != NULL
12857 : 0 : && (code->expr1->ts.type != BT_LOGICAL
12858 : 0 : || code->expr1->rank != 0))
12859 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12860 : : &code->expr1->where);
12861 : : break;
12862 : :
12863 : 69667 : case EXEC_CALL:
12864 : 69667 : call:
12865 : 69667 : resolve_call (code);
12866 : 69667 : break;
12867 : :
12868 : 1612 : case EXEC_COMPCALL:
12869 : 1612 : compcall:
12870 : 1612 : resolve_typebound_subroutine (code);
12871 : 1612 : break;
12872 : :
12873 : 121 : case EXEC_CALL_PPC:
12874 : 121 : resolve_ppc_call (code);
12875 : 121 : break;
12876 : :
12877 : 690 : case EXEC_SELECT:
12878 : : /* Select is complicated. Also, a SELECT construct could be
12879 : : a transformed computed GOTO. */
12880 : 690 : resolve_select (code, false);
12881 : 690 : break;
12882 : :
12883 : 2681 : case EXEC_SELECT_TYPE:
12884 : 2681 : resolve_select_type (code, ns);
12885 : 2681 : break;
12886 : :
12887 : 1005 : case EXEC_SELECT_RANK:
12888 : 1005 : resolve_select_rank (code, ns);
12889 : 1005 : break;
12890 : :
12891 : 7031 : case EXEC_BLOCK:
12892 : 7031 : resolve_block_construct (code);
12893 : 7031 : break;
12894 : :
12895 : 30049 : case EXEC_DO:
12896 : 30049 : if (code->ext.iterator != NULL)
12897 : : {
12898 : 30049 : gfc_iterator *iter = code->ext.iterator;
12899 : 30049 : if (gfc_resolve_iterator (iter, true, false))
12900 : 30035 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
12901 : : true);
12902 : : }
12903 : : break;
12904 : :
12905 : 521 : case EXEC_DO_WHILE:
12906 : 521 : if (code->expr1 == NULL)
12907 : 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
12908 : : "DO WHILE");
12909 : 521 : if (t
12910 : 521 : && (code->expr1->rank != 0
12911 : 521 : || code->expr1->ts.type != BT_LOGICAL))
12912 : 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
12913 : : "a scalar LOGICAL expression", &code->expr1->where);
12914 : : break;
12915 : :
12916 : 12057 : case EXEC_ALLOCATE:
12917 : 12057 : if (t)
12918 : 12055 : resolve_allocate_deallocate (code, "ALLOCATE");
12919 : :
12920 : : break;
12921 : :
12922 : 5406 : case EXEC_DEALLOCATE:
12923 : 5406 : if (t)
12924 : 5406 : resolve_allocate_deallocate (code, "DEALLOCATE");
12925 : :
12926 : : break;
12927 : :
12928 : 3821 : case EXEC_OPEN:
12929 : 3821 : if (!gfc_resolve_open (code->ext.open, &code->loc))
12930 : : break;
12931 : :
12932 : 3594 : resolve_branch (code->ext.open->err, code);
12933 : 3594 : break;
12934 : :
12935 : 3044 : case EXEC_CLOSE:
12936 : 3044 : if (!gfc_resolve_close (code->ext.close, &code->loc))
12937 : : break;
12938 : :
12939 : 3010 : resolve_branch (code->ext.close->err, code);
12940 : 3010 : break;
12941 : :
12942 : 2608 : case EXEC_BACKSPACE:
12943 : 2608 : case EXEC_ENDFILE:
12944 : 2608 : case EXEC_REWIND:
12945 : 2608 : case EXEC_FLUSH:
12946 : 2608 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
12947 : : break;
12948 : :
12949 : 2542 : resolve_branch (code->ext.filepos->err, code);
12950 : 2542 : break;
12951 : :
12952 : 817 : case EXEC_INQUIRE:
12953 : 817 : if (!gfc_resolve_inquire (code->ext.inquire))
12954 : : break;
12955 : :
12956 : 769 : resolve_branch (code->ext.inquire->err, code);
12957 : 769 : break;
12958 : :
12959 : 92 : case EXEC_IOLENGTH:
12960 : 92 : gcc_assert (code->ext.inquire != NULL);
12961 : 92 : if (!gfc_resolve_inquire (code->ext.inquire))
12962 : : break;
12963 : :
12964 : 90 : resolve_branch (code->ext.inquire->err, code);
12965 : 90 : break;
12966 : :
12967 : 89 : case EXEC_WAIT:
12968 : 89 : if (!gfc_resolve_wait (code->ext.wait))
12969 : : break;
12970 : :
12971 : 74 : resolve_branch (code->ext.wait->err, code);
12972 : 74 : resolve_branch (code->ext.wait->end, code);
12973 : 74 : resolve_branch (code->ext.wait->eor, code);
12974 : 74 : break;
12975 : :
12976 : 30563 : case EXEC_READ:
12977 : 30563 : case EXEC_WRITE:
12978 : 30563 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
12979 : : break;
12980 : :
12981 : 30254 : resolve_branch (code->ext.dt->err, code);
12982 : 30254 : resolve_branch (code->ext.dt->end, code);
12983 : 30254 : resolve_branch (code->ext.dt->eor, code);
12984 : 30254 : break;
12985 : :
12986 : 43923 : case EXEC_TRANSFER:
12987 : 43923 : resolve_transfer (code);
12988 : 43923 : break;
12989 : :
12990 : 2067 : case EXEC_DO_CONCURRENT:
12991 : 2067 : case EXEC_FORALL:
12992 : 2067 : resolve_forall_iterators (code->ext.forall_iterator);
12993 : :
12994 : 2067 : if (code->expr1 != NULL
12995 : 749 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
12996 : 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12997 : : "expression", &code->expr1->where);
12998 : : break;
12999 : :
13000 : 12253 : case EXEC_OACC_PARALLEL_LOOP:
13001 : 12253 : case EXEC_OACC_PARALLEL:
13002 : 12253 : case EXEC_OACC_KERNELS_LOOP:
13003 : 12253 : case EXEC_OACC_KERNELS:
13004 : 12253 : case EXEC_OACC_SERIAL_LOOP:
13005 : 12253 : case EXEC_OACC_SERIAL:
13006 : 12253 : case EXEC_OACC_DATA:
13007 : 12253 : case EXEC_OACC_HOST_DATA:
13008 : 12253 : case EXEC_OACC_LOOP:
13009 : 12253 : case EXEC_OACC_UPDATE:
13010 : 12253 : case EXEC_OACC_WAIT:
13011 : 12253 : case EXEC_OACC_CACHE:
13012 : 12253 : case EXEC_OACC_ENTER_DATA:
13013 : 12253 : case EXEC_OACC_EXIT_DATA:
13014 : 12253 : case EXEC_OACC_ATOMIC:
13015 : 12253 : case EXEC_OACC_DECLARE:
13016 : 12253 : gfc_resolve_oacc_directive (code, ns);
13017 : 12253 : break;
13018 : :
13019 : 14996 : case EXEC_OMP_ALLOCATE:
13020 : 14996 : case EXEC_OMP_ALLOCATORS:
13021 : 14996 : case EXEC_OMP_ASSUME:
13022 : 14996 : case EXEC_OMP_ATOMIC:
13023 : 14996 : case EXEC_OMP_BARRIER:
13024 : 14996 : case EXEC_OMP_CANCEL:
13025 : 14996 : case EXEC_OMP_CANCELLATION_POINT:
13026 : 14996 : case EXEC_OMP_CRITICAL:
13027 : 14996 : case EXEC_OMP_FLUSH:
13028 : 14996 : case EXEC_OMP_DEPOBJ:
13029 : 14996 : case EXEC_OMP_DISTRIBUTE:
13030 : 14996 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13031 : 14996 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13032 : 14996 : case EXEC_OMP_DISTRIBUTE_SIMD:
13033 : 14996 : case EXEC_OMP_DO:
13034 : 14996 : case EXEC_OMP_DO_SIMD:
13035 : 14996 : case EXEC_OMP_ERROR:
13036 : 14996 : case EXEC_OMP_LOOP:
13037 : 14996 : case EXEC_OMP_MASTER:
13038 : 14996 : case EXEC_OMP_MASTER_TASKLOOP:
13039 : 14996 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13040 : 14996 : case EXEC_OMP_MASKED:
13041 : 14996 : case EXEC_OMP_MASKED_TASKLOOP:
13042 : 14996 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13043 : 14996 : case EXEC_OMP_ORDERED:
13044 : 14996 : case EXEC_OMP_SCAN:
13045 : 14996 : case EXEC_OMP_SCOPE:
13046 : 14996 : case EXEC_OMP_SECTIONS:
13047 : 14996 : case EXEC_OMP_SIMD:
13048 : 14996 : case EXEC_OMP_SINGLE:
13049 : 14996 : case EXEC_OMP_TARGET:
13050 : 14996 : case EXEC_OMP_TARGET_DATA:
13051 : 14996 : case EXEC_OMP_TARGET_ENTER_DATA:
13052 : 14996 : case EXEC_OMP_TARGET_EXIT_DATA:
13053 : 14996 : case EXEC_OMP_TARGET_PARALLEL:
13054 : 14996 : case EXEC_OMP_TARGET_PARALLEL_DO:
13055 : 14996 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13056 : 14996 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13057 : 14996 : case EXEC_OMP_TARGET_SIMD:
13058 : 14996 : case EXEC_OMP_TARGET_TEAMS:
13059 : 14996 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13060 : 14996 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13061 : 14996 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13062 : 14996 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13063 : 14996 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13064 : 14996 : case EXEC_OMP_TARGET_UPDATE:
13065 : 14996 : case EXEC_OMP_TASK:
13066 : 14996 : case EXEC_OMP_TASKGROUP:
13067 : 14996 : case EXEC_OMP_TASKLOOP:
13068 : 14996 : case EXEC_OMP_TASKLOOP_SIMD:
13069 : 14996 : case EXEC_OMP_TASKWAIT:
13070 : 14996 : case EXEC_OMP_TASKYIELD:
13071 : 14996 : case EXEC_OMP_TEAMS:
13072 : 14996 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13073 : 14996 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13074 : 14996 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13075 : 14996 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13076 : 14996 : case EXEC_OMP_TEAMS_LOOP:
13077 : 14996 : case EXEC_OMP_WORKSHARE:
13078 : 14996 : gfc_resolve_omp_directive (code, ns);
13079 : 14996 : break;
13080 : :
13081 : 3452 : case EXEC_OMP_PARALLEL:
13082 : 3452 : case EXEC_OMP_PARALLEL_DO:
13083 : 3452 : case EXEC_OMP_PARALLEL_DO_SIMD:
13084 : 3452 : case EXEC_OMP_PARALLEL_LOOP:
13085 : 3452 : case EXEC_OMP_PARALLEL_MASKED:
13086 : 3452 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13087 : 3452 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13088 : 3452 : case EXEC_OMP_PARALLEL_MASTER:
13089 : 3452 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13090 : 3452 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13091 : 3452 : case EXEC_OMP_PARALLEL_SECTIONS:
13092 : 3452 : case EXEC_OMP_PARALLEL_WORKSHARE:
13093 : 3452 : omp_workshare_save = omp_workshare_flag;
13094 : 3452 : omp_workshare_flag = 0;
13095 : 3452 : gfc_resolve_omp_directive (code, ns);
13096 : 3452 : omp_workshare_flag = omp_workshare_save;
13097 : 3452 : break;
13098 : :
13099 : 0 : default:
13100 : 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
13101 : : }
13102 : : }
13103 : :
13104 : 578232 : cs_base = frame.prev;
13105 : 578232 : }
13106 : :
13107 : :
13108 : : /* Resolve initial values and make sure they are compatible with
13109 : : the variable. */
13110 : :
13111 : : static void
13112 : 1503138 : resolve_values (gfc_symbol *sym)
13113 : : {
13114 : 1503138 : bool t;
13115 : :
13116 : 1503138 : if (sym->value == NULL)
13117 : : return;
13118 : :
13119 : 307403 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
13120 : 4 : gfc_warning (OPT_Wdeprecated_declarations,
13121 : : "Using parameter %qs declared at %L is deprecated",
13122 : : sym->name, &sym->declared_at);
13123 : :
13124 : 307403 : if (sym->value->expr_type == EXPR_STRUCTURE)
13125 : 47044 : t= resolve_structure_cons (sym->value, 1);
13126 : : else
13127 : 260359 : t = gfc_resolve_expr (sym->value);
13128 : :
13129 : 307403 : if (!t)
13130 : : return;
13131 : :
13132 : 307401 : gfc_check_assign_symbol (sym, NULL, sym->value);
13133 : : }
13134 : :
13135 : :
13136 : : /* Verify any BIND(C) derived types in the namespace so we can report errors
13137 : : for them once, rather than for each variable declared of that type. */
13138 : :
13139 : : static void
13140 : 1477870 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
13141 : : {
13142 : 1477870 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
13143 : 70517 : && derived_sym->attr.is_bind_c == 1)
13144 : 22353 : verify_bind_c_derived_type (derived_sym);
13145 : :
13146 : 1477870 : return;
13147 : : }
13148 : :
13149 : :
13150 : : /* Check the interfaces of DTIO procedures associated with derived
13151 : : type 'sym'. These procedures can either have typebound bindings or
13152 : : can appear in DTIO generic interfaces. */
13153 : :
13154 : : static void
13155 : 1504101 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
13156 : : {
13157 : 1504101 : if (!sym || sym->attr.flavor != FL_DERIVED)
13158 : : return;
13159 : :
13160 : 78588 : gfc_check_dtio_interfaces (sym);
13161 : :
13162 : 78588 : return;
13163 : : }
13164 : :
13165 : : /* Verify that any binding labels used in a given namespace do not collide
13166 : : with the names or binding labels of any global symbols. Multiple INTERFACE
13167 : : for the same procedure are permitted. */
13168 : :
13169 : : static void
13170 : 1504101 : gfc_verify_binding_labels (gfc_symbol *sym)
13171 : : {
13172 : 1504101 : gfc_gsymbol *gsym;
13173 : 1504101 : const char *module;
13174 : :
13175 : 1504101 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
13176 : 47988 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
13177 : : return;
13178 : :
13179 : 24721 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
13180 : :
13181 : 24721 : if (sym->module)
13182 : : module = sym->module;
13183 : 10003 : else if (sym->ns && sym->ns->proc_name
13184 : 10003 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
13185 : 4377 : module = sym->ns->proc_name->name;
13186 : 5626 : else if (sym->ns && sym->ns->parent
13187 : 403 : && sym->ns && sym->ns->parent->proc_name
13188 : 403 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
13189 : 306 : module = sym->ns->parent->proc_name->name;
13190 : : else
13191 : : module = NULL;
13192 : :
13193 : 24721 : if (!gsym
13194 : 9153 : || (!gsym->defined
13195 : 6357 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
13196 : : {
13197 : 15568 : if (!gsym)
13198 : 15568 : gsym = gfc_get_gsymbol (sym->binding_label, true);
13199 : 21925 : gsym->where = sym->declared_at;
13200 : 21925 : gsym->sym_name = sym->name;
13201 : 21925 : gsym->binding_label = sym->binding_label;
13202 : 21925 : gsym->ns = sym->ns;
13203 : 21925 : gsym->mod_name = module;
13204 : 21925 : if (sym->attr.function)
13205 : 14536 : gsym->type = GSYM_FUNCTION;
13206 : 7389 : else if (sym->attr.subroutine)
13207 : 7267 : gsym->type = GSYM_SUBROUTINE;
13208 : : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
13209 : 21925 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
13210 : 21925 : return;
13211 : : }
13212 : :
13213 : 2796 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
13214 : : {
13215 : 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
13216 : : "identifier as entity at %L", sym->name,
13217 : : sym->binding_label, &sym->declared_at, &gsym->where);
13218 : : /* Clear the binding label to prevent checking multiple times. */
13219 : 1 : sym->binding_label = NULL;
13220 : 1 : return;
13221 : : }
13222 : :
13223 : 2795 : if (sym->attr.flavor == FL_VARIABLE && module
13224 : 19 : && (strcmp (module, gsym->mod_name) != 0
13225 : 17 : || strcmp (sym->name, gsym->sym_name) != 0))
13226 : : {
13227 : : /* This can only happen if the variable is defined in a module - if it
13228 : : isn't the same module, reject it. */
13229 : 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
13230 : : "uses the same global identifier as entity at %L from module %qs",
13231 : : sym->name, module, sym->binding_label,
13232 : : &sym->declared_at, &gsym->where, gsym->mod_name);
13233 : 3 : sym->binding_label = NULL;
13234 : 3 : return;
13235 : : }
13236 : :
13237 : 2792 : if ((sym->attr.function || sym->attr.subroutine)
13238 : 2773 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
13239 : 2770 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
13240 : 2458 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
13241 : 2071 : && (module != gsym->mod_name
13242 : 2066 : || strcmp (gsym->sym_name, sym->name) != 0
13243 : 2066 : || (module && strcmp (module, gsym->mod_name) != 0)))
13244 : : {
13245 : : /* Print an error if the procedure is defined multiple times; we have to
13246 : : exclude references to the same procedure via module association or
13247 : : multiple checks for the same procedure. */
13248 : 5 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
13249 : : "global identifier as entity at %L", sym->name,
13250 : : sym->binding_label, &sym->declared_at, &gsym->where);
13251 : 5 : sym->binding_label = NULL;
13252 : : }
13253 : : }
13254 : :
13255 : :
13256 : : /* Resolve an index expression. */
13257 : :
13258 : : static bool
13259 : 230185 : resolve_index_expr (gfc_expr *e)
13260 : : {
13261 : 230185 : if (!gfc_resolve_expr (e))
13262 : : return false;
13263 : :
13264 : 230175 : if (!gfc_simplify_expr (e, 0))
13265 : : return false;
13266 : :
13267 : 230173 : if (!gfc_specification_expr (e))
13268 : : return false;
13269 : :
13270 : : return true;
13271 : : }
13272 : :
13273 : :
13274 : : /* Resolve a charlen structure. */
13275 : :
13276 : : static bool
13277 : 85194 : resolve_charlen (gfc_charlen *cl)
13278 : : {
13279 : 85194 : int k;
13280 : 85194 : bool saved_specification_expr;
13281 : :
13282 : 85194 : if (cl->resolved)
13283 : : return true;
13284 : :
13285 : 77441 : cl->resolved = 1;
13286 : 77441 : saved_specification_expr = specification_expr;
13287 : 77441 : specification_expr = true;
13288 : :
13289 : 77441 : if (cl->length_from_typespec)
13290 : : {
13291 : 984 : if (!gfc_resolve_expr (cl->length))
13292 : : {
13293 : 1 : specification_expr = saved_specification_expr;
13294 : 1 : return false;
13295 : : }
13296 : :
13297 : 983 : if (!gfc_simplify_expr (cl->length, 0))
13298 : : {
13299 : 0 : specification_expr = saved_specification_expr;
13300 : 0 : return false;
13301 : : }
13302 : :
13303 : : /* cl->length has been resolved. It should have an integer type. */
13304 : 983 : if (cl->length
13305 : 982 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
13306 : : {
13307 : 4 : gfc_error ("Scalar INTEGER expression expected at %L",
13308 : : &cl->length->where);
13309 : 4 : return false;
13310 : : }
13311 : : }
13312 : : else
13313 : : {
13314 : 76457 : if (!resolve_index_expr (cl->length))
13315 : : {
13316 : 19 : specification_expr = saved_specification_expr;
13317 : 19 : return false;
13318 : : }
13319 : : }
13320 : :
13321 : : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
13322 : : a negative value, the length of character entities declared is zero. */
13323 : 77417 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
13324 : 48705 : && mpz_sgn (cl->length->value.integer) < 0)
13325 : 0 : gfc_replace_expr (cl->length,
13326 : : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
13327 : :
13328 : : /* Check that the character length is not too large. */
13329 : 77417 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
13330 : 77417 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
13331 : 48705 : && cl->length->ts.type == BT_INTEGER
13332 : 48705 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
13333 : : {
13334 : 4 : gfc_error ("String length at %L is too large", &cl->length->where);
13335 : 4 : specification_expr = saved_specification_expr;
13336 : 4 : return false;
13337 : : }
13338 : :
13339 : 77413 : specification_expr = saved_specification_expr;
13340 : 77413 : return true;
13341 : : }
13342 : :
13343 : :
13344 : : /* Test for non-constant shape arrays. */
13345 : :
13346 : : static bool
13347 : 109284 : is_non_constant_shape_array (gfc_symbol *sym)
13348 : : {
13349 : 109284 : gfc_expr *e;
13350 : 109284 : int i;
13351 : 109284 : bool not_constant;
13352 : :
13353 : 109284 : not_constant = false;
13354 : 109284 : if (sym->as != NULL)
13355 : : {
13356 : : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
13357 : : has not been simplified; parameter array references. Do the
13358 : : simplification now. */
13359 : 139676 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
13360 : : {
13361 : 79993 : if (i == GFC_MAX_DIMENSIONS)
13362 : : break;
13363 : :
13364 : 79991 : e = sym->as->lower[i];
13365 : 79991 : if (e && (!resolve_index_expr(e)
13366 : 77322 : || !gfc_is_constant_expr (e)))
13367 : : not_constant = true;
13368 : 79991 : e = sym->as->upper[i];
13369 : 79991 : if (e && (!resolve_index_expr(e)
13370 : 76379 : || !gfc_is_constant_expr (e)))
13371 : : not_constant = true;
13372 : : }
13373 : : }
13374 : 109284 : return not_constant;
13375 : : }
13376 : :
13377 : : /* Given a symbol and an initialization expression, add code to initialize
13378 : : the symbol to the function entry. */
13379 : : static void
13380 : 1140 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
13381 : : {
13382 : 1140 : gfc_expr *lval;
13383 : 1140 : gfc_code *init_st;
13384 : 1140 : gfc_namespace *ns = sym->ns;
13385 : :
13386 : : /* Search for the function namespace if this is a contained
13387 : : function without an explicit result. */
13388 : 1140 : if (sym->attr.function && sym == sym->result
13389 : 6 : && sym->name != sym->ns->proc_name->name)
13390 : : {
13391 : 6 : ns = ns->contained;
13392 : 18 : for (;ns; ns = ns->sibling)
13393 : 18 : if (strcmp (ns->proc_name->name, sym->name) == 0)
13394 : : break;
13395 : : }
13396 : :
13397 : 1140 : if (ns == NULL)
13398 : : {
13399 : 0 : gfc_free_expr (init);
13400 : 0 : return;
13401 : : }
13402 : :
13403 : : /* Build an l-value expression for the result. */
13404 : 1140 : lval = gfc_lval_expr_from_sym (sym);
13405 : :
13406 : : /* Add the code at scope entry. */
13407 : 1140 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
13408 : 1140 : init_st->next = ns->code;
13409 : 1140 : ns->code = init_st;
13410 : :
13411 : : /* Assign the default initializer to the l-value. */
13412 : 1140 : init_st->loc = sym->declared_at;
13413 : 1140 : init_st->expr1 = lval;
13414 : 1140 : init_st->expr2 = init;
13415 : : }
13416 : :
13417 : :
13418 : : /* Whether or not we can generate a default initializer for a symbol. */
13419 : :
13420 : : static bool
13421 : 36882 : can_generate_init (gfc_symbol *sym)
13422 : : {
13423 : 36882 : symbol_attribute *a;
13424 : 36882 : if (!sym)
13425 : : return false;
13426 : 36882 : a = &sym->attr;
13427 : :
13428 : : /* These symbols should never have a default initialization. */
13429 : 52695 : return !(
13430 : : a->allocatable
13431 : : || a->external
13432 : 36882 : || a->pointer
13433 : 36882 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
13434 : 5012 : && (CLASS_DATA (sym)->attr.class_pointer
13435 : 5012 : || CLASS_DATA (sym)->attr.proc_pointer))
13436 : : || a->in_equivalence
13437 : : || a->in_common
13438 : 35134 : || a->data
13439 : 34786 : || sym->module
13440 : : || a->cray_pointee
13441 : 19055 : || a->cray_pointer
13442 : 18993 : || sym->assoc
13443 : 16563 : || (!a->referenced && !a->result)
13444 : 15813 : || (a->dummy && (a->intent != INTENT_OUT
13445 : 815 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
13446 : 15813 : || (a->function && sym != sym->result)
13447 : : );
13448 : : }
13449 : :
13450 : :
13451 : : /* Assign the default initializer to a derived type variable or result. */
13452 : :
13453 : : static void
13454 : 7771 : apply_default_init (gfc_symbol *sym)
13455 : : {
13456 : 7771 : gfc_expr *init = NULL;
13457 : :
13458 : 7771 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
13459 : : return;
13460 : :
13461 : 7771 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
13462 : 7040 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
13463 : :
13464 : 7771 : if (init == NULL && sym->ts.type != BT_CLASS)
13465 : : return;
13466 : :
13467 : 758 : build_init_assign (sym, init);
13468 : 758 : sym->attr.referenced = 1;
13469 : : }
13470 : :
13471 : :
13472 : : /* Build an initializer for a local. Returns null if the symbol should not have
13473 : : a default initialization. */
13474 : :
13475 : : static gfc_expr *
13476 : 176002 : build_default_init_expr (gfc_symbol *sym)
13477 : : {
13478 : : /* These symbols should never have a default initialization. */
13479 : 176002 : if (sym->attr.allocatable
13480 : : || sym->attr.external
13481 : : || sym->attr.dummy
13482 : : || sym->attr.pointer
13483 : : || sym->attr.in_equivalence
13484 : : || sym->attr.in_common
13485 : 176002 : || sym->attr.data
13486 : 98108 : || sym->module
13487 : : || sym->attr.cray_pointee
13488 : 95778 : || sym->attr.cray_pointer
13489 : 95223 : || sym->assoc)
13490 : : return NULL;
13491 : :
13492 : : /* Get the appropriate init expression. */
13493 : 91053 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
13494 : : }
13495 : :
13496 : : /* Add an initialization expression to a local variable. */
13497 : : static void
13498 : 176002 : apply_default_init_local (gfc_symbol *sym)
13499 : : {
13500 : 176002 : gfc_expr *init = NULL;
13501 : :
13502 : : /* The symbol should be a variable or a function return value. */
13503 : 176002 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
13504 : 176002 : || (sym->attr.function && sym->result != sym))
13505 : : return;
13506 : :
13507 : : /* Try to build the initializer expression. If we can't initialize
13508 : : this symbol, then init will be NULL. */
13509 : 176002 : init = build_default_init_expr (sym);
13510 : 176002 : if (init == NULL)
13511 : : return;
13512 : :
13513 : : /* For saved variables, we don't want to add an initializer at function
13514 : : entry, so we just add a static initializer. Note that automatic variables
13515 : : are stack allocated even with -fno-automatic; we have also to exclude
13516 : : result variable, which are also nonstatic. */
13517 : 419 : if (!sym->attr.automatic
13518 : 419 : && (sym->attr.save || sym->ns->save_all
13519 : 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
13520 : 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
13521 : 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
13522 : : {
13523 : : /* Don't clobber an existing initializer! */
13524 : 37 : gcc_assert (sym->value == NULL);
13525 : 37 : sym->value = init;
13526 : 37 : return;
13527 : : }
13528 : :
13529 : 382 : build_init_assign (sym, init);
13530 : : }
13531 : :
13532 : :
13533 : : /* Resolution of common features of flavors variable and procedure. */
13534 : :
13535 : : static bool
13536 : 825084 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
13537 : : {
13538 : 825084 : gfc_array_spec *as;
13539 : :
13540 : 825084 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
13541 : 17105 : && sym->ts.u.derived && CLASS_DATA (sym))
13542 : 17099 : as = CLASS_DATA (sym)->as;
13543 : : else
13544 : 807985 : as = sym->as;
13545 : :
13546 : : /* Constraints on deferred shape variable. */
13547 : 825084 : if (as == NULL || as->type != AS_DEFERRED)
13548 : : {
13549 : 805599 : bool pointer, allocatable, dimension;
13550 : :
13551 : 805599 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
13552 : 14345 : && sym->ts.u.derived && CLASS_DATA (sym))
13553 : : {
13554 : 14339 : pointer = CLASS_DATA (sym)->attr.class_pointer;
13555 : 14339 : allocatable = CLASS_DATA (sym)->attr.allocatable;
13556 : 14339 : dimension = CLASS_DATA (sym)->attr.dimension;
13557 : : }
13558 : : else
13559 : : {
13560 : 791260 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
13561 : 791260 : allocatable = sym->attr.allocatable;
13562 : 791260 : dimension = sym->attr.dimension;
13563 : : }
13564 : :
13565 : 805599 : if (allocatable)
13566 : : {
13567 : 7318 : if (dimension
13568 : 7318 : && as
13569 : 499 : && as->type != AS_ASSUMED_RANK
13570 : 5 : && !sym->attr.select_rank_temporary)
13571 : : {
13572 : 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
13573 : : "shape or assumed rank", sym->name, &sym->declared_at);
13574 : 3 : return false;
13575 : : }
13576 : 7315 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
13577 : : "%qs at %L may not be ALLOCATABLE",
13578 : : sym->name, &sym->declared_at))
13579 : : return false;
13580 : : }
13581 : :
13582 : 805595 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
13583 : : {
13584 : 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
13585 : : "assumed rank", sym->name, &sym->declared_at);
13586 : 4 : sym->error = 1;
13587 : 4 : return false;
13588 : : }
13589 : : }
13590 : : else
13591 : : {
13592 : 19485 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
13593 : 4114 : && sym->ts.type != BT_CLASS && !sym->assoc)
13594 : : {
13595 : 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
13596 : : sym->name, &sym->declared_at);
13597 : 3 : return false;
13598 : : }
13599 : : }
13600 : :
13601 : : /* Constraints on polymorphic variables. */
13602 : 825073 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
13603 : : {
13604 : : /* F03:C502. */
13605 : 16508 : if (sym->attr.class_ok
13606 : 16452 : && sym->ts.u.derived
13607 : 16447 : && !sym->attr.select_type_temporary
13608 : 16036 : && !UNLIMITED_POLY (sym)
13609 : 13858 : && CLASS_DATA (sym)
13610 : 13857 : && CLASS_DATA (sym)->ts.u.derived
13611 : 30364 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
13612 : : {
13613 : 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
13614 : 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
13615 : : &sym->declared_at);
13616 : 5 : return false;
13617 : : }
13618 : :
13619 : : /* F03:C509. */
13620 : : /* Assume that use associated symbols were checked in the module ns.
13621 : : Class-variables that are associate-names are also something special
13622 : : and excepted from the test. */
13623 : 16503 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
13624 : : {
13625 : 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
13626 : : "or pointer", sym->name, &sym->declared_at);
13627 : 54 : return false;
13628 : : }
13629 : : }
13630 : :
13631 : : return true;
13632 : : }
13633 : :
13634 : :
13635 : : /* Additional checks for symbols with flavor variable and derived
13636 : : type. To be called from resolve_fl_variable. */
13637 : :
13638 : : static bool
13639 : 82591 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
13640 : : {
13641 : 82591 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
13642 : :
13643 : : /* Check to see if a derived type is blocked from being host
13644 : : associated by the presence of another class I symbol in the same
13645 : : namespace. 14.6.1.3 of the standard and the discussion on
13646 : : comp.lang.fortran. */
13647 : 82591 : if (sym->ts.u.derived
13648 : 82586 : && sym->ns != sym->ts.u.derived->ns
13649 : 40298 : && !sym->ts.u.derived->attr.use_assoc
13650 : 15160 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
13651 : : {
13652 : 14327 : gfc_symbol *s;
13653 : 14327 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
13654 : 14327 : if (s && s->attr.generic)
13655 : 0 : s = gfc_find_dt_in_generic (s);
13656 : 14327 : if (s && !gfc_fl_struct (s->attr.flavor))
13657 : : {
13658 : 1 : gfc_error ("The type %qs cannot be host associated at %L "
13659 : : "because it is blocked by an incompatible object "
13660 : : "of the same name declared at %L",
13661 : 1 : sym->ts.u.derived->name, &sym->declared_at,
13662 : : &s->declared_at);
13663 : 1 : return false;
13664 : : }
13665 : : }
13666 : :
13667 : : /* 4th constraint in section 11.3: "If an object of a type for which
13668 : : component-initialization is specified (R429) appears in the
13669 : : specification-part of a module and does not have the ALLOCATABLE
13670 : : or POINTER attribute, the object shall have the SAVE attribute."
13671 : :
13672 : : The check for initializers is performed with
13673 : : gfc_has_default_initializer because gfc_default_initializer generates
13674 : : a hidden default for allocatable components. */
13675 : 81380 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
13676 : 28764 : && sym->ns->proc_name->attr.flavor == FL_MODULE
13677 : 1660 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
13678 : 1652 : && !sym->attr.pointer && !sym->attr.allocatable
13679 : 20 : && gfc_has_default_initializer (sym->ts.u.derived)
13680 : 82599 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
13681 : : "%qs at %L, needed due to the default "
13682 : : "initialization", sym->name, &sym->declared_at))
13683 : : return false;
13684 : :
13685 : : /* Assign default initializer. */
13686 : 82588 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
13687 : 76457 : && (!no_init_flag
13688 : 49363 : || (sym->attr.intent == INTENT_OUT
13689 : 2905 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
13690 : 29842 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
13691 : :
13692 : : return true;
13693 : : }
13694 : :
13695 : :
13696 : : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
13697 : : except in the declaration of an entity or component that has the POINTER
13698 : : or ALLOCATABLE attribute. */
13699 : :
13700 : : static bool
13701 : 1225706 : deferred_requirements (gfc_symbol *sym)
13702 : : {
13703 : 1225706 : if (sym->ts.deferred
13704 : 100 : && !(sym->attr.pointer
13705 : 2821 : || sym->attr.allocatable
13706 : : || sym->attr.associate_var
13707 : : || sym->attr.omp_udr_artificial_var))
13708 : : {
13709 : : /* If a function has a result variable, only check the variable. */
13710 : 9 : if (sym->result && sym->name != sym->result->name)
13711 : : return true;
13712 : :
13713 : 8 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
13714 : : "requires either the POINTER or ALLOCATABLE attribute",
13715 : : sym->name, &sym->declared_at);
13716 : 8 : return false;
13717 : : }
13718 : : return true;
13719 : : }
13720 : :
13721 : :
13722 : : /* Resolve symbols with flavor variable. */
13723 : :
13724 : : static bool
13725 : 560673 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
13726 : : {
13727 : 560673 : const char *auto_save_msg = "Automatic object %qs at %L cannot have the "
13728 : : "SAVE attribute";
13729 : :
13730 : 560673 : if (!resolve_fl_var_and_proc (sym, mp_flag))
13731 : : return false;
13732 : :
13733 : : /* Set this flag to check that variables are parameters of all entries.
13734 : : This check is effected by the call to gfc_resolve_expr through
13735 : : is_non_constant_shape_array. */
13736 : 560613 : bool saved_specification_expr = specification_expr;
13737 : 560613 : specification_expr = true;
13738 : :
13739 : 560613 : if (sym->ns->proc_name
13740 : 560523 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
13741 : 554385 : || sym->ns->proc_name->attr.is_main_program)
13742 : : && !sym->attr.use_assoc
13743 : : && !sym->attr.allocatable
13744 : 86336 : && !sym->attr.pointer
13745 : 627348 : && is_non_constant_shape_array (sym))
13746 : : {
13747 : : /* F08:C541. The shape of an array defined in a main program or module
13748 : : * needs to be constant. */
13749 : 3 : gfc_error ("The module or main program array %qs at %L must "
13750 : : "have constant shape", sym->name, &sym->declared_at);
13751 : 3 : specification_expr = saved_specification_expr;
13752 : 3 : return false;
13753 : : }
13754 : :
13755 : : /* Constraints on deferred type parameter. */
13756 : 560610 : if (!deferred_requirements (sym))
13757 : : return false;
13758 : :
13759 : 560604 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
13760 : : {
13761 : : /* Make sure that character string variables with assumed length are
13762 : : dummy arguments. */
13763 : 32961 : gfc_expr *e = NULL;
13764 : :
13765 : 32961 : if (sym->ts.u.cl)
13766 : 32961 : e = sym->ts.u.cl->length;
13767 : : else
13768 : : return false;
13769 : :
13770 : 32961 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
13771 : 2172 : && !sym->ts.deferred && !sym->attr.select_type_temporary
13772 : 820 : && !sym->attr.omp_udr_artificial_var)
13773 : : {
13774 : 2 : gfc_error ("Entity with assumed character length at %L must be a "
13775 : : "dummy argument or a PARAMETER", &sym->declared_at);
13776 : 2 : specification_expr = saved_specification_expr;
13777 : 2 : return false;
13778 : : }
13779 : :
13780 : 19111 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
13781 : : {
13782 : 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
13783 : 1 : specification_expr = saved_specification_expr;
13784 : 1 : return false;
13785 : : }
13786 : :
13787 : 32958 : if (!gfc_is_constant_expr (e)
13788 : 32958 : && !(e->expr_type == EXPR_VARIABLE
13789 : 1285 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
13790 : : {
13791 : 2051 : if (!sym->attr.use_assoc && sym->ns->proc_name
13792 : 1558 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
13793 : 1557 : || sym->ns->proc_name->attr.is_main_program))
13794 : : {
13795 : 3 : gfc_error ("%qs at %L must have constant character length "
13796 : : "in this context", sym->name, &sym->declared_at);
13797 : 3 : specification_expr = saved_specification_expr;
13798 : 3 : return false;
13799 : : }
13800 : 2048 : if (sym->attr.in_common)
13801 : : {
13802 : 1 : gfc_error ("COMMON variable %qs at %L must have constant "
13803 : : "character length", sym->name, &sym->declared_at);
13804 : 1 : specification_expr = saved_specification_expr;
13805 : 1 : return false;
13806 : : }
13807 : : }
13808 : : }
13809 : :
13810 : 560597 : if (sym->value == NULL && sym->attr.referenced
13811 : 177756 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
13812 : 176002 : apply_default_init_local (sym); /* Try to apply a default initialization. */
13813 : :
13814 : : /* Determine if the symbol may not have an initializer. */
13815 : 560597 : int no_init_flag = 0, automatic_flag = 0;
13816 : 560597 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
13817 : 560597 : || sym->attr.intrinsic || sym->attr.result)
13818 : : no_init_flag = 1;
13819 : 35380 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
13820 : 169907 : && is_non_constant_shape_array (sym))
13821 : : {
13822 : 1261 : no_init_flag = automatic_flag = 1;
13823 : :
13824 : : /* Also, they must not have the SAVE attribute.
13825 : : SAVE_IMPLICIT is checked below. */
13826 : 1261 : if (sym->as && sym->attr.codimension)
13827 : : {
13828 : 7 : int corank = sym->as->corank;
13829 : 7 : sym->as->corank = 0;
13830 : 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
13831 : 7 : sym->as->corank = corank;
13832 : : }
13833 : 1261 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
13834 : : {
13835 : 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
13836 : 2 : specification_expr = saved_specification_expr;
13837 : 2 : return false;
13838 : : }
13839 : : }
13840 : :
13841 : : /* Ensure that any initializer is simplified. */
13842 : 560595 : if (sym->value)
13843 : 7737 : gfc_simplify_expr (sym->value, 1);
13844 : :
13845 : : /* Reject illegal initializers. */
13846 : 560595 : if (!sym->mark && sym->value)
13847 : : {
13848 : 7737 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
13849 : 67 : && CLASS_DATA (sym)->attr.allocatable))
13850 : 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
13851 : : sym->name, &sym->declared_at);
13852 : 7736 : else if (sym->attr.external)
13853 : 0 : gfc_error ("External %qs at %L cannot have an initializer",
13854 : : sym->name, &sym->declared_at);
13855 : 7736 : else if (sym->attr.dummy)
13856 : 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
13857 : : sym->name, &sym->declared_at);
13858 : 7733 : else if (sym->attr.intrinsic)
13859 : 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
13860 : : sym->name, &sym->declared_at);
13861 : 7733 : else if (sym->attr.result)
13862 : 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
13863 : : sym->name, &sym->declared_at);
13864 : 7732 : else if (automatic_flag)
13865 : 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
13866 : : sym->name, &sym->declared_at);
13867 : : else
13868 : 7727 : goto no_init_error;
13869 : 10 : specification_expr = saved_specification_expr;
13870 : 10 : return false;
13871 : : }
13872 : :
13873 : 552858 : no_init_error:
13874 : 560585 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
13875 : : {
13876 : 82591 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
13877 : 82591 : specification_expr = saved_specification_expr;
13878 : 82591 : return res;
13879 : : }
13880 : :
13881 : 477994 : specification_expr = saved_specification_expr;
13882 : 477994 : return true;
13883 : : }
13884 : :
13885 : :
13886 : : /* Compare the dummy characteristics of a module procedure interface
13887 : : declaration with the corresponding declaration in a submodule. */
13888 : : static gfc_formal_arglist *new_formal;
13889 : : static char errmsg[200];
13890 : :
13891 : : static void
13892 : 898 : compare_fsyms (gfc_symbol *sym)
13893 : : {
13894 : 898 : gfc_symbol *fsym;
13895 : :
13896 : 898 : if (sym == NULL || new_formal == NULL)
13897 : : return;
13898 : :
13899 : 898 : fsym = new_formal->sym;
13900 : :
13901 : 898 : if (sym == fsym)
13902 : : return;
13903 : :
13904 : 874 : if (strcmp (sym->name, fsym->name) == 0)
13905 : : {
13906 : 348 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
13907 : 3 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
13908 : : }
13909 : : }
13910 : :
13911 : :
13912 : : /* Resolve a procedure. */
13913 : :
13914 : : static bool
13915 : 399074 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
13916 : : {
13917 : 399074 : gfc_formal_arglist *arg;
13918 : 399074 : bool allocatable_or_pointer = false;
13919 : :
13920 : 399074 : if (sym->attr.function
13921 : 399074 : && !resolve_fl_var_and_proc (sym, mp_flag))
13922 : : return false;
13923 : :
13924 : : /* Constraints on deferred type parameter. */
13925 : 399064 : if (!deferred_requirements (sym))
13926 : : return false;
13927 : :
13928 : 399063 : if (sym->ts.type == BT_CHARACTER)
13929 : : {
13930 : 3253 : gfc_charlen *cl = sym->ts.u.cl;
13931 : :
13932 : 2590 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
13933 : 4303 : && !resolve_charlen (cl))
13934 : : return false;
13935 : :
13936 : 3252 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
13937 : 2203 : && sym->attr.proc == PROC_ST_FUNCTION)
13938 : : {
13939 : 0 : gfc_error ("Character-valued statement function %qs at %L must "
13940 : : "have constant length", sym->name, &sym->declared_at);
13941 : 0 : return false;
13942 : : }
13943 : : }
13944 : :
13945 : : /* Ensure that derived type for are not of a private type. Internal
13946 : : module procedures are excluded by 2.2.3.3 - i.e., they are not
13947 : : externally accessible and can access all the objects accessible in
13948 : : the host. */
13949 : 75591 : if (!(sym->ns->parent && sym->ns->parent->proc_name
13950 : 75591 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
13951 : 453619 : && gfc_check_symbol_access (sym))
13952 : : {
13953 : 371863 : gfc_interface *iface;
13954 : :
13955 : 773125 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
13956 : : {
13957 : 401263 : if (arg->sym
13958 : 401122 : && arg->sym->ts.type == BT_DERIVED
13959 : 35044 : && arg->sym->ts.u.derived
13960 : 35044 : && !arg->sym->ts.u.derived->attr.use_assoc
13961 : 3781 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
13962 : 401272 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
13963 : : "and cannot be a dummy argument"
13964 : : " of %qs, which is PUBLIC at %L",
13965 : 9 : arg->sym->name, sym->name,
13966 : : &sym->declared_at))
13967 : : {
13968 : : /* Stop this message from recurring. */
13969 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
13970 : 1 : return false;
13971 : : }
13972 : : }
13973 : :
13974 : : /* PUBLIC interfaces may expose PRIVATE procedures that take types
13975 : : PRIVATE to the containing module. */
13976 : 534157 : for (iface = sym->generic; iface; iface = iface->next)
13977 : : {
13978 : 376680 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
13979 : : {
13980 : 214385 : if (arg->sym
13981 : 214353 : && arg->sym->ts.type == BT_DERIVED
13982 : 7022 : && !arg->sym->ts.u.derived->attr.use_assoc
13983 : 205 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
13984 : 214389 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
13985 : : "PUBLIC interface %qs at %L "
13986 : : "takes dummy arguments of %qs which "
13987 : : "is PRIVATE", iface->sym->name,
13988 : 4 : sym->name, &iface->sym->declared_at,
13989 : 4 : gfc_typename(&arg->sym->ts)))
13990 : : {
13991 : : /* Stop this message from recurring. */
13992 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
13993 : 1 : return false;
13994 : : }
13995 : : }
13996 : : }
13997 : : }
13998 : :
13999 : 399060 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
14000 : 67 : && !sym->attr.proc_pointer)
14001 : : {
14002 : 2 : gfc_error ("Function %qs at %L cannot have an initializer",
14003 : : sym->name, &sym->declared_at);
14004 : :
14005 : : /* Make sure no second error is issued for this. */
14006 : 2 : sym->value->error = 1;
14007 : 2 : return false;
14008 : : }
14009 : :
14010 : : /* An external symbol may not have an initializer because it is taken to be
14011 : : a procedure. Exception: Procedure Pointers. */
14012 : 399058 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
14013 : : {
14014 : 0 : gfc_error ("External object %qs at %L may not have an initializer",
14015 : : sym->name, &sym->declared_at);
14016 : 0 : return false;
14017 : : }
14018 : :
14019 : : /* An elemental function is required to return a scalar 12.7.1 */
14020 : 399058 : if (sym->attr.elemental && sym->attr.function
14021 : 74477 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
14022 : 2 : && CLASS_DATA (sym)->as)))
14023 : : {
14024 : 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
14025 : : "result", sym->name, &sym->declared_at);
14026 : : /* Reset so that the error only occurs once. */
14027 : 3 : sym->attr.elemental = 0;
14028 : 3 : return false;
14029 : : }
14030 : :
14031 : 399055 : if (sym->attr.proc == PROC_ST_FUNCTION
14032 : 212 : && (sym->attr.allocatable || sym->attr.pointer))
14033 : : {
14034 : 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
14035 : : "allocatable attribute", sym->name, &sym->declared_at);
14036 : 2 : return false;
14037 : : }
14038 : :
14039 : : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
14040 : : char-len-param shall not be array-valued, pointer-valued, recursive
14041 : : or pure. ....snip... A character value of * may only be used in the
14042 : : following ways: (i) Dummy arg of procedure - dummy associates with
14043 : : actual length; (ii) To declare a named constant; or (iii) External
14044 : : function - but length must be declared in calling scoping unit. */
14045 : 399053 : if (sym->attr.function
14046 : 264392 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
14047 : 2888 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
14048 : : {
14049 : 178 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
14050 : 177 : || (sym->attr.recursive) || (sym->attr.pure))
14051 : : {
14052 : 4 : if (sym->as && sym->as->rank)
14053 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
14054 : : "array-valued", sym->name, &sym->declared_at);
14055 : :
14056 : 4 : if (sym->attr.pointer)
14057 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
14058 : : "pointer-valued", sym->name, &sym->declared_at);
14059 : :
14060 : 4 : if (sym->attr.pure)
14061 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
14062 : : "pure", sym->name, &sym->declared_at);
14063 : :
14064 : 4 : if (sym->attr.recursive)
14065 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
14066 : : "recursive", sym->name, &sym->declared_at);
14067 : :
14068 : 4 : return false;
14069 : : }
14070 : :
14071 : : /* Appendix B.2 of the standard. Contained functions give an
14072 : : error anyway. Deferred character length is an F2003 feature.
14073 : : Don't warn on intrinsic conversion functions, which start
14074 : : with two underscores. */
14075 : 174 : if (!sym->attr.contained && !sym->ts.deferred
14076 : 170 : && (sym->name[0] != '_' || sym->name[1] != '_'))
14077 : 170 : gfc_notify_std (GFC_STD_F95_OBS,
14078 : : "CHARACTER(*) function %qs at %L",
14079 : : sym->name, &sym->declared_at);
14080 : : }
14081 : :
14082 : : /* F2008, C1218. */
14083 : 399049 : if (sym->attr.elemental)
14084 : : {
14085 : 77263 : if (sym->attr.proc_pointer)
14086 : : {
14087 : 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
14088 : : : sym->name);
14089 : 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
14090 : : name, &sym->declared_at);
14091 : 7 : return false;
14092 : : }
14093 : 77256 : if (sym->attr.dummy)
14094 : : {
14095 : 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
14096 : : sym->name, &sym->declared_at);
14097 : 3 : return false;
14098 : : }
14099 : : }
14100 : :
14101 : : /* F2018, C15100: "The result of an elemental function shall be scalar,
14102 : : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
14103 : : pointer is tested and caught elsewhere. */
14104 : 399039 : if (sym->result)
14105 : 222038 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
14106 : 222038 : && CLASS_DATA (sym->result) ?
14107 : : (CLASS_DATA (sym->result)->attr.allocatable
14108 : 1494 : || CLASS_DATA (sym->result)->attr.pointer) :
14109 : : (sym->result->attr.allocatable
14110 : 220544 : || sym->result->attr.pointer);
14111 : :
14112 : 399039 : if (sym->attr.elemental && sym->result
14113 : 74093 : && allocatable_or_pointer)
14114 : : {
14115 : 4 : gfc_error ("Function result variable %qs at %L of elemental "
14116 : : "function %qs shall not have an ALLOCATABLE or POINTER "
14117 : : "attribute", sym->result->name,
14118 : : &sym->result->declared_at, sym->name);
14119 : 4 : return false;
14120 : : }
14121 : :
14122 : 399035 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
14123 : : {
14124 : 5568 : gfc_formal_arglist *curr_arg;
14125 : 5568 : int has_non_interop_arg = 0;
14126 : :
14127 : 5568 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
14128 : : sym->common_block))
14129 : : {
14130 : : /* Clear these to prevent looking at them again if there was an
14131 : : error. */
14132 : 3 : sym->attr.is_bind_c = 0;
14133 : 3 : sym->attr.is_c_interop = 0;
14134 : 3 : sym->ts.is_c_interop = 0;
14135 : : }
14136 : : else
14137 : : {
14138 : : /* So far, no errors have been found. */
14139 : 5565 : sym->attr.is_c_interop = 1;
14140 : 5565 : sym->ts.is_c_interop = 1;
14141 : : }
14142 : :
14143 : 5568 : curr_arg = gfc_sym_get_dummy_args (sym);
14144 : 24981 : while (curr_arg != NULL)
14145 : : {
14146 : : /* Skip implicitly typed dummy args here. */
14147 : 13845 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
14148 : 13789 : if (!gfc_verify_c_interop_param (curr_arg->sym))
14149 : : /* If something is found to fail, record the fact so we
14150 : : can mark the symbol for the procedure as not being
14151 : : BIND(C) to try and prevent multiple errors being
14152 : : reported. */
14153 : 13845 : has_non_interop_arg = 1;
14154 : :
14155 : 13845 : curr_arg = curr_arg->next;
14156 : : }
14157 : :
14158 : : /* See if any of the arguments were not interoperable and if so, clear
14159 : : the procedure symbol to prevent duplicate error messages. */
14160 : 5568 : if (has_non_interop_arg != 0)
14161 : : {
14162 : 128 : sym->attr.is_c_interop = 0;
14163 : 128 : sym->ts.is_c_interop = 0;
14164 : 128 : sym->attr.is_bind_c = 0;
14165 : : }
14166 : : }
14167 : :
14168 : 399035 : if (!sym->attr.proc_pointer)
14169 : : {
14170 : 398020 : if (sym->attr.save == SAVE_EXPLICIT)
14171 : : {
14172 : 4 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
14173 : : "in %qs at %L", sym->name, &sym->declared_at);
14174 : 4 : return false;
14175 : : }
14176 : 398016 : if (sym->attr.intent)
14177 : : {
14178 : 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
14179 : : "in %qs at %L", sym->name, &sym->declared_at);
14180 : 1 : return false;
14181 : : }
14182 : 398015 : if (sym->attr.subroutine && sym->attr.result)
14183 : : {
14184 : 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
14185 : 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
14186 : 2 : return false;
14187 : : }
14188 : 398013 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
14189 : 110328 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
14190 : 110325 : || sym->attr.contained))
14191 : : {
14192 : 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
14193 : : "in %qs at %L", sym->name, &sym->declared_at);
14194 : 3 : return false;
14195 : : }
14196 : 398010 : if (strcmp ("ppr@", sym->name) == 0)
14197 : : {
14198 : 0 : gfc_error ("Procedure pointer result %qs at %L "
14199 : : "is missing the pointer attribute",
14200 : 0 : sym->ns->proc_name->name, &sym->declared_at);
14201 : 0 : return false;
14202 : : }
14203 : : }
14204 : :
14205 : : /* Assume that a procedure whose body is not known has references
14206 : : to external arrays. */
14207 : 399025 : if (sym->attr.if_source != IFSRC_DECL)
14208 : 273136 : sym->attr.array_outer_dependency = 1;
14209 : :
14210 : : /* Compare the characteristics of a module procedure with the
14211 : : interface declaration. Ideally this would be done with
14212 : : gfc_compare_interfaces but, at present, the formal interface
14213 : : cannot be copied to the ts.interface. */
14214 : 399025 : if (sym->attr.module_procedure
14215 : 399025 : && sym->attr.if_source == IFSRC_DECL)
14216 : : {
14217 : 493 : gfc_symbol *iface;
14218 : 493 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
14219 : 493 : char *module_name;
14220 : 493 : char *submodule_name;
14221 : 493 : strcpy (name, sym->ns->proc_name->name);
14222 : 493 : module_name = strtok (name, ".");
14223 : 493 : submodule_name = strtok (NULL, ".");
14224 : :
14225 : 493 : iface = sym->tlink;
14226 : 493 : sym->tlink = NULL;
14227 : :
14228 : : /* Make sure that the result uses the correct charlen for deferred
14229 : : length results. */
14230 : 493 : if (iface && sym->result
14231 : 110 : && iface->ts.type == BT_CHARACTER
14232 : 19 : && iface->ts.deferred)
14233 : 6 : sym->result->ts.u.cl = iface->ts.u.cl;
14234 : :
14235 : 6 : if (iface == NULL)
14236 : 156 : goto check_formal;
14237 : :
14238 : : /* Check the procedure characteristics. */
14239 : 337 : if (sym->attr.elemental != iface->attr.elemental)
14240 : : {
14241 : 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
14242 : : "PROCEDURE at %L and its interface in %s",
14243 : : &sym->declared_at, module_name);
14244 : 10 : return false;
14245 : : }
14246 : :
14247 : 336 : if (sym->attr.pure != iface->attr.pure)
14248 : : {
14249 : 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
14250 : : "PROCEDURE at %L and its interface in %s",
14251 : : &sym->declared_at, module_name);
14252 : 2 : return false;
14253 : : }
14254 : :
14255 : 334 : if (sym->attr.recursive != iface->attr.recursive)
14256 : : {
14257 : 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
14258 : : "PROCEDURE at %L and its interface in %s",
14259 : : &sym->declared_at, module_name);
14260 : 2 : return false;
14261 : : }
14262 : :
14263 : : /* Check the result characteristics. */
14264 : 332 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
14265 : : {
14266 : 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
14267 : : "in MODULE %qs and the declaration at %L in "
14268 : : "(SUB)MODULE %qs",
14269 : : errmsg, module_name, &sym->declared_at,
14270 : : submodule_name ? submodule_name : module_name);
14271 : 5 : return false;
14272 : : }
14273 : :
14274 : 327 : check_formal:
14275 : : /* Check the characteristics of the formal arguments. */
14276 : 483 : if (sym->formal && sym->formal_ns)
14277 : : {
14278 : 894 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
14279 : : {
14280 : 504 : new_formal = arg;
14281 : 504 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
14282 : : }
14283 : : }
14284 : : }
14285 : :
14286 : : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
14287 : : BIND(C) attribute. */
14288 : 399015 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
14289 : : {
14290 : 1 : gfc_error ("Interface of %qs at %L must be explicit",
14291 : : sym->name, &sym->declared_at);
14292 : 1 : return false;
14293 : : }
14294 : :
14295 : : return true;
14296 : : }
14297 : :
14298 : :
14299 : : /* Resolve a list of finalizer procedures. That is, after they have hopefully
14300 : : been defined and we now know their defined arguments, check that they fulfill
14301 : : the requirements of the standard for procedures used as finalizers. */
14302 : :
14303 : : static bool
14304 : 96536 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
14305 : : {
14306 : 96536 : gfc_finalizer* list;
14307 : 96536 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
14308 : 96536 : bool result = true;
14309 : 96536 : bool seen_scalar = false;
14310 : 96536 : gfc_symbol *vtab;
14311 : 96536 : gfc_component *c;
14312 : 96536 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
14313 : :
14314 : 96536 : if (parent)
14315 : 13538 : gfc_resolve_finalizers (parent, finalizable);
14316 : :
14317 : : /* Ensure that derived-type components have a their finalizers resolved. */
14318 : 96536 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
14319 : 311869 : for (c = derived->components; c; c = c->next)
14320 : 215333 : if (c->ts.type == BT_DERIVED
14321 : 60337 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
14322 : : {
14323 : 6965 : bool has_final2 = false;
14324 : 6965 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
14325 : 0 : return false; /* Error. */
14326 : 6965 : has_final = has_final || has_final2;
14327 : : }
14328 : : /* Return early if not finalizable. */
14329 : 96536 : if (!has_final)
14330 : : {
14331 : 94444 : if (finalizable)
14332 : 6937 : *finalizable = false;
14333 : 94444 : return true;
14334 : : }
14335 : :
14336 : : /* Walk over the list of finalizer-procedures, check them, and if any one
14337 : : does not fit in with the standard's definition, print an error and remove
14338 : : it from the list. */
14339 : 2092 : prev_link = &derived->f2k_derived->finalizers;
14340 : 4352 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
14341 : : {
14342 : 2260 : gfc_formal_arglist *dummy_args;
14343 : 2260 : gfc_symbol* arg;
14344 : 2260 : gfc_finalizer* i;
14345 : 2260 : int my_rank;
14346 : :
14347 : : /* Skip this finalizer if we already resolved it. */
14348 : 2260 : if (list->proc_tree)
14349 : : {
14350 : 1822 : if (list->proc_tree->n.sym->formal->sym->as == NULL
14351 : 566 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
14352 : 1256 : seen_scalar = true;
14353 : 1822 : prev_link = &(list->next);
14354 : 1822 : continue;
14355 : : }
14356 : :
14357 : : /* Check this exists and is a SUBROUTINE. */
14358 : 438 : if (!list->proc_sym->attr.subroutine)
14359 : : {
14360 : 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
14361 : : list->proc_sym->name, &list->where);
14362 : 3 : goto error;
14363 : : }
14364 : :
14365 : : /* We should have exactly one argument. */
14366 : 435 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
14367 : 435 : if (!dummy_args || dummy_args->next)
14368 : : {
14369 : 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
14370 : : &list->where);
14371 : 2 : goto error;
14372 : : }
14373 : 433 : arg = dummy_args->sym;
14374 : :
14375 : 433 : if (!arg)
14376 : : {
14377 : 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14378 : 1 : &list->proc_sym->declared_at, derived->name);
14379 : 1 : goto error;
14380 : : }
14381 : :
14382 : 432 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
14383 : 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
14384 : : {
14385 : 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
14386 : : "be the only finalizer with the same kind/type "
14387 : : "(F2018: C790)", &list->where);
14388 : 0 : goto error;
14389 : : }
14390 : :
14391 : : /* This argument must be of our type. */
14392 : 432 : if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
14393 : : {
14394 : 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14395 : : &arg->declared_at, derived->name);
14396 : 2 : goto error;
14397 : : }
14398 : :
14399 : : /* It must neither be a pointer nor allocatable nor optional. */
14400 : 430 : if (arg->attr.pointer)
14401 : : {
14402 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
14403 : : &arg->declared_at);
14404 : 1 : goto error;
14405 : : }
14406 : 429 : if (arg->attr.allocatable)
14407 : : {
14408 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
14409 : : " ALLOCATABLE", &arg->declared_at);
14410 : 1 : goto error;
14411 : : }
14412 : 428 : if (arg->attr.optional)
14413 : : {
14414 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
14415 : : &arg->declared_at);
14416 : 1 : goto error;
14417 : : }
14418 : :
14419 : : /* It must not be INTENT(OUT). */
14420 : 427 : if (arg->attr.intent == INTENT_OUT)
14421 : : {
14422 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
14423 : : " INTENT(OUT)", &arg->declared_at);
14424 : 1 : goto error;
14425 : : }
14426 : :
14427 : : /* Warn if the procedure is non-scalar and not assumed shape. */
14428 : 426 : if (warn_surprising && arg->as && arg->as->rank != 0
14429 : 3 : && arg->as->type != AS_ASSUMED_SHAPE)
14430 : 2 : gfc_warning (OPT_Wsurprising,
14431 : : "Non-scalar FINAL procedure at %L should have assumed"
14432 : : " shape argument", &arg->declared_at);
14433 : :
14434 : : /* Check that it does not match in kind and rank with a FINAL procedure
14435 : : defined earlier. To really loop over the *earlier* declarations,
14436 : : we need to walk the tail of the list as new ones were pushed at the
14437 : : front. */
14438 : : /* TODO: Handle kind parameters once they are implemented. */
14439 : 426 : my_rank = (arg->as ? arg->as->rank : 0);
14440 : 515 : for (i = list->next; i; i = i->next)
14441 : : {
14442 : 91 : gfc_formal_arglist *dummy_args;
14443 : :
14444 : : /* Argument list might be empty; that is an error signalled earlier,
14445 : : but we nevertheless continued resolving. */
14446 : 91 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
14447 : 91 : if (dummy_args)
14448 : : {
14449 : 89 : gfc_symbol* i_arg = dummy_args->sym;
14450 : 89 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
14451 : 89 : if (i_rank == my_rank)
14452 : : {
14453 : 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
14454 : : " rank (%d) as %qs",
14455 : 2 : list->proc_sym->name, &list->where, my_rank,
14456 : 2 : i->proc_sym->name);
14457 : 2 : goto error;
14458 : : }
14459 : : }
14460 : : }
14461 : :
14462 : : /* Is this the/a scalar finalizer procedure? */
14463 : 424 : if (my_rank == 0)
14464 : 304 : seen_scalar = true;
14465 : :
14466 : : /* Find the symtree for this procedure. */
14467 : 424 : gcc_assert (!list->proc_tree);
14468 : 424 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
14469 : :
14470 : 424 : prev_link = &list->next;
14471 : 424 : continue;
14472 : :
14473 : : /* Remove wrong nodes immediately from the list so we don't risk any
14474 : : troubles in the future when they might fail later expectations. */
14475 : 14 : error:
14476 : 14 : i = list;
14477 : 14 : *prev_link = list->next;
14478 : 14 : gfc_free_finalizer (i);
14479 : 14 : result = false;
14480 : 424 : }
14481 : :
14482 : 2092 : if (result == false)
14483 : : return false;
14484 : :
14485 : : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
14486 : : were nodes in the list, must have been for arrays. It is surely a good
14487 : : idea to have a scalar version there if there's something to finalize. */
14488 : 2088 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
14489 : 1 : gfc_warning (OPT_Wsurprising,
14490 : : "Only array FINAL procedures declared for derived type %qs"
14491 : : " defined at %L, suggest also scalar one unless an assumed"
14492 : : " rank finalizer has been declared",
14493 : : derived->name, &derived->declared_at);
14494 : :
14495 : 2088 : vtab = gfc_find_derived_vtab (derived);
14496 : 2088 : c = vtab->ts.u.derived->components->next->next->next->next->next;
14497 : 2088 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
14498 : :
14499 : 2088 : if (finalizable)
14500 : 518 : *finalizable = true;
14501 : :
14502 : : return true;
14503 : : }
14504 : :
14505 : :
14506 : : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
14507 : :
14508 : : static bool
14509 : 380 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
14510 : : const char* generic_name, locus where)
14511 : : {
14512 : 380 : gfc_symbol *sym1, *sym2;
14513 : 380 : const char *pass1, *pass2;
14514 : 380 : gfc_formal_arglist *dummy_args;
14515 : :
14516 : 380 : gcc_assert (t1->specific && t2->specific);
14517 : 380 : gcc_assert (!t1->specific->is_generic);
14518 : 380 : gcc_assert (!t2->specific->is_generic);
14519 : 380 : gcc_assert (t1->is_operator == t2->is_operator);
14520 : :
14521 : 380 : sym1 = t1->specific->u.specific->n.sym;
14522 : 380 : sym2 = t2->specific->u.specific->n.sym;
14523 : :
14524 : 380 : if (sym1 == sym2)
14525 : : return true;
14526 : :
14527 : : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
14528 : 380 : if (sym1->attr.subroutine != sym2->attr.subroutine
14529 : 380 : || sym1->attr.function != sym2->attr.function)
14530 : : {
14531 : 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
14532 : : " GENERIC %qs at %L",
14533 : : sym1->name, sym2->name, generic_name, &where);
14534 : 2 : return false;
14535 : : }
14536 : :
14537 : : /* Determine PASS arguments. */
14538 : 378 : if (t1->specific->nopass)
14539 : : pass1 = NULL;
14540 : 327 : else if (t1->specific->pass_arg)
14541 : : pass1 = t1->specific->pass_arg;
14542 : : else
14543 : : {
14544 : 212 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
14545 : 212 : if (dummy_args)
14546 : 211 : pass1 = dummy_args->sym->name;
14547 : : else
14548 : : pass1 = NULL;
14549 : : }
14550 : 378 : if (t2->specific->nopass)
14551 : : pass2 = NULL;
14552 : 326 : else if (t2->specific->pass_arg)
14553 : : pass2 = t2->specific->pass_arg;
14554 : : else
14555 : : {
14556 : 207 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
14557 : 207 : if (dummy_args)
14558 : 206 : pass2 = dummy_args->sym->name;
14559 : : else
14560 : : pass2 = NULL;
14561 : : }
14562 : :
14563 : : /* Compare the interfaces. */
14564 : 378 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
14565 : : NULL, 0, pass1, pass2))
14566 : : {
14567 : 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
14568 : : sym1->name, sym2->name, generic_name, &where);
14569 : 8 : return false;
14570 : : }
14571 : :
14572 : : return true;
14573 : : }
14574 : :
14575 : :
14576 : : /* Worker function for resolving a generic procedure binding; this is used to
14577 : : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
14578 : :
14579 : : The difference between those cases is finding possible inherited bindings
14580 : : that are overridden, as one has to look for them in tb_sym_root,
14581 : : tb_uop_root or tb_op, respectively. Thus the caller must already find
14582 : : the super-type and set p->overridden correctly. */
14583 : :
14584 : : static bool
14585 : 2027 : resolve_tb_generic_targets (gfc_symbol* super_type,
14586 : : gfc_typebound_proc* p, const char* name)
14587 : : {
14588 : 2027 : gfc_tbp_generic* target;
14589 : 2027 : gfc_symtree* first_target;
14590 : 2027 : gfc_symtree* inherited;
14591 : :
14592 : 2027 : gcc_assert (p && p->is_generic);
14593 : :
14594 : : /* Try to find the specific bindings for the symtrees in our target-list. */
14595 : 2027 : gcc_assert (p->u.generic);
14596 : 4298 : for (target = p->u.generic; target; target = target->next)
14597 : 2288 : if (!target->specific)
14598 : : {
14599 : 2150 : gfc_typebound_proc* overridden_tbp;
14600 : 2150 : gfc_tbp_generic* g;
14601 : 2150 : const char* target_name;
14602 : :
14603 : 2150 : target_name = target->specific_st->name;
14604 : :
14605 : : /* Defined for this type directly. */
14606 : 2150 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
14607 : : {
14608 : 2141 : target->specific = target->specific_st->n.tb;
14609 : 2141 : goto specific_found;
14610 : : }
14611 : :
14612 : : /* Look for an inherited specific binding. */
14613 : 9 : if (super_type)
14614 : : {
14615 : 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
14616 : : true, NULL);
14617 : :
14618 : 5 : if (inherited)
14619 : : {
14620 : 5 : gcc_assert (inherited->n.tb);
14621 : 5 : target->specific = inherited->n.tb;
14622 : 5 : goto specific_found;
14623 : : }
14624 : : }
14625 : :
14626 : 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
14627 : : " at %L", target_name, name, &p->where);
14628 : 4 : return false;
14629 : :
14630 : : /* Once we've found the specific binding, check it is not ambiguous with
14631 : : other specifics already found or inherited for the same GENERIC. */
14632 : 2146 : specific_found:
14633 : 2146 : gcc_assert (target->specific);
14634 : :
14635 : : /* This must really be a specific binding! */
14636 : 2146 : if (target->specific->is_generic)
14637 : : {
14638 : 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
14639 : : " %qs is GENERIC, too", name, &p->where, target_name);
14640 : 3 : return false;
14641 : : }
14642 : :
14643 : : /* Check those already resolved on this type directly. */
14644 : 4996 : for (g = p->u.generic; g; g = g->next)
14645 : 724 : if (g != target && g->specific
14646 : 3222 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
14647 : : return false;
14648 : :
14649 : : /* Check for ambiguity with inherited specific targets. */
14650 : 2152 : for (overridden_tbp = p->overridden; overridden_tbp;
14651 : 16 : overridden_tbp = overridden_tbp->overridden)
14652 : 19 : if (overridden_tbp->is_generic)
14653 : : {
14654 : 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
14655 : : {
14656 : 18 : gcc_assert (g->specific);
14657 : 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
14658 : : return false;
14659 : : }
14660 : : }
14661 : : }
14662 : :
14663 : : /* If we attempt to "overwrite" a specific binding, this is an error. */
14664 : 2010 : if (p->overridden && !p->overridden->is_generic)
14665 : : {
14666 : 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
14667 : : " the same name", name, &p->where);
14668 : 1 : return false;
14669 : : }
14670 : :
14671 : : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14672 : : all must have the same attributes here. */
14673 : 2009 : first_target = p->u.generic->specific->u.specific;
14674 : 2009 : gcc_assert (first_target);
14675 : 2009 : p->subroutine = first_target->n.sym->attr.subroutine;
14676 : 2009 : p->function = first_target->n.sym->attr.function;
14677 : :
14678 : 2009 : return true;
14679 : : }
14680 : :
14681 : :
14682 : : /* Resolve a GENERIC procedure binding for a derived type. */
14683 : :
14684 : : static bool
14685 : 1042 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
14686 : : {
14687 : 1042 : gfc_symbol* super_type;
14688 : :
14689 : : /* Find the overridden binding if any. */
14690 : 1042 : st->n.tb->overridden = NULL;
14691 : 1042 : super_type = gfc_get_derived_super_type (derived);
14692 : 1042 : if (super_type)
14693 : : {
14694 : 40 : gfc_symtree* overridden;
14695 : 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
14696 : : true, NULL);
14697 : :
14698 : 40 : if (overridden && overridden->n.tb)
14699 : 21 : st->n.tb->overridden = overridden->n.tb;
14700 : : }
14701 : :
14702 : : /* Resolve using worker function. */
14703 : 1042 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
14704 : : }
14705 : :
14706 : :
14707 : : /* Retrieve the target-procedure of an operator binding and do some checks in
14708 : : common for intrinsic and user-defined type-bound operators. */
14709 : :
14710 : : static gfc_symbol*
14711 : 1049 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
14712 : : {
14713 : 1049 : gfc_symbol* target_proc;
14714 : :
14715 : 1049 : gcc_assert (target->specific && !target->specific->is_generic);
14716 : 1049 : target_proc = target->specific->u.specific->n.sym;
14717 : 1049 : gcc_assert (target_proc);
14718 : :
14719 : : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
14720 : 1049 : if (target->specific->nopass)
14721 : : {
14722 : 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
14723 : 2 : return NULL;
14724 : : }
14725 : :
14726 : : return target_proc;
14727 : : }
14728 : :
14729 : :
14730 : : /* Resolve a type-bound intrinsic operator. */
14731 : :
14732 : : static bool
14733 : 943 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
14734 : : gfc_typebound_proc* p)
14735 : : {
14736 : 943 : gfc_symbol* super_type;
14737 : 943 : gfc_tbp_generic* target;
14738 : :
14739 : : /* If there's already an error here, do nothing (but don't fail again). */
14740 : 943 : if (p->error)
14741 : : return true;
14742 : :
14743 : : /* Operators should always be GENERIC bindings. */
14744 : 943 : gcc_assert (p->is_generic);
14745 : :
14746 : : /* Look for an overridden binding. */
14747 : 943 : super_type = gfc_get_derived_super_type (derived);
14748 : 943 : if (super_type && super_type->f2k_derived)
14749 : 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
14750 : : op, true, NULL);
14751 : : else
14752 : 942 : p->overridden = NULL;
14753 : :
14754 : : /* Resolve general GENERIC properties using worker function. */
14755 : 943 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
14756 : 1 : goto error;
14757 : :
14758 : : /* Check the targets to be procedures of correct interface. */
14759 : 1928 : for (target = p->u.generic; target; target = target->next)
14760 : : {
14761 : 1006 : gfc_symbol* target_proc;
14762 : :
14763 : 1006 : target_proc = get_checked_tb_operator_target (target, p->where);
14764 : 1006 : if (!target_proc)
14765 : 1 : goto error;
14766 : :
14767 : 1005 : if (!gfc_check_operator_interface (target_proc, op, p->where))
14768 : 3 : goto error;
14769 : :
14770 : : /* Add target to non-typebound operator list. */
14771 : 1002 : if (!target->specific->deferred && !derived->attr.use_assoc
14772 : 351 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
14773 : : {
14774 : 349 : gfc_interface *head, *intr;
14775 : :
14776 : : /* Preempt 'gfc_check_new_interface' for submodules, where the
14777 : : mechanism for handling module procedures winds up resolving
14778 : : operator interfaces twice and would otherwise cause an error. */
14779 : 417 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
14780 : 82 : if (intr->sym == target_proc
14781 : 16 : && target_proc->attr.used_in_submodule)
14782 : : return true;
14783 : :
14784 : 335 : if (!gfc_check_new_interface (derived->ns->op[op],
14785 : : target_proc, p->where))
14786 : : return false;
14787 : 333 : head = derived->ns->op[op];
14788 : 333 : intr = gfc_get_interface ();
14789 : 333 : intr->sym = target_proc;
14790 : 333 : intr->where = p->where;
14791 : 333 : intr->next = head;
14792 : 333 : derived->ns->op[op] = intr;
14793 : : }
14794 : : }
14795 : :
14796 : : return true;
14797 : :
14798 : 5 : error:
14799 : 5 : p->error = 1;
14800 : 5 : return false;
14801 : : }
14802 : :
14803 : :
14804 : : /* Resolve a type-bound user operator (tree-walker callback). */
14805 : :
14806 : : static gfc_symbol* resolve_bindings_derived;
14807 : : static bool resolve_bindings_result;
14808 : :
14809 : : static bool check_uop_procedure (gfc_symbol* sym, locus where);
14810 : :
14811 : : static void
14812 : 42 : resolve_typebound_user_op (gfc_symtree* stree)
14813 : : {
14814 : 42 : gfc_symbol* super_type;
14815 : 42 : gfc_tbp_generic* target;
14816 : :
14817 : 42 : gcc_assert (stree && stree->n.tb);
14818 : :
14819 : 42 : if (stree->n.tb->error)
14820 : : return;
14821 : :
14822 : : /* Operators should always be GENERIC bindings. */
14823 : 42 : gcc_assert (stree->n.tb->is_generic);
14824 : :
14825 : : /* Find overridden procedure, if any. */
14826 : 42 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14827 : 42 : if (super_type && super_type->f2k_derived)
14828 : : {
14829 : 0 : gfc_symtree* overridden;
14830 : 0 : overridden = gfc_find_typebound_user_op (super_type, NULL,
14831 : : stree->name, true, NULL);
14832 : :
14833 : 0 : if (overridden && overridden->n.tb)
14834 : 0 : stree->n.tb->overridden = overridden->n.tb;
14835 : : }
14836 : : else
14837 : 42 : stree->n.tb->overridden = NULL;
14838 : :
14839 : : /* Resolve basically using worker function. */
14840 : 42 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
14841 : 0 : goto error;
14842 : :
14843 : : /* Check the targets to be functions of correct interface. */
14844 : 82 : for (target = stree->n.tb->u.generic; target; target = target->next)
14845 : : {
14846 : 43 : gfc_symbol* target_proc;
14847 : :
14848 : 43 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
14849 : 43 : if (!target_proc)
14850 : 1 : goto error;
14851 : :
14852 : 42 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
14853 : 2 : goto error;
14854 : : }
14855 : :
14856 : : return;
14857 : :
14858 : 3 : error:
14859 : 3 : resolve_bindings_result = false;
14860 : 3 : stree->n.tb->error = 1;
14861 : : }
14862 : :
14863 : :
14864 : : /* Resolve the type-bound procedures for a derived type. */
14865 : :
14866 : : static void
14867 : 8603 : resolve_typebound_procedure (gfc_symtree* stree)
14868 : : {
14869 : 8603 : gfc_symbol* proc;
14870 : 8603 : locus where;
14871 : 8603 : gfc_symbol* me_arg;
14872 : 8603 : gfc_symbol* super_type;
14873 : 8603 : gfc_component* comp;
14874 : :
14875 : 8603 : gcc_assert (stree);
14876 : :
14877 : : /* Undefined specific symbol from GENERIC target definition. */
14878 : 8603 : if (!stree->n.tb)
14879 : 8521 : return;
14880 : :
14881 : 8597 : if (stree->n.tb->error)
14882 : : return;
14883 : :
14884 : : /* If this is a GENERIC binding, use that routine. */
14885 : 8581 : if (stree->n.tb->is_generic)
14886 : : {
14887 : 1042 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
14888 : 17 : goto error;
14889 : : return;
14890 : : }
14891 : :
14892 : : /* Get the target-procedure to check it. */
14893 : 7539 : gcc_assert (!stree->n.tb->is_generic);
14894 : 7539 : gcc_assert (stree->n.tb->u.specific);
14895 : 7539 : proc = stree->n.tb->u.specific->n.sym;
14896 : 7539 : where = stree->n.tb->where;
14897 : :
14898 : : /* Default access should already be resolved from the parser. */
14899 : 7539 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
14900 : :
14901 : 7539 : if (stree->n.tb->deferred)
14902 : : {
14903 : 589 : if (!check_proc_interface (proc, &where))
14904 : 5 : goto error;
14905 : : }
14906 : : else
14907 : : {
14908 : : /* If proc has not been resolved at this point, proc->name may
14909 : : actually be a USE associated entity. See PR fortran/89647. */
14910 : 6950 : if (!proc->resolve_symbol_called
14911 : 4764 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
14912 : : {
14913 : 11 : gfc_symbol *tmp;
14914 : 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
14915 : 11 : if (tmp && tmp->attr.use_assoc)
14916 : : {
14917 : 1 : proc->module = tmp->module;
14918 : 1 : proc->attr.proc = tmp->attr.proc;
14919 : 1 : proc->attr.function = tmp->attr.function;
14920 : 1 : proc->attr.subroutine = tmp->attr.subroutine;
14921 : 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
14922 : 1 : proc->ts = tmp->ts;
14923 : 1 : proc->result = tmp->result;
14924 : : }
14925 : : }
14926 : :
14927 : : /* Check for F08:C465. */
14928 : 6950 : if ((!proc->attr.subroutine && !proc->attr.function)
14929 : 6940 : || (proc->attr.proc != PROC_MODULE
14930 : 21 : && proc->attr.if_source != IFSRC_IFBODY
14931 : 7 : && !proc->attr.module_procedure)
14932 : 6939 : || proc->attr.abstract)
14933 : : {
14934 : 12 : gfc_error ("%qs must be a module procedure or an external "
14935 : : "procedure with an explicit interface at %L",
14936 : : proc->name, &where);
14937 : 12 : goto error;
14938 : : }
14939 : : }
14940 : :
14941 : 7522 : stree->n.tb->subroutine = proc->attr.subroutine;
14942 : 7522 : stree->n.tb->function = proc->attr.function;
14943 : :
14944 : : /* Find the super-type of the current derived type. We could do this once and
14945 : : store in a global if speed is needed, but as long as not I believe this is
14946 : : more readable and clearer. */
14947 : 7522 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14948 : :
14949 : : /* If PASS, resolve and check arguments if not already resolved / loaded
14950 : : from a .mod file. */
14951 : 7522 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
14952 : : {
14953 : 2472 : gfc_formal_arglist *dummy_args;
14954 : :
14955 : 2472 : dummy_args = gfc_sym_get_dummy_args (proc);
14956 : 2472 : if (stree->n.tb->pass_arg)
14957 : : {
14958 : 441 : gfc_formal_arglist *i;
14959 : :
14960 : : /* If an explicit passing argument name is given, walk the arg-list
14961 : : and look for it. */
14962 : :
14963 : 441 : me_arg = NULL;
14964 : 441 : stree->n.tb->pass_arg_num = 1;
14965 : 561 : for (i = dummy_args; i; i = i->next)
14966 : : {
14967 : 559 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
14968 : : {
14969 : : me_arg = i->sym;
14970 : : break;
14971 : : }
14972 : 120 : ++stree->n.tb->pass_arg_num;
14973 : : }
14974 : :
14975 : 441 : if (!me_arg)
14976 : : {
14977 : 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14978 : : " argument %qs",
14979 : : proc->name, stree->n.tb->pass_arg, &where,
14980 : : stree->n.tb->pass_arg);
14981 : 2 : goto error;
14982 : : }
14983 : : }
14984 : : else
14985 : : {
14986 : : /* Otherwise, take the first one; there should in fact be at least
14987 : : one. */
14988 : 2031 : stree->n.tb->pass_arg_num = 1;
14989 : 2031 : if (!dummy_args)
14990 : : {
14991 : 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
14992 : : " least one argument", proc->name, &where);
14993 : 2 : goto error;
14994 : : }
14995 : 2029 : me_arg = dummy_args->sym;
14996 : : }
14997 : :
14998 : : /* Now check that the argument-type matches and the passed-object
14999 : : dummy argument is generally fine. */
15000 : :
15001 : 2029 : gcc_assert (me_arg);
15002 : :
15003 : 2468 : if (me_arg->ts.type != BT_CLASS)
15004 : : {
15005 : 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15006 : : " at %L", proc->name, &where);
15007 : 5 : goto error;
15008 : : }
15009 : :
15010 : : /* The derived type is not a PDT template. Resolve as usual. */
15011 : 2463 : if (!resolve_bindings_derived->attr.pdt_template
15012 : 2448 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
15013 : : {
15014 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
15015 : : "the derived-type %qs", me_arg->name, proc->name,
15016 : : me_arg->name, &where, resolve_bindings_derived->name);
15017 : 0 : goto error;
15018 : : }
15019 : :
15020 : 2463 : if (resolve_bindings_derived->attr.pdt_template
15021 : 2478 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
15022 : 15 : CLASS_DATA (me_arg)->ts.u.derived))
15023 : : {
15024 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
15025 : : "the parametric derived-type %qs", me_arg->name,
15026 : : proc->name, me_arg->name, &where,
15027 : : resolve_bindings_derived->name);
15028 : 0 : goto error;
15029 : : }
15030 : :
15031 : 2463 : if (resolve_bindings_derived->attr.pdt_template
15032 : 15 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
15033 : 15 : CLASS_DATA (me_arg)->ts.u.derived)
15034 : 15 : && (me_arg->param_list != NULL)
15035 : 2478 : && (gfc_spec_list_type (me_arg->param_list,
15036 : 15 : CLASS_DATA(me_arg)->ts.u.derived)
15037 : : != SPEC_ASSUMED))
15038 : : {
15039 : :
15040 : : /* Add a check to verify if there are any LEN parameters in the
15041 : : first place. If there are LEN parameters, throw this error.
15042 : : If there are only KIND parameters, then don't trigger
15043 : : this error. */
15044 : 7 : gfc_component *c;
15045 : 7 : bool seen_len_param = false;
15046 : 7 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
15047 : :
15048 : 8 : for (; me_arg_param; me_arg_param = me_arg_param->next)
15049 : : {
15050 : 7 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
15051 : : me_arg_param->name, true, true, NULL);
15052 : :
15053 : 7 : gcc_assert (c != NULL);
15054 : :
15055 : 7 : if (c->attr.pdt_kind)
15056 : 1 : continue;
15057 : :
15058 : : /* Getting here implies that there is a pdt_len parameter
15059 : : in the list. */
15060 : : seen_len_param = true;
15061 : : break;
15062 : : }
15063 : :
15064 : 7 : if (seen_len_param)
15065 : : {
15066 : 6 : gfc_error ("All LEN type parameters of the passed dummy "
15067 : : "argument %qs of %qs at %L must be ASSUMED.",
15068 : : me_arg->name, proc->name, &where);
15069 : 6 : goto error;
15070 : : }
15071 : : }
15072 : :
15073 : 2457 : gcc_assert (me_arg->ts.type == BT_CLASS);
15074 : 2457 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
15075 : : {
15076 : 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
15077 : : " scalar", proc->name, &where);
15078 : 1 : goto error;
15079 : : }
15080 : 2456 : if (CLASS_DATA (me_arg)->attr.allocatable)
15081 : : {
15082 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
15083 : : " be ALLOCATABLE", proc->name, &where);
15084 : 2 : goto error;
15085 : : }
15086 : 2454 : if (CLASS_DATA (me_arg)->attr.class_pointer)
15087 : : {
15088 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
15089 : : " be POINTER", proc->name, &where);
15090 : 2 : goto error;
15091 : : }
15092 : : }
15093 : :
15094 : : /* If we are extending some type, check that we don't override a procedure
15095 : : flagged NON_OVERRIDABLE. */
15096 : 7502 : stree->n.tb->overridden = NULL;
15097 : 7502 : if (super_type)
15098 : : {
15099 : 1324 : gfc_symtree* overridden;
15100 : 1324 : overridden = gfc_find_typebound_proc (super_type, NULL,
15101 : : stree->name, true, NULL);
15102 : :
15103 : 1324 : if (overridden)
15104 : : {
15105 : 1106 : if (overridden->n.tb)
15106 : 1106 : stree->n.tb->overridden = overridden->n.tb;
15107 : :
15108 : 1106 : if (!gfc_check_typebound_override (stree, overridden))
15109 : 26 : goto error;
15110 : : }
15111 : : }
15112 : :
15113 : : /* See if there's a name collision with a component directly in this type. */
15114 : 17453 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
15115 : 9978 : if (!strcmp (comp->name, stree->name))
15116 : : {
15117 : 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
15118 : : " %qs",
15119 : : stree->name, &where, resolve_bindings_derived->name);
15120 : 1 : goto error;
15121 : : }
15122 : :
15123 : : /* Try to find a name collision with an inherited component. */
15124 : 7475 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
15125 : : NULL))
15126 : : {
15127 : 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
15128 : : " component of %qs",
15129 : : stree->name, &where, resolve_bindings_derived->name);
15130 : 1 : goto error;
15131 : : }
15132 : :
15133 : 7474 : stree->n.tb->error = 0;
15134 : 7474 : return;
15135 : :
15136 : 82 : error:
15137 : 82 : resolve_bindings_result = false;
15138 : 82 : stree->n.tb->error = 1;
15139 : : }
15140 : :
15141 : :
15142 : : static bool
15143 : 74362 : resolve_typebound_procedures (gfc_symbol* derived)
15144 : : {
15145 : 74362 : int op;
15146 : 74362 : gfc_symbol* super_type;
15147 : :
15148 : 74362 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
15149 : : return true;
15150 : :
15151 : 4190 : super_type = gfc_get_derived_super_type (derived);
15152 : 4190 : if (super_type)
15153 : 759 : resolve_symbol (super_type);
15154 : :
15155 : 4190 : resolve_bindings_derived = derived;
15156 : 4190 : resolve_bindings_result = true;
15157 : :
15158 : 4190 : if (derived->f2k_derived->tb_sym_root)
15159 : 4190 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
15160 : : &resolve_typebound_procedure);
15161 : :
15162 : 4190 : if (derived->f2k_derived->tb_uop_root)
15163 : 38 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
15164 : : &resolve_typebound_user_op);
15165 : :
15166 : 121510 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
15167 : : {
15168 : 117320 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
15169 : 117320 : if (p && !resolve_typebound_intrinsic_op (derived,
15170 : : (gfc_intrinsic_op)op, p))
15171 : 7 : resolve_bindings_result = false;
15172 : : }
15173 : :
15174 : 4190 : return resolve_bindings_result;
15175 : : }
15176 : :
15177 : :
15178 : : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
15179 : : to give all identical derived types the same backend_decl. */
15180 : : static void
15181 : 166264 : add_dt_to_dt_list (gfc_symbol *derived)
15182 : : {
15183 : 166264 : if (!derived->dt_next)
15184 : : {
15185 : 69723 : if (gfc_derived_types)
15186 : : {
15187 : 56583 : derived->dt_next = gfc_derived_types->dt_next;
15188 : 56583 : gfc_derived_types->dt_next = derived;
15189 : : }
15190 : : else
15191 : : {
15192 : 13140 : derived->dt_next = derived;
15193 : : }
15194 : 69723 : gfc_derived_types = derived;
15195 : : }
15196 : 166264 : }
15197 : :
15198 : :
15199 : : /* Ensure that a derived-type is really not abstract, meaning that every
15200 : : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
15201 : :
15202 : : static bool
15203 : 6104 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
15204 : : {
15205 : 6104 : if (!st)
15206 : : return true;
15207 : :
15208 : 2437 : if (!ensure_not_abstract_walker (sub, st->left))
15209 : : return false;
15210 : 2435 : if (!ensure_not_abstract_walker (sub, st->right))
15211 : : return false;
15212 : :
15213 : 2434 : if (st->n.tb && st->n.tb->deferred)
15214 : : {
15215 : 1809 : gfc_symtree* overriding;
15216 : 1809 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
15217 : 1809 : if (!overriding)
15218 : : return false;
15219 : 1808 : gcc_assert (overriding->n.tb);
15220 : 1808 : if (overriding->n.tb->deferred)
15221 : : {
15222 : 4 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
15223 : : " %qs is DEFERRED and not overridden",
15224 : : sub->name, &sub->declared_at, st->name);
15225 : 4 : return false;
15226 : : }
15227 : : }
15228 : :
15229 : : return true;
15230 : : }
15231 : :
15232 : : static bool
15233 : 1156 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
15234 : : {
15235 : : /* The algorithm used here is to recursively travel up the ancestry of sub
15236 : : and for each ancestor-type, check all bindings. If any of them is
15237 : : DEFERRED, look it up starting from sub and see if the found (overriding)
15238 : : binding is not DEFERRED.
15239 : : This is not the most efficient way to do this, but it should be ok and is
15240 : : clearer than something sophisticated. */
15241 : :
15242 : 1233 : gcc_assert (ancestor && !sub->attr.abstract);
15243 : :
15244 : 1233 : if (!ancestor->attr.abstract)
15245 : : return true;
15246 : :
15247 : : /* Walk bindings of this ancestor. */
15248 : 1232 : if (ancestor->f2k_derived)
15249 : : {
15250 : 1232 : bool t;
15251 : 1232 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
15252 : 1232 : if (!t)
15253 : : return false;
15254 : : }
15255 : :
15256 : : /* Find next ancestor type and recurse on it. */
15257 : 1227 : ancestor = gfc_get_derived_super_type (ancestor);
15258 : 1227 : if (ancestor)
15259 : : return ensure_not_abstract (sub, ancestor);
15260 : :
15261 : : return true;
15262 : : }
15263 : :
15264 : :
15265 : : /* This check for typebound defined assignments is done recursively
15266 : : since the order in which derived types are resolved is not always in
15267 : : order of the declarations. */
15268 : :
15269 : : static void
15270 : 168543 : check_defined_assignments (gfc_symbol *derived)
15271 : : {
15272 : 168543 : gfc_component *c;
15273 : :
15274 : 634337 : for (c = derived->components; c; c = c->next)
15275 : : {
15276 : 467271 : if (!gfc_bt_struct (c->ts.type)
15277 : 116119 : || c->attr.pointer
15278 : 16603 : || c->attr.proc_pointer_comp
15279 : : || c->attr.class_pointer
15280 : 16603 : || c->attr.proc_pointer)
15281 : 451150 : continue;
15282 : :
15283 : 16121 : if (c->ts.u.derived->attr.defined_assign_comp
15284 : 15916 : || (c->ts.u.derived->f2k_derived
15285 : 15560 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
15286 : : {
15287 : 1453 : derived->attr.defined_assign_comp = 1;
15288 : 1453 : return;
15289 : : }
15290 : :
15291 : 14668 : if (c->attr.allocatable)
15292 : 5090 : continue;
15293 : :
15294 : 9578 : check_defined_assignments (c->ts.u.derived);
15295 : 9578 : if (c->ts.u.derived->attr.defined_assign_comp)
15296 : : {
15297 : 24 : derived->attr.defined_assign_comp = 1;
15298 : 24 : return;
15299 : : }
15300 : : }
15301 : : }
15302 : :
15303 : :
15304 : : /* Resolve a single component of a derived type or structure. */
15305 : :
15306 : : static bool
15307 : 451508 : resolve_component (gfc_component *c, gfc_symbol *sym)
15308 : : {
15309 : 451508 : gfc_symbol *super_type;
15310 : 451508 : symbol_attribute *attr;
15311 : :
15312 : 451508 : if (c->attr.artificial)
15313 : : return true;
15314 : :
15315 : : /* Do not allow vtype components to be resolved in nameless namespaces
15316 : : such as block data because the procedure pointers will cause ICEs
15317 : : and vtables are not needed in these contexts. */
15318 : 366389 : if (sym->attr.vtype && sym->attr.use_assoc
15319 : 139566 : && sym->ns->proc_name == NULL)
15320 : : return true;
15321 : :
15322 : : /* F2008, C442. */
15323 : 366359 : if ((!sym->attr.is_class || c != sym->components)
15324 : 366359 : && c->attr.codimension
15325 : 159 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
15326 : : {
15327 : 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
15328 : : "deferred shape", c->name, &c->loc);
15329 : 4 : return false;
15330 : : }
15331 : :
15332 : : /* F2008, C443. */
15333 : 366355 : if (c->attr.codimension && c->ts.type == BT_DERIVED
15334 : 69 : && c->ts.u.derived->ts.is_iso_c)
15335 : : {
15336 : 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15337 : : "shall not be a coarray", c->name, &c->loc);
15338 : 1 : return false;
15339 : : }
15340 : :
15341 : : /* F2008, C444. */
15342 : 366354 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
15343 : 22 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
15344 : 22 : || c->attr.allocatable))
15345 : : {
15346 : 3 : gfc_error ("Component %qs at %L with coarray component "
15347 : : "shall be a nonpointer, nonallocatable scalar",
15348 : : c->name, &c->loc);
15349 : 3 : return false;
15350 : : }
15351 : :
15352 : : /* F2008, C448. */
15353 : 366351 : if (c->ts.type == BT_CLASS)
15354 : : {
15355 : 6633 : if (c->attr.class_ok && CLASS_DATA (c))
15356 : : {
15357 : 6623 : attr = &(CLASS_DATA (c)->attr);
15358 : :
15359 : : /* Fix up contiguous attribute. */
15360 : 6623 : if (c->attr.contiguous)
15361 : 3 : attr->contiguous = 1;
15362 : : }
15363 : : else
15364 : : attr = NULL;
15365 : : }
15366 : : else
15367 : 359718 : attr = &c->attr;
15368 : :
15369 : 366344 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
15370 : : {
15371 : 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
15372 : : "is not an array pointer", c->name, &c->loc);
15373 : 5 : return false;
15374 : : }
15375 : :
15376 : : /* F2003, 15.2.1 - length has to be one. */
15377 : 34523 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
15378 : 366365 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
15379 : 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
15380 : 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
15381 : : {
15382 : 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
15383 : : c->name, &c->loc);
15384 : 1 : return false;
15385 : : }
15386 : :
15387 : 366345 : if (c->attr.proc_pointer && c->ts.interface)
15388 : : {
15389 : 55780 : gfc_symbol *ifc = c->ts.interface;
15390 : :
15391 : 55780 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
15392 : : {
15393 : 6 : c->tb->error = 1;
15394 : 6 : return false;
15395 : : }
15396 : :
15397 : 55774 : if (ifc->attr.if_source || ifc->attr.intrinsic)
15398 : : {
15399 : : /* Resolve interface and copy attributes. */
15400 : 55743 : if (ifc->formal && !ifc->formal_ns)
15401 : 40735 : resolve_symbol (ifc);
15402 : 55743 : if (ifc->attr.intrinsic)
15403 : 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
15404 : :
15405 : 55743 : if (ifc->result)
15406 : : {
15407 : 8132 : c->ts = ifc->result->ts;
15408 : 8132 : c->attr.allocatable = ifc->result->attr.allocatable;
15409 : 8132 : c->attr.pointer = ifc->result->attr.pointer;
15410 : 8132 : c->attr.dimension = ifc->result->attr.dimension;
15411 : 8132 : c->as = gfc_copy_array_spec (ifc->result->as);
15412 : 8132 : c->attr.class_ok = ifc->result->attr.class_ok;
15413 : : }
15414 : : else
15415 : : {
15416 : 47611 : c->ts = ifc->ts;
15417 : 47611 : c->attr.allocatable = ifc->attr.allocatable;
15418 : 47611 : c->attr.pointer = ifc->attr.pointer;
15419 : 47611 : c->attr.dimension = ifc->attr.dimension;
15420 : 47611 : c->as = gfc_copy_array_spec (ifc->as);
15421 : 47611 : c->attr.class_ok = ifc->attr.class_ok;
15422 : : }
15423 : 55743 : c->ts.interface = ifc;
15424 : 55743 : c->attr.function = ifc->attr.function;
15425 : 55743 : c->attr.subroutine = ifc->attr.subroutine;
15426 : :
15427 : 55743 : c->attr.pure = ifc->attr.pure;
15428 : 55743 : c->attr.elemental = ifc->attr.elemental;
15429 : 55743 : c->attr.recursive = ifc->attr.recursive;
15430 : 55743 : c->attr.always_explicit = ifc->attr.always_explicit;
15431 : 55743 : c->attr.ext_attr |= ifc->attr.ext_attr;
15432 : : /* Copy char length. */
15433 : 55743 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
15434 : : {
15435 : 212 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
15436 : 167 : if (cl->length && !cl->resolved
15437 : 220 : && !gfc_resolve_expr (cl->length))
15438 : : {
15439 : 0 : c->tb->error = 1;
15440 : 0 : return false;
15441 : : }
15442 : 212 : c->ts.u.cl = cl;
15443 : : }
15444 : : }
15445 : : }
15446 : 310565 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
15447 : : {
15448 : : /* Since PPCs are not implicitly typed, a PPC without an explicit
15449 : : interface must be a subroutine. */
15450 : 43810 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
15451 : : }
15452 : :
15453 : : /* Procedure pointer components: Check PASS arg. */
15454 : 366339 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
15455 : 83159 : && !sym->attr.vtype)
15456 : : {
15457 : 94 : gfc_symbol* me_arg;
15458 : :
15459 : 94 : if (c->tb->pass_arg)
15460 : : {
15461 : 19 : gfc_formal_arglist* i;
15462 : :
15463 : : /* If an explicit passing argument name is given, walk the arg-list
15464 : : and look for it. */
15465 : :
15466 : 19 : me_arg = NULL;
15467 : 19 : c->tb->pass_arg_num = 1;
15468 : 33 : for (i = c->ts.interface->formal; i; i = i->next)
15469 : : {
15470 : 32 : if (!strcmp (i->sym->name, c->tb->pass_arg))
15471 : : {
15472 : : me_arg = i->sym;
15473 : : break;
15474 : : }
15475 : 14 : c->tb->pass_arg_num++;
15476 : : }
15477 : :
15478 : 19 : if (!me_arg)
15479 : : {
15480 : 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
15481 : : "at %L has no argument %qs", c->name,
15482 : : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
15483 : 1 : c->tb->error = 1;
15484 : 1 : return false;
15485 : : }
15486 : : }
15487 : : else
15488 : : {
15489 : : /* Otherwise, take the first one; there should in fact be at least
15490 : : one. */
15491 : 75 : c->tb->pass_arg_num = 1;
15492 : 75 : if (!c->ts.interface->formal)
15493 : : {
15494 : 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
15495 : : "must have at least one argument",
15496 : : c->name, &c->loc);
15497 : 3 : c->tb->error = 1;
15498 : 3 : return false;
15499 : : }
15500 : 72 : me_arg = c->ts.interface->formal->sym;
15501 : : }
15502 : :
15503 : : /* Now check that the argument-type matches. */
15504 : 72 : gcc_assert (me_arg);
15505 : 90 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
15506 : 89 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
15507 : 89 : || (me_arg->ts.type == BT_CLASS
15508 : 81 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
15509 : : {
15510 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
15511 : : " the derived type %qs", me_arg->name, c->name,
15512 : : me_arg->name, &c->loc, sym->name);
15513 : 1 : c->tb->error = 1;
15514 : 1 : return false;
15515 : : }
15516 : :
15517 : : /* Check for F03:C453. */
15518 : 89 : if (CLASS_DATA (me_arg)->attr.dimension)
15519 : : {
15520 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15521 : : "must be scalar", me_arg->name, c->name, me_arg->name,
15522 : : &c->loc);
15523 : 1 : c->tb->error = 1;
15524 : 1 : return false;
15525 : : }
15526 : :
15527 : 88 : if (CLASS_DATA (me_arg)->attr.class_pointer)
15528 : : {
15529 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15530 : : "may not have the POINTER attribute", me_arg->name,
15531 : : c->name, me_arg->name, &c->loc);
15532 : 1 : c->tb->error = 1;
15533 : 1 : return false;
15534 : : }
15535 : :
15536 : 87 : if (CLASS_DATA (me_arg)->attr.allocatable)
15537 : : {
15538 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15539 : : "may not be ALLOCATABLE", me_arg->name, c->name,
15540 : : me_arg->name, &c->loc);
15541 : 1 : c->tb->error = 1;
15542 : 1 : return false;
15543 : : }
15544 : :
15545 : 86 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
15546 : : {
15547 : 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15548 : : " at %L", c->name, &c->loc);
15549 : 2 : return false;
15550 : : }
15551 : :
15552 : : }
15553 : :
15554 : : /* Check type-spec if this is not the parent-type component. */
15555 : 366329 : if (((sym->attr.is_class
15556 : 10765 : && (!sym->components->ts.u.derived->attr.extension
15557 : 2150 : || c != CLASS_DATA (sym->components)))
15558 : 356728 : || (!sym->attr.is_class
15559 : 355564 : && (!sym->attr.extension || c != sym->components)))
15560 : 359268 : && !sym->attr.vtype
15561 : 504114 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
15562 : : return false;
15563 : :
15564 : 366328 : super_type = gfc_get_derived_super_type (sym);
15565 : :
15566 : : /* If this type is an extension, set the accessibility of the parent
15567 : : component. */
15568 : 366328 : if (super_type
15569 : 22444 : && ((sym->attr.is_class
15570 : 10765 : && c == CLASS_DATA (sym->components))
15571 : 15017 : || (!sym->attr.is_class && c == sym->components))
15572 : 13324 : && strcmp (super_type->name, c->name) == 0)
15573 : 5763 : c->attr.access = super_type->attr.access;
15574 : :
15575 : : /* If this type is an extension, see if this component has the same name
15576 : : as an inherited type-bound procedure. */
15577 : 22444 : if (super_type && !sym->attr.is_class
15578 : 11679 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
15579 : : {
15580 : 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
15581 : : " inherited type-bound procedure",
15582 : : c->name, sym->name, &c->loc);
15583 : 1 : return false;
15584 : : }
15585 : :
15586 : 366327 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
15587 : 8684 : && !c->ts.deferred)
15588 : : {
15589 : 6696 : if (c->ts.u.cl->length == NULL
15590 : 6690 : || (!resolve_charlen(c->ts.u.cl))
15591 : 13385 : || !gfc_is_constant_expr (c->ts.u.cl->length))
15592 : : {
15593 : 9 : gfc_error ("Character length of component %qs needs to "
15594 : : "be a constant specification expression at %L",
15595 : : c->name,
15596 : 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
15597 : 9 : return false;
15598 : : }
15599 : :
15600 : 6687 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
15601 : : {
15602 : 2 : if (!c->ts.u.cl->length->error)
15603 : : {
15604 : 1 : gfc_error ("Character length expression of component %qs at %L "
15605 : : "must be of INTEGER type, found %s",
15606 : 1 : c->name, &c->ts.u.cl->length->where,
15607 : : gfc_basic_typename (c->ts.u.cl->length->ts.type));
15608 : 1 : c->ts.u.cl->length->error = 1;
15609 : : }
15610 : 2 : return false;
15611 : : }
15612 : : }
15613 : :
15614 : 366316 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
15615 : 2032 : && !c->attr.pointer && !c->attr.allocatable)
15616 : : {
15617 : 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
15618 : : "length must be a POINTER or ALLOCATABLE",
15619 : : c->name, sym->name, &c->loc);
15620 : 1 : return false;
15621 : : }
15622 : :
15623 : : /* Add the hidden deferred length field. */
15624 : 366315 : if (c->ts.type == BT_CHARACTER
15625 : 8898 : && (c->ts.deferred || c->attr.pdt_string)
15626 : 2167 : && !c->attr.function
15627 : 2123 : && !sym->attr.is_class)
15628 : : {
15629 : 1995 : char name[GFC_MAX_SYMBOL_LEN+9];
15630 : 1995 : gfc_component *strlen;
15631 : 1995 : sprintf (name, "_%s_length", c->name);
15632 : 1995 : strlen = gfc_find_component (sym, name, true, true, NULL);
15633 : 1995 : if (strlen == NULL)
15634 : : {
15635 : 421 : if (!gfc_add_component (sym, name, &strlen))
15636 : 0 : return false;
15637 : 421 : strlen->ts.type = BT_INTEGER;
15638 : 421 : strlen->ts.kind = gfc_charlen_int_kind;
15639 : 421 : strlen->attr.access = ACCESS_PRIVATE;
15640 : 421 : strlen->attr.artificial = 1;
15641 : : }
15642 : : }
15643 : :
15644 : 366315 : if (c->ts.type == BT_DERIVED
15645 : 58160 : && sym->component_access != ACCESS_PRIVATE
15646 : 57270 : && gfc_check_symbol_access (sym)
15647 : 112960 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
15648 : 56446 : && !c->ts.u.derived->attr.use_assoc
15649 : 22845 : && !gfc_check_symbol_access (c->ts.u.derived)
15650 : 366448 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
15651 : : "PRIVATE type and cannot be a component of "
15652 : : "%qs, which is PUBLIC at %L", c->name,
15653 : : sym->name, &sym->declared_at))
15654 : : return false;
15655 : :
15656 : 366314 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
15657 : : {
15658 : 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
15659 : : "type %s", c->name, &c->loc, sym->name);
15660 : 2 : return false;
15661 : : }
15662 : :
15663 : 366312 : if (sym->attr.sequence)
15664 : : {
15665 : 2509 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
15666 : : {
15667 : 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
15668 : : "not have the SEQUENCE attribute",
15669 : : c->ts.u.derived->name, &sym->declared_at);
15670 : 0 : return false;
15671 : : }
15672 : : }
15673 : :
15674 : 366312 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
15675 : 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
15676 : 366312 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
15677 : 6947 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
15678 : 0 : CLASS_DATA (c)->ts.u.derived
15679 : 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
15680 : :
15681 : : /* If an allocatable component derived type is of the same type as
15682 : : the enclosing derived type, we need a vtable generating so that
15683 : : the __deallocate procedure is created. */
15684 : 366312 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
15685 : 65119 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
15686 : 166 : gfc_find_vtab (&c->ts);
15687 : :
15688 : : /* Ensure that all the derived type components are put on the
15689 : : derived type list; even in formal namespaces, where derived type
15690 : : pointer components might not have been declared. */
15691 : 366312 : if (c->ts.type == BT_DERIVED
15692 : 58159 : && c->ts.u.derived
15693 : 58159 : && c->ts.u.derived->components
15694 : 55248 : && c->attr.pointer
15695 : 42839 : && sym != c->ts.u.derived)
15696 : 4854 : add_dt_to_dt_list (c->ts.u.derived);
15697 : :
15698 : 366312 : if (c->as && c->as->type != AS_DEFERRED
15699 : 5533 : && (c->attr.pointer || c->attr.allocatable))
15700 : : return false;
15701 : :
15702 : 366296 : if (!gfc_resolve_array_spec (c->as,
15703 : 366296 : !(c->attr.pointer || c->attr.proc_pointer
15704 : : || c->attr.allocatable)))
15705 : : return false;
15706 : :
15707 : 132551 : if (c->initializer && !sym->attr.vtype
15708 : 25837 : && !c->attr.pdt_kind && !c->attr.pdt_len
15709 : 390968 : && !gfc_check_assign_symbol (sym, c, c->initializer))
15710 : : return false;
15711 : :
15712 : : return true;
15713 : : }
15714 : :
15715 : :
15716 : : /* Be nice about the locus for a structure expression - show the locus of the
15717 : : first non-null sub-expression if we can. */
15718 : :
15719 : : static locus *
15720 : 4 : cons_where (gfc_expr *struct_expr)
15721 : : {
15722 : 4 : gfc_constructor *cons;
15723 : :
15724 : 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
15725 : :
15726 : 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
15727 : 12 : for (; cons; cons = gfc_constructor_next (cons))
15728 : : {
15729 : 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
15730 : 4 : return &cons->expr->where;
15731 : : }
15732 : :
15733 : 0 : return &struct_expr->where;
15734 : : }
15735 : :
15736 : : /* Resolve the components of a structure type. Much less work than derived
15737 : : types. */
15738 : :
15739 : : static bool
15740 : 913 : resolve_fl_struct (gfc_symbol *sym)
15741 : : {
15742 : 913 : gfc_component *c;
15743 : 913 : gfc_expr *init = NULL;
15744 : 913 : bool success;
15745 : :
15746 : : /* Make sure UNIONs do not have overlapping initializers. */
15747 : 913 : if (sym->attr.flavor == FL_UNION)
15748 : : {
15749 : 498 : for (c = sym->components; c; c = c->next)
15750 : : {
15751 : 331 : if (init && c->initializer)
15752 : : {
15753 : 2 : gfc_error ("Conflicting initializers in union at %L and %L",
15754 : : cons_where (init), cons_where (c->initializer));
15755 : 2 : gfc_free_expr (c->initializer);
15756 : 2 : c->initializer = NULL;
15757 : : }
15758 : 291 : if (init == NULL)
15759 : 291 : init = c->initializer;
15760 : : }
15761 : : }
15762 : :
15763 : 913 : success = true;
15764 : 2830 : for (c = sym->components; c; c = c->next)
15765 : 1917 : if (!resolve_component (c, sym))
15766 : 0 : success = false;
15767 : :
15768 : 913 : if (!success)
15769 : : return false;
15770 : :
15771 : 913 : if (sym->components)
15772 : 862 : add_dt_to_dt_list (sym);
15773 : :
15774 : : return true;
15775 : : }
15776 : :
15777 : :
15778 : : /* Resolve the components of a derived type. This does not have to wait until
15779 : : resolution stage, but can be done as soon as the dt declaration has been
15780 : : parsed. */
15781 : :
15782 : : static bool
15783 : 159051 : resolve_fl_derived0 (gfc_symbol *sym)
15784 : : {
15785 : 159051 : gfc_symbol* super_type;
15786 : 159051 : gfc_component *c;
15787 : 159051 : gfc_formal_arglist *f;
15788 : 159051 : bool success;
15789 : :
15790 : 159051 : if (sym->attr.unlimited_polymorphic)
15791 : : return true;
15792 : :
15793 : 159051 : super_type = gfc_get_derived_super_type (sym);
15794 : :
15795 : : /* F2008, C432. */
15796 : 159051 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
15797 : : {
15798 : 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
15799 : : "parent type %qs shall also have one", sym->name,
15800 : : &sym->declared_at, super_type->name);
15801 : 2 : return false;
15802 : : }
15803 : :
15804 : : /* Ensure the extended type gets resolved before we do. */
15805 : 15115 : if (super_type && !resolve_fl_derived0 (super_type))
15806 : : return false;
15807 : :
15808 : : /* An ABSTRACT type must be extensible. */
15809 : 159043 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
15810 : : {
15811 : 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
15812 : : sym->name, &sym->declared_at);
15813 : 2 : return false;
15814 : : }
15815 : :
15816 : 159041 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
15817 : : : sym->components;
15818 : :
15819 : : success = true;
15820 : 608632 : for ( ; c != NULL; c = c->next)
15821 : 449591 : if (!resolve_component (c, sym))
15822 : 85 : success = false;
15823 : :
15824 : 159041 : if (!success)
15825 : : return false;
15826 : :
15827 : : /* Now add the caf token field, where needed. */
15828 : 158965 : if (flag_coarray != GFC_FCOARRAY_NONE
15829 : 2903 : && !sym->attr.is_class && !sym->attr.vtype)
15830 : : {
15831 : 4398 : for (c = sym->components; c; c = c->next)
15832 : 2743 : if (!c->attr.dimension && !c->attr.codimension
15833 : 2023 : && (c->attr.allocatable || c->attr.pointer))
15834 : : {
15835 : 572 : char name[GFC_MAX_SYMBOL_LEN+9];
15836 : 572 : gfc_component *token;
15837 : 572 : sprintf (name, "_caf_%s", c->name);
15838 : 572 : token = gfc_find_component (sym, name, true, true, NULL);
15839 : 572 : if (token == NULL)
15840 : : {
15841 : 136 : if (!gfc_add_component (sym, name, &token))
15842 : 0 : return false;
15843 : 136 : token->ts.type = BT_VOID;
15844 : 136 : token->ts.kind = gfc_default_integer_kind;
15845 : 136 : token->attr.access = ACCESS_PRIVATE;
15846 : 136 : token->attr.artificial = 1;
15847 : 136 : token->attr.caf_token = 1;
15848 : : }
15849 : : }
15850 : : }
15851 : :
15852 : 158965 : check_defined_assignments (sym);
15853 : :
15854 : 158965 : if (!sym->attr.defined_assign_comp && super_type)
15855 : 14297 : sym->attr.defined_assign_comp
15856 : 14297 : = super_type->attr.defined_assign_comp;
15857 : :
15858 : : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15859 : : all DEFERRED bindings are overridden. */
15860 : 15108 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
15861 : 1159 : && !sym->attr.is_class
15862 : 2609 : && !ensure_not_abstract (sym, super_type))
15863 : : return false;
15864 : :
15865 : : /* Check that there is a component for every PDT parameter. */
15866 : 158960 : if (sym->attr.pdt_template)
15867 : : {
15868 : 970 : for (f = sym->formal; f; f = f->next)
15869 : : {
15870 : 642 : if (!f->sym)
15871 : 1 : continue;
15872 : 641 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
15873 : 641 : if (c == NULL)
15874 : : {
15875 : 9 : gfc_error ("Parameterized type %qs does not have a component "
15876 : : "corresponding to parameter %qs at %L", sym->name,
15877 : 9 : f->sym->name, &sym->declared_at);
15878 : 9 : break;
15879 : : }
15880 : : }
15881 : : }
15882 : :
15883 : : /* Add derived type to the derived type list. */
15884 : 158960 : add_dt_to_dt_list (sym);
15885 : :
15886 : 158960 : return true;
15887 : : }
15888 : :
15889 : :
15890 : : /* The following procedure does the full resolution of a derived type,
15891 : : including resolution of all type-bound procedures (if present). In contrast
15892 : : to 'resolve_fl_derived0' this can only be done after the module has been
15893 : : parsed completely. */
15894 : :
15895 : : static bool
15896 : 76048 : resolve_fl_derived (gfc_symbol *sym)
15897 : : {
15898 : 76048 : gfc_symbol *gen_dt = NULL;
15899 : :
15900 : 76048 : if (sym->attr.unlimited_polymorphic)
15901 : : return true;
15902 : :
15903 : 76048 : if (!sym->attr.is_class)
15904 : 65243 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
15905 : 50072 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
15906 : 2145 : && (!gen_dt->generic->sym->attr.use_assoc
15907 : 2045 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
15908 : 76181 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
15909 : : "%qs at %L being the same name as derived "
15910 : : "type at %L", sym->name,
15911 : : gen_dt->generic->sym == sym
15912 : 11 : ? gen_dt->generic->next->sym->name
15913 : : : gen_dt->generic->sym->name,
15914 : : gen_dt->generic->sym == sym
15915 : 11 : ? &gen_dt->generic->next->sym->declared_at
15916 : : : &gen_dt->generic->sym->declared_at,
15917 : : &sym->declared_at))
15918 : : return false;
15919 : :
15920 : 76044 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
15921 : : {
15922 : 11 : gfc_error ("Derived type %qs at %L has not been declared",
15923 : : sym->name, &sym->declared_at);
15924 : 11 : return false;
15925 : : }
15926 : :
15927 : : /* Resolve the finalizer procedures. */
15928 : 76033 : if (!gfc_resolve_finalizers (sym, NULL))
15929 : : return false;
15930 : :
15931 : 76030 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
15932 : : {
15933 : : /* Fix up incomplete CLASS symbols. */
15934 : 10805 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
15935 : 10805 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
15936 : :
15937 : : /* Nothing more to do for unlimited polymorphic entities. */
15938 : 10805 : if (data->ts.u.derived->attr.unlimited_polymorphic)
15939 : : {
15940 : 1588 : add_dt_to_dt_list (sym);
15941 : 1588 : return true;
15942 : : }
15943 : 9217 : else if (vptr->ts.u.derived == NULL)
15944 : : {
15945 : 5524 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
15946 : 5524 : gcc_assert (vtab);
15947 : 5524 : vptr->ts.u.derived = vtab->ts.u.derived;
15948 : 5524 : if (!resolve_fl_derived0 (vptr->ts.u.derived))
15949 : : return false;
15950 : : }
15951 : : }
15952 : :
15953 : 74442 : if (!resolve_fl_derived0 (sym))
15954 : : return false;
15955 : :
15956 : : /* Resolve the type-bound procedures. */
15957 : 74362 : if (!resolve_typebound_procedures (sym))
15958 : : return false;
15959 : :
15960 : : /* Generate module vtables subject to their accessibility and their not
15961 : : being vtables or pdt templates. If this is not done class declarations
15962 : : in external procedures wind up with their own version and so SELECT TYPE
15963 : : fails because the vptrs do not have the same address. */
15964 : 74321 : if (gfc_option.allow_std & GFC_STD_F2003
15965 : 74274 : && sym->ns->proc_name
15966 : 74260 : && sym->ns->proc_name->attr.flavor == FL_MODULE
15967 : 19916 : && sym->attr.access != ACCESS_PRIVATE
15968 : 19889 : && !(sym->attr.vtype || sym->attr.pdt_template))
15969 : : {
15970 : 16940 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
15971 : 16940 : gfc_set_sym_referenced (vtab);
15972 : : }
15973 : :
15974 : : return true;
15975 : : }
15976 : :
15977 : :
15978 : : static bool
15979 : 805 : resolve_fl_namelist (gfc_symbol *sym)
15980 : : {
15981 : 805 : gfc_namelist *nl;
15982 : 805 : gfc_symbol *nlsym;
15983 : :
15984 : 2890 : for (nl = sym->namelist; nl; nl = nl->next)
15985 : : {
15986 : : /* Check again, the check in match only works if NAMELIST comes
15987 : : after the decl. */
15988 : 2090 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
15989 : : {
15990 : 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
15991 : : "allowed", nl->sym->name, sym->name, &sym->declared_at);
15992 : 1 : return false;
15993 : : }
15994 : :
15995 : 650 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
15996 : 2097 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
15997 : : "with assumed shape in namelist %qs at %L",
15998 : : nl->sym->name, sym->name, &sym->declared_at))
15999 : : return false;
16000 : :
16001 : 2088 : if (is_non_constant_shape_array (nl->sym)
16002 : 2138 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
16003 : : "with nonconstant shape in namelist %qs at %L",
16004 : 50 : nl->sym->name, sym->name, &sym->declared_at))
16005 : : return false;
16006 : :
16007 : 2087 : if (nl->sym->ts.type == BT_CHARACTER
16008 : 568 : && (nl->sym->ts.u.cl->length == NULL
16009 : 531 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
16010 : 2167 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
16011 : : "nonconstant character length in "
16012 : 80 : "namelist %qs at %L", nl->sym->name,
16013 : : sym->name, &sym->declared_at))
16014 : : return false;
16015 : :
16016 : : }
16017 : :
16018 : : /* Reject PRIVATE objects in a PUBLIC namelist. */
16019 : 800 : if (gfc_check_symbol_access (sym))
16020 : : {
16021 : 2871 : for (nl = sym->namelist; nl; nl = nl->next)
16022 : : {
16023 : 2084 : if (!nl->sym->attr.use_assoc
16024 : 3948 : && !is_sym_host_assoc (nl->sym, sym->ns)
16025 : 4036 : && !gfc_check_symbol_access (nl->sym))
16026 : : {
16027 : 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
16028 : : "cannot be member of PUBLIC namelist %qs at %L",
16029 : 2 : nl->sym->name, sym->name, &sym->declared_at);
16030 : 2 : return false;
16031 : : }
16032 : :
16033 : 2082 : if (nl->sym->ts.type == BT_DERIVED
16034 : 466 : && (nl->sym->ts.u.derived->attr.alloc_comp
16035 : 466 : || nl->sym->ts.u.derived->attr.pointer_comp))
16036 : : {
16037 : 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
16038 : : "namelist %qs at %L with ALLOCATABLE "
16039 : : "or POINTER components", nl->sym->name,
16040 : : sym->name, &sym->declared_at))
16041 : : return false;
16042 : : return true;
16043 : : }
16044 : :
16045 : : /* Types with private components that came here by USE-association. */
16046 : 2077 : if (nl->sym->ts.type == BT_DERIVED
16047 : 2077 : && derived_inaccessible (nl->sym->ts.u.derived))
16048 : : {
16049 : 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
16050 : : "components and cannot be member of namelist %qs at %L",
16051 : : nl->sym->name, sym->name, &sym->declared_at);
16052 : 6 : return false;
16053 : : }
16054 : :
16055 : : /* Types with private components that are defined in the same module. */
16056 : 2071 : if (nl->sym->ts.type == BT_DERIVED
16057 : 910 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
16058 : 2349 : && nl->sym->ts.u.derived->attr.private_comp)
16059 : : {
16060 : 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
16061 : : "cannot be a member of PUBLIC namelist %qs at %L",
16062 : : nl->sym->name, sym->name, &sym->declared_at);
16063 : 0 : return false;
16064 : : }
16065 : : }
16066 : : }
16067 : :
16068 : :
16069 : : /* 14.1.2 A module or internal procedure represent local entities
16070 : : of the same type as a namelist member and so are not allowed. */
16071 : 2855 : for (nl = sym->namelist; nl; nl = nl->next)
16072 : : {
16073 : 2071 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
16074 : 1508 : continue;
16075 : :
16076 : 563 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
16077 : 7 : if ((nl->sym == sym->ns->proc_name)
16078 : 1 : ||
16079 : 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
16080 : 6 : continue;
16081 : :
16082 : 557 : nlsym = NULL;
16083 : 557 : if (nl->sym->name)
16084 : 557 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
16085 : 557 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
16086 : : {
16087 : 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
16088 : : "attribute in %qs at %L", nlsym->name,
16089 : : &sym->declared_at);
16090 : 3 : return false;
16091 : : }
16092 : : }
16093 : :
16094 : : return true;
16095 : : }
16096 : :
16097 : :
16098 : : static bool
16099 : 266049 : resolve_fl_parameter (gfc_symbol *sym)
16100 : : {
16101 : : /* A parameter array's shape needs to be constant. */
16102 : 266049 : if (sym->as != NULL
16103 : 266049 : && (sym->as->type == AS_DEFERRED
16104 : 4923 : || is_non_constant_shape_array (sym)))
16105 : : {
16106 : 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
16107 : : "or of deferred shape", sym->name, &sym->declared_at);
16108 : 17 : return false;
16109 : : }
16110 : :
16111 : : /* Constraints on deferred type parameter. */
16112 : 266032 : if (!deferred_requirements (sym))
16113 : : return false;
16114 : :
16115 : : /* Make sure a parameter that has been implicitly typed still
16116 : : matches the implicit type, since PARAMETER statements can precede
16117 : : IMPLICIT statements. */
16118 : 266031 : if (sym->attr.implicit_type
16119 : 266031 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
16120 : : sym->ns)))
16121 : : {
16122 : 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
16123 : : "later IMPLICIT type", sym->name, &sym->declared_at);
16124 : 0 : return false;
16125 : : }
16126 : :
16127 : : /* Make sure the types of derived parameters are consistent. This
16128 : : type checking is deferred until resolution because the type may
16129 : : refer to a derived type from the host. */
16130 : 266031 : if (sym->ts.type == BT_DERIVED
16131 : 266031 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
16132 : : {
16133 : 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
16134 : 0 : &sym->value->where);
16135 : 0 : return false;
16136 : : }
16137 : :
16138 : : /* F03:C509,C514. */
16139 : 266031 : if (sym->ts.type == BT_CLASS)
16140 : : {
16141 : 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
16142 : : sym->name, &sym->declared_at);
16143 : 0 : return false;
16144 : : }
16145 : :
16146 : : return true;
16147 : : }
16148 : :
16149 : :
16150 : : /* Called by resolve_symbol to check PDTs. */
16151 : :
16152 : : static void
16153 : 522 : resolve_pdt (gfc_symbol* sym)
16154 : : {
16155 : 522 : gfc_symbol *derived = NULL;
16156 : 522 : gfc_actual_arglist *param;
16157 : 522 : gfc_component *c;
16158 : 522 : bool const_len_exprs = true;
16159 : 522 : bool assumed_len_exprs = false;
16160 : 522 : symbol_attribute *attr;
16161 : :
16162 : 522 : if (sym->ts.type == BT_DERIVED)
16163 : : {
16164 : 462 : derived = sym->ts.u.derived;
16165 : 462 : attr = &(sym->attr);
16166 : : }
16167 : 60 : else if (sym->ts.type == BT_CLASS)
16168 : : {
16169 : 60 : derived = CLASS_DATA (sym)->ts.u.derived;
16170 : 60 : attr = &(CLASS_DATA (sym)->attr);
16171 : : }
16172 : : else
16173 : 0 : gcc_unreachable ();
16174 : :
16175 : 522 : gcc_assert (derived->attr.pdt_type);
16176 : :
16177 : 1383 : for (param = sym->param_list; param; param = param->next)
16178 : : {
16179 : 861 : c = gfc_find_component (derived, param->name, false, true, NULL);
16180 : 861 : gcc_assert (c);
16181 : 861 : if (c->attr.pdt_kind)
16182 : 386 : continue;
16183 : :
16184 : 292 : if (param->expr && !gfc_is_constant_expr (param->expr)
16185 : 502 : && c->attr.pdt_len)
16186 : : const_len_exprs = false;
16187 : 448 : else if (param->spec_type == SPEC_ASSUMED)
16188 : 142 : assumed_len_exprs = true;
16189 : :
16190 : 475 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
16191 : 10 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
16192 : 8 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
16193 : 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
16194 : : "parameter %qs and requires either the POINTER "
16195 : : "or ALLOCATABLE attribute",
16196 : : sym->name, &sym->declared_at,
16197 : : param->name);
16198 : :
16199 : : }
16200 : :
16201 : 522 : if (!const_len_exprs
16202 : 27 : && (sym->ns->proc_name->attr.is_main_program
16203 : 26 : || sym->ns->proc_name->attr.flavor == FL_MODULE
16204 : 25 : || sym->attr.save != SAVE_NONE))
16205 : 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
16206 : : "SAVE attribute or be a variable declared in the "
16207 : : "main program, a module or a submodule(F08/C513)",
16208 : : sym->name, &sym->declared_at);
16209 : :
16210 : 522 : if (assumed_len_exprs && !(sym->attr.dummy
16211 : : || sym->attr.select_type_temporary || sym->attr.associate_var))
16212 : 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
16213 : : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
16214 : : sym->name, &sym->declared_at);
16215 : 522 : }
16216 : :
16217 : :
16218 : : /* Resolve the symbol's array spec. */
16219 : :
16220 : : static bool
16221 : 1389258 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
16222 : : {
16223 : 1389258 : gfc_namespace *orig_current_ns = gfc_current_ns;
16224 : 1389258 : gfc_current_ns = gfc_get_spec_ns (sym);
16225 : :
16226 : 1389258 : bool saved_specification_expr = specification_expr;
16227 : 1389258 : specification_expr = true;
16228 : :
16229 : 1389258 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
16230 : :
16231 : 1389258 : specification_expr = saved_specification_expr;
16232 : 1389258 : gfc_current_ns = orig_current_ns;
16233 : :
16234 : 1389258 : return result;
16235 : : }
16236 : :
16237 : :
16238 : : /* Do anything necessary to resolve a symbol. Right now, we just
16239 : : assume that an otherwise unknown symbol is a variable. This sort
16240 : : of thing commonly happens for symbols in module. */
16241 : :
16242 : : static void
16243 : 1525851 : resolve_symbol (gfc_symbol *sym)
16244 : : {
16245 : 1525851 : int check_constant, mp_flag;
16246 : 1525851 : gfc_symtree *symtree;
16247 : 1525851 : gfc_symtree *this_symtree;
16248 : 1525851 : gfc_namespace *ns;
16249 : 1525851 : gfc_component *c;
16250 : 1525851 : symbol_attribute class_attr;
16251 : 1525851 : gfc_array_spec *as;
16252 : :
16253 : 1525851 : if (sym->resolve_symbol_called >= 1)
16254 : 163378 : return;
16255 : 1441057 : sym->resolve_symbol_called = 1;
16256 : :
16257 : : /* No symbol will ever have union type; only components can be unions.
16258 : : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
16259 : : (just like derived type declaration symbols have flavor FL_DERIVED). */
16260 : 1441057 : gcc_assert (sym->ts.type != BT_UNION);
16261 : :
16262 : : /* Coarrayed polymorphic objects with allocatable or pointer components are
16263 : : yet unsupported for -fcoarray=lib. */
16264 : 1441057 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
16265 : 70 : && sym->ts.u.derived && CLASS_DATA (sym)
16266 : 70 : && CLASS_DATA (sym)->attr.codimension
16267 : 59 : && CLASS_DATA (sym)->ts.u.derived
16268 : 58 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
16269 : 58 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
16270 : : {
16271 : 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
16272 : : "type coarrays at %L are unsupported", &sym->declared_at);
16273 : 6 : return;
16274 : : }
16275 : :
16276 : 1441051 : if (sym->attr.artificial)
16277 : : return;
16278 : :
16279 : 1364768 : if (sym->attr.unlimited_polymorphic)
16280 : : return;
16281 : :
16282 : 1363593 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
16283 : : {
16284 : 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
16285 : : "the OpenMP DEPEND clause", &sym->declared_at);
16286 : 4 : return;
16287 : : }
16288 : :
16289 : 1363589 : if (sym->attr.flavor == FL_UNKNOWN
16290 : 1343898 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
16291 : 399560 : && !sym->attr.generic && !sym->attr.external
16292 : 153476 : && sym->attr.if_source == IFSRC_UNKNOWN
16293 : 67665 : && sym->ts.type == BT_UNKNOWN))
16294 : : {
16295 : :
16296 : : /* If we find that a flavorless symbol is an interface in one of the
16297 : : parent namespaces, find its symtree in this namespace, free the
16298 : : symbol and set the symtree to point to the interface symbol. */
16299 : 109087 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
16300 : : {
16301 : 29584 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
16302 : 29584 : if (symtree && (symtree->n.sym->generic ||
16303 : 656 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
16304 : 553 : && sym->ns->construct_entities)))
16305 : : {
16306 : 617 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
16307 : : sym->name);
16308 : 617 : if (this_symtree->n.sym == sym)
16309 : : {
16310 : 609 : symtree->n.sym->refs++;
16311 : 609 : gfc_release_symbol (sym);
16312 : 609 : this_symtree->n.sym = symtree->n.sym;
16313 : 609 : return;
16314 : : }
16315 : : }
16316 : : }
16317 : :
16318 : : /* Otherwise give it a flavor according to such attributes as
16319 : : it has. */
16320 : 79503 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
16321 : 19567 : && sym->attr.intrinsic == 0)
16322 : 19513 : sym->attr.flavor = FL_VARIABLE;
16323 : 59990 : else if (sym->attr.flavor == FL_UNKNOWN)
16324 : : {
16325 : 54 : sym->attr.flavor = FL_PROCEDURE;
16326 : 54 : if (sym->attr.dimension)
16327 : 0 : sym->attr.function = 1;
16328 : : }
16329 : : }
16330 : :
16331 : 1362980 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
16332 : 2125 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
16333 : :
16334 : 1389 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
16335 : 1364369 : && !resolve_procedure_interface (sym))
16336 : : return;
16337 : :
16338 : 1362969 : if (sym->attr.is_protected && !sym->attr.proc_pointer
16339 : 120 : && (sym->attr.procedure || sym->attr.external))
16340 : : {
16341 : 0 : if (sym->attr.external)
16342 : 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
16343 : : "at %L", &sym->declared_at);
16344 : : else
16345 : 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
16346 : : "at %L", &sym->declared_at);
16347 : :
16348 : 0 : return;
16349 : : }
16350 : :
16351 : 1362969 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
16352 : : return;
16353 : :
16354 : 1362199 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
16355 : 1362962 : && !resolve_fl_struct (sym))
16356 : : return;
16357 : :
16358 : : /* Symbols that are module procedures with results (functions) have
16359 : : the types and array specification copied for type checking in
16360 : : procedures that call them, as well as for saving to a module
16361 : : file. These symbols can't stand the scrutiny that their results
16362 : : can. */
16363 : 1362830 : mp_flag = (sym->result != NULL && sym->result != sym);
16364 : :
16365 : : /* Make sure that the intrinsic is consistent with its internal
16366 : : representation. This needs to be done before assigning a default
16367 : : type to avoid spurious warnings. */
16368 : 1332893 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
16369 : 1388505 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
16370 : : return;
16371 : :
16372 : : /* Resolve associate names. */
16373 : 1362801 : if (sym->assoc)
16374 : 5964 : resolve_assoc_var (sym, true);
16375 : :
16376 : : /* Assign default type to symbols that need one and don't have one. */
16377 : 1362801 : if (sym->ts.type == BT_UNKNOWN)
16378 : : {
16379 : 347780 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
16380 : : {
16381 : 11447 : gfc_set_default_type (sym, 1, NULL);
16382 : : }
16383 : :
16384 : 347780 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
16385 : 220421 : && !sym->attr.function && !sym->attr.subroutine
16386 : 349270 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
16387 : 455 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
16388 : :
16389 : 347780 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
16390 : : {
16391 : : /* The specific case of an external procedure should emit an error
16392 : : in the case that there is no implicit type. */
16393 : 85760 : if (!mp_flag)
16394 : : {
16395 : 80486 : if (!sym->attr.mixed_entry_master)
16396 : 80380 : gfc_set_default_type (sym, sym->attr.external, NULL);
16397 : : }
16398 : : else
16399 : : {
16400 : : /* Result may be in another namespace. */
16401 : 5274 : resolve_symbol (sym->result);
16402 : :
16403 : 5274 : if (!sym->result->attr.proc_pointer)
16404 : : {
16405 : 5109 : sym->ts = sym->result->ts;
16406 : 5109 : sym->as = gfc_copy_array_spec (sym->result->as);
16407 : 5109 : sym->attr.dimension = sym->result->attr.dimension;
16408 : 5109 : sym->attr.pointer = sym->result->attr.pointer;
16409 : 5109 : sym->attr.allocatable = sym->result->attr.allocatable;
16410 : 5109 : sym->attr.contiguous = sym->result->attr.contiguous;
16411 : : }
16412 : : }
16413 : : }
16414 : : }
16415 : 1015021 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
16416 : 26782 : resolve_symbol_array_spec (sym->result, false);
16417 : :
16418 : : /* For a CLASS-valued function with a result variable, affirm that it has
16419 : : been resolved also when looking at the symbol 'sym'. */
16420 : 374562 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
16421 : 650 : sym->attr.class_ok = sym->result->attr.class_ok;
16422 : :
16423 : 1362801 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
16424 : 17108 : && CLASS_DATA (sym))
16425 : : {
16426 : 17107 : as = CLASS_DATA (sym)->as;
16427 : 17107 : class_attr = CLASS_DATA (sym)->attr;
16428 : 17107 : class_attr.pointer = class_attr.class_pointer;
16429 : : }
16430 : : else
16431 : : {
16432 : 1345694 : class_attr = sym->attr;
16433 : 1345694 : as = sym->as;
16434 : : }
16435 : :
16436 : : /* F2008, C530. */
16437 : 1362801 : if (sym->attr.contiguous
16438 : 6712 : && (!class_attr.dimension
16439 : 6709 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
16440 : 121 : && !class_attr.pointer)))
16441 : : {
16442 : 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
16443 : : "array pointer or an assumed-shape or assumed-rank array",
16444 : : sym->name, &sym->declared_at);
16445 : 7 : return;
16446 : : }
16447 : :
16448 : : /* Assumed size arrays and assumed shape arrays must be dummy
16449 : : arguments. Array-spec's of implied-shape should have been resolved to
16450 : : AS_EXPLICIT already. */
16451 : :
16452 : 1356206 : if (as)
16453 : : {
16454 : : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
16455 : : specification expression. */
16456 : 123194 : if (as->type == AS_IMPLIED_SHAPE)
16457 : : {
16458 : : int i;
16459 : 1 : for (i=0; i<as->rank; i++)
16460 : : {
16461 : 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
16462 : : {
16463 : 1 : gfc_error ("Bad specification for assumed size array at %L",
16464 : : &as->lower[i]->where);
16465 : 1 : return;
16466 : : }
16467 : : }
16468 : 0 : gcc_unreachable();
16469 : : }
16470 : :
16471 : 123193 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
16472 : 95356 : || as->type == AS_ASSUMED_SHAPE)
16473 : 37775 : && !sym->attr.dummy && !sym->attr.select_type_temporary
16474 : 59 : && !sym->attr.associate_var)
16475 : : {
16476 : 7 : if (as->type == AS_ASSUMED_SIZE)
16477 : 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
16478 : : &sym->declared_at);
16479 : : else
16480 : 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
16481 : : &sym->declared_at);
16482 : 7 : return;
16483 : : }
16484 : : /* TS 29113, C535a. */
16485 : 123186 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
16486 : 60 : && !sym->attr.select_type_temporary
16487 : 60 : && !(cs_base && cs_base->current
16488 : 45 : && cs_base->current->op == EXEC_SELECT_RANK))
16489 : : {
16490 : 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
16491 : : &sym->declared_at);
16492 : 18 : return;
16493 : : }
16494 : 123168 : if (as->type == AS_ASSUMED_RANK
16495 : 21180 : && (sym->attr.codimension || sym->attr.value))
16496 : : {
16497 : 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
16498 : : "CODIMENSION attribute", &sym->declared_at);
16499 : 2 : return;
16500 : : }
16501 : : }
16502 : :
16503 : : /* Make sure symbols with known intent or optional are really dummy
16504 : : variable. Because of ENTRY statement, this has to be deferred
16505 : : until resolution time. */
16506 : :
16507 : 1362766 : if (!sym->attr.dummy
16508 : 976348 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
16509 : : {
16510 : 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
16511 : 2 : return;
16512 : : }
16513 : :
16514 : 1362764 : if (sym->attr.value && !sym->attr.dummy)
16515 : : {
16516 : 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
16517 : : "it is not a dummy argument", sym->name, &sym->declared_at);
16518 : 2 : return;
16519 : : }
16520 : :
16521 : 1362762 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
16522 : : {
16523 : 546 : gfc_charlen *cl = sym->ts.u.cl;
16524 : 546 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
16525 : : {
16526 : 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
16527 : : "attribute must have constant length",
16528 : : sym->name, &sym->declared_at);
16529 : 2 : return;
16530 : : }
16531 : :
16532 : 544 : if (sym->ts.is_c_interop
16533 : 376 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
16534 : : {
16535 : 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
16536 : : "with VALUE attribute must have length one",
16537 : : sym->name, &sym->declared_at);
16538 : 1 : return;
16539 : : }
16540 : : }
16541 : :
16542 : 1362759 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
16543 : 114681 : && sym->ts.u.derived->attr.generic)
16544 : : {
16545 : 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
16546 : 20 : if (!sym->ts.u.derived)
16547 : : {
16548 : 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
16549 : : "which has not been defined", sym->name,
16550 : : &sym->declared_at, sym->ts.u.derived->name);
16551 : 0 : sym->ts.type = BT_UNKNOWN;
16552 : 0 : return;
16553 : : }
16554 : : }
16555 : :
16556 : : /* Use the same constraints as TYPE(*), except for the type check
16557 : : and that only scalars and assumed-size arrays are permitted. */
16558 : 1362759 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
16559 : : {
16560 : 11026 : if (!sym->attr.dummy)
16561 : : {
16562 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16563 : : "a dummy argument", sym->name, &sym->declared_at);
16564 : 1 : return;
16565 : : }
16566 : :
16567 : 11025 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
16568 : 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
16569 : 0 : && sym->ts.type != BT_COMPLEX)
16570 : : {
16571 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16572 : : "of type TYPE(*) or of an numeric intrinsic type",
16573 : : sym->name, &sym->declared_at);
16574 : 0 : return;
16575 : : }
16576 : :
16577 : 11025 : if (sym->attr.allocatable || sym->attr.codimension
16578 : 11025 : || sym->attr.pointer || sym->attr.value)
16579 : : {
16580 : 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16581 : : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
16582 : : "attribute", sym->name, &sym->declared_at);
16583 : 4 : return;
16584 : : }
16585 : :
16586 : 11021 : if (sym->attr.intent == INTENT_OUT)
16587 : : {
16588 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16589 : : "have the INTENT(OUT) attribute",
16590 : : sym->name, &sym->declared_at);
16591 : 0 : return;
16592 : : }
16593 : 11021 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
16594 : : {
16595 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
16596 : : "either be a scalar or an assumed-size array",
16597 : : sym->name, &sym->declared_at);
16598 : 1 : return;
16599 : : }
16600 : :
16601 : : /* Set the type to TYPE(*) and add a dimension(*) to ensure
16602 : : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
16603 : : packing. */
16604 : 11020 : sym->ts.type = BT_ASSUMED;
16605 : 11020 : sym->as = gfc_get_array_spec ();
16606 : 11020 : sym->as->type = AS_ASSUMED_SIZE;
16607 : 11020 : sym->as->rank = 1;
16608 : 11020 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
16609 : : }
16610 : 1351733 : else if (sym->ts.type == BT_ASSUMED)
16611 : : {
16612 : : /* TS 29113, C407a. */
16613 : 8010 : if (!sym->attr.dummy)
16614 : : {
16615 : 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
16616 : : "for dummy variables", sym->name, &sym->declared_at);
16617 : 7 : return;
16618 : : }
16619 : 8003 : if (sym->attr.allocatable || sym->attr.codimension
16620 : 8003 : || sym->attr.pointer || sym->attr.value)
16621 : : {
16622 : 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
16623 : : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
16624 : : sym->name, &sym->declared_at);
16625 : 8 : return;
16626 : : }
16627 : 7995 : if (sym->attr.intent == INTENT_OUT)
16628 : : {
16629 : 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
16630 : : "INTENT(OUT) attribute",
16631 : : sym->name, &sym->declared_at);
16632 : 2 : return;
16633 : : }
16634 : 7993 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
16635 : : {
16636 : 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
16637 : : "explicit-shape array", sym->name, &sym->declared_at);
16638 : 3 : return;
16639 : : }
16640 : : }
16641 : :
16642 : : /* If the symbol is marked as bind(c), that it is declared at module level
16643 : : scope and verify its type and kind. Do not do the latter for symbols
16644 : : that are implicitly typed because that is handled in
16645 : : gfc_set_default_type. Handle dummy arguments and procedure definitions
16646 : : separately. Also, anything that is use associated is not handled here
16647 : : but instead is handled in the module it is declared in. Finally, derived
16648 : : type definitions are allowed to be BIND(C) since that only implies that
16649 : : they're interoperable, and they are checked fully for interoperability
16650 : : when a variable is declared of that type. */
16651 : 1362733 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
16652 : 1362733 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
16653 : 542 : && sym->attr.flavor != FL_DERIVED)
16654 : : {
16655 : 149 : bool t = true;
16656 : :
16657 : : /* First, make sure the variable is declared at the
16658 : : module-level scope (J3/04-007, Section 15.3). */
16659 : 149 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
16660 : 7 : && !sym->attr.in_common)
16661 : : {
16662 : 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
16663 : : "is neither a COMMON block nor declared at the "
16664 : : "module level scope", sym->name, &(sym->declared_at));
16665 : 6 : t = false;
16666 : : }
16667 : 143 : else if (sym->ts.type == BT_CHARACTER
16668 : 143 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
16669 : 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
16670 : 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
16671 : : {
16672 : 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
16673 : 1 : sym->name, &sym->declared_at);
16674 : 1 : t = false;
16675 : : }
16676 : 142 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
16677 : : {
16678 : 1 : t = verify_com_block_vars_c_interop (sym->common_head);
16679 : : }
16680 : 141 : else if (sym->attr.implicit_type == 0)
16681 : : {
16682 : : /* If type() declaration, we need to verify that the components
16683 : : of the given type are all C interoperable, etc. */
16684 : 139 : if (sym->ts.type == BT_DERIVED &&
16685 : 24 : sym->ts.u.derived->attr.is_c_interop != 1)
16686 : : {
16687 : : /* Make sure the user marked the derived type as BIND(C). If
16688 : : not, call the verify routine. This could print an error
16689 : : for the derived type more than once if multiple variables
16690 : : of that type are declared. */
16691 : 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
16692 : 1 : verify_bind_c_derived_type (sym->ts.u.derived);
16693 : 139 : t = false;
16694 : : }
16695 : :
16696 : : /* Verify the variable itself as C interoperable if it
16697 : : is BIND(C). It is not possible for this to succeed if
16698 : : the verify_bind_c_derived_type failed, so don't have to handle
16699 : : any error returned by verify_bind_c_derived_type. */
16700 : 139 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
16701 : : sym->common_block);
16702 : : }
16703 : :
16704 : 147 : if (!t)
16705 : : {
16706 : : /* clear the is_bind_c flag to prevent reporting errors more than
16707 : : once if something failed. */
16708 : 10 : sym->attr.is_bind_c = 0;
16709 : 10 : return;
16710 : : }
16711 : : }
16712 : :
16713 : : /* If a derived type symbol has reached this point, without its
16714 : : type being declared, we have an error. Notice that most
16715 : : conditions that produce undefined derived types have already
16716 : : been dealt with. However, the likes of:
16717 : : implicit type(t) (t) ..... call foo (t) will get us here if
16718 : : the type is not declared in the scope of the implicit
16719 : : statement. Change the type to BT_UNKNOWN, both because it is so
16720 : : and to prevent an ICE. */
16721 : 1362723 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
16722 : 114679 : && sym->ts.u.derived->components == NULL
16723 : 872 : && !sym->ts.u.derived->attr.zero_comp)
16724 : : {
16725 : 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
16726 : : "which has not been defined", sym->name,
16727 : : &sym->declared_at, sym->ts.u.derived->name);
16728 : 3 : sym->ts.type = BT_UNKNOWN;
16729 : 3 : return;
16730 : : }
16731 : :
16732 : : /* Make sure that the derived type has been resolved and that the
16733 : : derived type is visible in the symbol's namespace, if it is a
16734 : : module function and is not PRIVATE. */
16735 : 1362720 : if (sym->ts.type == BT_DERIVED
16736 : 120938 : && sym->ts.u.derived->attr.use_assoc
16737 : 105355 : && sym->ns->proc_name
16738 : 105344 : && sym->ns->proc_name->attr.flavor == FL_MODULE
16739 : 1369190 : && !resolve_fl_derived (sym->ts.u.derived))
16740 : : return;
16741 : :
16742 : : /* Unless the derived-type declaration is use associated, Fortran 95
16743 : : does not allow public entries of private derived types.
16744 : : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
16745 : : 161 in 95-006r3. */
16746 : 1362720 : if (sym->ts.type == BT_DERIVED
16747 : 120938 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
16748 : 8397 : && !sym->ts.u.derived->attr.use_assoc
16749 : 1927 : && gfc_check_symbol_access (sym)
16750 : 1757 : && !gfc_check_symbol_access (sym->ts.u.derived)
16751 : 1362729 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
16752 : : "derived type %qs",
16753 : 9 : (sym->attr.flavor == FL_PARAMETER)
16754 : : ? "parameter" : "variable",
16755 : : sym->name, &sym->declared_at,
16756 : 9 : sym->ts.u.derived->name))
16757 : : return;
16758 : :
16759 : : /* F2008, C1302. */
16760 : 1362713 : if (sym->ts.type == BT_DERIVED
16761 : 120931 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16762 : 120931 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
16763 : 120907 : || sym->ts.u.derived->attr.lock_comp)
16764 : 37 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
16765 : : {
16766 : 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16767 : : "type LOCK_TYPE must be a coarray", sym->name,
16768 : : &sym->declared_at);
16769 : 4 : return;
16770 : : }
16771 : :
16772 : : /* TS18508, C702/C703. */
16773 : 1362709 : if (sym->ts.type == BT_DERIVED
16774 : 120927 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16775 : 120927 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
16776 : 120917 : || sym->ts.u.derived->attr.event_comp)
16777 : 10 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
16778 : : {
16779 : 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
16780 : : "type EVENT_TYPE must be a coarray", sym->name,
16781 : : &sym->declared_at);
16782 : 1 : return;
16783 : : }
16784 : :
16785 : : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
16786 : : default initialization is defined (5.1.2.4.4). */
16787 : 1362708 : if (sym->ts.type == BT_DERIVED
16788 : 120926 : && sym->attr.dummy
16789 : 36781 : && sym->attr.intent == INTENT_OUT
16790 : 2156 : && sym->as
16791 : 375 : && sym->as->type == AS_ASSUMED_SIZE)
16792 : : {
16793 : 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
16794 : : {
16795 : 1 : if (c->initializer)
16796 : : {
16797 : 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
16798 : : "ASSUMED SIZE and so cannot have a default initializer",
16799 : : sym->name, &sym->declared_at);
16800 : 1 : return;
16801 : : }
16802 : : }
16803 : : }
16804 : :
16805 : : /* F2008, C542. */
16806 : 1362707 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16807 : 36780 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
16808 : : {
16809 : 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
16810 : : "INTENT(OUT)", sym->name, &sym->declared_at);
16811 : 0 : return;
16812 : : }
16813 : :
16814 : : /* TS18508. */
16815 : 1362707 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16816 : 36780 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
16817 : : {
16818 : 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16819 : : "INTENT(OUT)", sym->name, &sym->declared_at);
16820 : 0 : return;
16821 : : }
16822 : :
16823 : : /* F2008, C525. */
16824 : 1362707 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16825 : 1362624 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16826 : 17111 : && sym->ts.u.derived && CLASS_DATA (sym)
16827 : 17105 : && CLASS_DATA (sym)->attr.coarray_comp))
16828 : 1362624 : || class_attr.codimension)
16829 : 1380 : && (sym->attr.result || sym->result == sym))
16830 : : {
16831 : 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
16832 : : "a coarray component", sym->name, &sym->declared_at);
16833 : 8 : return;
16834 : : }
16835 : :
16836 : : /* F2008, C524. */
16837 : 1362699 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
16838 : 349 : && sym->ts.u.derived->ts.is_iso_c)
16839 : : {
16840 : 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16841 : : "shall not be a coarray", sym->name, &sym->declared_at);
16842 : 3 : return;
16843 : : }
16844 : :
16845 : : /* F2008, C525. */
16846 : 1362696 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16847 : 1362616 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16848 : 17110 : && sym->ts.u.derived && CLASS_DATA (sym)
16849 : 17104 : && CLASS_DATA (sym)->attr.coarray_comp))
16850 : 80 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
16851 : 80 : || class_attr.allocatable))
16852 : : {
16853 : 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
16854 : : "nonpointer, nonallocatable scalar, which is not a coarray",
16855 : : sym->name, &sym->declared_at);
16856 : 4 : return;
16857 : : }
16858 : :
16859 : : /* F2008, C526. The function-result case was handled above. */
16860 : 1362692 : if (class_attr.codimension
16861 : 1294 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
16862 : : || sym->attr.select_type_temporary
16863 : 227 : || sym->attr.associate_var
16864 : 176 : || (sym->ns->save_all && !sym->attr.automatic)
16865 : 176 : || sym->ns->proc_name->attr.flavor == FL_MODULE
16866 : 176 : || sym->ns->proc_name->attr.is_main_program
16867 : : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
16868 : : {
16869 : 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
16870 : : "nor a dummy argument", sym->name, &sym->declared_at);
16871 : 4 : return;
16872 : : }
16873 : : /* F2008, C528. */
16874 : 1362688 : else if (class_attr.codimension && !sym->attr.select_type_temporary
16875 : 1236 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
16876 : : {
16877 : 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
16878 : : "deferred shape", sym->name, &sym->declared_at);
16879 : 6 : return;
16880 : : }
16881 : 1362682 : else if (class_attr.codimension && class_attr.allocatable && as
16882 : 461 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
16883 : : {
16884 : 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
16885 : : "deferred shape", sym->name, &sym->declared_at);
16886 : 9 : return;
16887 : : }
16888 : :
16889 : : /* F2008, C541. */
16890 : 1362673 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16891 : 1362597 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
16892 : 17105 : && sym->ts.u.derived && CLASS_DATA (sym)
16893 : 17099 : && CLASS_DATA (sym)->attr.coarray_comp))
16894 : 1362597 : || (class_attr.codimension && class_attr.allocatable))
16895 : 528 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
16896 : : {
16897 : 3 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
16898 : : "allocatable coarray or have coarray components",
16899 : : sym->name, &sym->declared_at);
16900 : 3 : return;
16901 : : }
16902 : :
16903 : 1362670 : if (class_attr.codimension && sym->attr.dummy
16904 : 393 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
16905 : : {
16906 : 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16907 : : "procedure %qs", sym->name, &sym->declared_at,
16908 : : sym->ns->proc_name->name);
16909 : 2 : return;
16910 : : }
16911 : :
16912 : 1362668 : if (sym->ts.type == BT_LOGICAL
16913 : 96682 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
16914 : 96679 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
16915 : 26841 : && sym->ns->proc_name->attr.is_bind_c)))
16916 : : {
16917 : : int i;
16918 : 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
16919 : 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
16920 : : break;
16921 : 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
16922 : 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
16923 : : "%L with non-C_Bool kind in BIND(C) procedure "
16924 : : "%qs", sym->name, &sym->declared_at,
16925 : 13 : sym->ns->proc_name->name))
16926 : : return;
16927 : 167 : else if (!gfc_logical_kinds[i].c_bool
16928 : 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
16929 : : "%qs at %L with non-C_Bool kind in "
16930 : : "BIND(C) procedure %qs", sym->name,
16931 : : &sym->declared_at,
16932 : 15 : sym->attr.function ? sym->name
16933 : 13 : : sym->ns->proc_name->name))
16934 : : return;
16935 : : }
16936 : :
16937 : 1362665 : switch (sym->attr.flavor)
16938 : : {
16939 : 560673 : case FL_VARIABLE:
16940 : 560673 : if (!resolve_fl_variable (sym, mp_flag))
16941 : : return;
16942 : : break;
16943 : :
16944 : 399075 : case FL_PROCEDURE:
16945 : 399075 : if (sym->formal && !sym->formal_ns)
16946 : : {
16947 : : /* Check that none of the arguments are a namelist. */
16948 : : gfc_formal_arglist *formal = sym->formal;
16949 : :
16950 : 96818 : for (; formal; formal = formal->next)
16951 : 65958 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
16952 : : {
16953 : 1 : gfc_error ("Namelist %qs cannot be an argument to "
16954 : : "subroutine or function at %L",
16955 : : formal->sym->name, &sym->declared_at);
16956 : 1 : return;
16957 : : }
16958 : : }
16959 : :
16960 : 399074 : if (!resolve_fl_procedure (sym, mp_flag))
16961 : : return;
16962 : : break;
16963 : :
16964 : 805 : case FL_NAMELIST:
16965 : 805 : if (!resolve_fl_namelist (sym))
16966 : : return;
16967 : : break;
16968 : :
16969 : 266049 : case FL_PARAMETER:
16970 : 266049 : if (!resolve_fl_parameter (sym))
16971 : : return;
16972 : : break;
16973 : :
16974 : : default:
16975 : : break;
16976 : : }
16977 : :
16978 : : /* Resolve array specifier. Check as well some constraints
16979 : : on COMMON blocks. */
16980 : :
16981 : 1362476 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
16982 : :
16983 : 1362476 : resolve_symbol_array_spec (sym, check_constant);
16984 : :
16985 : : /* Resolve formal namespaces. */
16986 : 1362476 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
16987 : 214193 : && !sym->attr.contained && !sym->attr.intrinsic)
16988 : 195164 : gfc_resolve (sym->formal_ns);
16989 : :
16990 : : /* Make sure the formal namespace is present. */
16991 : 1362476 : if (sym->formal && !sym->formal_ns)
16992 : : {
16993 : : gfc_formal_arglist *formal = sym->formal;
16994 : 31061 : while (formal && !formal->sym)
16995 : 11 : formal = formal->next;
16996 : :
16997 : 31050 : if (formal)
16998 : : {
16999 : 31039 : sym->formal_ns = formal->sym->ns;
17000 : 31039 : if (sym->formal_ns && sym->ns != formal->sym->ns)
17001 : 22755 : sym->formal_ns->refs++;
17002 : : }
17003 : : }
17004 : :
17005 : : /* Check threadprivate restrictions. */
17006 : 1362476 : if (sym->attr.threadprivate
17007 : 1362476 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
17008 : 32 : && !(sym->ns->save_all && !sym->attr.automatic)
17009 : 31 : && sym->module == NULL
17010 : 16 : && (sym->ns->proc_name == NULL
17011 : 16 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
17012 : 3 : && !sym->ns->proc_name->attr.is_main_program)))
17013 : 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
17014 : :
17015 : : /* Check omp declare target restrictions. */
17016 : 1362476 : if (sym->attr.omp_declare_target
17017 : 1362476 : && sym->attr.flavor == FL_VARIABLE
17018 : 597 : && !sym->attr.save
17019 : 195 : && !(sym->ns->save_all && !sym->attr.automatic)
17020 : 195 : && (!sym->attr.in_common
17021 : 182 : && sym->module == NULL
17022 : 92 : && (sym->ns->proc_name == NULL
17023 : 92 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
17024 : 2 : && !sym->ns->proc_name->attr.is_main_program))))
17025 : 1 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
17026 : : sym->name, &sym->declared_at);
17027 : :
17028 : : /* If we have come this far we can apply default-initializers, as
17029 : : described in 14.7.5, to those variables that have not already
17030 : : been assigned one. */
17031 : 1362476 : if (sym->ts.type == BT_DERIVED
17032 : 120899 : && !sym->value
17033 : 85928 : && !sym->attr.allocatable
17034 : 83374 : && !sym->attr.alloc_comp)
17035 : : {
17036 : 83374 : symbol_attribute *a = &sym->attr;
17037 : :
17038 : 83374 : if ((!a->save && !a->dummy && !a->pointer
17039 : 83374 : && !a->in_common && !a->use_assoc
17040 : 8665 : && a->referenced
17041 : 6918 : && !((a->function || a->result)
17042 : 1167 : && (!a->dimension
17043 : 60 : || sym->ts.u.derived->attr.alloc_comp
17044 : 60 : || sym->ts.u.derived->attr.pointer_comp))
17045 : 5790 : && !(a->function && sym != sym->result))
17046 : 77592 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
17047 : 1340 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
17048 : 7040 : apply_default_init (sym);
17049 : 76334 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
17050 : 10408 : && (sym->ts.u.derived->attr.alloc_comp
17051 : 10408 : || sym->ts.u.derived->attr.pointer_comp))
17052 : : /* Mark the result symbol to be referenced, when it has allocatable
17053 : : components. */
17054 : 700 : sym->result->attr.referenced = 1;
17055 : : }
17056 : :
17057 : 1362476 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
17058 : 16683 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
17059 : 1104 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
17060 : 1029 : && !CLASS_DATA (sym)->attr.class_pointer
17061 : 1029 : && !CLASS_DATA (sym)->attr.allocatable)
17062 : 731 : apply_default_init (sym);
17063 : :
17064 : : /* If this symbol has a type-spec, check it. */
17065 : 1362476 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
17066 : 535863 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
17067 : 1090972 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
17068 : : return;
17069 : :
17070 : 1362473 : if (sym->param_list)
17071 : 522 : resolve_pdt (sym);
17072 : : }
17073 : :
17074 : :
17075 : : /************* Resolve DATA statements *************/
17076 : :
17077 : : static struct
17078 : : {
17079 : : gfc_data_value *vnode;
17080 : : mpz_t left;
17081 : : }
17082 : : values;
17083 : :
17084 : :
17085 : : /* Advance the values structure to point to the next value in the data list. */
17086 : :
17087 : : static bool
17088 : 11571 : next_data_value (void)
17089 : : {
17090 : 17856 : while (mpz_cmp_ui (values.left, 0) == 0)
17091 : : {
17092 : :
17093 : 8786 : if (values.vnode->next == NULL)
17094 : : return false;
17095 : :
17096 : 6285 : values.vnode = values.vnode->next;
17097 : 6285 : mpz_set (values.left, values.vnode->repeat);
17098 : : }
17099 : :
17100 : : return true;
17101 : : }
17102 : :
17103 : :
17104 : : static bool
17105 : 3650 : check_data_variable (gfc_data_variable *var, locus *where)
17106 : : {
17107 : 3650 : gfc_expr *e;
17108 : 3650 : mpz_t size;
17109 : 3650 : mpz_t offset;
17110 : 3650 : bool t;
17111 : 3650 : ar_type mark = AR_UNKNOWN;
17112 : 3650 : int i;
17113 : 3650 : mpz_t section_index[GFC_MAX_DIMENSIONS];
17114 : 3650 : int vector_offset[GFC_MAX_DIMENSIONS];
17115 : 3650 : gfc_ref *ref;
17116 : 3650 : gfc_array_ref *ar;
17117 : 3650 : gfc_symbol *sym;
17118 : 3650 : int has_pointer;
17119 : :
17120 : 3650 : if (!gfc_resolve_expr (var->expr))
17121 : : return false;
17122 : :
17123 : 3650 : ar = NULL;
17124 : 3650 : e = var->expr;
17125 : :
17126 : 3650 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
17127 : 2 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
17128 : 2 : e = e->value.function.actual->expr;
17129 : :
17130 : 3650 : if (e->expr_type != EXPR_VARIABLE)
17131 : : {
17132 : 0 : gfc_error ("Expecting definable entity near %L", where);
17133 : 0 : return false;
17134 : : }
17135 : :
17136 : 3650 : sym = e->symtree->n.sym;
17137 : :
17138 : 3650 : if (sym->ns->is_block_data && !sym->attr.in_common)
17139 : : {
17140 : 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
17141 : : sym->name, &sym->declared_at);
17142 : 2 : return false;
17143 : : }
17144 : :
17145 : 3648 : if (e->ref == NULL && sym->as)
17146 : : {
17147 : 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
17148 : : " declaration", sym->name, where);
17149 : 1 : return false;
17150 : : }
17151 : :
17152 : 3647 : if (gfc_is_coindexed (e))
17153 : : {
17154 : 5 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
17155 : : where);
17156 : 5 : return false;
17157 : : }
17158 : :
17159 : 3642 : has_pointer = sym->attr.pointer;
17160 : :
17161 : 6215 : for (ref = e->ref; ref; ref = ref->next)
17162 : : {
17163 : 2577 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
17164 : : has_pointer = 1;
17165 : :
17166 : 2551 : if (has_pointer)
17167 : : {
17168 : 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
17169 : : {
17170 : 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
17171 : : "be a full array", sym->name, where);
17172 : 1 : return false;
17173 : : }
17174 : :
17175 : 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
17176 : : {
17177 : 1 : gfc_error ("DATA object near %L has the pointer attribute "
17178 : : "and the corresponding DATA value is not a valid "
17179 : : "initial-data-target", where);
17180 : 1 : return false;
17181 : : }
17182 : : }
17183 : :
17184 : 2575 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
17185 : : {
17186 : 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
17187 : : "attribute", ref->u.c.component->name, &e->where);
17188 : 1 : return false;
17189 : : }
17190 : :
17191 : : /* Reject substrings of strings of non-constant length. */
17192 : 2574 : if (ref->type == REF_SUBSTRING
17193 : 93 : && ref->u.ss.length
17194 : 93 : && ref->u.ss.length->length
17195 : 2667 : && !gfc_is_constant_expr (ref->u.ss.length->length))
17196 : 1 : goto bad_charlen;
17197 : : }
17198 : :
17199 : : /* Reject strings with deferred length or non-constant length. */
17200 : 3638 : if (e->ts.type == BT_CHARACTER
17201 : 3638 : && (e->ts.deferred
17202 : 399 : || (e->ts.u.cl->length
17203 : 348 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
17204 : 5 : goto bad_charlen;
17205 : :
17206 : 3633 : mpz_init_set_si (offset, 0);
17207 : :
17208 : 3633 : if (e->rank == 0 || has_pointer)
17209 : : {
17210 : 2693 : mpz_init_set_ui (size, 1);
17211 : 2693 : ref = NULL;
17212 : : }
17213 : : else
17214 : : {
17215 : 940 : ref = e->ref;
17216 : :
17217 : : /* Find the array section reference. */
17218 : 1123 : for (ref = e->ref; ref; ref = ref->next)
17219 : : {
17220 : 1123 : if (ref->type != REF_ARRAY)
17221 : 92 : continue;
17222 : 1031 : if (ref->u.ar.type == AR_ELEMENT)
17223 : 91 : continue;
17224 : : break;
17225 : : }
17226 : 940 : gcc_assert (ref);
17227 : :
17228 : : /* Set marks according to the reference pattern. */
17229 : 940 : switch (ref->u.ar.type)
17230 : : {
17231 : : case AR_FULL:
17232 : : mark = AR_FULL;
17233 : : break;
17234 : :
17235 : 149 : case AR_SECTION:
17236 : 149 : ar = &ref->u.ar;
17237 : : /* Get the start position of array section. */
17238 : 149 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
17239 : 149 : mark = AR_SECTION;
17240 : 149 : break;
17241 : :
17242 : 0 : default:
17243 : 0 : gcc_unreachable ();
17244 : : }
17245 : :
17246 : 940 : if (!gfc_array_size (e, &size))
17247 : : {
17248 : 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
17249 : : where);
17250 : 1 : mpz_clear (offset);
17251 : 1 : return false;
17252 : : }
17253 : : }
17254 : :
17255 : 3632 : t = true;
17256 : :
17257 : 12640 : while (mpz_cmp_ui (size, 0) > 0)
17258 : : {
17259 : 9071 : if (!next_data_value ())
17260 : : {
17261 : 1 : gfc_error ("DATA statement at %L has more variables than values",
17262 : : where);
17263 : 1 : t = false;
17264 : 1 : break;
17265 : : }
17266 : :
17267 : 9070 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
17268 : 9070 : if (!t)
17269 : : break;
17270 : :
17271 : : /* If we have more than one element left in the repeat count,
17272 : : and we have more than one element left in the target variable,
17273 : : then create a range assignment. */
17274 : : /* FIXME: Only done for full arrays for now, since array sections
17275 : : seem tricky. */
17276 : 9051 : if (mark == AR_FULL && ref && ref->next == NULL
17277 : 5976 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
17278 : : {
17279 : 162 : mpz_t range;
17280 : :
17281 : 162 : if (mpz_cmp (size, values.left) >= 0)
17282 : : {
17283 : 141 : mpz_init_set (range, values.left);
17284 : 141 : mpz_sub (size, size, values.left);
17285 : 141 : mpz_set_ui (values.left, 0);
17286 : : }
17287 : : else
17288 : : {
17289 : 21 : mpz_init_set (range, size);
17290 : 21 : mpz_sub (values.left, values.left, size);
17291 : 21 : mpz_set_ui (size, 0);
17292 : : }
17293 : :
17294 : 162 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
17295 : : offset, &range);
17296 : :
17297 : 162 : mpz_add (offset, offset, range);
17298 : 162 : mpz_clear (range);
17299 : :
17300 : 162 : if (!t)
17301 : : break;
17302 : 154 : }
17303 : :
17304 : : /* Assign initial value to symbol. */
17305 : : else
17306 : : {
17307 : 8889 : mpz_sub_ui (values.left, values.left, 1);
17308 : 8889 : mpz_sub_ui (size, size, 1);
17309 : :
17310 : 8889 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
17311 : : offset, NULL);
17312 : 8889 : if (!t)
17313 : : break;
17314 : :
17315 : 8854 : if (mark == AR_FULL)
17316 : 5843 : mpz_add_ui (offset, offset, 1);
17317 : :
17318 : : /* Modify the array section indexes and recalculate the offset
17319 : : for next element. */
17320 : 3011 : else if (mark == AR_SECTION)
17321 : 363 : gfc_advance_section (section_index, ar, &offset, vector_offset);
17322 : : }
17323 : : }
17324 : :
17325 : 3632 : if (mark == AR_SECTION)
17326 : : {
17327 : 340 : for (i = 0; i < ar->dimen; i++)
17328 : 192 : mpz_clear (section_index[i]);
17329 : : }
17330 : :
17331 : 3632 : mpz_clear (size);
17332 : 3632 : mpz_clear (offset);
17333 : :
17334 : 3632 : return t;
17335 : :
17336 : 6 : bad_charlen:
17337 : 6 : gfc_error ("Non-constant character length at %L in DATA statement",
17338 : : &e->where);
17339 : 6 : return false;
17340 : : }
17341 : :
17342 : :
17343 : : static bool traverse_data_var (gfc_data_variable *, locus *);
17344 : :
17345 : : /* Iterate over a list of elements in a DATA statement. */
17346 : :
17347 : : static bool
17348 : 251 : traverse_data_list (gfc_data_variable *var, locus *where)
17349 : : {
17350 : 251 : mpz_t trip;
17351 : 251 : iterator_stack frame;
17352 : 251 : gfc_expr *e, *start, *end, *step;
17353 : 251 : bool retval = true;
17354 : :
17355 : 251 : mpz_init (frame.value);
17356 : 251 : mpz_init (trip);
17357 : :
17358 : 251 : start = gfc_copy_expr (var->iter.start);
17359 : 251 : end = gfc_copy_expr (var->iter.end);
17360 : 251 : step = gfc_copy_expr (var->iter.step);
17361 : :
17362 : 251 : if (!gfc_simplify_expr (start, 1)
17363 : 251 : || start->expr_type != EXPR_CONSTANT)
17364 : : {
17365 : 0 : gfc_error ("start of implied-do loop at %L could not be "
17366 : : "simplified to a constant value", &start->where);
17367 : 0 : retval = false;
17368 : 0 : goto cleanup;
17369 : : }
17370 : 251 : if (!gfc_simplify_expr (end, 1)
17371 : 251 : || end->expr_type != EXPR_CONSTANT)
17372 : : {
17373 : 0 : gfc_error ("end of implied-do loop at %L could not be "
17374 : : "simplified to a constant value", &end->where);
17375 : 0 : retval = false;
17376 : 0 : goto cleanup;
17377 : : }
17378 : 251 : if (!gfc_simplify_expr (step, 1)
17379 : 251 : || step->expr_type != EXPR_CONSTANT)
17380 : : {
17381 : 0 : gfc_error ("step of implied-do loop at %L could not be "
17382 : : "simplified to a constant value", &step->where);
17383 : 0 : retval = false;
17384 : 0 : goto cleanup;
17385 : : }
17386 : 251 : if (mpz_cmp_si (step->value.integer, 0) == 0)
17387 : : {
17388 : 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
17389 : : &step->where);
17390 : 1 : retval = false;
17391 : 1 : goto cleanup;
17392 : : }
17393 : :
17394 : 250 : mpz_set (trip, end->value.integer);
17395 : 250 : mpz_sub (trip, trip, start->value.integer);
17396 : 250 : mpz_add (trip, trip, step->value.integer);
17397 : :
17398 : 250 : mpz_div (trip, trip, step->value.integer);
17399 : :
17400 : 250 : mpz_set (frame.value, start->value.integer);
17401 : :
17402 : 250 : frame.prev = iter_stack;
17403 : 250 : frame.variable = var->iter.var->symtree;
17404 : 250 : iter_stack = &frame;
17405 : :
17406 : 1169 : while (mpz_cmp_ui (trip, 0) > 0)
17407 : : {
17408 : 933 : if (!traverse_data_var (var->list, where))
17409 : : {
17410 : 14 : retval = false;
17411 : 14 : goto cleanup;
17412 : : }
17413 : :
17414 : 919 : e = gfc_copy_expr (var->expr);
17415 : 919 : if (!gfc_simplify_expr (e, 1))
17416 : : {
17417 : 0 : gfc_free_expr (e);
17418 : 0 : retval = false;
17419 : 0 : goto cleanup;
17420 : : }
17421 : :
17422 : 919 : mpz_add (frame.value, frame.value, step->value.integer);
17423 : :
17424 : 919 : mpz_sub_ui (trip, trip, 1);
17425 : : }
17426 : :
17427 : 236 : cleanup:
17428 : 251 : mpz_clear (frame.value);
17429 : 251 : mpz_clear (trip);
17430 : :
17431 : 251 : gfc_free_expr (start);
17432 : 251 : gfc_free_expr (end);
17433 : 251 : gfc_free_expr (step);
17434 : :
17435 : 251 : iter_stack = frame.prev;
17436 : 251 : return retval;
17437 : : }
17438 : :
17439 : :
17440 : : /* Type resolve variables in the variable list of a DATA statement. */
17441 : :
17442 : : static bool
17443 : 3515 : traverse_data_var (gfc_data_variable *var, locus *where)
17444 : : {
17445 : 3515 : bool t;
17446 : :
17447 : 7320 : for (; var; var = var->next)
17448 : : {
17449 : 3901 : if (var->expr == NULL)
17450 : 251 : t = traverse_data_list (var, where);
17451 : : else
17452 : 3650 : t = check_data_variable (var, where);
17453 : :
17454 : 3901 : if (!t)
17455 : : return false;
17456 : : }
17457 : :
17458 : : return true;
17459 : : }
17460 : :
17461 : :
17462 : : /* Resolve the expressions and iterators associated with a data statement.
17463 : : This is separate from the assignment checking because data lists should
17464 : : only be resolved once. */
17465 : :
17466 : : static bool
17467 : 2746 : resolve_data_variables (gfc_data_variable *d)
17468 : : {
17469 : 5873 : for (; d; d = d->next)
17470 : : {
17471 : 3132 : if (d->list == NULL)
17472 : : {
17473 : 2970 : if (!gfc_resolve_expr (d->expr))
17474 : : return false;
17475 : : }
17476 : : else
17477 : : {
17478 : 162 : if (!gfc_resolve_iterator (&d->iter, false, true))
17479 : : return false;
17480 : :
17481 : 159 : if (!resolve_data_variables (d->list))
17482 : : return false;
17483 : : }
17484 : : }
17485 : :
17486 : : return true;
17487 : : }
17488 : :
17489 : :
17490 : : /* Resolve a single DATA statement. We implement this by storing a pointer to
17491 : : the value list into static variables, and then recursively traversing the
17492 : : variables list, expanding iterators and such. */
17493 : :
17494 : : static void
17495 : 2587 : resolve_data (gfc_data *d)
17496 : : {
17497 : :
17498 : 2587 : if (!resolve_data_variables (d->var))
17499 : : return;
17500 : :
17501 : 2582 : values.vnode = d->value;
17502 : 2582 : if (d->value == NULL)
17503 : 0 : mpz_set_ui (values.left, 0);
17504 : : else
17505 : 2582 : mpz_set (values.left, d->value->repeat);
17506 : :
17507 : 2582 : if (!traverse_data_var (d->var, &d->where))
17508 : : return;
17509 : :
17510 : : /* At this point, we better not have any values left. */
17511 : :
17512 : 2500 : if (next_data_value ())
17513 : 0 : gfc_error ("DATA statement at %L has more values than variables",
17514 : : &d->where);
17515 : : }
17516 : :
17517 : :
17518 : : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
17519 : : accessed by host or use association, is a dummy argument to a pure function,
17520 : : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
17521 : : is storage associated with any such variable, shall not be used in the
17522 : : following contexts: (clients of this function). */
17523 : :
17524 : : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
17525 : : procedure. Returns zero if assignment is OK, nonzero if there is a
17526 : : problem. */
17527 : : bool
17528 : 48628 : gfc_impure_variable (gfc_symbol *sym)
17529 : : {
17530 : 48628 : gfc_symbol *proc;
17531 : 48628 : gfc_namespace *ns;
17532 : :
17533 : 48628 : if (sym->attr.use_assoc || sym->attr.in_common)
17534 : : return 1;
17535 : :
17536 : : /* Check if the symbol's ns is inside the pure procedure. */
17537 : 52308 : for (ns = gfc_current_ns; ns; ns = ns->parent)
17538 : : {
17539 : 52043 : if (ns == sym->ns)
17540 : : break;
17541 : 5334 : if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
17542 : : return 1;
17543 : : }
17544 : :
17545 : 46974 : proc = sym->ns->proc_name;
17546 : 46974 : if (sym->attr.dummy
17547 : 46974 : && !sym->attr.value
17548 : 5213 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
17549 : 5068 : || proc->attr.function))
17550 : 594 : return 1;
17551 : :
17552 : : /* TODO: Sort out what can be storage associated, if anything, and include
17553 : : it here. In principle equivalences should be scanned but it does not
17554 : : seem to be possible to storage associate an impure variable this way. */
17555 : : return 0;
17556 : : }
17557 : :
17558 : :
17559 : : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
17560 : : current namespace is inside a pure procedure. */
17561 : :
17562 : : bool
17563 : 1828787 : gfc_pure (gfc_symbol *sym)
17564 : : {
17565 : 1828787 : symbol_attribute attr;
17566 : 1828787 : gfc_namespace *ns;
17567 : :
17568 : 1828787 : if (sym == NULL)
17569 : : {
17570 : : /* Check if the current namespace or one of its parents
17571 : : belongs to a pure procedure. */
17572 : 2298501 : for (ns = gfc_current_ns; ns; ns = ns->parent)
17573 : : {
17574 : 1309129 : sym = ns->proc_name;
17575 : 1309129 : if (sym == NULL)
17576 : : return 0;
17577 : 1308003 : attr = sym->attr;
17578 : 1308003 : if (attr.flavor == FL_PROCEDURE && attr.pure)
17579 : : return 1;
17580 : : }
17581 : : return 0;
17582 : : }
17583 : :
17584 : 832254 : attr = sym->attr;
17585 : :
17586 : 832254 : return attr.flavor == FL_PROCEDURE && attr.pure;
17587 : : }
17588 : :
17589 : :
17590 : : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
17591 : : checks if the current namespace is implicitly pure. Note that this
17592 : : function returns false for a PURE procedure. */
17593 : :
17594 : : bool
17595 : 485038 : gfc_implicit_pure (gfc_symbol *sym)
17596 : : {
17597 : 485038 : gfc_namespace *ns;
17598 : :
17599 : 485038 : if (sym == NULL)
17600 : : {
17601 : : /* Check if the current procedure is implicit_pure. Walk up
17602 : : the procedure list until we find a procedure. */
17603 : 740939 : for (ns = gfc_current_ns; ns; ns = ns->parent)
17604 : : {
17605 : 474134 : sym = ns->proc_name;
17606 : 474134 : if (sym == NULL)
17607 : : return 0;
17608 : :
17609 : 474061 : if (sym->attr.flavor == FL_PROCEDURE)
17610 : : break;
17611 : : }
17612 : : }
17613 : :
17614 : 484965 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
17615 : 484965 : && !sym->attr.pure;
17616 : : }
17617 : :
17618 : :
17619 : : void
17620 : 367274 : gfc_unset_implicit_pure (gfc_symbol *sym)
17621 : : {
17622 : 367274 : gfc_namespace *ns;
17623 : :
17624 : 367274 : if (sym == NULL)
17625 : : {
17626 : : /* Check if the current procedure is implicit_pure. Walk up
17627 : : the procedure list until we find a procedure. */
17628 : 612212 : for (ns = gfc_current_ns; ns; ns = ns->parent)
17629 : : {
17630 : 371043 : sym = ns->proc_name;
17631 : 371043 : if (sym == NULL)
17632 : : return;
17633 : :
17634 : 370223 : if (sym->attr.flavor == FL_PROCEDURE)
17635 : : break;
17636 : : }
17637 : : }
17638 : :
17639 : 366454 : if (sym->attr.flavor == FL_PROCEDURE)
17640 : 117869 : sym->attr.implicit_pure = 0;
17641 : : else
17642 : 248585 : sym->attr.pure = 0;
17643 : : }
17644 : :
17645 : :
17646 : : /* Test whether the current procedure is elemental or not. */
17647 : :
17648 : : bool
17649 : 1109834 : gfc_elemental (gfc_symbol *sym)
17650 : : {
17651 : 1109834 : symbol_attribute attr;
17652 : :
17653 : 1109834 : if (sym == NULL)
17654 : 0 : sym = gfc_current_ns->proc_name;
17655 : 0 : if (sym == NULL)
17656 : : return 0;
17657 : 1109834 : attr = sym->attr;
17658 : :
17659 : 1109834 : return attr.flavor == FL_PROCEDURE && attr.elemental;
17660 : : }
17661 : :
17662 : :
17663 : : /* Warn about unused labels. */
17664 : :
17665 : : static void
17666 : 4310 : warn_unused_fortran_label (gfc_st_label *label)
17667 : : {
17668 : 4313 : if (label == NULL)
17669 : : return;
17670 : :
17671 : 4 : warn_unused_fortran_label (label->left);
17672 : :
17673 : 4 : if (label->defined == ST_LABEL_UNKNOWN)
17674 : : return;
17675 : :
17676 : 3 : switch (label->referenced)
17677 : : {
17678 : 1 : case ST_LABEL_UNKNOWN:
17679 : 1 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
17680 : : label->value, &label->where);
17681 : 1 : break;
17682 : :
17683 : 1 : case ST_LABEL_BAD_TARGET:
17684 : 1 : gfc_warning (OPT_Wunused_label,
17685 : : "Label %d at %L defined but cannot be used",
17686 : : label->value, &label->where);
17687 : 1 : break;
17688 : :
17689 : : default:
17690 : : break;
17691 : : }
17692 : :
17693 : 3 : warn_unused_fortran_label (label->right);
17694 : : }
17695 : :
17696 : :
17697 : : /* Returns the sequence type of a symbol or sequence. */
17698 : :
17699 : : static seq_type
17700 : 1101 : sequence_type (gfc_typespec ts)
17701 : : {
17702 : 1101 : seq_type result;
17703 : 1101 : gfc_component *c;
17704 : :
17705 : 1101 : switch (ts.type)
17706 : : {
17707 : 54 : case BT_DERIVED:
17708 : :
17709 : 54 : if (ts.u.derived->components == NULL)
17710 : : return SEQ_NONDEFAULT;
17711 : :
17712 : 54 : result = sequence_type (ts.u.derived->components->ts);
17713 : 108 : for (c = ts.u.derived->components->next; c; c = c->next)
17714 : 67 : if (sequence_type (c->ts) != result)
17715 : : return SEQ_MIXED;
17716 : :
17717 : : return result;
17718 : :
17719 : 129 : case BT_CHARACTER:
17720 : 129 : if (ts.kind != gfc_default_character_kind)
17721 : 0 : return SEQ_NONDEFAULT;
17722 : :
17723 : : return SEQ_CHARACTER;
17724 : :
17725 : 250 : case BT_INTEGER:
17726 : 250 : if (ts.kind != gfc_default_integer_kind)
17727 : 25 : return SEQ_NONDEFAULT;
17728 : :
17729 : : return SEQ_NUMERIC;
17730 : :
17731 : 569 : case BT_REAL:
17732 : 569 : if (!(ts.kind == gfc_default_real_kind
17733 : 274 : || ts.kind == gfc_default_double_kind))
17734 : 0 : return SEQ_NONDEFAULT;
17735 : :
17736 : : return SEQ_NUMERIC;
17737 : :
17738 : 81 : case BT_COMPLEX:
17739 : 81 : if (ts.kind != gfc_default_complex_kind)
17740 : 48 : return SEQ_NONDEFAULT;
17741 : :
17742 : : return SEQ_NUMERIC;
17743 : :
17744 : 17 : case BT_LOGICAL:
17745 : 17 : if (ts.kind != gfc_default_logical_kind)
17746 : 0 : return SEQ_NONDEFAULT;
17747 : :
17748 : : return SEQ_NUMERIC;
17749 : :
17750 : : default:
17751 : : return SEQ_NONDEFAULT;
17752 : : }
17753 : : }
17754 : :
17755 : :
17756 : : /* Resolve derived type EQUIVALENCE object. */
17757 : :
17758 : : static bool
17759 : 85 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
17760 : : {
17761 : 85 : gfc_component *c = derived->components;
17762 : :
17763 : 85 : if (!derived)
17764 : : return true;
17765 : :
17766 : : /* Shall not be an object of nonsequence derived type. */
17767 : 85 : if (!derived->attr.sequence)
17768 : : {
17769 : 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
17770 : : "attribute to be an EQUIVALENCE object", sym->name,
17771 : : &e->where);
17772 : 0 : return false;
17773 : : }
17774 : :
17775 : : /* Shall not have allocatable components. */
17776 : 85 : if (derived->attr.alloc_comp)
17777 : : {
17778 : 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
17779 : : "components to be an EQUIVALENCE object",sym->name,
17780 : : &e->where);
17781 : 1 : return false;
17782 : : }
17783 : :
17784 : 84 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
17785 : : {
17786 : 1 : gfc_error ("Derived type variable %qs at %L with default "
17787 : : "initialization cannot be in EQUIVALENCE with a variable "
17788 : : "in COMMON", sym->name, &e->where);
17789 : 1 : return false;
17790 : : }
17791 : :
17792 : 255 : for (; c ; c = c->next)
17793 : : {
17794 : 172 : if (gfc_bt_struct (c->ts.type)
17795 : 172 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
17796 : : return false;
17797 : :
17798 : : /* Shall not be an object of sequence derived type containing a pointer
17799 : : in the structure. */
17800 : 172 : if (c->attr.pointer)
17801 : : {
17802 : 0 : gfc_error ("Derived type variable %qs at %L with pointer "
17803 : : "component(s) cannot be an EQUIVALENCE object",
17804 : : sym->name, &e->where);
17805 : 0 : return false;
17806 : : }
17807 : : }
17808 : : return true;
17809 : : }
17810 : :
17811 : :
17812 : : /* Resolve equivalence object.
17813 : : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17814 : : an allocatable array, an object of nonsequence derived type, an object of
17815 : : sequence derived type containing a pointer at any level of component
17816 : : selection, an automatic object, a function name, an entry name, a result
17817 : : name, a named constant, a structure component, or a subobject of any of
17818 : : the preceding objects. A substring shall not have length zero. A
17819 : : derived type shall not have components with default initialization nor
17820 : : shall two objects of an equivalence group be initialized.
17821 : : Either all or none of the objects shall have an protected attribute.
17822 : : The simple constraints are done in symbol.cc(check_conflict) and the rest
17823 : : are implemented here. */
17824 : :
17825 : : static void
17826 : 1580 : resolve_equivalence (gfc_equiv *eq)
17827 : : {
17828 : 1580 : gfc_symbol *sym;
17829 : 1580 : gfc_symbol *first_sym;
17830 : 1580 : gfc_expr *e;
17831 : 1580 : gfc_ref *r;
17832 : 1580 : locus *last_where = NULL;
17833 : 1580 : seq_type eq_type, last_eq_type;
17834 : 1580 : gfc_typespec *last_ts;
17835 : 1580 : int object, cnt_protected;
17836 : 1580 : const char *msg;
17837 : :
17838 : 1580 : last_ts = &eq->expr->symtree->n.sym->ts;
17839 : :
17840 : 1580 : first_sym = eq->expr->symtree->n.sym;
17841 : :
17842 : 1580 : cnt_protected = 0;
17843 : :
17844 : 4772 : for (object = 1; eq; eq = eq->eq, object++)
17845 : : {
17846 : 3201 : e = eq->expr;
17847 : :
17848 : 3201 : e->ts = e->symtree->n.sym->ts;
17849 : : /* match_varspec might not know yet if it is seeing
17850 : : array reference or substring reference, as it doesn't
17851 : : know the types. */
17852 : 3201 : if (e->ref && e->ref->type == REF_ARRAY)
17853 : : {
17854 : 2167 : gfc_ref *ref = e->ref;
17855 : 2167 : sym = e->symtree->n.sym;
17856 : :
17857 : 2167 : if (sym->attr.dimension)
17858 : : {
17859 : 1870 : ref->u.ar.as = sym->as;
17860 : 1870 : ref = ref->next;
17861 : : }
17862 : :
17863 : : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17864 : 2167 : if (e->ts.type == BT_CHARACTER
17865 : 592 : && ref
17866 : 371 : && ref->type == REF_ARRAY
17867 : 371 : && ref->u.ar.dimen == 1
17868 : 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
17869 : 371 : && ref->u.ar.stride[0] == NULL)
17870 : : {
17871 : 370 : gfc_expr *start = ref->u.ar.start[0];
17872 : 370 : gfc_expr *end = ref->u.ar.end[0];
17873 : 370 : void *mem = NULL;
17874 : :
17875 : : /* Optimize away the (:) reference. */
17876 : 370 : if (start == NULL && end == NULL)
17877 : : {
17878 : 9 : if (e->ref == ref)
17879 : 0 : e->ref = ref->next;
17880 : : else
17881 : 9 : e->ref->next = ref->next;
17882 : : mem = ref;
17883 : : }
17884 : : else
17885 : : {
17886 : 361 : ref->type = REF_SUBSTRING;
17887 : 361 : if (start == NULL)
17888 : 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
17889 : : NULL, 1);
17890 : 361 : ref->u.ss.start = start;
17891 : 361 : if (end == NULL && e->ts.u.cl)
17892 : 27 : end = gfc_copy_expr (e->ts.u.cl->length);
17893 : 361 : ref->u.ss.end = end;
17894 : 361 : ref->u.ss.length = e->ts.u.cl;
17895 : 361 : e->ts.u.cl = NULL;
17896 : : }
17897 : 370 : ref = ref->next;
17898 : 370 : free (mem);
17899 : : }
17900 : :
17901 : : /* Any further ref is an error. */
17902 : 1945 : if (ref)
17903 : : {
17904 : 1 : gcc_assert (ref->type == REF_ARRAY);
17905 : 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17906 : : &ref->u.ar.where);
17907 : 1 : continue;
17908 : : }
17909 : : }
17910 : :
17911 : 3200 : if (!gfc_resolve_expr (e))
17912 : 2 : continue;
17913 : :
17914 : 3198 : sym = e->symtree->n.sym;
17915 : :
17916 : 3198 : if (sym->attr.is_protected)
17917 : 2 : cnt_protected++;
17918 : 3198 : if (cnt_protected > 0 && cnt_protected != object)
17919 : : {
17920 : 2 : gfc_error ("Either all or none of the objects in the "
17921 : : "EQUIVALENCE set at %L shall have the "
17922 : : "PROTECTED attribute",
17923 : : &e->where);
17924 : 2 : break;
17925 : : }
17926 : :
17927 : : /* Shall not equivalence common block variables in a PURE procedure. */
17928 : 3196 : if (sym->ns->proc_name
17929 : 3180 : && sym->ns->proc_name->attr.pure
17930 : 7 : && sym->attr.in_common)
17931 : : {
17932 : : /* Need to check for symbols that may have entered the pure
17933 : : procedure via a USE statement. */
17934 : 7 : bool saw_sym = false;
17935 : 7 : if (sym->ns->use_stmts)
17936 : : {
17937 : 6 : gfc_use_rename *r;
17938 : 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
17939 : 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
17940 : : }
17941 : : else
17942 : : saw_sym = true;
17943 : :
17944 : 6 : if (saw_sym)
17945 : 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
17946 : : "EQUIVALENCE object in the pure procedure %qs",
17947 : : sym->name, &e->where, sym->ns->proc_name->name);
17948 : : break;
17949 : : }
17950 : :
17951 : : /* Shall not be a named constant. */
17952 : 3189 : if (e->expr_type == EXPR_CONSTANT)
17953 : : {
17954 : 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
17955 : : "object", sym->name, &e->where);
17956 : 0 : continue;
17957 : : }
17958 : :
17959 : 3191 : if (e->ts.type == BT_DERIVED
17960 : 3189 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
17961 : 2 : continue;
17962 : :
17963 : : /* Check that the types correspond correctly:
17964 : : Note 5.28:
17965 : : A numeric sequence structure may be equivalenced to another sequence
17966 : : structure, an object of default integer type, default real type, double
17967 : : precision real type, default logical type such that components of the
17968 : : structure ultimately only become associated to objects of the same
17969 : : kind. A character sequence structure may be equivalenced to an object
17970 : : of default character kind or another character sequence structure.
17971 : : Other objects may be equivalenced only to objects of the same type and
17972 : : kind parameters. */
17973 : :
17974 : : /* Identical types are unconditionally OK. */
17975 : 3187 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
17976 : 2697 : goto identical_types;
17977 : :
17978 : 490 : last_eq_type = sequence_type (*last_ts);
17979 : 490 : eq_type = sequence_type (sym->ts);
17980 : :
17981 : : /* Since the pair of objects is not of the same type, mixed or
17982 : : non-default sequences can be rejected. */
17983 : :
17984 : 490 : msg = "Sequence %s with mixed components in EQUIVALENCE "
17985 : : "statement at %L with different type objects";
17986 : 491 : if ((object ==2
17987 : 490 : && last_eq_type == SEQ_MIXED
17988 : 7 : && last_where
17989 : 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
17990 : 496 : || (eq_type == SEQ_MIXED
17991 : 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
17992 : 1 : continue;
17993 : :
17994 : 489 : msg = "Non-default type object or sequence %s in EQUIVALENCE "
17995 : : "statement at %L with objects of different type";
17996 : 493 : if ((object ==2
17997 : 489 : && last_eq_type == SEQ_NONDEFAULT
17998 : 50 : && last_where
17999 : 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
18000 : 535 : || (eq_type == SEQ_NONDEFAULT
18001 : 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
18002 : 4 : continue;
18003 : :
18004 : 485 : msg ="Non-CHARACTER object %qs in default CHARACTER "
18005 : : "EQUIVALENCE statement at %L";
18006 : 489 : if (last_eq_type == SEQ_CHARACTER
18007 : 485 : && eq_type != SEQ_CHARACTER
18008 : 485 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
18009 : 4 : continue;
18010 : :
18011 : 481 : msg ="Non-NUMERIC object %qs in default NUMERIC "
18012 : : "EQUIVALENCE statement at %L";
18013 : 483 : if (last_eq_type == SEQ_NUMERIC
18014 : 481 : && eq_type != SEQ_NUMERIC
18015 : 481 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
18016 : 2 : continue;
18017 : :
18018 : 3176 : identical_types:
18019 : :
18020 : 3176 : last_ts =&sym->ts;
18021 : 3176 : last_where = &e->where;
18022 : :
18023 : 3176 : if (!e->ref)
18024 : 1018 : continue;
18025 : :
18026 : : /* Shall not be an automatic array. */
18027 : 2158 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
18028 : : {
18029 : 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
18030 : : "an EQUIVALENCE object", sym->name, &e->where);
18031 : 3 : continue;
18032 : : }
18033 : :
18034 : 2155 : r = e->ref;
18035 : 4356 : while (r)
18036 : : {
18037 : : /* Shall not be a structure component. */
18038 : 2202 : if (r->type == REF_COMPONENT)
18039 : : {
18040 : 0 : gfc_error ("Structure component %qs at %L cannot be an "
18041 : : "EQUIVALENCE object",
18042 : 0 : r->u.c.component->name, &e->where);
18043 : 0 : break;
18044 : : }
18045 : :
18046 : : /* A substring shall not have length zero. */
18047 : 2202 : if (r->type == REF_SUBSTRING)
18048 : : {
18049 : 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
18050 : : {
18051 : 1 : gfc_error ("Substring at %L has length zero",
18052 : : &r->u.ss.start->where);
18053 : 1 : break;
18054 : : }
18055 : : }
18056 : 2201 : r = r->next;
18057 : : }
18058 : : }
18059 : 1580 : }
18060 : :
18061 : :
18062 : : /* Function called by resolve_fntype to flag other symbols used in the
18063 : : length type parameter specification of function results. */
18064 : :
18065 : : static bool
18066 : 3819 : flag_fn_result_spec (gfc_expr *expr,
18067 : : gfc_symbol *sym,
18068 : : int *f ATTRIBUTE_UNUSED)
18069 : : {
18070 : 3819 : gfc_namespace *ns;
18071 : 3819 : gfc_symbol *s;
18072 : :
18073 : 3819 : if (expr->expr_type == EXPR_VARIABLE)
18074 : : {
18075 : 1207 : s = expr->symtree->n.sym;
18076 : 1892 : for (ns = s->ns; ns; ns = ns->parent)
18077 : 1892 : if (!ns->parent)
18078 : : break;
18079 : :
18080 : 1207 : if (sym == s)
18081 : : {
18082 : 1 : gfc_error ("Self reference in character length expression "
18083 : : "for %qs at %L", sym->name, &expr->where);
18084 : 1 : return true;
18085 : : }
18086 : :
18087 : 1206 : if (!s->fn_result_spec
18088 : 1206 : && s->attr.flavor == FL_PARAMETER)
18089 : : {
18090 : : /* Function contained in a module.... */
18091 : 38 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
18092 : : {
18093 : 19 : gfc_symtree *st;
18094 : 19 : s->fn_result_spec = 1;
18095 : : /* Make sure that this symbol is translated as a module
18096 : : variable. */
18097 : 19 : st = gfc_get_unique_symtree (ns);
18098 : 19 : st->n.sym = s;
18099 : 19 : s->refs++;
18100 : 19 : }
18101 : : /* ... which is use associated and called. */
18102 : 19 : else if (s->attr.use_assoc || s->attr.used_in_submodule
18103 : 0 : ||
18104 : : /* External function matched with an interface. */
18105 : 0 : (s->ns->proc_name
18106 : 0 : && ((s->ns == ns
18107 : 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
18108 : 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
18109 : 0 : && s->ns->proc_name->attr.function))
18110 : 19 : s->fn_result_spec = 1;
18111 : : }
18112 : : }
18113 : : return false;
18114 : : }
18115 : :
18116 : :
18117 : : /* Resolve function and ENTRY types, issue diagnostics if needed. */
18118 : :
18119 : : static void
18120 : 291543 : resolve_fntype (gfc_namespace *ns)
18121 : : {
18122 : 291543 : gfc_entry_list *el;
18123 : 291543 : gfc_symbol *sym;
18124 : :
18125 : 291543 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
18126 : : return;
18127 : :
18128 : : /* If there are any entries, ns->proc_name is the entry master
18129 : : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
18130 : 148448 : if (ns->entries)
18131 : 563 : sym = ns->entries->sym;
18132 : : else
18133 : : sym = ns->proc_name;
18134 : 148448 : if (sym->result == sym
18135 : 120152 : && sym->ts.type == BT_UNKNOWN
18136 : 6 : && !gfc_set_default_type (sym, 0, NULL)
18137 : 148452 : && !sym->attr.untyped)
18138 : : {
18139 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
18140 : : sym->name, &sym->declared_at);
18141 : 3 : sym->attr.untyped = 1;
18142 : : }
18143 : :
18144 : 9831 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
18145 : 1385 : && !sym->attr.contained
18146 : 250 : && !gfc_check_symbol_access (sym->ts.u.derived)
18147 : 148448 : && gfc_check_symbol_access (sym))
18148 : : {
18149 : 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
18150 : : "%L of PRIVATE type %qs", sym->name,
18151 : 0 : &sym->declared_at, sym->ts.u.derived->name);
18152 : : }
18153 : :
18154 : 148448 : if (ns->entries)
18155 : 1187 : for (el = ns->entries->next; el; el = el->next)
18156 : : {
18157 : 624 : if (el->sym->result == el->sym
18158 : 412 : && el->sym->ts.type == BT_UNKNOWN
18159 : 2 : && !gfc_set_default_type (el->sym, 0, NULL)
18160 : 626 : && !el->sym->attr.untyped)
18161 : : {
18162 : 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
18163 : : el->sym->name, &el->sym->declared_at);
18164 : 2 : el->sym->attr.untyped = 1;
18165 : : }
18166 : : }
18167 : :
18168 : 148448 : if (sym->ts.type == BT_CHARACTER
18169 : 2037 : && sym->ts.u.cl->length
18170 : 1592 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
18171 : 1587 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
18172 : : }
18173 : :
18174 : :
18175 : : /* 12.3.2.1.1 Defined operators. */
18176 : :
18177 : : static bool
18178 : 371 : check_uop_procedure (gfc_symbol *sym, locus where)
18179 : : {
18180 : 371 : gfc_formal_arglist *formal;
18181 : :
18182 : 371 : if (!sym->attr.function)
18183 : : {
18184 : 3 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
18185 : : sym->name, &where);
18186 : 3 : return false;
18187 : : }
18188 : :
18189 : 368 : if (sym->ts.type == BT_CHARACTER
18190 : 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
18191 : 2 : && !(sym->result && ((sym->result->ts.u.cl
18192 : 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
18193 : : {
18194 : 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
18195 : : "character length", sym->name, &where);
18196 : 2 : return false;
18197 : : }
18198 : :
18199 : 366 : formal = gfc_sym_get_dummy_args (sym);
18200 : 366 : if (!formal || !formal->sym)
18201 : : {
18202 : 1 : gfc_error ("User operator procedure %qs at %L must have at least "
18203 : : "one argument", sym->name, &where);
18204 : 1 : return false;
18205 : : }
18206 : :
18207 : 365 : if (formal->sym->attr.intent != INTENT_IN)
18208 : : {
18209 : 0 : gfc_error ("First argument of operator interface at %L must be "
18210 : : "INTENT(IN)", &where);
18211 : 0 : return false;
18212 : : }
18213 : :
18214 : 365 : if (formal->sym->attr.optional)
18215 : : {
18216 : 0 : gfc_error ("First argument of operator interface at %L cannot be "
18217 : : "optional", &where);
18218 : 0 : return false;
18219 : : }
18220 : :
18221 : 365 : formal = formal->next;
18222 : 365 : if (!formal || !formal->sym)
18223 : : return true;
18224 : :
18225 : 232 : if (formal->sym->attr.intent != INTENT_IN)
18226 : : {
18227 : 0 : gfc_error ("Second argument of operator interface at %L must be "
18228 : : "INTENT(IN)", &where);
18229 : 0 : return false;
18230 : : }
18231 : :
18232 : 232 : if (formal->sym->attr.optional)
18233 : : {
18234 : 1 : gfc_error ("Second argument of operator interface at %L cannot be "
18235 : : "optional", &where);
18236 : 1 : return false;
18237 : : }
18238 : :
18239 : 231 : if (formal->next)
18240 : : {
18241 : 2 : gfc_error ("Operator interface at %L must have, at most, two "
18242 : : "arguments", &where);
18243 : 2 : return false;
18244 : : }
18245 : :
18246 : : return true;
18247 : : }
18248 : :
18249 : : static void
18250 : 292209 : gfc_resolve_uops (gfc_symtree *symtree)
18251 : : {
18252 : 292209 : gfc_interface *itr;
18253 : :
18254 : 292209 : if (symtree == NULL)
18255 : : return;
18256 : :
18257 : 333 : gfc_resolve_uops (symtree->left);
18258 : 333 : gfc_resolve_uops (symtree->right);
18259 : :
18260 : 662 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
18261 : 329 : check_uop_procedure (itr->sym, itr->sym->declared_at);
18262 : : }
18263 : :
18264 : :
18265 : : /* Examine all of the expressions associated with a program unit,
18266 : : assign types to all intermediate expressions, make sure that all
18267 : : assignments are to compatible types and figure out which names
18268 : : refer to which functions or subroutines. It doesn't check code
18269 : : block, which is handled by gfc_resolve_code. */
18270 : :
18271 : : static void
18272 : 293339 : resolve_types (gfc_namespace *ns)
18273 : : {
18274 : 293339 : gfc_namespace *n;
18275 : 293339 : gfc_charlen *cl;
18276 : 293339 : gfc_data *d;
18277 : 293339 : gfc_equiv *eq;
18278 : 293339 : gfc_namespace* old_ns = gfc_current_ns;
18279 : 293339 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
18280 : :
18281 : 293339 : if (ns->types_resolved)
18282 : : return;
18283 : :
18284 : : /* Check that all IMPLICIT types are ok. */
18285 : 291544 : if (!ns->seen_implicit_none)
18286 : : {
18287 : : unsigned letter;
18288 : 7309252 : for (letter = 0; letter != GFC_LETTERS; ++letter)
18289 : 7038539 : if (ns->set_flag[letter]
18290 : 7038539 : && !resolve_typespec_used (&ns->default_type[letter],
18291 : : &ns->implicit_loc[letter], NULL))
18292 : : return;
18293 : : }
18294 : :
18295 : 291543 : gfc_current_ns = ns;
18296 : :
18297 : 291543 : resolve_entries (ns);
18298 : :
18299 : 291543 : resolve_common_vars (&ns->blank_common, false);
18300 : 291543 : resolve_common_blocks (ns->common_root);
18301 : :
18302 : 291543 : resolve_contained_functions (ns);
18303 : :
18304 : 291543 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
18305 : 291495 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
18306 : 158203 : gfc_resolve_formal_arglist (ns->proc_name);
18307 : :
18308 : 291543 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
18309 : :
18310 : 368997 : for (cl = ns->cl_list; cl; cl = cl->next)
18311 : 77454 : resolve_charlen (cl);
18312 : :
18313 : 291543 : gfc_traverse_ns (ns, resolve_symbol);
18314 : :
18315 : 291543 : resolve_fntype (ns);
18316 : :
18317 : 331358 : for (n = ns->contained; n; n = n->sibling)
18318 : : {
18319 : : /* Exclude final wrappers with the test for the artificial attribute. */
18320 : 39815 : if (gfc_pure (ns->proc_name)
18321 : 5 : && !gfc_pure (n->proc_name)
18322 : 39815 : && !n->proc_name->attr.artificial)
18323 : 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
18324 : : "also be PURE", n->proc_name->name,
18325 : : &n->proc_name->declared_at);
18326 : :
18327 : 39815 : resolve_types (n);
18328 : : }
18329 : :
18330 : 291543 : forall_flag = 0;
18331 : 291543 : gfc_do_concurrent_flag = 0;
18332 : 291543 : gfc_check_interfaces (ns);
18333 : :
18334 : 291543 : gfc_traverse_ns (ns, resolve_values);
18335 : :
18336 : 291543 : if (ns->save_all || (!flag_automatic && !recursive))
18337 : 339 : gfc_save_all (ns);
18338 : :
18339 : 291543 : iter_stack = NULL;
18340 : 294130 : for (d = ns->data; d; d = d->next)
18341 : 2587 : resolve_data (d);
18342 : :
18343 : 291543 : iter_stack = NULL;
18344 : 291543 : gfc_traverse_ns (ns, gfc_formalize_init_value);
18345 : :
18346 : 291543 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
18347 : :
18348 : 293123 : for (eq = ns->equiv; eq; eq = eq->next)
18349 : 1580 : resolve_equivalence (eq);
18350 : :
18351 : : /* Warn about unused labels. */
18352 : 291543 : if (warn_unused_label)
18353 : 4306 : warn_unused_fortran_label (ns->st_labels);
18354 : :
18355 : 291543 : gfc_resolve_uops (ns->uop_root);
18356 : :
18357 : 291543 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
18358 : :
18359 : 291543 : gfc_resolve_omp_declare_simd (ns);
18360 : :
18361 : 291543 : gfc_resolve_omp_udrs (ns->omp_udr_root);
18362 : :
18363 : 291543 : ns->types_resolved = 1;
18364 : :
18365 : 291543 : gfc_current_ns = old_ns;
18366 : : }
18367 : :
18368 : :
18369 : : /* Call gfc_resolve_code recursively. */
18370 : :
18371 : : static void
18372 : 293376 : resolve_codes (gfc_namespace *ns)
18373 : : {
18374 : 293376 : gfc_namespace *n;
18375 : 293376 : bitmap_obstack old_obstack;
18376 : :
18377 : 293376 : if (ns->resolved == 1)
18378 : 11466 : return;
18379 : :
18380 : 321762 : for (n = ns->contained; n; n = n->sibling)
18381 : 39852 : resolve_codes (n);
18382 : :
18383 : 281910 : gfc_current_ns = ns;
18384 : :
18385 : : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
18386 : 281910 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
18387 : 271193 : cs_base = NULL;
18388 : :
18389 : : /* Set to an out of range value. */
18390 : 281910 : current_entry_id = -1;
18391 : :
18392 : 281910 : old_obstack = labels_obstack;
18393 : 281910 : bitmap_obstack_initialize (&labels_obstack);
18394 : :
18395 : 281910 : gfc_resolve_oacc_declare (ns);
18396 : 281910 : gfc_resolve_oacc_routines (ns);
18397 : 281910 : gfc_resolve_omp_local_vars (ns);
18398 : 281910 : if (ns->omp_allocate)
18399 : 48 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
18400 : 281910 : gfc_resolve_code (ns->code, ns);
18401 : :
18402 : 281909 : bitmap_obstack_release (&labels_obstack);
18403 : 281909 : labels_obstack = old_obstack;
18404 : : }
18405 : :
18406 : :
18407 : : /* This function is called after a complete program unit has been compiled.
18408 : : Its purpose is to examine all of the expressions associated with a program
18409 : : unit, assign types to all intermediate expressions, make sure that all
18410 : : assignments are to compatible types and figure out which names refer to
18411 : : which functions or subroutines. */
18412 : :
18413 : : void
18414 : 256146 : gfc_resolve (gfc_namespace *ns)
18415 : : {
18416 : 256146 : gfc_namespace *old_ns;
18417 : 256146 : code_stack *old_cs_base;
18418 : 256146 : struct gfc_omp_saved_state old_omp_state;
18419 : :
18420 : 256146 : if (ns->resolved)
18421 : 2622 : return;
18422 : :
18423 : 253524 : ns->resolved = -1;
18424 : 253524 : old_ns = gfc_current_ns;
18425 : 253524 : old_cs_base = cs_base;
18426 : :
18427 : : /* As gfc_resolve can be called during resolution of an OpenMP construct
18428 : : body, we should clear any state associated to it, so that say NS's
18429 : : DO loops are not interpreted as OpenMP loops. */
18430 : 253524 : if (!ns->construct_entities)
18431 : 242807 : gfc_omp_save_and_clear_state (&old_omp_state);
18432 : :
18433 : 253524 : resolve_types (ns);
18434 : 253524 : component_assignment_level = 0;
18435 : 253524 : resolve_codes (ns);
18436 : :
18437 : 253523 : if (ns->omp_assumes)
18438 : 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
18439 : :
18440 : 253523 : gfc_current_ns = old_ns;
18441 : 253523 : cs_base = old_cs_base;
18442 : 253523 : ns->resolved = 1;
18443 : :
18444 : 253523 : gfc_run_passes (ns);
18445 : :
18446 : 253523 : if (!ns->construct_entities)
18447 : 242806 : gfc_omp_restore_state (&old_omp_state);
18448 : : }
|
